Skip to content

Commit 683aeec

Browse files
cristianoccristianoc
committed
reanalyze: make ModulePath pure during AST traversal
Remove global ModulePath mutable state used during per-file AST traversal by threading ModulePath.t explicitly through traversal code. This is preparation for parallel per-file processing and reduces shared global state during MAP. Signed-Off-By: Cristiano Calcagno <cristiano.calcagno@gmail.com>
1 parent 14721cb commit 683aeec

File tree

6 files changed

+203
-161
lines changed

6 files changed

+203
-161
lines changed

‎analysis/reanalyze/src/DceFileProcessing.ml‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -32,6 +32,7 @@ let processSignature ~config ~decls ~(file : file_context) ~doValues ~doTypes
3232
|> List.iter (fun sig_item ->
3333
DeadValue.processSignatureItem ~config ~decls ~file:dead_common_file
3434
~doValues ~doTypes ~moduleLoc:Location.none
35+
~modulePath:ModulePath.initial
3536
~path:[module_name_tagged file]
3637
sig_item)
3738

‎analysis/reanalyze/src/DeadException.ml‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -2,13 +2,13 @@ open DeadCommon
22

33
let declarations = Hashtbl.create 1
44

5-
let add ~config ~decls ~file ~path ~loc ~(strLoc : Location.t) name =
5+
let add ~config ~decls ~file ~path ~loc ~(strLoc : Location.t)
6+
~(moduleLoc : Location.t) name =
67
let exceptionPath = name :: path in
78
Hashtbl.add declarations exceptionPath loc;
89
name
910
|> addDeclaration_ ~config ~decls ~file ~posEnd:strLoc.loc_end
10-
~posStart:strLoc.loc_start ~declKind:Exception
11-
~moduleLoc:(ModulePath.getCurrent ()).loc ~path ~loc
11+
~posStart:strLoc.loc_start ~declKind:Exception ~moduleLoc ~path ~loc
1212

1313
let find_exception path = Hashtbl.find_opt declarations path
1414

‎analysis/reanalyze/src/DeadType.ml‎

Lines changed: 4 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -80,17 +80,16 @@ let addTypeDependenciesInnerModule ~config ~pathToType ~loc ~typeLabelName =
8080
extendTypeDependencies ~config loc2 loc
8181
| None -> TypeLabels.add path loc
8282

83-
let addDeclaration ~config ~decls ~file ~(typeId : Ident.t)
84-
~(typeKind : Types.type_kind) =
85-
let currentModulePath = ModulePath.getCurrent () in
83+
let addDeclaration ~config ~decls ~file ~(modulePath : ModulePath.t)
84+
~(typeId : Ident.t) ~(typeKind : Types.type_kind) =
8685
let pathToType =
8786
(typeId |> Ident.name |> Name.create)
88-
:: (currentModulePath.path @ [FileContext.module_name_tagged file])
87+
:: (modulePath.path @ [FileContext.module_name_tagged file])
8988
in
9089
let processTypeLabel ?(posAdjustment = Decl.Nothing) typeLabelName ~declKind
9190
~(loc : Location.t) =
9291
addDeclaration_ ~config ~decls ~file ~declKind ~path:pathToType ~loc
93-
~moduleLoc:currentModulePath.loc ~posAdjustment typeLabelName;
92+
~moduleLoc:modulePath.loc ~posAdjustment typeLabelName;
9493
addTypeDependenciesAcrossFiles ~config ~file ~pathToType ~loc ~typeLabelName;
9594
addTypeDependenciesInnerModule ~config ~pathToType ~loc ~typeLabelName;
9695
TypeLabels.add (typeLabelName :: pathToType) loc

‎analysis/reanalyze/src/DeadValue.ml‎

Lines changed: 111 additions & 107 deletions
Original file line numberDiff line numberDiff line change
@@ -3,22 +3,22 @@
33
open DeadCommon
44

55
let checkAnyValueBindingWithNoSideEffects ~config ~decls ~file
6+
~(modulePath : ModulePath.t)
67
({vb_pat = {pat_desc}; vb_expr = expr; vb_loc = loc} :
78
Typedtree.value_binding) =
89
match pat_desc with
910
| Tpat_any when (not (SideEffects.checkExpr expr)) && not loc.loc_ghost ->
1011
let name = "_" |> Name.create ~isInterface:false in
11-
let currentModulePath = ModulePath.getCurrent () in
12-
let path = currentModulePath.path @ [FileContext.module_name_tagged file] in
12+
let path = modulePath.path @ [FileContext.module_name_tagged file] in
1313
name
1414
|> addValueDeclaration ~config ~decls ~file ~path ~loc
15-
~moduleLoc:currentModulePath.loc ~sideEffects:false
15+
~moduleLoc:modulePath.loc ~sideEffects:false
1616
| _ -> ()
1717

