@@ -107,11 +107,11 @@ module Stats = struct
107107
108108 let logLoop () = incr nInfiniteLoops
109109
110- let logCache ~functionCall ~hit ~loc =
110+ let logCache ~config ~ functionCall ~hit ~loc =
111111 incr nCacheChecks;
112112 if hit then incr nCacheHits;
113- if ! Common.Cli . debug then
114- Log_. warning ~config: ( DceConfig. current () ) ~for Stats:false ~loc
113+ if config. DceConfig. cli .debug then
114+ Log_. warning ~config ~for Stats:false ~loc
115115 (Termination
116116 {
117117 termination = TerminationAnalysisInternal ;
@@ -123,9 +123,9 @@ module Stats = struct
123123 (FunctionCall. toString functionCall);
124124 })
125125
126- let logResult ~functionCall ~loc ~resString =
127- if ! Common.Cli . debug then
128- Log_. warning ~config: ( DceConfig. current () ) ~for Stats:false ~loc
126+ let logResult ~config ~ functionCall ~loc ~resString =
127+ if config. DceConfig. cli .debug then
128+ Log_. warning ~config ~for Stats:false ~loc
129129 (Termination
130130 {
131131 termination = TerminationAnalysisInternal ;
@@ -591,7 +591,8 @@ module ExtendFunctionTable = struct
591591 if args |> List. for_all checkArg then Some (path, loc) else None
592592 | _ -> None
593593
594- let traverseExpr ~functionTable ~progressFunctions ~valueBindingsTable =
594+ let traverseExpr ~config ~functionTable ~progressFunctions ~valueBindingsTable
595+ =
595596 let super = Tast_mapper. default in
596597 let expr (self : Tast_mapper.mapper ) (e : Typedtree.expression ) =
597598 (match e.exp_desc with
@@ -609,8 +610,8 @@ module ExtendFunctionTable = struct
609610 if not (callee |> FunctionTable. isInFunctionInTable ~function Table)
610611 then (
611612 functionTable |> FunctionTable. addFunction ~function Name;
612- if ! Common.Cli . debug then
613- Log_. warning ~config: ( DceConfig. current () ) ~for Stats:false ~loc
613+ if config. DceConfig. cli .debug then
614+ Log_. warning ~config ~for Stats:false ~loc
614615 (Termination
615616 {
616617 termination = TerminationAnalysisInternal ;
@@ -631,9 +632,8 @@ module ExtendFunctionTable = struct
631632 ->
632633 functionTable
633634 |> FunctionTable. addLabelToKind ~function Name ~label ;
634- if ! Common.Cli. debug then
635- Log_. warning ~config: (DceConfig. current () ) ~for Stats:false
636- ~loc
635+ if config.DceConfig. cli.debug then
636+ Log_. warning ~config ~for Stats:false ~loc
637637 (Termination
638638 {
639639 termination = TerminationAnalysisInternal ;
@@ -649,16 +649,16 @@ module ExtendFunctionTable = struct
649649 in
650650 {super with Tast_mapper. expr}
651651
652- let run ~functionTable ~progressFunctions ~valueBindingsTable
652+ let run ~config ~ functionTable ~progressFunctions ~valueBindingsTable
653653 (expression : Typedtree.expression ) =
654654 let traverseExpr =
655- traverseExpr ~function Table ~progress Functions ~value BindingsTable
655+ traverseExpr ~config ~ function Table ~progress Functions ~value BindingsTable
656656 in
657657 expression |> traverseExpr.expr traverseExpr |> ignore
658658end
659659
660660module CheckExpressionWellFormed = struct
661- let traverseExpr ~functionTable ~valueBindingsTable =
661+ let traverseExpr ~config ~ functionTable ~valueBindingsTable =
662662 let super = Tast_mapper. default in
663663 let checkIdent ~path ~loc =
664664 if path |> FunctionTable. isInFunctionInTable ~function Table then
@@ -699,9 +699,8 @@ module CheckExpressionWellFormed = struct
699699 |> FunctionTable. addFunction ~function Name;
700700 functionTable
701701 |> FunctionTable. addLabelToKind ~function Name ~label ;
702- if ! Common.Cli. debug then
703- Log_. warning ~config: (DceConfig. current () )
704- ~for Stats:false ~loc: body.exp_loc
702+ if config.DceConfig. cli.debug then
703+ Log_. warning ~config ~for Stats:false ~loc: body.exp_loc
705704 (Termination
706705 {
707706 termination = TerminationAnalysisInternal ;
@@ -719,22 +718,27 @@ module CheckExpressionWellFormed = struct
719718 in
720719 {super with Tast_mapper. expr}
721720
722- let run ~functionTable ~valueBindingsTable (expression : Typedtree.expression )
723- =
724- let traverseExpr = traverseExpr ~function Table ~value BindingsTable in
721+ let run ~config ~functionTable ~valueBindingsTable
722+ (expression : Typedtree.expression ) =
723+ let traverseExpr =
724+ traverseExpr ~config ~function Table ~value BindingsTable
725+ in
725726 expression |> traverseExpr.expr traverseExpr |> ignore
726727end
727728
728729module Compile = struct
729730 type ctx = {
731+ config : DceConfig .t ;
730732 currentFunctionName : FunctionName .t ;
731733 functionTable : FunctionTable .t ;
732734 innerRecursiveFunctions : (FunctionName .t , FunctionName .t ) Hashtbl .t ;
733735 isProgressFunction : Path .t -> bool ;
734736 }
735737
736738 let rec expression ~ctx (expr : Typedtree.expression ) =
737- let {currentFunctionName; functionTable; isProgressFunction} = ctx in
739+ let {config; currentFunctionName; functionTable; isProgressFunction} =
740+ ctx
741+ in
738742 let loc = expr.exp_loc in
739743 let notImplemented case =
740744 Log_. error ~loc
@@ -874,8 +878,8 @@ module Compile = struct
874878 Hashtbl. replace ctx.innerRecursiveFunctions oldFunctionName
875879 newFunctionName;
876880 newFunctionDefinition.body < - Some (vb_expr |> expression ~ctx: newCtx);
877- if ! Common.Cli . debug then
878- Log_. warning ~config: ( DceConfig. current () ) ~for Stats:false ~loc: pat_loc
881+ if config. DceConfig. cli .debug then
882+ Log_. warning ~config ~for Stats:false ~loc: pat_loc
879883 (Termination
880884 {
881885 termination = TerminationAnalysisInternal ;
@@ -1069,8 +1073,9 @@ module Eval = struct
10691073 let lookupCache ~functionCall (cache : cache ) =
10701074 Hashtbl. find_opt cache functionCall
10711075
1072- let updateCache ~functionCall ~loc ~state (cache : cache ) =
1073- Stats. logResult ~function Call ~res String:(state |> State. toString) ~loc ;
1076+ let updateCache ~config ~functionCall ~loc ~state (cache : cache ) =
1077+ Stats. logResult ~config ~function Call ~res String:(state |> State. toString)
1078+ ~loc ;
10741079 if not (Hashtbl. mem cache functionCall) then
10751080 Hashtbl. replace cache functionCall state
10761081
@@ -1101,7 +1106,7 @@ module Eval = struct
11011106 true )
11021107 else false
11031108
1104- let rec runFunctionCall ~cache ~callStack ~functionArgs ~functionTable
1109+ let rec runFunctionCall ~config ~ cache ~callStack ~functionArgs ~functionTable
11051110 ~madeProgressOn ~loc ~state functionCallToInstantiate : State.t =
11061111 let pos = loc.Location. loc_start in
11071112 let functionCall =
@@ -1113,7 +1118,7 @@ module Eval = struct
11131118 let stateAfterCall =
11141119 match cache |> lookupCache ~function Call with
11151120 | Some stateAfterCall ->
1116- Stats. logCache ~function Call ~hit: true ~loc ;
1121+ Stats. logCache ~config ~ function Call ~hit: true ~loc ;
11171122 {
11181123 stateAfterCall with
11191124 trace = Trace. Tcall (call, stateAfterCall.progress);
@@ -1126,7 +1131,7 @@ module Eval = struct
11261131 ~loc ~state
11271132 then {state with trace = Trace. Tcall (call, state.progress)}
11281133 else (
1129- Stats. logCache ~function Call ~hit: false ~loc ;
1134+ Stats. logCache ~config ~ function Call ~hit: false ~loc ;
11301135 let functionDefinition =
11311136 functionTable |> FunctionTable. getFunctionDefinition ~function Name
11321137 in
@@ -1138,23 +1143,24 @@ module Eval = struct
11381143 in
11391144 let stateAfterCall =
11401145 body
1141- |> run ~cache ~call Stack ~function Args:functionCall.functionArgs
1142- ~function Table ~made ProgressOn ~state: (State. init () )
1146+ |> run ~config ~cache ~call Stack
1147+ ~function Args:functionCall.functionArgs ~function Table
1148+ ~made ProgressOn ~state: (State. init () )
11431149 in
1144- cache |> updateCache ~function Call ~loc ~state: stateAfterCall;
1150+ cache |> updateCache ~config ~ function Call ~loc ~state: stateAfterCall;
11451151 (* Invariant: run should restore the callStack *)
11461152 callStack |> CallStack. removeFunctionCall ~function Call;
11471153 let trace = Trace. Tcall (call, stateAfterCall.progress) in
11481154 {stateAfterCall with trace})
11491155 in
11501156 State. seq state stateAfterCall
11511157
1152- and run ~(cache : cache ) ~callStack ~functionArgs ~functionTable
1158+ and run ~config ~ (cache : cache ) ~callStack ~functionArgs ~functionTable
11531159 ~madeProgressOn ~state (command : Command.t ) : State.t =
11541160 match command with
11551161 | Call (FunctionCall functionCall , loc ) ->
11561162 functionCall
1157- |> runFunctionCall ~cache ~call Stack ~function Args ~function Table
1163+ |> runFunctionCall ~config ~ cache ~call Stack ~function Args ~function Table
11581164 ~made ProgressOn ~loc ~state
11591165 | Call ((ProgressFunction _ as call ), _pos ) ->
11601166 let state1 =
@@ -1179,7 +1185,7 @@ module Eval = struct
11791185 | c :: nextCommands ->
11801186 let state1 =
11811187 c
1182- |> run ~cache ~call Stack ~function Args ~function Table
1188+ |> run ~config ~ cache ~call Stack ~function Args ~function Table
11831189 ~made ProgressOn ~state
11841190 in
11851191 let madeProgressOn, callStack =
@@ -1202,7 +1208,7 @@ module Eval = struct
12021208 commands
12031209 |> List. map (fun c ->
12041210 c
1205- |> run ~cache ~call Stack ~function Args ~function Table
1211+ |> run ~config ~ cache ~call Stack ~function Args ~function Table
12061212 ~made ProgressOn ~state: stateNoTrace)
12071213 in
12081214 State. seq state (states |> State. unorderedSequence)
@@ -1213,36 +1219,36 @@ module Eval = struct
12131219 commands
12141220 |> List. map (fun c ->
12151221 c
1216- |> run ~cache ~call Stack ~function Args ~function Table
1222+ |> run ~config ~ cache ~call Stack ~function Args ~function Table
12171223 ~made ProgressOn ~state: stateNoTrace)
12181224 in
12191225 State. seq state (states |> State. nondet)
12201226 | SwitchOption {functionCall; loc; some; none} -> (
12211227 let stateAfterCall =
12221228 functionCall
1223- |> runFunctionCall ~cache ~call Stack ~function Args ~function Table
1224- ~made ProgressOn ~loc ~state
1229+ |> runFunctionCall ~config ~ cache ~call Stack ~function Args
1230+ ~function Table ~ made ProgressOn ~loc ~state
12251231 in
12261232 match stateAfterCall.valuesOpt with
12271233 | None ->
12281234 Command. nondet [some; none]
1229- |> run ~cache ~call Stack ~function Args ~function Table ~made ProgressOn
1230- ~state: stateAfterCall
1235+ |> run ~config ~ cache ~call Stack ~function Args ~function Table
1236+ ~made ProgressOn ~ state: stateAfterCall
12311237 | Some values ->
12321238 let runOpt c progressOpt =
12331239 match progressOpt with
12341240 | None -> State. init ~progress: Progress ()
12351241 | Some progress ->
12361242 c
1237- |> run ~cache ~call Stack ~function Args ~function Table
1243+ |> run ~config ~ cache ~call Stack ~function Args ~function Table
12381244 ~made ProgressOn ~state: (State. init ~progress () )
12391245 in
12401246 let stateNone = values |> Values. getNone |> runOpt none in
12411247 let stateSome = values |> Values. getSome |> runOpt some in
12421248 State. seq stateAfterCall (State. nondet [stateSome; stateNone]))
12431249
1244- let analyzeFunction ~cache ~functionTable ~loc functionName =
1245- if ! Common.Cli . debug then
1250+ let analyzeFunction ~config ~ cache ~functionTable ~loc functionName =
1251+ if config. DceConfig. cli .debug then
12461252 Log_. log " @[<v 2>@,@{<warning>Termination Analysis@} for @{<info>%s@}@]@."
12471253 functionName;
12481254 let pos = loc.Location. loc_start in
@@ -1263,10 +1269,10 @@ module Eval = struct
12631269 in
12641270 let state =
12651271 body
1266- |> run ~cache ~call Stack ~function Args ~function Table
1272+ |> run ~config ~ cache ~call Stack ~function Args ~function Table
12671273 ~made ProgressOn:FunctionCallSet. empty ~state: (State. init () )
12681274 in
1269- cache |> updateCache ~function Call ~loc ~state
1275+ cache |> updateCache ~config ~ function Call ~loc ~state
12701276end
12711277
12721278let progressFunctionsFromAttributes attributes =
@@ -1285,7 +1291,7 @@ let progressFunctionsFromAttributes attributes =
12851291 | _ -> [] )
12861292 else None
12871293
1288- let traverseAst ~valueBindingsTable =
1294+ let traverseAst ~config ~ valueBindingsTable =
12891295 let super = Tast_mapper. default in
12901296 let value_bindings (self : Tast_mapper.mapper ) (recFlag , valueBindings ) =
12911297 (* Update the table of value bindings for variables *)
@@ -1352,12 +1358,13 @@ let traverseAst ~valueBindingsTable =
13521358 recursiveDefinitions
13531359 |> List. iter (fun (_ , body ) ->
13541360 body
1355- |> ExtendFunctionTable. run ~function Table ~progress Functions
1356- ~value BindingsTable);
1361+ |> ExtendFunctionTable. run ~config ~function Table
1362+ ~progress Functions ~ value BindingsTable);
13571363 recursiveDefinitions
13581364 |> List. iter (fun (_ , body ) ->
13591365 body
1360- |> CheckExpressionWellFormed. run ~function Table ~value BindingsTable);
1366+ |> CheckExpressionWellFormed. run ~config ~function Table
1367+ ~value BindingsTable);
13611368 functionTable
13621369 |> Hashtbl. iter
13631370 (fun
@@ -1376,17 +1383,19 @@ let traverseAst ~valueBindingsTable =
13761383 |> Compile. expression
13771384 ~ctx:
13781385 {
1386+ config;
13791387 currentFunctionName = functionName;
13801388 functionTable;
13811389 innerRecursiveFunctions = Hashtbl. create 1 ;
13821390 isProgressFunction;
13831391 }))
13841392 ~function Name);
1385- if ! Common.Cli . debug then FunctionTable. dump functionTable;
1393+ if config. DceConfig. cli .debug then FunctionTable. dump functionTable;
13861394 let cache = Eval. createCache () in
13871395 functionsToAnalyze
13881396 |> List. iter (fun (functionName , loc ) ->
1389- functionName |> Eval. analyzeFunction ~cache ~function Table ~loc );
1397+ functionName
1398+ |> Eval. analyzeFunction ~config ~cache ~function Table ~loc );
13901399 Stats. newRecursiveFunctions ~num Functions:(Hashtbl. length functionTable));
13911400 valueBindings
13921401 |> List. iter (fun valueBinding ->
@@ -1395,16 +1404,16 @@ let traverseAst ~valueBindingsTable =
13951404 in
13961405 {super with Tast_mapper. value_bindings}
13971406
1398- let processStructure (structure : Typedtree.structure ) =
1407+ let processStructure ~ config (structure : Typedtree.structure ) =
13991408 Stats. newFile () ;
14001409 let valueBindingsTable = Hashtbl. create 1 in
1401- let traverseAst = traverseAst ~value BindingsTable in
1410+ let traverseAst = traverseAst ~config ~ value BindingsTable in
14021411 structure |> traverseAst.structure traverseAst |> ignore
14031412
1404- let processCmt (cmt_infos : Cmt_format.cmt_infos ) =
1413+ let processCmt ~ config (cmt_infos : Cmt_format.cmt_infos ) =
14051414 match cmt_infos.cmt_annots with
14061415 | Interface _ -> ()
1407- | Implementation structure -> processStructure structure
1416+ | Implementation structure -> processStructure ~config structure
14081417 | _ -> ()
14091418
1410- let reportStats () = Stats. dump ~ppf: Format. std_formatter
1419+ let reportStats ~ config : _ = Stats. dump ~ppf: Format. std_formatter
0 commit comments