1818
let collectValueBinding ~config ~decls ~file ~(current_binding : Location.t)
19-
(vb : Typedtree.value_binding) =
19+
~(modulePath : ModulePath.t) (vb : Typedtree.value_binding) =
2020
let oldLastBinding = current_binding in
21-
checkAnyValueBindingWithNoSideEffects ~config ~decls ~file vb;
21+
checkAnyValueBindingWithNoSideEffects ~config ~decls ~file ~modulePath vb;
2222
let loc =
2323
match vb.vb_pat.pat_desc with
2424
| Tpat_var (id, {loc = {loc_start; loc_ghost} as loc})
@@ -37,10 +37,7 @@ let collectValueBinding ~config ~decls ~file ~(current_binding : Location.t)
3737
true
3838
| _ -> false
3939
in
40-
let currentModulePath = ModulePath.getCurrent () in
41-
let path =
42-
currentModulePath.path @ [FileContext.module_name_tagged file]
43-
in
40+
let path = modulePath.path @ [FileContext.module_name_tagged file] in
4441
let isFirstClassModule =
4542
match vb.vb_expr.exp_type.desc with
4643
| Tpackage _ -> true
@@ -52,7 +49,7 @@ let collectValueBinding ~config ~decls ~file ~(current_binding : Location.t)
5249
let sideEffects = SideEffects.checkExpr vb.vb_expr in
5350
name
5451
|> addValueDeclaration ~config ~decls ~file ~isToplevel ~loc
55-
~moduleLoc:currentModulePath.loc ~optionalArgs ~path ~sideEffects);
52+
~moduleLoc:modulePath.loc ~optionalArgs ~path ~sideEffects);
5653
(match Declarations.find_opt_builder decls loc_start with
5754
| None -> ()
5855
| Some decl ->
@@ -246,12 +243,11 @@ let rec getSignature (moduleType : Types.module_type) =
246243
| _ -> []
247244

248245
let rec processSignatureItem ~config ~decls ~file ~doTypes ~doValues ~moduleLoc
249-
~path (si : Types.signature_item) =
250-
let oldModulePath = ModulePath.getCurrent () in
251-
(match si with
246+
~(modulePath : ModulePath.t) ~path (si : Types.signature_item) =
247+
match si with
252248
| Sig_type (id, t, _) when doTypes ->
253249
if !Config.analyzeTypes then
254-
DeadType.addDeclaration ~config ~decls ~file ~typeId:id
250+
DeadType.addDeclaration ~config ~decls ~file ~modulePath ~typeId:id
255251
~typeKind:t.type_kind
256252
| Sig_value (id, {Types.val_loc = loc; val_kind = kind; val_type})
257253
when doValues ->
@@ -274,12 +270,11 @@ let rec processSignatureItem ~config ~decls ~file ~doTypes ~doValues ~moduleLoc
274270
~optionalArgs ~path ~sideEffects:false
275271
| Sig_module (id, {Types.md_type = moduleType; md_loc = moduleLoc}, _)
276272
| Sig_modtype (id, {Types.mtd_type = Some moduleType; mtd_loc = moduleLoc}) ->
277-
ModulePath.setCurrent
278-
{
279-
oldModulePath with
280-
loc = moduleLoc;
281-
path = (id |> Ident.name |> Name.create) :: oldModulePath.path;
282-
};
273+
let modulePath' =
274+
ModulePath.enterModule modulePath
275+
~name:(id |> Ident.name |> Name.create)
276+
~loc:moduleLoc
277+
in
283278
let collect =
284279
match si with
285280
| Sig_modtype _ -> false
@@ -289,15 +284,15 @@ let rec processSignatureItem ~config ~decls ~file ~doTypes ~doValues ~moduleLoc
289284
getSignature moduleType
290285
|> List.iter
291286
(processSignatureItem ~config ~decls ~file ~doTypes ~doValues
292-
~moduleLoc
287+
~moduleLoc ~modulePath:modulePath'
293288
~path:((id |> Ident.name |> Name.create) :: path))
294-
| _ -> ());
295-
ModulePath.setCurrent oldModulePath
289+
| _ -> ()
296290

297291
(* Traverse the AST *)
298292
let traverseStructure ~config ~decls ~refs ~file_deps ~cross_file ~file ~doTypes
299293
~doExternals (structure : Typedtree.structure) : unit =
300-
let rec create_mapper (last_binding : Location.t) =
294+
let rec create_mapper (last_binding : Location.t) (modulePath : ModulePath.t)
295+
=
301296
let super = Tast_mapper.default in
302297
let rec mapper =
303298
{
@@ -310,103 +305,112 @@ let traverseStructure ~config ~decls ~refs ~file_deps ~cross_file ~file ~doTypes
310305
pat = (fun _self p -> p |> collectPattern ~config ~refs super mapper);
311306
structure_item =
312307
(fun _self (structureItem : Typedtree.structure_item) ->
313-
let oldModulePath = ModulePath.getCurrent () in
314-
(match structureItem.str_desc with
315-
| Tstr_module {mb_expr; mb_id; mb_loc} -> (
316-
let hasInterface =
317-
match mb_expr.mod_desc with
318-
| Tmod_constraint _ -> true
319-
| _ -> false
320-
in
321-
ModulePath.setCurrent
322-
{
323-
oldModulePath with
324-
loc = mb_loc;
325-
path =
326-
(mb_id |> Ident.name |> Name.create) :: oldModulePath.path;
327-
};
328-
if hasInterface then
329-
match mb_expr.mod_type with
330-
| Mty_signature signature ->
331-
signature
308+
let modulePath_for_item_opt =
309+
match structureItem.str_desc with
310+
| Tstr_module {mb_expr; mb_id; mb_loc} ->
311+
let hasInterface =
312+
match mb_expr.mod_desc with
313+
| Tmod_constraint _ -> true
314+
| _ -> false
315+
in
316+
let modulePath' =
317+
ModulePath.enterModule modulePath
318+
~name:(mb_id |> Ident.name |> Name.create)
319+
~loc:mb_loc
320+
in
321+
if hasInterface then
322+
match mb_expr.mod_type with
323+
| Mty_signature signature ->
324+
signature
325+
|> List.iter
326+
(processSignatureItem ~config ~decls ~file ~doTypes
327+
~doValues:false ~moduleLoc:mb_expr.mod_loc
328+
~modulePath:modulePath'
329+
~path:
330+
(modulePath'.path
331+
@ [FileContext.module_name_tagged file]))
332+
| _ -> ()
333+
else ();
334+
Some modulePath'
335+
| Tstr_primitive vd when doExternals && !Config.analyzeExternals
336+
->
337+
let path =
338+
modulePath.path @ [FileContext.module_name_tagged file]
339+
in
340+
let exists =
341+
match
342+
Declarations.find_opt_builder decls vd.val_loc.loc_start
343+
with
344+
| Some {declKind = Value _} -> true
345+
| _ -> false
346+
in
347+
let id = vd.val_id |> Ident.name in
348+
Printf.printf "Primitive %s\n" id;
349+
if
350+
(not exists) && id <> "unsafe_expr"
351+
(* see https://github.com/BuckleScript/bucklescript/issues/4532 *)
352+
then
353+
id
354+
|> Name.create ~isInterface:false
355+
|> addValueDeclaration ~config ~decls ~file ~path
356+
~loc:vd.val_loc ~moduleLoc:modulePath.loc
357+
~sideEffects:false;
358+
None
359+
| Tstr_type (_recFlag, typeDeclarations) when doTypes ->
360+
if !Config.analyzeTypes then
361+
typeDeclarations
362+
|> List.iter
363+
(fun (typeDeclaration : Typedtree.type_declaration) ->
364+
DeadType.addDeclaration ~config ~decls ~file
365+
~modulePath ~typeId:typeDeclaration.typ_id
366+
~typeKind:typeDeclaration.typ_type.type_kind);
367+
None
368+
| Tstr_include {incl_mod; incl_type} ->
369+
(match incl_mod.mod_desc with
370+
| Tmod_ident (_path, _lid) ->
371+
let currentPath =
372+
modulePath.path @ [FileContext.module_name_tagged file]
373+
in
374+
incl_type
332375
|> List.iter
333376
(processSignatureItem ~config ~decls ~file ~doTypes
334-
~doValues:false ~moduleLoc:mb_expr.mod_loc
335-
~path:
336-
((ModulePath.getCurrent ()).path
337-
@ [FileContext.module_name_tagged file]))
338-
| _ -> ())
339-
| Tstr_primitive vd when doExternals && !Config.analyzeExternals ->
340-
let currentModulePath = ModulePath.getCurrent () in
341-
let path =
342-
currentModulePath.path @ [FileContext.module_name_tagged file]
343-
in
344-
let exists =
345-
match
346-
Declarations.find_opt_builder decls vd.val_loc.loc_start
347-
with
348-
| Some {declKind = Value _} -> true
349-
| _ -> false
350-
in
351-
let id = vd.val_id |> Ident.name in
352-
Printf.printf "Primitive %s\n" id;
353-
if
354-
(not exists) && id <> "unsafe_expr"
355-
(* see https://github.com/BuckleScript/bucklescript/issues/4532 *)
356-
then
357-
id
358-
|> Name.create ~isInterface:false
359-
|> addValueDeclaration ~config ~decls ~file ~path
360-
~loc:vd.val_loc ~moduleLoc:currentModulePath.loc
361-
~sideEffects:false
362-
| Tstr_type (_recFlag, typeDeclarations) when doTypes ->
363-
if !Config.analyzeTypes then
364-
typeDeclarations
365-
|> List.iter
366-
(fun (typeDeclaration : Typedtree.type_declaration) ->
367-
DeadType.addDeclaration ~config ~decls ~file
368-
~typeId:typeDeclaration.typ_id
369-
~typeKind:typeDeclaration.typ_type.type_kind)
370-
| Tstr_include {incl_mod; incl_type} -> (
371-
match incl_mod.mod_desc with
372-
| Tmod_ident (_path, _lid) ->
373-
let currentPath =
374-
(ModulePath.getCurrent ()).path
375-
@ [FileContext.module_name_tagged file]
377+
~doValues:false (* TODO: also values? *)
378+
~moduleLoc:incl_mod.mod_loc ~modulePath
379+
~path:currentPath)
380+
| _ -> ());
381+
None
382+
| Tstr_exception {ext_id = id; ext_loc = loc} ->
383+
let path =
384+
modulePath.path @ [FileContext.module_name_tagged file]
376385
in
377-
incl_type
378-
|> List.iter
379-
(processSignatureItem ~config ~decls ~file ~doTypes
380-
~doValues:false (* TODO: also values? *)
381-
~moduleLoc:incl_mod.mod_loc ~path:currentPath)
382-
| _ -> ())
383-
| Tstr_exception {ext_id = id; ext_loc = loc} ->
384-
let path =
385-
(ModulePath.getCurrent ()).path
386-
@ [FileContext.module_name_tagged file]
387-
in
388-
let name = id |> Ident.name |> Name.create in
389-
name
390-
|> DeadException.add ~config ~decls ~file ~path ~loc
391-
~strLoc:structureItem.str_loc
392-
| _ -> ());
393-
let result = super.structure_item mapper structureItem in
394-
ModulePath.setCurrent oldModulePath;
395-
result);
386+
let name = id |> Ident.name |> Name.create in
387+
name
388+
|> DeadException.add ~config ~decls ~file ~path ~loc
389+
~strLoc:structureItem.str_loc ~moduleLoc:modulePath.loc;
390+
None
391+
| _ -> None
392+
in
393+
let mapper_for_item =
394+
match modulePath_for_item_opt with
395+
| None -> mapper
396+
| Some modulePath_for_item ->
397+
create_mapper last_binding modulePath_for_item
398+
in
399+
super.structure_item mapper_for_item structureItem);
396400
value_binding =
397401
(fun _self vb ->
398402
let loc =
399403
vb
400404
|> collectValueBinding ~config ~decls ~file
401-
~current_binding:last_binding
405+
~current_binding:last_binding ~modulePath
402406
in
403-
let nested_mapper = create_mapper loc in
407+
let nested_mapper = create_mapper loc modulePath in
404408
super.Tast_mapper.value_binding nested_mapper vb);
405409
}
406410
in
407411
mapper
408412
in
409-
let mapper = create_mapper Location.none in
413+
let mapper = create_mapper Location.none ModulePath.initial in
410414
mapper.structure mapper structure |> ignore
411415

412416
(* Merge a location's references to another one's *)

0 commit comments

Comments
 (0)