diff --git a/.gitignore b/.gitignore index ba748abd224..d58419eeeee 100644 --- a/.gitignore +++ b/.gitignore @@ -108,3 +108,6 @@ package.tgz # AI Agents .claude/settings.local.json + +# reanalyze DCE report output +_dce/ diff --git a/_dce/report.txt b/_dce/report.txt new file mode 100644 index 00000000000..e7d7e3978ba --- /dev/null +++ b/_dce/report.txt @@ -0,0 +1,1876 @@ + + Warning Unused Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_compile.ml", line 820, characters 4-2265 + optional argument declaration of function +switch is never used + + Warning Unused Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_compile.ml", line 820, characters 4-2265 + optional argument default of function +switch is never used + + Warning Unused Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/analysis/reanalyze/src/reanalyze.ml", line 199, characters 0-11133 + optional argument file_stats of function +run_analysis is never used + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 344, characters 2-178 + optional argument attrs of function Te.+constructor is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 344, characters 2-178 + optional argument loc of function Te.+constructor is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 335, characters 2-246 + optional argument attrs of function Te.+mk is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 335, characters 2-246 + optional argument params of function Te.+mk is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 335, characters 2-246 + optional argument priv of function Te.+mk is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 323, characters 2-210 + optional argument attrs of function Type.+field is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 323, characters 2-210 + optional argument loc of function Type.+field is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 323, characters 2-210 + optional argument mut of function Type.+field is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 313, characters 2-226 + optional argument args of function Type.+constructor is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 313, characters 2-226 + optional argument attrs of function Type.+constructor is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 313, characters 2-226 + optional argument loc of function Type.+constructor is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 300, characters 2-372 + optional argument attrs of function Type.+mk is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 300, characters 2-372 + optional argument cstrs of function Type.+mk is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 300, characters 2-372 + optional argument kind of function Type.+mk is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 300, characters 2-372 + optional argument loc of function Type.+mk is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 300, characters 2-372 + optional argument params of function Type.+mk is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 300, characters 2-372 + optional argument priv of function Type.+mk is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 295, characters 2-131 + optional argument attrs of function Vb.+mk is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 295, characters 2-131 + optional argument loc of function Vb.+mk is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 290, characters 2-119 + optional argument attrs of function Incl.+mk is always supplied (2 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 290, characters 2-119 + optional argument loc of function Incl.+mk is always supplied (2 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 280, characters 2-193 + optional argument attrs of function Opn.+mk is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 280, characters 2-193 + optional argument loc of function Opn.+mk is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 280, characters 2-193 + optional argument override of function Opn.+mk is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 275, characters 2-134 + optional argument attrs of function Mb.+mk is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 275, characters 2-134 + optional argument loc of function Mb.+mk is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 270, characters 2-137 + optional argument attrs of function Mtd.+mk is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 270, characters 2-137 + optional argument loc of function Mtd.+mk is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 265, characters 2-132 + optional argument attrs of function Md.+mk is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 265, characters 2-132 + optional argument loc of function Md.+mk is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 254, characters 2-204 + optional argument attrs of function Val.+mk is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 254, characters 2-204 + optional argument loc of function Val.+mk is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 254, characters 2-204 + optional argument prim of function Val.+mk is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 250, characters 2-51 + optional argument loc of function Str.+attribute is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 249, characters 2-74 + optional argument attrs of function Str.+extension is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 249, characters 2-74 + optional argument loc of function Str.+extension is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 248, characters 2-48 + optional argument loc of function Str.+include_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 247, characters 2-42 + optional argument loc of function Str.+open_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 246, characters 2-47 + optional argument loc of function Str.+modtype is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 245, characters 2-52 + optional argument loc of function Str.+rec_module is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 244, characters 2-46 + optional argument loc of function Str.+module_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 243, characters 2-52 + optional argument loc of function Str.+exception_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 242, characters 2-53 + optional argument loc of function Str.+type_extension is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 241, characters 2-63 + optional argument loc of function Str.+type_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 240, characters 2-51 + optional argument loc of function Str.+primitive is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 239, characters 2-50 + optional argument loc of function Str.+value is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 232, characters 2-51 + optional argument loc of function Sig.+attribute is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 231, characters 2-74 + optional argument attrs of function Sig.+extension is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 231, characters 2-74 + optional argument loc of function Sig.+extension is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 229, characters 2-48 + optional argument loc of function Sig.+include_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 228, characters 2-42 + optional argument loc of function Sig.+open_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 227, characters 2-47 + optional argument loc of function Sig.+modtype is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 226, characters 2-52 + optional argument loc of function Sig.+rec_module is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 225, characters 2-46 + optional argument loc of function Sig.+module_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 224, characters 2-52 + optional argument loc of function Sig.+exception_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 223, characters 2-53 + optional argument loc of function Sig.+type_extension is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 222, characters 2-63 + optional argument loc of function Sig.+type_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 221, characters 2-43 + optional argument loc of function Sig.+value is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 215, characters 2-65 + optional argument attrs of function Mod.+extension is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 215, characters 2-65 + optional argument loc of function Mod.+extension is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 214, characters 2-59 + optional argument attrs of function Mod.+unpack is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 214, characters 2-59 + optional argument loc of function Mod.+unpack is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 213, characters 2-79 + optional argument attrs of function Mod.+constraint_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 213, characters 2-79 + optional argument loc of function Mod.+constraint_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 212, characters 2-68 + optional argument attrs of function Mod.+apply is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 212, characters 2-68 + optional argument loc of function Mod.+apply is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 210, characters 2-98 + optional argument attrs of function Mod.+functor_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 210, characters 2-98 + optional argument loc of function Mod.+functor_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 209, characters 2-65 + optional argument attrs of function Mod.+structure is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 209, characters 2-65 + optional argument loc of function Mod.+structure is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 208, characters 2-57 + optional argument attrs of function Mod.+ident is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 208, characters 2-57 + optional argument loc of function Mod.+ident is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 200, characters 2-65 + optional argument attrs of function Mty.+extension is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 200, characters 2-65 + optional argument loc of function Mty.+extension is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 199, characters 2-60 + optional argument attrs of function Mty.+typeof_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 199, characters 2-60 + optional argument loc of function Mty.+typeof_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 198, characters 2-63 + optional argument attrs of function Mty.+with_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 198, characters 2-63 + optional argument loc of function Mty.+with_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 197, characters 2-74 + optional argument attrs of function Mty.+functor_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 197, characters 2-74 + optional argument loc of function Mty.+functor_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 196, characters 2-65 + optional argument attrs of function Mty.+signature is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 196, characters 2-65 + optional argument loc of function Mty.+signature is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 195, characters 2-57 + optional argument attrs of function Mty.+alias is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 195, characters 2-57 + optional argument loc of function Mty.+alias is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 194, characters 2-57 + optional argument attrs of function Mty.+ident is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 194, characters 2-57 + optional argument loc of function Mty.+ident is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 184, characters 2-65 + optional argument attrs of function Exp.+extension is always supplied (3 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 184, characters 2-65 + optional argument loc of function Exp.+extension is always supplied (3 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 183, characters 2-68 + optional argument attrs of function Exp.+open_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 183, characters 2-68 + optional argument loc of function Exp.+open_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 182, characters 2-55 + optional argument attrs of function Exp.+pack is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 182, characters 2-55 + optional argument loc of function Exp.+pack is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 181, characters 2-68 + optional argument attrs of function Exp.+newtype is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 181, characters 2-68 + optional argument loc of function Exp.+newtype is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 178, characters 2-60 + optional argument attrs of function Exp.+assert_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 178, characters 2-60 + optional argument loc of function Exp.+assert_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 177, characters 2-78 + optional argument attrs of function Exp.+letexception is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 177, characters 2-78 + optional argument loc of function Exp.+letexception is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 176, characters 2-77 + optional argument attrs of function Exp.+letmodule is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 176, characters 2-77 + optional argument loc of function Exp.+letmodule is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 172, characters 2-62 + optional argument attrs of function Exp.+send is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 172, characters 2-62 + optional argument loc of function Exp.+send is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 171, characters 2-70 + optional argument attrs of function Exp.+coerce is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 171, characters 2-70 + optional argument loc of function Exp.+coerce is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 170, characters 2-75 + optional argument attrs of function Exp.+constraint_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 170, characters 2-75 + optional argument loc of function Exp.+constraint_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 169, characters 2-76 + optional argument attrs of function Exp.+for_ is always supplied (3 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 169, characters 2-76 + optional argument loc of function Exp.+for_ is always supplied (3 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 168, characters 2-65 + optional argument attrs of function Exp.+while_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 168, characters 2-65 + optional argument loc of function Exp.+while_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 167, characters 2-70 + optional argument attrs of function Exp.+sequence is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 167, characters 2-70 + optional argument loc of function Exp.+sequence is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 166, characters 2-79 + optional argument attrs of function Exp.+ifthenelse is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 166, characters 2-79 + optional argument loc of function Exp.+ifthenelse is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 165, characters 2-57 + optional argument attrs of function Exp.+array is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 165, characters 2-57 + optional argument loc of function Exp.+array is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 164, characters 2-75 + optional argument attrs of function Exp.+setfield is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 164, characters 2-75 + optional argument loc of function Exp.+setfield is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 163, characters 2-64 + optional argument attrs of function Exp.+field is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 163, characters 2-64 + optional argument loc of function Exp.+field is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 162, characters 2-66 + optional argument attrs of function Exp.+record is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 162, characters 2-66 + optional argument loc of function Exp.+record is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 161, characters 2-68 + optional argument attrs of function Exp.+variant is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 161, characters 2-68 + optional argument loc of function Exp.+variant is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 159, characters 2-57 + optional argument attrs of function Exp.+tuple is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 159, characters 2-57 + optional argument loc of function Exp.+tuple is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 158, characters 2-61 + optional argument attrs of function Exp.+try_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 158, characters 2-61 + optional argument loc of function Exp.+try_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 157, characters 2-65 + optional argument attrs of function Exp.+match_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 157, characters 2-65 + optional argument loc of function Exp.+match_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 156, characters 2-64 + optional argument attrs of function Exp.+apply is always supplied (3 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 156, characters 2-64 + optional argument loc of function Exp.+apply is always supplied (3 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 154, characters 2-71 + optional argument attrs of function Exp.+fun_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 154, characters 2-71 + optional argument loc of function Exp.+fun_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 153, characters 2-66 + optional argument attrs of function Exp.+let_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 153, characters 2-66 + optional argument loc of function Exp.+let_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 143, characters 2-65 + optional argument attrs of function Pat.+extension is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 143, characters 2-65 + optional argument loc of function Pat.+extension is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 142, characters 2-66 + optional argument attrs of function Pat.+exception_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 142, characters 2-66 + optional argument loc of function Pat.+exception_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 141, characters 2-63 + optional argument attrs of function Pat.+open_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 141, characters 2-63 + optional argument loc of function Pat.+open_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 140, characters 2-59 + optional argument attrs of function Pat.+unpack is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 140, characters 2-59 + optional argument loc of function Pat.+unpack is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 138, characters 2-56 + optional argument attrs of function Pat.+type_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 138, characters 2-56 + optional argument loc of function Pat.+type_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 137, characters 2-75 + optional argument attrs of function Pat.+constraint_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 137, characters 2-75 + optional argument loc of function Pat.+constraint_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 136, characters 2-59 + optional argument attrs of function Pat.+or_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 136, characters 2-59 + optional argument loc of function Pat.+or_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 135, characters 2-57 + optional argument attrs of function Pat.+array is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 135, characters 2-57 + optional argument loc of function Pat.+array is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 134, characters 2-66 + optional argument attrs of function Pat.+record is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 134, characters 2-66 + optional argument loc of function Pat.+record is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 133, characters 2-68 + optional argument attrs of function Pat.+variant is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 133, characters 2-68 + optional argument loc of function Pat.+variant is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 132, characters 2-72 + optional argument attrs of function Pat.+construct is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 132, characters 2-72 + optional argument loc of function Pat.+construct is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 131, characters 2-57 + optional argument attrs of function Pat.+tuple is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 131, characters 2-57 + optional argument loc of function Pat.+tuple is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 130, characters 2-70 + optional argument attrs of function Pat.+interval is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 130, characters 2-70 + optional argument loc of function Pat.+interval is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 129, characters 2-63 + optional argument attrs of function Pat.+constant is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 129, characters 2-63 + optional argument loc of function Pat.+constant is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 128, characters 2-64 + optional argument attrs of function Pat.+alias is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 128, characters 2-64 + optional argument loc of function Pat.+alias is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 127, characters 2-53 + optional argument attrs of function Pat.+var is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 127, characters 2-53 + optional argument loc of function Pat.+var is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 126, characters 2-50 + optional argument attrs of function Pat.+any is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 126, characters 2-50 + optional argument loc of function Pat.+any is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 65, characters 2-65 + optional argument attrs of function Typ.+extension is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 65, characters 2-65 + optional argument loc of function Typ.+extension is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 64, characters 2-68 + optional argument attrs of function Typ.+package is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 64, characters 2-68 + optional argument loc of function Typ.+package is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 63, characters 2-62 + optional argument loc of function Typ.+poly is always supplied (2 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 62, characters 2-73 + optional argument loc of function Typ.+variant is always supplied (2 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 61, characters 2-64 + optional argument attrs of function Typ.+alias is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 61, characters 2-64 + optional argument loc of function Typ.+alias is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 60, characters 2-67 + optional argument attrs of function Typ.+object_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 60, characters 2-67 + optional argument loc of function Typ.+object_ is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 59, characters 2-66 + optional argument loc of function Typ.+constr is always supplied (2 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 58, characters 2-57 + optional argument attrs of function Typ.+tuple is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 58, characters 2-57 + optional argument loc of function Typ.+tuple is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 57, characters 2-69 + optional argument attrs of function Typ.+arrow is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 57, characters 2-69 + optional argument loc of function Typ.+arrow is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 56, characters 2-53 + optional argument attrs of function Typ.+var is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 56, characters 2-53 + optional argument loc of function Typ.+var is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 55, characters 2-50 + optional argument attrs of function Typ.+any is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 55, characters 2-50 + optional argument loc of function Typ.+any is always supplied (1 calls) + + Warning Unused Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/analysis/src/type_utils.ml", line 587, characters 2-51 + optional argument print_opening_debug of function +extract_type is never used + + Warning Unused Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/analysis/src/type_utils.ml", line 587, characters 2-51 + optional argument type_arg_context_from_type_manifest of function +extract_type is never used + + Warning Unused Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/analysis/src/type_utils.ml", line 179, characters 0-2146 + optional argument type_arg_context of function +instantiate_type2 is never used + + Warning Unused Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/typecore.ml", line 1145, characters 2-61 + optional argument from_type of function Constructor.+unbound_name_error is never used + + Warning Unused Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/typecore.ml", line 967, characters 2-55 + optional argument from_type of function Label.+unbound_name_error is never used + + Warning Unused Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/typetexp.mli", line 102, characters 0-91 + optional argument from_type of function +unbound_label_error is never used + + Warning Unused Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/typetexp.mli", line 100, characters 0-97 + optional argument from_type of function +unbound_constructor_error is never used + + Warning Unused Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/typetexp.ml", line 173, characters 0-141 + optional argument from_type of function +unbound_label_error is never used + + Warning Unused Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/typetexp.ml", line 168, characters 0-160 + optional argument from_type of function +unbound_constructor_error is never used + + Warning Unused Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/env.mli", line 112, characters 0-90 + optional argument loc of function +lookup_modtype is never used + + Warning Unused Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/env.mli", line 106, characters 0-63 + optional argument loc of function +lookup_type is never used + + Warning Unused Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/env.mli", line 101, characters 0-112 + optional argument loc of function +lookup_all_labels is never used + + Warning Unused Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/env.mli", line 96, characters 0-124 + optional argument loc of function +lookup_all_constructors is never used + + Warning Unused Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/env.mli", line 94, characters 0-89 + optional argument loc of function +lookup_constructor is never used + + Warning Unused Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/env.mli", line 92, characters 0-86 + optional argument loc of function +lookup_value is never used + + Warning Unused Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/env.ml", line 1216, characters 0-295 + optional argument loc of function +lookup_all_labels is never used + + Warning Unused Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/env.ml", line 1190, characters 0-313 + optional argument loc of function +lookup_all_constructors is never used + + Warning Unused Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/env.ml", line 1178, characters 0-206 + optional argument loc of function +lookup_constructor is never used + + Warning Unused Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/env.ml", line 1162, characters 0-137 + optional argument loc of function +lookup_type is never used + + Warning Unused Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/env.ml", line 1157, characters 0-138 + optional argument loc of function +lookup_value is never used + + Warning Unused Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/env.ml", line 1101, characters 0-84 + optional argument loc of function +lookup_modtype is never used + + Warning Unused Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/env.ml", line 1060, characters 0-663 + optional argument loc of function +lookup_all_simple is never used + + Warning Unused Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/env.ml", line 1048, characters 0-391 + optional argument loc of function +lookup is never used + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/location.mli", line 103, characters 0-108 + optional argument custom_intro of function +report_error is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/location.mli", line 103, characters 0-108 + optional argument src of function +report_error is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/location.ml", line 253, characters 0-108 + optional argument custom_intro of function +report_error is always supplied (1 calls) + + Warning Redundant Optional Argument + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/location.ml", line 253, characters 0-108 + optional argument src of function +report_error is always supplied (1 calls) + + Warning Dead Module + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/common/bs_loc.ml", line 1, characters 0-0 + +bs_loc is a dead module as all its items are dead. + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/common/bs_loc.ml", line 26, characters 2-29 + t.loc_start is a record label never used to read a value + <-- line 26 + loc_start: Lexing.position; [@dead "t.loc_start"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/common/bs_loc.ml", line 27, characters 2-27 + t.loc_end is a record label never used to read a value + <-- line 27 + loc_end: Lexing.position; [@dead "t.loc_end"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/common/bs_loc.ml", line 28, characters 2-18 + t.loc_ghost is a record label never used to read a value + <-- line 28 + loc_ghost: bool; [@dead "t.loc_ghost"] + + Warning Dead Module + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/common/bs_loc.mli", line 1, characters 0-0 + bs_loc is a dead module as all its items are dead. + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/common/bs_loc.mli", line 26, characters 2-29 + t.loc_start is a record label never used to read a value + <-- line 26 + loc_start: Lexing.position; [@dead "t.loc_start"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/common/bs_loc.mli", line 27, characters 2-27 + t.loc_end is a record label never used to read a value + <-- line 27 + loc_end: Lexing.position; [@dead "t.loc_end"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/common/bs_loc.mli", line 28, characters 2-18 + t.loc_ghost is a record label never used to read a value + <-- line 28 + loc_ghost: bool; [@dead "t.loc_ghost"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/j.ml", line 77, characters 65-78 + delim.DBackQuotes is a variant case which is never constructed + <-- line 77 + and delim = External_arg_spec.delim = DNone | DStarJ | DNoQuotes | DBackQuotes [@dead "delim.DBackQuotes"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/js_dump_program.mli", line 28, characters 0-124 + +pp_deps_program is never used + <-- line 28 + unit [@@dead "+pp_deps_program"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/js_of_lam_variant.ml", line 28, characters 22-29 + arg_expression.Splice0 is a variant case which is never constructed + <-- line 28 + type arg_expression = Splice0 [@dead "arg_expression.Splice0"] | Splice1 of E.t | Splice2 of E.t * E.t + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/js_of_lam_variant.ml", line 28, characters 30-46 + arg_expression.Splice1 is a variant case which is never constructed + <-- line 28 + type arg_expression = Splice0 [@dead "arg_expression.Splice0"] | Splice1 of E.t [@dead "arg_expression.Splice1"] | Splice2 of E.t * E.t + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/js_of_lam_variant.mli", line 28, characters 2-11 + arg_expression.Splice0 is a variant case which is never constructed + <-- line 28 + | Splice0 [@dead "arg_expression.Splice0"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/js_of_lam_variant.mli", line 29, characters 2-27 + arg_expression.Splice1 is a variant case which is never constructed + <-- line 29 + | Splice1 of J.expression [@dead "arg_expression.Splice1"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/js_op.ml", line 99, characters 38-44 + property.Strict is a variant case which is never constructed + <-- line 99 + type property = Lam_compat.let_kind = Strict [@dead "property.Strict"] | Alias | StrictOpt | Variable + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/js_op.ml", line 99, characters 45-52 + property.Alias is a variant case which is never constructed + <-- line 99 + type property = Lam_compat.let_kind = Strict [@dead "property.Strict"] | Alias [@dead "property.Alias"] | StrictOpt | Variable + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/js_op.ml", line 99, characters 53-64 + property.StrictOpt is a variant case which is never constructed + <-- line 99 + type property = Lam_compat.let_kind = Strict [@dead "property.Strict"] | Alias [@dead "property.Alias"] | StrictOpt [@dead "property.StrictOpt"] | Variable + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/js_op.ml", line 99, characters 65-75 + property.Variable is a variant case which is never constructed + <-- line 99 + type property = Lam_compat.let_kind = Strict [@dead "property.Strict"] | Alias [@dead "property.Alias"] | StrictOpt [@dead "property.StrictOpt"] | Variable [@dead "property.Variable"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_compat.ml", line 57, characters 2-69 + field_dbg_info.Fld_record is a variant case which is never constructed + <-- line 57 + | Fld_record of {name: string; mutable_flag: Asttypes.mutable_flag} [@dead "field_dbg_info.Fld_record"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_compat.ml", line 58, characters 2-32 + field_dbg_info.Fld_module is a variant case which is never constructed + <-- line 58 + | Fld_module of {name: string} [@dead "field_dbg_info.Fld_module"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_compat.ml", line 59, characters 2-39 + field_dbg_info.Fld_record_inline is a variant case which is never constructed + <-- line 59 + | Fld_record_inline of {name: string} [@dead "field_dbg_info.Fld_record_inline"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_compat.ml", line 60, characters 2-42 + field_dbg_info.Fld_record_extension is a variant case which is never constructed + <-- line 60 + | Fld_record_extension of {name: string} [@dead "field_dbg_info.Fld_record_extension"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_compat.ml", line 61, characters 2-13 + field_dbg_info.Fld_tuple is a variant case which is never constructed + <-- line 61 + | Fld_tuple [@dead "field_dbg_info.Fld_tuple"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_compat.ml", line 62, characters 2-20 + field_dbg_info.Fld_poly_var_tag is a variant case which is never constructed + <-- line 62 + | Fld_poly_var_tag [@dead "field_dbg_info.Fld_poly_var_tag"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_compat.ml", line 63, characters 2-24 + field_dbg_info.Fld_poly_var_content is a variant case which is never constructed + <-- line 63 + | Fld_poly_var_content [@dead "field_dbg_info.Fld_poly_var_content"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_compat.ml", line 64, characters 2-17 + field_dbg_info.Fld_extension is a variant case which is never constructed + <-- line 64 + | Fld_extension [@dead "field_dbg_info.Fld_extension"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_compat.ml", line 65, characters 2-15 + field_dbg_info.Fld_variant is a variant case which is never constructed + <-- line 65 + | Fld_variant [@dead "field_dbg_info.Fld_variant"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_compat.ml", line 66, characters 2-12 + field_dbg_info.Fld_cons is a variant case which is never constructed + <-- line 66 + | Fld_cons [@dead "field_dbg_info.Fld_cons"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_compat.ml", line 82, characters 2-38 + set_field_dbg_info.Fld_record_extension_set is a variant case which is never constructed + <-- line 82 + | Fld_record_extension_set of string [@dead "set_field_dbg_info.Fld_record_extension_set"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_compat.mli", line 30, characters 2-69 + field_dbg_info.Fld_record is a variant case which is never constructed + <-- line 30 + | Fld_record of {name: string; mutable_flag: Asttypes.mutable_flag} [@dead "field_dbg_info.Fld_record"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_compat.mli", line 31, characters 2-32 + field_dbg_info.Fld_module is a variant case which is never constructed + <-- line 31 + | Fld_module of {name: string} [@dead "field_dbg_info.Fld_module"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_compat.mli", line 32, characters 2-39 + field_dbg_info.Fld_record_inline is a variant case which is never constructed + <-- line 32 + | Fld_record_inline of {name: string} [@dead "field_dbg_info.Fld_record_inline"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_compat.mli", line 33, characters 2-42 + field_dbg_info.Fld_record_extension is a variant case which is never constructed + <-- line 33 + | Fld_record_extension of {name: string} [@dead "field_dbg_info.Fld_record_extension"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_compat.mli", line 34, characters 2-13 + field_dbg_info.Fld_tuple is a variant case which is never constructed + <-- line 34 + | Fld_tuple [@dead "field_dbg_info.Fld_tuple"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_compat.mli", line 35, characters 2-20 + field_dbg_info.Fld_poly_var_tag is a variant case which is never constructed + <-- line 35 + | Fld_poly_var_tag [@dead "field_dbg_info.Fld_poly_var_tag"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_compat.mli", line 36, characters 2-24 + field_dbg_info.Fld_poly_var_content is a variant case which is never constructed + <-- line 36 + | Fld_poly_var_content [@dead "field_dbg_info.Fld_poly_var_content"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_compat.mli", line 37, characters 2-17 + field_dbg_info.Fld_extension is a variant case which is never constructed + <-- line 37 + | Fld_extension [@dead "field_dbg_info.Fld_extension"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_compat.mli", line 38, characters 2-15 + field_dbg_info.Fld_variant is a variant case which is never constructed + <-- line 38 + | Fld_variant [@dead "field_dbg_info.Fld_variant"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_compat.mli", line 39, characters 2-12 + field_dbg_info.Fld_cons is a variant case which is never constructed + <-- line 39 + | Fld_cons [@dead "field_dbg_info.Fld_cons"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_compat.mli", line 46, characters 2-38 + set_field_dbg_info.Fld_record_extension_set is a variant case which is never constructed + <-- line 46 + | Fld_record_extension_set of string [@dead "set_field_dbg_info.Fld_record_extension_set"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_compile_env.ml", line 33, characters 2-15 + ident_info.name is a record label never used to read a value + <-- line 33 + name: string; [@dead "ident_info.name"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_compile_env.ml", line 34, characters 2-29 + ident_info.arity is a record label never used to read a value + <-- line 34 + arity: Js_cmj_format.arity; [@dead "ident_info.arity"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_compile_env.ml", line 35, characters 2-41 + ident_info.persistent_closed_lambda is a record label never used to read a value + <-- line 35 + persistent_closed_lambda: Lam.t option; [@dead "ident_info.persistent_closed_lambda"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_compile_external_call.ml", line 60, characters 2-24 + arg_expression.Splice2 is a variant case which is never constructed + <-- line 60 + | Splice2 of E.t * E.t [@dead "arg_expression.Splice2"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_module_ident.ml", line 25, characters 55-75 + t.dynamic_import is a record label never used to read a value + <-- line 25 + type t = J.module_id = {id: Ident.t; kind: Js_op.kind; dynamic_import: bool [@dead "t.dynamic_import"] } + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_module_ident.mli", line 31, characters 2-23 + t.dynamic_import is a record label never used to read a value + <-- line 31 + dynamic_import: bool; [@dead "t.dynamic_import"] + + Warning Dead Value With Side Effects + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_print.ml", line 493, characters 0-50 + +lambda_to_string is never used and could have side effects + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/core/lam_print.mli", line 29, characters 0-38 + +lambda_to_string is never used + <-- line 29 + val lambda_to_string : Lam.t -> string [@@dead "+lambda_to_string"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/ext_ident.ml", line 166, characters 0-31 + +make_unused is never used + <-- line 166 + let make_unused () = create "_" [@@dead "+make_unused"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/ext_ident.mli", line 38, characters 0-33 + +make_unused is never used + <-- line 38 + val make_unused : unit -> Ident.t [@@dead "+make_unused"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/ext_namespace.ml", line 59, characters 0-352 + +is_valid_npm_package_name is never used + <-- line 59 + | _ -> false [@@dead "+is_valid_npm_package_name"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/ext_namespace.ml", line 72, characters 0-598 + +namespace_of_package_name is never used + <-- line 72 + Ext_buffer.contents buf [@@dead "+namespace_of_package_name"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/ext_namespace.mli", line 48, characters 0-46 + +is_valid_npm_package_name is never used + <-- line 48 + val is_valid_npm_package_name : string -> bool [@@dead "+is_valid_npm_package_name"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/ext_namespace.mli", line 50, characters 0-48 + +namespace_of_package_name is never used + <-- line 50 + val namespace_of_package_name : string -> string [@@dead "+namespace_of_package_name"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/ext_pervasives.ml", line 69, characters 0-221 + +int_of_string_aux is never used + <-- line 69 + else -1 [@@dead "+int_of_string_aux"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/ext_pervasives.ml", line 77, characters 0-134 + +nat_of_string_exn is never used + <-- line 77 + if acc < 0 then invalid_arg s else acc [@@dead "+nat_of_string_exn"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/ext_pervasives.ml", line 82, characters 0-441 + +parse_nat_of_string is never used + <-- line 82 + !acc [@@dead "+parse_nat_of_string"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/ext_pervasives.mli", line 51, characters 0-37 + +nat_of_string_exn is never used + <-- line 51 + val nat_of_string_exn : string -> int [@@dead "+nat_of_string_exn"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/ext_pervasives.mli", line 53, characters 0-50 + +parse_nat_of_string is never used + <-- line 53 + val parse_nat_of_string : string -> int ref -> int [@@dead "+parse_nat_of_string"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/hash_set_poly.mli", line 33, characters 0-31 + +remove is never used + <-- line 33 + val remove : 'a t -> 'a -> unit [@@dead "+remove"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/hash_set_poly.mli", line 37, characters 0-39 + +iter is never used + <-- line 37 + val iter : 'a t -> ('a -> unit) -> unit [@@dead "+iter"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/hash_set_poly.mli", line 39, characters 0-24 + +length is never used + <-- line 39 + val length : 'a t -> int [@@dead "+length"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/map_gen.ml", line 72, characters 2-9 + t.Empty is a variant case which is never constructed + <-- line 72 + | Empty [@dead "t.Empty"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/map_gen.ml", line 73, characters 2-28 + t.Leaf is a variant case which is never constructed + <-- line 73 + | Leaf of {k: 'key; v: 'a} [@dead "t.Leaf"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/map_gen.ml", line 74, characters 2-70 + t.Node is a variant case which is never constructed + <-- line 74 + | Node of {l: ('key, 'a) t; k: 'key; v: 'a; r: ('key, 'a) t; h: int} [@dead "t.Node"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/map_gen.mli", line 2, characters 2-9 + t.Empty is a variant case which is never constructed + <-- line 2 + | Empty [@dead "t.Empty"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/map_gen.mli", line 3, characters 2-28 + t.Leaf is a variant case which is never constructed + <-- line 3 + | Leaf of {k: 'key; v: 'a} [@dead "t.Leaf"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/map_gen.mli", line 4, characters 2-70 + t.Node is a variant case which is never constructed + <-- line 4 + | Node of {l: ('key, 'a) t; k: 'key; v: 'a; r: ('key, 'a) t; h: int} [@dead "t.Node"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/misc.ml", line 313, characters 17-21 + Color.setting.Auto is a variant case which is never constructed + <-- line 313 + type setting = Auto [@dead "Color.setting.Auto"] | Always | Never + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/misc.ml", line 313, characters 22-30 + Color.setting.Always is a variant case which is never constructed + <-- line 313 + type setting = Auto [@dead "Color.setting.Auto"] | Always [@dead "Color.setting.Always"] | Never + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/misc.ml", line 313, characters 31-38 + Color.setting.Never is a variant case which is never constructed + <-- line 313 + type setting = Auto [@dead "Color.setting.Auto"] | Always [@dead "Color.setting.Always"] | Never [@dead "Color.setting.Never"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/set_gen.ml", line 48, characters 2-9 + t.Empty is a variant case which is never constructed + <-- line 48 + | Empty [@dead "t.Empty"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/set_gen.ml", line 49, characters 2-14 + t.Leaf is a variant case which is never constructed + <-- line 49 + | Leaf of 'a [@dead "t.Leaf"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/set_gen.ml", line 50, characters 2-47 + t.Node is a variant case which is never constructed + <-- line 50 + | Node of {l: 'a t0; v: 'a; r: 'a t0; h: int} [@dead "t.Node"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/set_gen.mli", line 2, characters 2-9 + t.Empty is a variant case which is never constructed + <-- line 2 + | Empty [@dead "t.Empty"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/set_gen.mli", line 3, characters 2-14 + t.Leaf is a variant case which is never constructed + <-- line 3 + | Leaf of 'a [@dead "t.Leaf"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/set_gen.mli", line 4, characters 2-45 + t.Node is a variant case which is never constructed + <-- line 4 + | Node of {l: 'a t; v: 'a; r: 'a t; h: int} [@dead "t.Node"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/warnings.ml", line 468, characters 0-33 + +reset_fatal is never used + <-- line 468 + let reset_fatal () = nerrors := 0 [@@dead "+reset_fatal"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ext/warnings.mli", line 89, characters 0-30 + +reset_fatal is never used + <-- line 89 + val reset_fatal : unit -> unit [@@dead "+reset_fatal"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/frontend/ast_literal.ml", line 48, characters 2-74 + Lid.+ignore_id is never used + <-- line 48 + let ignore_id : t = Ldot (Lident Primitive_modules.pervasives, "ignore") [@@dead "Lid.+ignore_id"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/frontend/ast_literal.mli", line 38, characters 2-19 + Lid.+ignore_id is never used + <-- line 38 + val ignore_id : t [@@dead "Lid.+ignore_id"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 28, characters 0-182 + +with_default_loc is never used + <-- line 28 + raise exn [@@dead "+with_default_loc"] + + Warning Dead Module + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 39, characters 0-513 + +ast_helper0.Const is a dead module as all its items are dead. + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 40, characters 2-52 + Const.+integer is never used + <-- line 40 + let integer ?suffix i = Pconst_integer (i, suffix) [@@dead "Const.+integer"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 41, characters 2-55 + Const.+int is never used + <-- line 41 + let int ?suffix i = integer ?suffix (string_of_int i) [@@dead "Const.+int"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 42, characters 2-67 + Const.+int32 is never used + <-- line 42 + let int32 ?(suffix = 'l') i = integer ~suffix (Int32.to_string i) [@@dead "Const.+int32"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 43, characters 2-67 + Const.+int64 is never used + <-- line 43 + let int64 ?(suffix = 'L') i = integer ~suffix (Int64.to_string i) [@@dead "Const.+int64"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 44, characters 2-75 + Const.+nativeint is never used + <-- line 44 + let nativeint ?(suffix = 'n') i = integer ~suffix (Nativeint.to_string i) [@@dead "Const.+nativeint"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 45, characters 2-48 + Const.+float is never used + <-- line 45 + let float ?suffix f = Pconst_float (f, suffix) [@@dead "Const.+float"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 46, characters 2-40 + Const.+char is never used + <-- line 46 + let char c = Pconst_char (Char.code c) [@@dead "Const.+char"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 47, characters 2-76 + Const.+string is never used + <-- line 47 + let string ?quotation_delimiter s = Pconst_string (s, quotation_delimiter) [@@dead "Const.+string"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 53, characters 2-67 + Typ.+attr is never used + <-- line 53 + let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]} [@@dead "Typ.+attr"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 67, characters 2-107 + Typ.+force_poly is never used + <-- line 67 + | _ -> poly ~loc:t.ptyp_loc [] t [@@dead "Typ.+force_poly"] (* -> ghost? *) + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 72, characters 2-1986 + Typ.+varify_constructors is never used + <-- line 72 + loop t [@@dead "Typ.+varify_constructors"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 124, characters 2-67 + Pat.+attr is never used + <-- line 124 + let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]} [@@dead "Pat.+attr"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 139, characters 2-56 + Pat.+lazy_ is never used + <-- line 139 + let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a) [@@dead "Pat.+lazy_"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 149, characters 2-67 + Exp.+attr is never used + <-- line 149 + let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]} [@@dead "Exp.+attr"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 155, characters 2-64 + Exp.+function_ is never used + <-- line 155 + let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a) [@@dead "Exp.+function_"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 173, characters 2-54 + Exp.+new_ is never used + <-- line 173 + let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a) [@@dead "Exp.+new_"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 174, characters 2-74 + Exp.+setinstvar is never used + <-- line 174 + let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b)) [@@dead "Exp.+setinstvar"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 175, characters 2-63 + Exp.+override is never used + <-- line 175 + let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a) [@@dead "Exp.+override"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 179, characters 2-56 + Exp.+lazy_ is never used + <-- line 179 + let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a) [@@dead "Exp.+lazy_"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 180, characters 2-62 + Exp.+poly is never used + <-- line 180 + let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b)) [@@dead "Exp.+poly"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 186, characters 2-74 + Exp.+case is never used + <-- line 186 + let case lhs ?guard rhs = {pc_lhs = lhs; pc_guard = guard; pc_rhs = rhs} [@@dead "Exp.+case"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 192, characters 2-67 + Mty.+attr is never used + <-- line 192 + let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]} [@@dead "Mty.+attr"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 206, characters 2-67 + Mod.+attr is never used + <-- line 206 + let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]} [@@dead "Mod.+attr"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 352, characters 2-219 + Te.+decl is never used + <-- line 352 + } [@@dead "Te.+decl"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_helper0.ml", line 361, characters 2-183 + Te.+rebind is never used + <-- line 361 + } [@@dead "Te.+rebind"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_mapper.ml", line 529, characters 0-136 + +attribute_of_warning is never used + <-- line 529 + PStr [Str.eval ~loc (Exp.constant (Pconst_string (s, None)))] ) [@@dead "+attribute_of_warning"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_mapper.ml", line 540, characters 0-81 + +get_cookie is never used + <-- line 540 + try Some (String_map.find k !cookies) with Not_found -> None [@@dead "+get_cookie"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_mapper.ml", line 543, characters 0-59 + +set_cookie is never used + <-- line 543 + let set_cookie k v = cookies := String_map.add k v !cookies [@@dead "+set_cookie"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_mapper.ml", line 547, characters 0-33 + +tool_name is never used + <-- line 547 + let tool_name () = !tool_name_ref [@@dead "+tool_name"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_mapper.ml", line 790, characters 0-80 + +apply is never used + <-- line 790 + let apply ~source ~target mapper = apply_lazy ~source ~target (fun () -> mapper) [@@dead "+apply"] + + Warning Dead Value With Side Effects + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_mapper.ml", line 813, characters 0-55 + +register_function is never used and could have side effects + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_mapper.ml", line 814, characters 0-47 + +register is never used + <-- line 814 + let register name f = !register_function name f [@@dead "+register"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_mapper.mli", line 101, characters 0-30 + +tool_name is never used + <-- line 101 + val tool_name : unit -> string [@@dead "+tool_name"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_mapper.mli", line 110, characters 0-60 + +apply is never used + <-- line 110 + val apply : source:string -> target:string -> mapper -> unit [@@dead "+apply"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_mapper.mli", line 116, characters 0-46 + +run_main is never used + <-- line 116 + val run_main : (string list -> mapper) -> unit [@@dead "+run_main"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_mapper.mli", line 125, characters 0-71 + +register_function is never used + <-- line 125 + val register_function : (string -> (string list -> mapper) -> unit) ref [@@dead "+register_function"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_mapper.mli", line 127, characters 0-56 + +register is never used + <-- line 127 + val register : string -> (string list -> mapper) -> unit [@@dead "+register"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_mapper.mli", line 146, characters 0-50 + +map_opt is never used + <-- line 146 + val map_opt : ('a -> 'b) -> 'a option -> 'b option [@@dead "+map_opt"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_mapper.mli", line 148, characters 0-52 + +extension_of_error is never used + <-- line 148 + val extension_of_error : Location.error -> extension [@@dead "+extension_of_error"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_mapper.mli", line 153, characters 0-60 + +attribute_of_warning is never used + <-- line 153 + val attribute_of_warning : Location.t -> string -> attribute [@@dead "+attribute_of_warning"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_mapper.mli", line 187, characters 0-55 + +set_cookie is never used + <-- line 187 + val set_cookie : string -> Parsetree.expression -> unit [@@dead "+set_cookie"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/ast_mapper.mli", line 188, characters 0-54 + +get_cookie is never used + <-- line 188 + val get_cookie : string -> Parsetree.expression option [@@dead "+get_cookie"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/env.ml", line 718, characters 0-434 + +reset_cache_toplevel is never used + <-- line 718 + Hashtbl.clear prefixed_sg [@@dead "+reset_cache_toplevel"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/env.mli", line 171, characters 0-39 + +reset_cache_toplevel is never used + <-- line 171 + val reset_cache_toplevel : unit -> unit [@@dead "+reset_cache_toplevel"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/env.mli", line 288, characters 4-21 + t.filename is a record label never used to read a value + <-- line 288 + filename: string; [@dead "t.filename"] (** Name of the file containing the signature. *) + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/env.mli", line 289, characters 4-30 + t.cmi is a record label never used to read a value + <-- line 289 + cmi: Cmi_format.cmi_infos; [@dead "t.cmi"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/experimental_features.ml", line 23, characters 0-52 + +reset is never used + <-- line 23 + let reset () = enabled_features := Feature_set.empty [@@dead "+reset"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/experimental_features.mli", line 6, characters 0-24 + +reset is never used + <-- line 6 + val reset : unit -> unit [@@dead "+reset"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/lambda.ml", line 342, characters 43-53 + let_kind.Variable is a variant case which is never constructed + <-- line 342 + type let_kind = Strict | Alias | StrictOpt | Variable [@dead "let_kind.Variable"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/lambda.mli", line 299, characters 43-53 + let_kind.Variable is a variant case which is never constructed + <-- line 299 + type let_kind = Strict | Alias | StrictOpt | Variable [@dead "let_kind.Variable"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/location.mli", line 47, characters 0-64 + +warning_printer is never used + <-- line 47 + val warning_printer : (t -> formatter -> Warnings.t -> unit) ref [@@dead "+warning_printer"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/location.mli", line 50, characters 0-42 + +formatter_for_warnings is never used + <-- line 50 + val formatter_for_warnings : formatter ref [@@dead "+formatter_for_warnings"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/location.mli", line 52, characters 0-66 + +default_warning_printer is never used + <-- line 52 + val default_warning_printer : t -> formatter -> Warnings.t -> unit [@@dead "+default_warning_printer"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/location.mli", line 110, characters 0-118 + +error_reporter is never used + <-- line 110 + ref [@@dead "+error_reporter"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/location.mli", line 119, characters 0-118 + +default_error_reporter is never used + <-- line 119 + unit [@@dead "+default_error_reporter"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/parsetree0.ml", line 98, characters 2-22 + core_type_desc.Ptyp_class is a variant case which is never constructed + <-- line 98 + | Ptyp_class of unit [@dead "core_type_desc.Ptyp_class"] (* dummy AST node *) + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/parsetree0.ml", line 302, characters 2-23 + expression_desc.Pexp_object is a variant case which is never constructed + <-- line 302 + | Pexp_object of unit [@dead "expression_desc.Pexp_object"] (* dummy AST node *) + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/parsetree0.ml", line 314, characters 2-20 + expression_desc.Pexp_unreachable is a variant case which is never constructed + <-- line 314 + | Pexp_unreachable [@dead "expression_desc.Pexp_unreachable"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/parsetree0.ml", line 474, characters 2-22 + signature_item_desc.Psig_class is a variant case which is never constructed + <-- line 474 + | Psig_class of unit [@dead "signature_item_desc.Psig_class"] (* Dummy AST node *) + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/parsetree0.ml", line 475, characters 2-27 + signature_item_desc.Psig_class_type is a variant case which is never constructed + <-- line 475 + | Psig_class_type of unit [@dead "signature_item_desc.Psig_class_type"] (* Dummy AST node *) + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/parsetree0.ml", line 576, characters 2-22 + structure_item_desc.Pstr_class is a variant case which is never constructed + <-- line 576 + | Pstr_class of unit [@dead "structure_item_desc.Pstr_class"] (* Dummy AST node *) + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/parsetree0.ml", line 577, characters 2-27 + structure_item_desc.Pstr_class_type is a variant case which is never constructed + <-- line 577 + | Pstr_class_type of unit [@dead "structure_item_desc.Pstr_class_type"] (* Dummy AST node *) + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/typedtree.ml", line 281, characters 2-23 + open_description.open_loc is a record label never used to read a value + <-- line 281 + open_loc: Location.t; [@dead "open_description.open_loc"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/typedtree.ml", line 327, characters 2-31 + package_type.pack_type is a record label never used to read a value + <-- line 327 + pack_type: Types.module_type; [@dead "package_type.pack_type"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/typedtree.ml", line 328, characters 2-28 + package_type.pack_txt is a record label never used to read a value + <-- line 328 + pack_txt: Longident.t loc; [@dead "package_type.pack_txt"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/typedtree.ml", line 393, characters 2-29 + type_extension.tyext_txt is a record label never used to read a value + <-- line 393 + tyext_txt: Longident.t loc; [@dead "type_extension.tyext_txt"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/typedtree.ml", line 402, characters 2-23 + extension_constructor.ext_name is a record label never used to read a value + <-- line 402 + ext_name: string loc; [@dead "extension_constructor.ext_name"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/typedtree.mli", line 387, characters 2-23 + open_description.open_loc is a record label never used to read a value + <-- line 387 + open_loc: Location.t; [@dead "open_description.open_loc"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/typedtree.mli", line 433, characters 2-31 + package_type.pack_type is a record label never used to read a value + <-- line 433 + pack_type: Types.module_type; [@dead "package_type.pack_type"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/typedtree.mli", line 434, characters 2-28 + package_type.pack_txt is a record label never used to read a value + <-- line 434 + pack_txt: Longident.t loc; [@dead "package_type.pack_txt"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/typedtree.mli", line 499, characters 2-29 + type_extension.tyext_txt is a record label never used to read a value + <-- line 499 + tyext_txt: Longident.t loc; [@dead "type_extension.tyext_txt"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/typedtree.mli", line 508, characters 2-23 + extension_constructor.ext_name is a record label never used to read a value + <-- line 508 + ext_name: string loc; [@dead "extension_constructor.ext_name"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/typedtree_iter.ml", line 72, characters 2-40 + Make_iterator.+iter_structure is never used + <-- line 72 + val iter_structure : structure -> unit [@@dead "Make_iterator.+iter_structure"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/typedtree_iter.ml", line 73, characters 2-40 + Make_iterator.+iter_signature is never used + <-- line 73 + val iter_signature : signature -> unit [@@dead "Make_iterator.+iter_signature"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/typedtree_iter.ml", line 74, characters 2-50 + Make_iterator.+iter_structure_item is never used + <-- line 74 + val iter_structure_item : structure_item -> unit [@@dead "Make_iterator.+iter_structure_item"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/typedtree_iter.ml", line 75, characters 2-50 + Make_iterator.+iter_signature_item is never used + <-- line 75 + val iter_signature_item : signature_item -> unit [@@dead "Make_iterator.+iter_signature_item"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/typedtree_iter.ml", line 77, characters 2-44 + Make_iterator.+iter_module_type is never used + <-- line 77 + val iter_module_type : module_type -> unit [@@dead "Make_iterator.+iter_module_type"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/typedtree_iter.ml", line 78, characters 2-36 + Make_iterator.+iter_pattern is never used + <-- line 78 + val iter_pattern : pattern -> unit [@@dead "Make_iterator.+iter_pattern"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/typedtree_iter.mli", line 64, characters 2-40 + Make_iterator.+iter_structure is never used + <-- line 64 + val iter_structure : structure -> unit [@@dead "Make_iterator.+iter_structure"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/typedtree_iter.mli", line 65, characters 2-40 + Make_iterator.+iter_signature is never used + <-- line 65 + val iter_signature : signature -> unit [@@dead "Make_iterator.+iter_signature"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/typedtree_iter.mli", line 66, characters 2-50 + Make_iterator.+iter_structure_item is never used + <-- line 66 + val iter_structure_item : structure_item -> unit [@@dead "Make_iterator.+iter_structure_item"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/typedtree_iter.mli", line 67, characters 2-50 + Make_iterator.+iter_signature_item is never used + <-- line 67 + val iter_signature_item : signature_item -> unit [@@dead "Make_iterator.+iter_signature_item"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/typedtree_iter.mli", line 69, characters 2-44 + Make_iterator.+iter_module_type is never used + <-- line 69 + val iter_module_type : module_type -> unit [@@dead "Make_iterator.+iter_module_type"] + + Warning Dead Value + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/typedtree_iter.mli", line 70, characters 2-36 + Make_iterator.+iter_pattern is never used + <-- line 70 + val iter_pattern : pattern -> unit [@@dead "Make_iterator.+iter_pattern"] + + Warning Dead Type + File "/home/jono/.codex/worktrees/2166/rescript-compiler/compiler/ml/types.ml", line 99, characters 29-39 + Variance.f.May_weak is a variant case which is never constructed + <-- line 99 + type f = May_pos | May_neg | May_weak [@dead "Variance.f.May_weak"] | Inj | Pos | Neg | Inv + + Analysis reported 387 issues (Warning Dead Module:3, Warning Dead Type:80, Warning Dead Value:83, Warning Dead Value With Side Effects:2, Warning Redundant Optional Argument:193, Warning Unused Argument:26) diff --git a/analysis/reactive/src/reactive.ml b/analysis/reactive/src/reactive.ml index 9a12f90fd96..6413be70e54 100644 --- a/analysis/reactive/src/reactive.ml +++ b/analysis/reactive/src/reactive.ml @@ -15,7 +15,6 @@ type ('k, 'v) delta = | Batch of ('k * 'v option) list let set k v = (k, Some v) -let remove k = (k, None) let delta_to_entries = function | Set (k, v) -> [(k, Some v)] @@ -437,8 +436,6 @@ module Scheduler = struct !processed_nodes wave_elapsed_ms); propagating := false) - let wave_count () = !wave_counter - let reset_wave_count () = wave_counter := 0 end (** {1 Collection Interface} *) @@ -457,8 +454,6 @@ let iter f t = t.iter f let get t k = t.get k let length t = t.length () let stats t = t.stats -let level t = t.level -let name t = t.name (** {1 Source Collection} *) diff --git a/analysis/reactive/src/reactive.mli b/analysis/reactive/src/reactive.mli index b666907d5bc..6cb91c1982b 100644 --- a/analysis/reactive/src/reactive.mli +++ b/analysis/reactive/src/reactive.mli @@ -18,12 +18,6 @@ type ('k, 'v) delta = val set : 'k -> 'v -> 'k * 'v option (** Create a batch entry that sets a key *) -val remove : 'k -> 'k * 'v option -(** Create a batch entry that removes a key *) - -val delta_to_entries : ('k, 'v) delta -> ('k * 'v option) list -(** Convert delta to batch entries *) - (** {1 Statistics} *) type stats = { @@ -45,41 +39,6 @@ type stats = { } (** Per-node statistics for diagnostics *) -val create_stats : unit -> stats - -(** {1 Node Registry} *) - -module Registry : sig - type node_info - (** Information about a registered node *) - - val clear : unit -> unit - (** Clear all registered nodes *) - - val to_mermaid : unit -> string - (** Generate a Mermaid diagram of the pipeline *) - - val print_stats : unit -> unit - (** Print timing statistics for all nodes *) -end - -(** {1 Scheduler} *) - -module Scheduler : sig - val propagate : unit -> unit - (** Process all dirty nodes in topological order. - Called automatically when a source emits. *) - - val is_propagating : unit -> bool - (** Returns true if currently in a propagation wave *) - - val wave_count : unit -> int - (** Number of propagation waves executed *) - - val reset_wave_count : unit -> unit - (** Reset the wave counter *) -end - (** {1 Collection Interface} *) type ('k, 'v) t = { @@ -97,8 +56,6 @@ val iter : ('k -> 'v -> unit) -> ('k, 'v) t -> unit val get : ('k, 'v) t -> 'k -> 'v option val length : ('k, 'v) t -> int val stats : ('k, 'v) t -> stats -val level : ('k, 'v) t -> int -val name : ('k, 'v) t -> string (** {1 Source Collection} *) diff --git a/analysis/reactive/src/reactive_file_collection.ml b/analysis/reactive/src/reactive_file_collection.ml index bcae68a0b79..b7cc7c3a859 100644 --- a/analysis/reactive/src/reactive_file_collection.ml +++ b/analysis/reactive/src/reactive_file_collection.ml @@ -39,23 +39,6 @@ let to_collection t : (string, 'v) Reactive.t = t.collection (** Emit a delta *) let emit t delta = t.emit delta -(** Process a file if changed. Emits delta to subscribers. *) -let process_if_changed t path = - let new_id = get_file_id path in - match Hashtbl.find_opt t.internal.cache path with - | Some (old_id, _) when not (file_changed ~old_id ~new_id) -> - false (* unchanged *) - | _ -> - let raw = t.internal.read_file path in - let value = t.internal.process path raw in - Hashtbl.replace t.internal.cache path (new_id, value); - emit t (Reactive.Set (path, value)); - true (* changed *) - -(** Process multiple files (emits individual deltas) *) -let process_files t paths = - List.iter (fun path -> ignore (process_if_changed t path)) paths - (** Process a file without emitting. Returns batch entry if changed. *) let process_file_silent t path = let new_id = get_file_id path in @@ -77,11 +60,6 @@ let process_files_batch t paths = if entries <> [] then emit t (Reactive.Batch entries); List.length entries -(** Remove a file *) -let remove t path = - Hashtbl.remove t.internal.cache path; - emit t (Reactive.Remove path) - (** Remove multiple files as a batch *) let remove_batch t paths = let entries = @@ -95,17 +73,5 @@ let remove_batch t paths = if entries <> [] then emit t (Reactive.Batch entries); List.length entries -(** Clear all cached data *) -let clear t = Hashtbl.clear t.internal.cache - -(** Invalidate a path *) -let invalidate t path = Hashtbl.remove t.internal.cache path - -let get t path = - match Hashtbl.find_opt t.internal.cache path with - | Some (_, v) -> Some v - | None -> None - let mem t path = Hashtbl.mem t.internal.cache path -let length t = Reactive.length t.collection let iter f t = Reactive.iter f t.collection diff --git a/analysis/reactive/src/reactive_file_collection.mli b/analysis/reactive/src/reactive_file_collection.mli index e50c6618284..058ff74590f 100644 --- a/analysis/reactive/src/reactive_file_collection.mli +++ b/analysis/reactive/src/reactive_file_collection.mli @@ -39,33 +39,17 @@ val to_collection : ('raw, 'v) t -> (string, 'v) Reactive.t (** {1 Processing} *) -val process_files : ('raw, 'v) t -> string list -> unit -(** Process files, emitting individual deltas for each changed file. *) - val process_files_batch : ('raw, 'v) t -> string list -> int (** Process files, emitting a single [Batch] delta with all changes. Returns the number of files that changed. More efficient than [process_files] when processing many files at once, as downstream combinators can process all changes together. *) -val process_if_changed : ('raw, 'v) t -> string -> bool -(** Process a file if changed. Returns true if file was processed. *) - -val remove : ('raw, 'v) t -> string -> unit -(** Remove a file from the collection. *) - val remove_batch : ('raw, 'v) t -> string list -> int (** Remove multiple files as a batch. Returns the number of files removed. More efficient than calling [remove] multiple times. *) -(** {1 Cache Management} *) - -val invalidate : ('raw, 'v) t -> string -> unit -val clear : ('raw, 'v) t -> unit - (** {1 Access} *) -val get : ('raw, 'v) t -> string -> 'v option val mem : ('raw, 'v) t -> string -> bool -val length : ('raw, 'v) t -> int val iter : (string -> 'v -> unit) -> ('raw, 'v) t -> unit diff --git a/analysis/reanalyze/src/analysis_result.ml b/analysis/reanalyze/src/analysis_result.ml index a2075b67d5b..144d6b57c14 100644 --- a/analysis/reanalyze/src/analysis_result.ml +++ b/analysis/reanalyze/src/analysis_result.ml @@ -8,15 +8,11 @@ type t = {issues: Issue.t list} let empty = {issues = []} -let add_issue result issue = {issues = issue :: result.issues} - let add_issues result new_issues = {issues = List.rev_append new_issues result.issues} let get_issues result = result.issues |> List.rev -let issue_count result = List.length result.issues - (** Create a dead code issue *) let make_dead_issue ~loc ~dead_warning ~path ~message : Issue.t = { diff --git a/analysis/reanalyze/src/analysis_result.mli b/analysis/reanalyze/src/analysis_result.mli index 1fd429ad04d..d4b90ca09fe 100644 --- a/analysis/reanalyze/src/analysis_result.mli +++ b/analysis/reanalyze/src/analysis_result.mli @@ -9,18 +9,12 @@ type t val empty : t (** Empty result with no issues *) -val add_issue : t -> Issue.t -> t -(** Add a single issue to the result *) - val add_issues : t -> Issue.t list -> t (** Add multiple issues to the result *) val get_issues : t -> Issue.t list (** Get all issues in order they were added *) -val issue_count : t -> int -(** Count of issues *) - (** {2 Issue constructors} *) val make_dead_issue : diff --git a/analysis/reanalyze/src/collect_annotations.ml b/analysis/reanalyze/src/collect_annotations.ml index 1e05fcfef08..cf31294f33f 100644 --- a/analysis/reanalyze/src/collect_annotations.ml +++ b/analysis/reanalyze/src/collect_annotations.ml @@ -90,19 +90,17 @@ let collect_export_locations ~state ~config ~do_gentype = ({cd_attributes; cd_loc; cd_args} : Typedtree.constructor_declaration) -> - let _process_inline_records = - match cd_args with - | Cstr_record flds -> - List.iter - (fun ({ld_attributes; ld_loc} : Typedtree.label_declaration) - -> - toplevel_attrs @ cd_attributes @ ld_attributes - |> process_attributes ~scope_default:!current_scope_default - ~state ~config ~do_gentype:false ~name:"" - ~pos:ld_loc.loc_start) - flds - | Cstr_tuple _ -> () - in + (match cd_args with + | Cstr_record flds -> + List.iter + (fun ({ld_attributes; ld_loc} : Typedtree.label_declaration) + -> + toplevel_attrs @ cd_attributes @ ld_attributes + |> process_attributes ~scope_default:!current_scope_default + ~state ~config ~do_gentype:false ~name:"" + ~pos:ld_loc.loc_start) + flds + | Cstr_tuple _ -> ()); toplevel_attrs @ cd_attributes |> process_attributes ~scope_default:!current_scope_default ~state ~config ~do_gentype:false ~name:"" ~pos:cd_loc.loc_start) diff --git a/analysis/reanalyze/src/cross_file_items_store.mli b/analysis/reanalyze/src/cross_file_items_store.mli index f8da5db43c8..7f43bb457b4 100644 --- a/analysis/reanalyze/src/cross_file_items_store.mli +++ b/analysis/reanalyze/src/cross_file_items_store.mli @@ -15,13 +15,6 @@ val of_frozen : Cross_file_items.t -> t val of_reactive : (string, Cross_file_items.t) Reactive.t -> t (** Wrap reactive collection directly (no intermediate collection) *) -val iter_optional_arg_calls : - t -> (Cross_file_items.optional_arg_call -> unit) -> unit -(** Iterate over all optional arg calls *) - -val iter_function_refs : t -> (Cross_file_items.function_ref -> unit) -> unit -(** Iterate over all function refs *) - val compute_optional_args_state : t -> find_decl:(Lexing.position -> Decl.t option) -> diff --git a/analysis/reanalyze/src/dead_code.ml b/analysis/reanalyze/src/dead_code.ml deleted file mode 100644 index e97abaa18bf..00000000000 --- a/analysis/reanalyze/src/dead_code.ml +++ /dev/null @@ -1,4 +0,0 @@ -(** Dead code analysis - cmt file processing. - Delegates to DceFileProcessing for AST traversal. *) - -let process_cmt = Dce_file_processing.process_cmt_file diff --git a/analysis/reanalyze/src/dead_common.ml b/analysis/reanalyze/src/dead_common.ml index a843d68606b..0ba1a7a7d96 100644 --- a/analysis/reanalyze/src/dead_common.ml +++ b/analysis/reanalyze/src/dead_common.ml @@ -16,7 +16,6 @@ module Config = struct let analyze_externals = ref false let report_underscore = false let report_types_dead_only_in_interface = false - let warn_on_circular_dependencies = false end let rec check_sub s1 s2 n = @@ -469,154 +468,6 @@ let solve_dead_forward ~ann_store ~config ~decl_store ~refs ~optional_args_state let all_issues = List.rev !inline_issues @ dead_issues in Analysis_result.add_issues Analysis_result.empty all_issues -(** Reactive solver using reactive liveness collection. - [value_refs_from] is only needed when [transitive=false] for hasRefBelow. - Pass [None] when [transitive=true] to avoid any refs computation. *) -let solve_dead_reactive ~ann_store ~config ~decl_store ~value_refs_from - ~(live : (Lexing.position, unit) Reactive.t) - ~(roots : (Lexing.position, unit) Reactive.t) ~optional_args_state - ~check_optional_arg: - (check_optional_arg_fn : - optional_args_state:Optional_args_state.t -> - ann_store:Annotation_store.t -> - config:Dce_config.t -> - Decl.t -> - Issue.t list) : Analysis_result.t = - let t0 = Unix.gettimeofday () in - let debug = config.Dce_config.cli.debug in - let transitive = config.Dce_config.run.transitive in - let is_live pos = Reactive.get live pos <> None in - - (* hasRefBelow uses on-demand search through value_refs_from *) - let has_ref_below = - match value_refs_from with - | None -> fun _ -> false - | Some refs_from -> - make_hasRefBelow ~transitive ~iter_value_refs_from:(fun f -> - Reactive.iter f refs_from) - in - - (* Process each declaration based on computed liveness *) - let dead_declarations = ref [] in - let inline_issues = ref [] in - - let t1 = Unix.gettimeofday () in - (* For consistent debug output, collect and sort declarations *) - let all_decls = - Declaration_store.fold (fun _pos decl acc -> decl :: acc) decl_store [] - in - let t2 = Unix.gettimeofday () in - let all_decls = all_decls |> List.fast_sort Decl.compare_for_reporting in - let t3 = Unix.gettimeofday () in - let num_decls = List.length all_decls in - - (* Count operations in the loop *) - let num_live_checks = ref 0 in - let num_dead = ref 0 in - let num_live = ref 0 in - - all_decls - |> List.iter (fun (decl : Decl.t) -> - let pos = decl.pos in - incr num_live_checks; - let is_live = is_live pos in - let is_dead = not is_live in - - (* Debug output (forward model): derive root/propagated from [roots]. *) - (if debug then - let live_reason : Liveness.live_reason option = - if not is_live then None - else if Reactive.get roots pos <> None then - if Annotation_store.is_annotated_gentype_or_live ann_store pos - then Some Liveness.Annotated - else Some Liveness.ExternalRef - else Some Liveness.Propagated - in - let status = - match live_reason with - | None -> "Dead" - | Some reason -> - Printf.sprintf "Live (%s)" (Liveness.reason_to_string reason) - in - Log_.item "%s %s %s@." status - (decl.decl_kind |> Decl.Kind.to_string) - (decl.path |> Dce_path.to_string)); - - decl.resolved_dead <- Some is_dead; - - if is_dead then ( - incr num_dead; - decl.path - |> Dead_modules.mark_dead ~config - ~is_type:(decl.decl_kind |> Decl.Kind.is_type) - ~loc:decl.module_loc; - if not (do_report_dead ~ann_store decl.pos) then decl.report <- false; - dead_declarations := decl :: !dead_declarations) - else ( - incr num_live; - (* Collect optional args issues for live declarations *) - check_optional_arg_fn ~optional_args_state ~ann_store ~config decl - |> List.iter (fun issue -> inline_issues := issue :: !inline_issues); - decl.path - |> Dead_modules.mark_live ~config - ~is_type:(decl.decl_kind |> Decl.Kind.is_type) - ~loc:decl.module_loc; - if Annotation_store.is_annotated_dead ann_store decl.pos then ( - (* Collect incorrect @dead annotation issue *) - let issue = - make_dead_issue ~decl ~message:" is annotated @dead but is live" - IncorrectDeadAnnotation - in - decl.path - |> Dce_path.to_module_name - ~is_type:(decl.decl_kind |> Decl.Kind.is_type) - |> Dead_modules.check_module_dead ~config - ~file_name:decl.pos.pos_fname - |> Option.iter (fun mod_issue -> - inline_issues := mod_issue :: !inline_issues); - inline_issues := issue :: !inline_issues))); - let t4 = Unix.gettimeofday () in - - let sorted_dead_declarations = - !dead_declarations |> List.fast_sort Decl.compare_for_reporting - in - let t5 = Unix.gettimeofday () in - - (* Collect issues from dead declarations *) - let reporting_ctx = Reporting_context.create () in - let dead_issues = - sorted_dead_declarations - |> List.concat_map (fun decl -> - report_declaration ~config ~has_ref_below reporting_ctx decl) - in - let t6 = Unix.gettimeofday () in - let all_issues = List.rev !inline_issues @ dead_issues in - let t7 = Unix.gettimeofday () in - - Printf.eprintf - " solveDeadReactive timing breakdown:\n\ - \ setup: %6.2fms\n\ - \ collect: %6.2fms (DeclarationStore.fold)\n\ - \ sort: %6.2fms (List.fast_sort %d decls)\n\ - \ iterate: %6.2fms (check liveness for %d decls: %d dead, %d live)\n\ - \ sort_dead: %6.2fms (sort %d dead decls)\n\ - \ report: %6.2fms (generate issues)\n\ - \ combine: %6.2fms\n\ - \ TOTAL: %6.2fms\n" - ((t1 -. t0) *. 1000.0) - ((t2 -. t1) *. 1000.0) - ((t3 -. t2) *. 1000.0) - num_decls - ((t4 -. t3) *. 1000.0) - !num_live_checks !num_dead !num_live - ((t5 -. t4) *. 1000.0) - !num_dead - ((t6 -. t5) *. 1000.0) - ((t7 -. t6) *. 1000.0) - ((t7 -. t0) *. 1000.0); - - Analysis_result.add_issues Analysis_result.empty all_issues - (** Main entry point - uses forward solver. *) let solve_dead ~ann_store ~config ~decl_store ~ref_store ~optional_args_state ~check_optional_arg : Analysis_result.t = @@ -626,5 +477,5 @@ let solve_dead ~ann_store ~config ~decl_store ~ref_store ~optional_args_state ~check_optional_arg | None -> failwith - "solveDead: ReferenceStore must be Frozen (use solveDeadReactive for \ + "solveDead: ReferenceStore must be Frozen (use Reactive_solver for \ reactive mode)" diff --git a/analysis/reanalyze/src/dead_type.ml b/analysis/reanalyze/src/dead_type.ml index 1bfad3e33a3..00835465ba5 100644 --- a/analysis/reanalyze/src/dead_type.ml +++ b/analysis/reanalyze/src/dead_type.ml @@ -42,17 +42,15 @@ let add_declaration ~config ~decls ~file ~(module_path : Module_path.t) | Type_variant decls -> List.iteri (fun i {Types.cd_id; cd_loc; cd_args} -> - let _handle_inline_records = - match cd_args with - | Cstr_record lbls -> - List.iter - (fun {Types.ld_id; ld_loc} -> - Ident.name cd_id ^ "." ^ Ident.name ld_id - |> Name.create - |> process_type_label ~decl_kind:RecordLabel ~loc:ld_loc) - lbls - | Cstr_tuple _ -> () - in + (match cd_args with + | Cstr_record lbls -> + List.iter + (fun {Types.ld_id; ld_loc} -> + Ident.name cd_id ^ "." ^ Ident.name ld_id + |> Name.create + |> process_type_label ~decl_kind:RecordLabel ~loc:ld_loc) + lbls + | Cstr_tuple _ -> ()); let pos_adjustment = (* In Res the variant loc can include the | and spaces after it *) let is_res = diff --git a/analysis/reanalyze/src/decl.ml b/analysis/reanalyze/src/decl.ml index aa457b3f5b8..f56cfd62beb 100644 --- a/analysis/reanalyze/src/decl.ml +++ b/analysis/reanalyze/src/decl.ml @@ -54,30 +54,6 @@ let is_live decl = | Some true -> false | Some false | None -> true -let compare_using_dependencies ~ordered_files - { - decl_kind = kind1; - path = _path1; - pos = - {pos_fname = fname1; pos_lnum = lnum1; pos_bol = bol1; pos_cnum = cnum1}; - } - { - decl_kind = kind2; - path = _path2; - pos = - {pos_fname = fname2; pos_lnum = lnum2; pos_bol = bol2; pos_cnum = cnum2}; - } = - let find_position fn = Hashtbl.find ordered_files fn [@@raises Not_found] in - (* From the root of the file dependency DAG to the leaves. - From the bottom of the file to the top. *) - let position1, position2 = - try (fname1 |> find_position, fname2 |> find_position) - with Not_found -> (0, 0) - in - compare - (position1, lnum2, bol2, cnum2, kind1) - (position2, lnum1, bol1, cnum1, kind2) - let compare_for_reporting { decl_kind = kind1; diff --git a/analysis/reanalyze/src/declarations.ml b/analysis/reanalyze/src/declarations.ml index bcdee966ab7..ef78f8a89c7 100644 --- a/analysis/reanalyze/src/declarations.ml +++ b/analysis/reanalyze/src/declarations.ml @@ -35,8 +35,6 @@ let merge_all (builders : builder list) : t = let builder_to_list (builder : builder) : (Lexing.position * Decl.t) list = Pos_hash.fold (fun pos decl acc -> (pos, decl) :: acc) builder [] -let create_from_hashtbl (h : Decl.t Pos_hash.t) : t = h - (* ===== Read-only API ===== *) let find_opt (t : t) pos = Pos_hash.find_opt t pos @@ -44,5 +42,3 @@ let find_opt (t : t) pos = Pos_hash.find_opt t pos let fold f (t : t) init = Pos_hash.fold f t init let iter f (t : t) = Pos_hash.iter f t - -let length (t : t) = Pos_hash.length t diff --git a/analysis/reanalyze/src/declarations.mli b/analysis/reanalyze/src/declarations.mli index 4020a4f122b..6470942e639 100644 --- a/analysis/reanalyze/src/declarations.mli +++ b/analysis/reanalyze/src/declarations.mli @@ -30,13 +30,8 @@ val merge_all : builder list -> t val builder_to_list : builder -> (Lexing.position * Decl.t) list (** Extract all declarations as a list for reactive merge *) -val create_from_hashtbl : Decl.t Pos_hash.t -> t -(** Create from hashtable for reactive merge *) - (** {2 Read-only API for t - for solver} *) val find_opt : t -> Lexing.position -> Decl.t option val fold : (Lexing.position -> Decl.t -> 'a -> 'a) -> t -> 'a -> 'a val iter : (Lexing.position -> Decl.t -> unit) -> t -> unit - -val length : t -> int diff --git a/analysis/reanalyze/src/exn.ml b/analysis/reanalyze/src/exn.ml index 0f83bc988b1..c14e5476969 100644 --- a/analysis/reanalyze/src/exn.ml +++ b/analysis/reanalyze/src/exn.ml @@ -4,14 +4,11 @@ let compare = String.compare let decode_error = "DecodeError" let assert_failure = "Assert_failure" let division_by_zero = "Division_by_zero" -let end_of_file = "End_of_file" -let exit = "exit" let failure = "Failure" let invalid_argument = "Invalid_argument" let js_exn = "JsExn" let match_failure = "Match_failure" let not_found = "Not_found" -let sys_error = "Sys_error" let from_lid lid = lid |> Longident.flatten |> String.concat "." let from_string s = s let to_string s = s diff --git a/analysis/reanalyze/src/exn.mli b/analysis/reanalyze/src/exn.mli index 694e2ea4429..fc6ee05557b 100644 --- a/analysis/reanalyze/src/exn.mli +++ b/analysis/reanalyze/src/exn.mli @@ -4,8 +4,6 @@ val compare : t -> t -> int val assert_failure : t val decode_error : t val division_by_zero : t -val end_of_file : t -val exit : t val failure : t val from_lid : Longident.t -> t val from_string : string -> t @@ -13,7 +11,6 @@ val invalid_argument : t val js_exn : t val match_failure : t val not_found : t -val sys_error : t val to_string : t -> string val yojson_json_error : t val yojson_type_error : t diff --git a/analysis/reanalyze/src/file_annotations.ml b/analysis/reanalyze/src/file_annotations.ml index 83cded03713..da19061a0e0 100644 --- a/analysis/reanalyze/src/file_annotations.ml +++ b/analysis/reanalyze/src/file_annotations.ml @@ -38,8 +38,6 @@ let builder_to_list (builder : builder) : (Lexing.position * annotated_as) list = Pos_hash.fold (fun pos value acc -> (pos, value) :: acc) builder [] -let create_from_hashtbl (h : annotated_as Pos_hash.t) : t = h - (* ===== Read-only API ===== *) let is_annotated_dead (state : t) pos = Pos_hash.find_opt state pos = Some Dead @@ -53,7 +51,3 @@ let is_annotated_gentype_or_dead (state : t) pos = match Pos_hash.find_opt state pos with | Some (Dead | GenType) -> true | Some Live | None -> false - -let length (t : t) = Pos_hash.length t - -let iter f (t : t) = Pos_hash.iter f t diff --git a/analysis/reanalyze/src/file_annotations.mli b/analysis/reanalyze/src/file_annotations.mli index 3ca50fcacd2..e2751bf01e5 100644 --- a/analysis/reanalyze/src/file_annotations.mli +++ b/analysis/reanalyze/src/file_annotations.mli @@ -32,13 +32,8 @@ val merge_all : builder list -> t val builder_to_list : builder -> (Lexing.position * annotated_as) list (** Extract all annotations as a list for reactive merge *) -val create_from_hashtbl : annotated_as Pos_hash.t -> t -(** Create from hashtable for reactive merge *) - (** {2 Read-only API for t - for solver} *) val is_annotated_dead : t -> Lexing.position -> bool val is_annotated_gentype_or_live : t -> Lexing.position -> bool val is_annotated_gentype_or_dead : t -> Lexing.position -> bool -val length : t -> int -val iter : (Lexing.position -> annotated_as -> unit) -> t -> unit diff --git a/analysis/reanalyze/src/file_deps.ml b/analysis/reanalyze/src/file_deps.ml index d02a040a77b..65cb6234bb8 100644 --- a/analysis/reanalyze/src/file_deps.ml +++ b/analysis/reanalyze/src/file_deps.ml @@ -10,13 +10,6 @@ module File_hash = Hashtbl.Make (struct let equal (x : t) y = x = y end) -(** {2 Types} *) - -type t = { - files: File_set.t; - deps: File_set.t File_hash.t; (* from_file -> set of to_files *) -} - type builder = {mutable files: File_set.t; deps: File_set.t File_hash.t} (** {2 Builder API} *) @@ -51,107 +44,3 @@ let merge_into_builder ~(from : builder) ~(into : builder) = in File_hash.replace into.deps from_file (File_set.union existing to_files)) from.deps - -let freeze_builder (b : builder) : t = - (* This is a zero-copy operation, so it's "unsafe" if the builder is - subsequently mutated. However, the calling discipline is that the - builder is no longer used after freezing. *) - {files = b.files; deps = b.deps} - -let merge_all (builders : builder list) : t = - let merged_builder = create_builder () in - builders - |> List.iter (fun b -> merge_into_builder ~from:b ~into:merged_builder); - freeze_builder merged_builder - -(** {2 Builder extraction for reactive merge} *) - -let builder_files (builder : builder) : File_set.t = builder.files - -let builder_deps_to_list (builder : builder) : (string * File_set.t) list = - File_hash.fold - (fun from_file to_files acc -> (from_file, to_files) :: acc) - builder.deps [] - -let create ~files ~deps : t = {files; deps} - -(** {2 Read-only API} *) - -let get_files (t : t) = t.files - -let get_deps (t : t) file = - match File_hash.find_opt t.deps file with - | Some s -> s - | None -> File_set.empty - -let iter_deps (t : t) f = File_hash.iter f t.deps - -let file_exists (t : t) file = File_hash.mem t.deps file - -let files_count (t : t) = File_set.cardinal t.files - -let deps_count (t : t) = File_hash.length t.deps - -(** {2 Topological ordering} *) - -let iter_files_from_roots_to_leaves (t : t) iter_fun = - (* For each file, the number of incoming references *) - let inverse_references = (Hashtbl.create 256 : (string, int) Hashtbl.t) in - (* For each number of incoming references, the files *) - let references_by_number = - (Hashtbl.create 256 : (int, File_set.t) Hashtbl.t) - in - let get_num file_name = - try Hashtbl.find inverse_references file_name with Not_found -> 0 - in - let get_set num = - try Hashtbl.find references_by_number num with Not_found -> File_set.empty - in - let add_incoming_edge file_name = - let old_num = get_num file_name in - let new_num = old_num + 1 in - let old_set_at_num = get_set old_num in - let new_set_at_num = File_set.remove file_name old_set_at_num in - let old_set_at_new_num = get_set new_num in - let new_set_at_new_num = File_set.add file_name old_set_at_new_num in - Hashtbl.replace inverse_references file_name new_num; - Hashtbl.replace references_by_number old_num new_set_at_num; - Hashtbl.replace references_by_number new_num new_set_at_new_num - in - let remove_incoming_edge file_name = - let old_num = get_num file_name in - let new_num = old_num - 1 in - let old_set_at_num = get_set old_num in - let new_set_at_num = File_set.remove file_name old_set_at_num in - let old_set_at_new_num = get_set new_num in - let new_set_at_new_num = File_set.add file_name old_set_at_new_num in - Hashtbl.replace inverse_references file_name new_num; - Hashtbl.replace references_by_number old_num new_set_at_num; - Hashtbl.replace references_by_number new_num new_set_at_new_num - in - let add_edge from_file to_file = - if file_exists t from_file then add_incoming_edge to_file - in - let remove_edge from_file to_file = - if file_exists t from_file then remove_incoming_edge to_file - in - iter_deps t (fun from_file set -> - if get_num from_file = 0 then - Hashtbl.replace references_by_number 0 - (File_set.add from_file (get_set 0)); - set |> File_set.iter (fun to_file -> add_edge from_file to_file)); - while get_set 0 <> File_set.empty do - let files_with_no_incoming_references = get_set 0 in - Hashtbl.remove references_by_number 0; - files_with_no_incoming_references - |> File_set.iter (fun file_name -> - iter_fun file_name; - let references = get_deps t file_name in - references - |> File_set.iter (fun to_file -> remove_edge file_name to_file)) - done; - (* Process any remaining items in case of circular references *) - references_by_number - |> Hashtbl.iter (fun _num set -> - if File_set.is_empty set then () - else set |> File_set.iter (fun file_name -> iter_fun file_name)) diff --git a/analysis/reanalyze/src/file_deps.mli b/analysis/reanalyze/src/file_deps.mli index 3e43a806e37..aa359a828dd 100644 --- a/analysis/reanalyze/src/file_deps.mli +++ b/analysis/reanalyze/src/file_deps.mli @@ -1,14 +1,6 @@ (** File dependencies collected during AST processing. - - Tracks which files reference which other files. - Two types are provided: - - [builder] - mutable, for AST processing - - [t] - immutable, for analysis *) -(** {2 Types} *) - -type t -(** Immutable file dependencies - for analysis *) + Tracks which files reference which other files with a mutable [builder]. *) type builder (** Mutable builder - for AST processing *) @@ -27,52 +19,3 @@ val add_dep : builder -> from_file:string -> to_file:string -> unit val merge_into_builder : from:builder -> into:builder -> unit (** Merge one builder into another. *) - -val freeze_builder : builder -> t -(** Freeze a builder into an immutable result. - Note: Zero-copy - caller must not mutate builder after freezing. *) - -val merge_all : builder list -> t -(** Merge all builders into one immutable result. Order doesn't matter. *) - -(** {2 Builder extraction for reactive merge} *) - -val builder_files : builder -> File_set.t -(** Get files set from builder *) - -val builder_deps_to_list : builder -> (string * File_set.t) list -(** Extract all deps as a list for reactive merge *) - -(** {2 Internal types (for ReactiveMerge)} *) - -module File_hash : Hashtbl.S with type key = string -(** File-keyed hashtable *) - -val create : files:File_set.t -> deps:File_set.t File_hash.t -> t -(** Create a FileDeps.t from files set and deps hashtable *) - -(** {2 Read-only API for t - for analysis} *) - -val get_files : t -> File_set.t -(** Get all files. *) - -val get_deps : t -> string -> File_set.t -(** Get files that a given file depends on. *) - -val iter_deps : t -> (string -> File_set.t -> unit) -> unit -(** Iterate over all file dependencies. *) - -val file_exists : t -> string -> bool -(** Check if a file exists in the graph. *) - -val files_count : t -> int -(** Count of files in the file set. *) - -val deps_count : t -> int -(** Count of dependencies (number of from_file entries). *) - -(** {2 Topological ordering} *) - -val iter_files_from_roots_to_leaves : t -> (string -> unit) -> unit -(** Iterate over files in topological order (roots first, leaves last). - Files with no incoming references are processed first. *) diff --git a/analysis/reanalyze/src/issue.ml b/analysis/reanalyze/src/issue.ml index 4aa9bb76a69..767922a0fa1 100644 --- a/analysis/reanalyze/src/issue.ml +++ b/analysis/reanalyze/src/issue.ml @@ -29,7 +29,6 @@ type dead_warning = | IncorrectDeadAnnotation type description = - | Circular of {message: string} | ExceptionAnalysis of {message: string} | ExceptionAnalysisMissing of missing_throw_info | DeadModule of {message: string} diff --git a/analysis/reanalyze/src/issues.ml b/analysis/reanalyze/src/issues.ml index 62f64523703..0218f472a50 100644 --- a/analysis/reanalyze/src/issues.ml +++ b/analysis/reanalyze/src/issues.ml @@ -4,7 +4,6 @@ let error_termination = "Error Termination" let exception_analysis = "Exception Analysis" let incorrect_dead_annotation = "Incorrect Dead Annotation" let termination_analysis_internal = "Termination Analysis Internal" -let warning_dead_analysis_cycle = "Warning Dead Analysis Cycle" let warning_dead_exception = "Warning Dead Exception" let warning_dead_module = "Warning Dead Module" let warning_dead_type = "Warning Dead Type" diff --git a/analysis/reanalyze/src/liveness.ml b/analysis/reanalyze/src/liveness.ml index c40f4b3426e..2e4615718c2 100644 --- a/analysis/reanalyze/src/liveness.ml +++ b/analysis/reanalyze/src/liveness.ml @@ -255,11 +255,6 @@ let compute_forward ~debug ~(decl_store : Declaration_store.t) (live, decl_refs_index) -(** Check if a position is live according to forward-computed liveness *) -let is_live_forward ~(live : live_reason Pos_hash.t) (pos : Lexing.position) : - bool = - Pos_hash.mem live pos - (** Get the reason why a position is live, if it is *) let get_live_reason ~(live : live_reason Pos_hash.t) (pos : Lexing.position) : live_reason option = diff --git a/analysis/reanalyze/src/liveness.mli b/analysis/reanalyze/src/liveness.mli index c2a3c2b3e77..d467fc9354a 100644 --- a/analysis/reanalyze/src/liveness.mli +++ b/analysis/reanalyze/src/liveness.mli @@ -30,9 +30,6 @@ val compute_forward : decl_pos -> (value_targets, type_targets). Pass [~debug:true] for verbose output. *) -val is_live_forward : live:live_reason Pos_hash.t -> Lexing.position -> bool -(** Check if a position is live according to forward-computed liveness *) - val get_live_reason : live:live_reason Pos_hash.t -> Lexing.position -> live_reason option (** Get the reason why a position is live, if it is *) diff --git a/analysis/reanalyze/src/log_.ml b/analysis/reanalyze/src/log_.ml index f365b1f1c6c..85254b4af67 100644 --- a/analysis/reanalyze/src/log_.ml +++ b/analysis/reanalyze/src/log_.ml @@ -125,7 +125,6 @@ let missing_throw_info_to_message let description_to_message (description : Issue.description) = match description with - | Circular {message} -> message | DeadModule {message} -> message | DeadOptional {message} -> message | DeadWarning {path; message} -> @@ -137,7 +136,6 @@ let description_to_message (description : Issue.description) = let description_to_name (description : Issue.description) = match description with - | Circular _ -> Issues.warning_dead_analysis_cycle | DeadModule _ -> Issues.warning_dead_module | DeadOptional {dead_optional = WarningUnusedArgument} -> Issues.warning_unused_argument diff --git a/analysis/reanalyze/src/optional_args.ml b/analysis/reanalyze/src/optional_args.ml index 6974f1580ec..a98d4cbe406 100644 --- a/analysis/reanalyze/src/optional_args.ml +++ b/analysis/reanalyze/src/optional_args.ml @@ -37,9 +37,6 @@ let combine_pair x y = let always_used = String_set.inter x.always_used y.always_used in ({x with unused; always_used}, {y with unused; always_used}) -let iter_unused f x = String_set.iter f x.unused -let iter_always_used f x = String_set.iter (fun s -> f s x.count) x.always_used - let fold_unused f x init = String_set.fold f x.unused init let fold_always_used f x init = diff --git a/analysis/reanalyze/src/reactive_analysis.ml b/analysis/reanalyze/src/reactive_analysis.ml index be535742286..38a0d213011 100644 --- a/analysis/reanalyze/src/reactive_analysis.ml +++ b/analysis/reanalyze/src/reactive_analysis.ml @@ -131,9 +131,6 @@ let process_files ~(collection : t) ~config:_ cmt_file_paths : }, stats )) -(** Get collection length *) -let length (collection : t) = Reactive_file_collection.length collection - (** Get the underlying reactive collection for composition. Returns (path, file_data option) suitable for ReactiveMerge. *) let to_file_data_collection (collection : t) : diff --git a/analysis/reanalyze/src/reactive_exception_refs.ml b/analysis/reanalyze/src/reactive_exception_refs.ml index bafd2673f06..b0cd3c21331 100644 --- a/analysis/reanalyze/src/reactive_exception_refs.ml +++ b/analysis/reanalyze/src/reactive_exception_refs.ml @@ -10,8 +10,6 @@ (** {1 Types} *) type t = { - exception_decls: (Dce_path.t, Location.t) Reactive.t; - resolved_refs: (Lexing.position, Pos_set.t) Reactive.t; resolved_refs_from: (Lexing.position, Pos_set.t) Reactive.t; } (** Reactive exception ref collections *) @@ -67,28 +65,4 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) ~merge:Pos_set.union () in - {exception_decls; resolved_refs; resolved_refs_from} - -(** {1 Freezing} *) - -(** Add all resolved exception refs to a References.builder *) -let add_to_refs_builder (t : t) ~(refs : References.builder) : unit = - Reactive.iter - (fun pos_to pos_from_set -> - Pos_set.iter - (fun pos_from -> References.add_value_ref refs ~pos_to ~pos_from) - pos_from_set) - t.resolved_refs - -(** Add file dependencies for resolved refs *) -let add_to_file_deps_builder (t : t) ~(file_deps : File_deps.builder) : unit = - Reactive.iter - (fun pos_to pos_from_set -> - Pos_set.iter - (fun pos_from -> - let from_file = pos_from.Lexing.pos_fname in - let to_file = pos_to.Lexing.pos_fname in - if from_file <> to_file then - File_deps.add_dep file_deps ~from_file ~to_file) - pos_from_set) - t.resolved_refs + {resolved_refs_from} diff --git a/analysis/reanalyze/src/reactive_exception_refs.mli b/analysis/reanalyze/src/reactive_exception_refs.mli index c418057c598..cd58ca4b0c3 100644 --- a/analysis/reanalyze/src/reactive_exception_refs.mli +++ b/analysis/reanalyze/src/reactive_exception_refs.mli @@ -26,15 +26,12 @@ ~decls:merged.decls ~exception_refs:(flatMap cross_file ~f:extract_exception_refs ()) in - ReactiveExceptionRefs.add_to_refs_builder exc_refs ~refs:my_refs_builder + Reactive.iter (fun pos refs -> ...) exc_refs.resolved_refs_from ]} *) (** {1 Types} *) type t = { - exception_decls: (Dce_path.t, Location.t) Reactive.t; - resolved_refs: (Lexing.position, Pos_set.t) Reactive.t; - (** refs_to direction: target -> sources *) resolved_refs_from: (Lexing.position, Pos_set.t) Reactive.t; (** refs_from direction: source -> targets (for forward solver) *) } @@ -49,11 +46,3 @@ val create : (** Create reactive exception refs from decls and cross-file exception refs. When the source collections change, resolved refs automatically update. *) - -(** {1 Freezing} *) - -val add_to_refs_builder : t -> refs:References.builder -> unit -(** Add all resolved exception refs to a References.builder. *) - -val add_to_file_deps_builder : t -> file_deps:File_deps.builder -> unit -(** Add file dependencies for resolved refs. *) diff --git a/analysis/reanalyze/src/reactive_merge.ml b/analysis/reanalyze/src/reactive_merge.ml index 6c376e0efa6..8b1158759b1 100644 --- a/analysis/reanalyze/src/reactive_merge.ml +++ b/analysis/reanalyze/src/reactive_merge.ml @@ -11,8 +11,6 @@ type t = { value_refs_from: (Lexing.position, Pos_set.t) Reactive.t; type_refs_from: (Lexing.position, Pos_set.t) Reactive.t; cross_file_items: (string, Cross_file_items.t) Reactive.t; - file_deps_map: (string, File_set.t) Reactive.t; - files: (string, unit) Reactive.t; (* Reactive type/exception dependencies *) type_deps: Reactive_type_deps.t; exception_refs: Reactive_exception_refs.t; @@ -92,32 +90,6 @@ let create (source : (string, Dce_file_processing.file_data option) Reactive.t) () in - (* File deps map: (from_file, FileSet of to_files) with FileSet.union merge *) - let file_deps_map = - Reactive.flat_map ~name:"file_deps_map" source - ~f:(fun _path file_data_opt -> - match file_data_opt with - | None -> [] - | Some file_data -> - File_deps.builder_deps_to_list file_data.Dce_file_processing.file_deps) - ~merge:File_set.union () - in - - (* Files set: (source_path, ()) - just track which source files exist *) - let files = - Reactive.flat_map ~name:"files" source - ~f:(fun _cmt_path file_data_opt -> - match file_data_opt with - | None -> [] - | Some file_data -> - (* Include all source files from file_deps (NOT the CMT path) *) - let file_set = - File_deps.builder_files file_data.Dce_file_processing.file_deps - in - File_set.fold (fun f acc -> (f, ()) :: acc) file_set []) - () - in - (* Extract exception_refs from cross_file_items for ReactiveExceptionRefs *) let exception_refs_collection = Reactive.flat_map ~name:"exception_refs_collection" cross_file_items @@ -147,125 +119,6 @@ let create (source : (string, Dce_file_processing.file_data option) Reactive.t) value_refs_from; type_refs_from; cross_file_items; - file_deps_map; - files; type_deps; exception_refs; } - -(** {1 Conversion to solver-ready format} *) - -(** Convert reactive decls to Declarations.t for solver *) -let freeze_decls (t : t) : Declarations.t = - let result = Pos_hash.create 256 in - Reactive.iter (fun pos decl -> Pos_hash.replace result pos decl) t.decls; - Declarations.create_from_hashtbl result - -(** Convert reactive annotations to FileAnnotations.t for solver *) -let freeze_annotations (t : t) : File_annotations.t = - let result = Pos_hash.create 256 in - Reactive.iter (fun pos ann -> Pos_hash.replace result pos ann) t.annotations; - File_annotations.create_from_hashtbl result - -(** Convert reactive refs to References.t for solver. - Includes type-label deps and exception refs from reactive computations. *) -let freeze_refs (t : t) : References.t = - let value_refs_from = Pos_hash.create 256 in - let type_refs_from = Pos_hash.create 256 in - - (* Helper to add to refs_from hashtable *) - let add_to_from tbl pos_from pos_to = - let existing = - match Pos_hash.find_opt tbl pos_from with - | Some s -> s - | None -> Pos_set.empty - in - Pos_hash.replace tbl pos_from (Pos_set.add pos_to existing) - in - - (* Merge per-file value refs_from *) - Reactive.iter - (fun pos_from pos_to_set -> - Pos_set.iter - (fun pos_to -> add_to_from value_refs_from pos_from pos_to) - pos_to_set) - t.value_refs_from; - - (* Merge per-file type refs_from *) - Reactive.iter - (fun pos_from pos_to_set -> - Pos_set.iter - (fun pos_to -> add_to_from type_refs_from pos_from pos_to) - pos_to_set) - t.type_refs_from; - - (* Add type-label dependency refs from all sources *) - let add_type_refs_from reactive = - Reactive.iter - (fun pos_from pos_to_set -> - Pos_set.iter - (fun pos_to -> add_to_from type_refs_from pos_from pos_to) - pos_to_set) - reactive - in - add_type_refs_from t.type_deps.all_type_refs_from; - - (* Add exception refs (to value refs_from) *) - Reactive.iter - (fun pos_from pos_to_set -> - Pos_set.iter - (fun pos_to -> add_to_from value_refs_from pos_from pos_to) - pos_to_set) - t.exception_refs.resolved_refs_from; - - References.create ~value_refs_from ~type_refs_from - -(** Collect all cross-file items *) -let collect_cross_file_items (t : t) : Cross_file_items.t = - let exception_refs = ref [] in - let optional_arg_calls = ref [] in - let function_refs = ref [] in - Reactive.iter - (fun _path items -> - exception_refs := items.Cross_file_items.exception_refs @ !exception_refs; - optional_arg_calls := - items.Cross_file_items.optional_arg_calls @ !optional_arg_calls; - function_refs := items.Cross_file_items.function_refs @ !function_refs) - t.cross_file_items; - { - Cross_file_items.exception_refs = !exception_refs; - optional_arg_calls = !optional_arg_calls; - function_refs = !function_refs; - } - -(** Convert reactive file deps to FileDeps.t for solver. - Includes file deps from exception refs. *) -let freeze_file_deps (t : t) : File_deps.t = - let files = - let result = ref File_set.empty in - Reactive.iter (fun path () -> result := File_set.add path !result) t.files; - !result - in - let deps = File_deps.File_hash.create 256 in - Reactive.iter - (fun from_file to_files -> - File_deps.File_hash.replace deps from_file to_files) - t.file_deps_map; - (* Add file deps from exception refs - iterate value_refs_from *) - Reactive.iter - (fun pos_from pos_to_set -> - Pos_set.iter - (fun pos_to -> - let from_file = pos_from.Lexing.pos_fname in - let to_file = pos_to.Lexing.pos_fname in - if from_file <> to_file then - let existing = - match File_deps.File_hash.find_opt deps from_file with - | Some s -> s - | None -> File_set.empty - in - File_deps.File_hash.replace deps from_file - (File_set.add to_file existing)) - pos_to_set) - t.exception_refs.resolved_refs_from; - File_deps.create ~files ~deps diff --git a/analysis/reanalyze/src/reactive_merge.mli b/analysis/reanalyze/src/reactive_merge.mli index d170b398407..2f1c6e15a6c 100644 --- a/analysis/reanalyze/src/reactive_merge.mli +++ b/analysis/reanalyze/src/reactive_merge.mli @@ -17,9 +17,6 @@ (* Access derived collections *) Reactive.iter (fun pos decl -> ...) merged.decls; - - (* Or freeze for solver *) - let decls = ReactiveMerge.freeze_decls merged in ]} *) (** {1 Types} *) @@ -32,8 +29,6 @@ type t = { type_refs_from: (Lexing.position, Pos_set.t) Reactive.t; (** Type refs: source -> targets *) cross_file_items: (string, Cross_file_items.t) Reactive.t; - file_deps_map: (string, File_set.t) Reactive.t; - files: (string, unit) Reactive.t; (* Reactive type/exception dependencies *) type_deps: Reactive_type_deps.t; exception_refs: Reactive_exception_refs.t; @@ -45,20 +40,3 @@ type t = { val create : (string, Dce_file_processing.file_data option) Reactive.t -> t (** Create reactive merge from a file data collection. All derived collections update automatically when source changes. *) - -(** {1 Conversion to solver-ready format} *) - -val freeze_decls : t -> Declarations.t -(** Convert reactive decls to Declarations.t for solver *) - -val freeze_annotations : t -> File_annotations.t -(** Convert reactive annotations to FileAnnotations.t for solver *) - -val freeze_refs : t -> References.t -(** Convert reactive refs to References.t for solver *) - -val collect_cross_file_items : t -> Cross_file_items.t -(** Collect all cross-file items *) - -val freeze_file_deps : t -> File_deps.t -(** Convert reactive file deps to FileDeps.t for solver *) diff --git a/analysis/reanalyze/src/reactive_solver.ml b/analysis/reanalyze/src/reactive_solver.ml index e0b7456b555..61614bc245e 100644 --- a/analysis/reanalyze/src/reactive_solver.ml +++ b/analysis/reanalyze/src/reactive_solver.ml @@ -27,7 +27,6 @@ type t = { live: (Lexing.position, unit) Reactive.t; dead_decls: (Lexing.position, Decl.t) Reactive.t; live_decls: (Lexing.position, Decl.t) Reactive.t; - annotations: (Lexing.position, File_annotations.annotated_as) Reactive.t; value_refs_from: (Lexing.position, Pos_set.t) Reactive.t option; dead_modules: (Name.t, Location.t * string) Reactive.t; (** Modules where all declarations are dead. Value is (loc, fileName). Reactive anti-join. *) @@ -41,7 +40,6 @@ type t = { (** Live declarations with @dead annotation. Reactive join of live_decls + annotations. *) dead_module_issues: (Name.t, Issue.t) Reactive.t; (** Dead module issues. Reactive join of dead_modules + modules_with_reported. *) - config: Dce_config.t; } (** Extract module name from a declaration *) @@ -241,14 +239,12 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) live; dead_decls; live_decls; - annotations; value_refs_from; dead_modules; dead_decls_by_file; issues_by_file; incorrect_dead_decls; dead_module_issues; - config; } (** Check if a module is dead using reactive collection. Returns issue if dead. @@ -280,7 +276,7 @@ let check_module_dead ~(dead_modules : (Name.t, Location.t * string) Reactive.t) let collect_issues ~(t : t) ~(config : Dce_config.t) ~(ann_store : Annotation_store.t) : Issue.t list = ignore (config, ann_store); - (* config is stored in t, ann_store used via reactive annotations *) + (* Kept for call-site parity with the non-reactive solver. *) let t0 = Unix.gettimeofday () in (* Track reported modules to avoid duplicates across files *) let reported_modules = Hashtbl.create 64 in diff --git a/analysis/reanalyze/src/reactive_type_deps.ml b/analysis/reanalyze/src/reactive_type_deps.ml index 233f37e67b6..a3775e33704 100644 --- a/analysis/reanalyze/src/reactive_type_deps.ml +++ b/analysis/reanalyze/src/reactive_type_deps.ml @@ -11,7 +11,6 @@ type decl_info = { pos: Lexing.position; - pos_end: Lexing.position; path: Dce_path.t; is_interface: bool; } @@ -26,21 +25,12 @@ let decl_to_info (decl : Decl.t) : decl_info option = | module_name_tag :: _ -> ( try (module_name_tag |> Name.to_string).[0] <> '+' with _ -> true) in - Some - {pos = decl.pos; pos_end = decl.pos_end; path = decl.path; is_interface} + Some {pos = decl.pos; path = decl.path; is_interface} | _ -> None (** {1 Reactive Collections} *) type t = { - decl_by_path: (Dce_path.t, decl_info list) Reactive.t; - (* refs_to direction: target -> sources *) - same_path_refs: (Lexing.position, Pos_set.t) Reactive.t; - cross_file_refs: (Lexing.position, Pos_set.t) Reactive.t; - all_type_refs: (Lexing.position, Pos_set.t) Reactive.t; - impl_to_intf_refs_path2: (Lexing.position, Pos_set.t) Reactive.t; - intf_to_impl_refs: (Lexing.position, Pos_set.t) Reactive.t; - (* refs_from direction: source -> targets (for forward solver) *) all_type_refs_from: (Lexing.position, Pos_set.t) Reactive.t; } (** All reactive collections for type-label dependencies *) @@ -198,10 +188,6 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) - intf_to_impl_refs *) let cross_file_refs = impl_to_intf_refs in - (* All type refs = same_path_refs + all cross-file sources. - We expose these separately and merge in freeze_refs. *) - let all_type_refs = same_path_refs in - (* Create refs_from by combining and inverting all refs_to sources. We use a single flatMap that iterates all sources once. *) let all_type_refs_from = @@ -226,23 +212,4 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) ~merge:Pos_set.union () in - { - decl_by_path; - same_path_refs; - cross_file_refs; - all_type_refs; - impl_to_intf_refs_path2; - intf_to_impl_refs; - all_type_refs_from; - } - -(** {1 Freezing for solver} *) - -(** Add all type refs to a References.builder *) -let add_to_refs_builder (t : t) ~(refs : References.builder) : unit = - Reactive.iter - (fun pos_to pos_from_set -> - Pos_set.iter - (fun pos_from -> References.add_type_ref refs ~pos_to ~pos_from) - pos_from_set) - t.all_type_refs + {all_type_refs_from} diff --git a/analysis/reanalyze/src/reactive_type_deps.mli b/analysis/reanalyze/src/reactive_type_deps.mli index c563ec19717..6423e4f0161 100644 --- a/analysis/reanalyze/src/reactive_type_deps.mli +++ b/analysis/reanalyze/src/reactive_type_deps.mli @@ -24,27 +24,18 @@ ~report_types_dead_only_in_interface:true in (* Type refs update automatically when decls change *) - ReactiveTypeDeps.add_to_refs_builder type_deps ~refs:my_refs_builder + Reactive.iter (fun pos refs -> ...) type_deps.all_type_refs_from ]} *) (** {1 Types} *) type t = { - decl_by_path: (Dce_path.t, decl_info list) Reactive.t; - (* refs_to direction: target -> sources *) - same_path_refs: (Lexing.position, Pos_set.t) Reactive.t; - cross_file_refs: (Lexing.position, Pos_set.t) Reactive.t; - all_type_refs: (Lexing.position, Pos_set.t) Reactive.t; - impl_to_intf_refs_path2: (Lexing.position, Pos_set.t) Reactive.t; - intf_to_impl_refs: (Lexing.position, Pos_set.t) Reactive.t; - (* refs_from direction: source -> targets (for forward solver) *) all_type_refs_from: (Lexing.position, Pos_set.t) Reactive.t; } (** Reactive type-label dependency collections *) and decl_info = { pos: Lexing.position; - pos_end: Lexing.position; path: Dce_path.t; is_interface: bool; } @@ -62,11 +53,3 @@ val create : [report_types_dead_only_in_interface] controls whether refs are bidirectional (false) or only intf->impl (true). *) - -(** {1 Freezing} *) - -val add_to_refs_builder : t -> refs:References.builder -> unit -(** Add all computed type refs to a References.builder. - - Call this after processing files to get the current type refs. - The builder will contain all type-label dependency refs. *) diff --git a/analysis/reanalyze/src/reanalyze_server.ml b/analysis/reanalyze/src/reanalyze_server.ml index 5e17554ca61..6448577b1dc 100644 --- a/analysis/reanalyze/src/reanalyze_server.ml +++ b/analysis/reanalyze/src/reanalyze_server.ml @@ -71,11 +71,6 @@ let try_request_default () : response option = try_request ~socket_dir:(Some socket_dir) ~socket_path module Server = struct - let ( let* ) x f = - match x with - | Ok v -> f v - | Error _ as e -> e - let errorf fmt = Printf.ksprintf (fun s -> Error s) fmt type server_config = {socket_path: string; cwd: string option} @@ -105,7 +100,6 @@ module Server = struct } type server_state = { - parse_argv: string array -> string option; run_analysis: dce_config:Dce_config.t -> cmt_root:string option -> @@ -325,7 +319,6 @@ Examples: let pipeline = create_reactive_pipeline () in Ok { - parse_argv; run_analysis; config; cmt_root; diff --git a/analysis/reanalyze/src/references.ml b/analysis/reanalyze/src/references.ml index 8b917dce9e0..110ef4e7f0e 100644 --- a/analysis/reanalyze/src/references.ml +++ b/analysis/reanalyze/src/references.ml @@ -44,15 +44,6 @@ let merge_into_builder ~(from : builder) ~(into : builder) = |> Pos_set.iter (fun to_pos -> add_set into.type_refs_from pos to_pos)) from.type_refs_from -let merge_all (builders : builder list) : t = - let result = create_builder () in - builders - |> List.iter (fun builder -> merge_into_builder ~from:builder ~into:result); - { - value_refs_from = result.value_refs_from; - type_refs_from = result.type_refs_from; - } - let freeze_builder (builder : builder) : t = (* Zero-copy freeze - builder should not be used after this *) { @@ -74,13 +65,7 @@ let builder_type_refs_from_list (builder : builder) : (fun pos refs acc -> (pos, refs) :: acc) builder.type_refs_from [] -let create ~value_refs_from ~type_refs_from : t = - {value_refs_from; type_refs_from} - (* ===== Read-only API ===== *) let iter_value_refs_from (t : t) f = Pos_hash.iter f t.value_refs_from let iter_type_refs_from (t : t) f = Pos_hash.iter f t.type_refs_from - -let value_refs_from_length (t : t) = Pos_hash.length t.value_refs_from -let type_refs_from_length (t : t) = Pos_hash.length t.type_refs_from diff --git a/analysis/reanalyze/src/references.mli b/analysis/reanalyze/src/references.mli index d4b9ef9b762..2a13ef71930 100644 --- a/analysis/reanalyze/src/references.mli +++ b/analysis/reanalyze/src/references.mli @@ -32,9 +32,6 @@ val add_type_ref : val merge_into_builder : from:builder -> into:builder -> unit (** Merge one builder into another. *) -val merge_all : builder list -> t -(** Merge all builders into one immutable result. Order doesn't matter. *) - val freeze_builder : builder -> t (** Convert builder to immutable t. Builder should not be used after this. *) @@ -46,12 +43,6 @@ val builder_value_refs_from_list : builder -> (Lexing.position * Pos_set.t) list val builder_type_refs_from_list : builder -> (Lexing.position * Pos_set.t) list (** Extract type refs (posFrom -> targets) *) -val create : - value_refs_from:Pos_set.t Pos_hash.t -> - type_refs_from:Pos_set.t Pos_hash.t -> - t -(** Create a References.t from hashtables *) - (** {2 Read-only API - for liveness} *) val iter_value_refs_from : t -> (Lexing.position -> Pos_set.t -> unit) -> unit @@ -59,8 +50,3 @@ val iter_value_refs_from : t -> (Lexing.position -> Pos_set.t -> unit) -> unit val iter_type_refs_from : t -> (Lexing.position -> Pos_set.t -> unit) -> unit (** Iterate all type refs *) - -(** {2 Length} *) - -val value_refs_from_length : t -> int -val type_refs_from_length : t -> int diff --git a/analysis/reanalyze/src/run_config.ml b/analysis/reanalyze/src/run_config.ml index 1fe02a6d445..f372fd209fa 100644 --- a/analysis/reanalyze/src/run_config.ml +++ b/analysis/reanalyze/src/run_config.ml @@ -40,23 +40,14 @@ let termination () = run_config.termination <- true let transitive b = run_config.transitive <- b -type snapshot = { - dce: bool; - exception_: bool; - suppress: string list; - termination: bool; - transitive: bool; - unsuppress: string list; -} +type snapshot = bool * bool * string list * bool * bool * string list let snapshot () = - { - dce = run_config.dce; - exception_ = run_config.exception_; - suppress = run_config.suppress; - termination = run_config.termination; - transitive = run_config.transitive; - unsuppress = run_config.unsuppress; - } + ( run_config.dce, + run_config.exception_, + run_config.suppress, + run_config.termination, + run_config.transitive, + run_config.unsuppress ) let equal_snapshot (a : snapshot) (b : snapshot) = a = b diff --git a/analysis/src/cli.ml b/analysis/src/cli.ml index a30e36530a7..1fa75508d42 100644 --- a/analysis/src/cli.ml +++ b/analysis/src/cli.ml @@ -230,19 +230,6 @@ let test ~state ~path = | "dv-" -> Debug.debug_level := Off | "in+" -> Cfg.in_incremental_typechecking_mode := true | "in-" -> Cfg.in_incremental_typechecking_mode := false - | "ve+" -> ( - let version = String.sub rest 3 (String.length rest - 3) in - let version = String.trim version in - if Debug.verbose () then - Printf.printf "Setting version: %s\n" version; - match String.split_on_char '.' version with - | [major_raw; minor_raw] -> - let version = - (int_of_string major_raw, int_of_string minor_raw) - in - Packages.override_rescript_version := Some version - | _ -> ()) - | "ve-" -> Packages.override_rescript_version := None | "def" -> print_endline ("Definition " ^ path ^ " " ^ string_of_int line ^ ":" diff --git a/analysis/src/cmt_viewer.ml b/analysis/src/cmt_viewer.ml index ce32f8885bc..9de0717ffa8 100644 --- a/analysis/src/cmt_viewer.ml +++ b/analysis/src/cmt_viewer.ml @@ -1,22 +1,4 @@ -let filter_by_cursor cursor (loc : Warnings.loc) : bool = - match cursor with - | None -> true - | Some (line, col) -> - let start = loc.loc_start and end_ = loc.loc_end in - let line_in = start.pos_lnum <= line && line <= end_.pos_lnum in - let col_in = - if start.pos_lnum = end_.pos_lnum then - start.pos_cnum - start.pos_bol <= col - && col <= end_.pos_cnum - end_.pos_bol - else if line = start.pos_lnum then col >= start.pos_cnum - start.pos_bol - else if line = end_.pos_lnum then col <= end_.pos_cnum - end_.pos_bol - else true - in - line_in && col_in - -type filter = Cursor of (int * int) | Loc of Loc.t - -let dump ~state ?filter rescript_json cmt_path = +let dump ~state rescript_json cmt_path = let uri = Uri.from_path (Filename.remove_extension cmt_path ^ ".res") in let package = let uri = Uri.from_path rescript_json in @@ -31,25 +13,9 @@ let dump ~state ?filter rescript_json cmt_path = | Some full -> let open Shared_types in let open Shared_types.Stamps in - let apply_filter = - match filter with - | None -> fun _ -> true - | Some (Cursor cursor) -> Loc.has_pos ~pos:cursor - | Some (Loc loc) -> Loc.is_inside loc - in - (match filter with - | None -> () - | Some (Cursor (line, col)) -> - Printf.printf "Filtering by cursor %d,%d\n" line col - | Some (Loc loc) -> - Printf.printf "Filtering by loc %s\n" (Loc.to_string loc)); - Printf.printf "file moduleName: %s\n\n" full.file.module_name; - let stamps = - full.file.stamps |> get_entries - |> List.filter (fun (_, stamp) -> apply_filter (loc_of_kind stamp)) - in + let stamps = full.file.stamps |> get_entries in let total_stamps = List.length stamps in Printf.printf "Found %d stamps:\n%s" total_stamps @@ -110,8 +76,7 @@ let dump ~state ?filter rescript_json cmt_path = (* Dump all locItems (typed nodes) *) let loc_items = match full.extra with - | {loc_items} -> - loc_items |> List.filter (fun loc_item -> apply_filter loc_item.loc) + | {loc_items} -> loc_items in Printf.printf "\nFound %d locItems (typed nodes):\n\n" diff --git a/analysis/src/completion_back_end.ml b/analysis/src/completion_back_end.ml index 3f63bb53027..24456a17a47 100644 --- a/analysis/src/completion_back_end.ml +++ b/analysis/src/completion_back_end.ml @@ -900,12 +900,6 @@ let completion_to_item ~state filterText = filter_text; } -let completions_get_type_env = function - | {Completion.kind = Value typ; env} :: _ -> Some (typ, env) - | {Completion.kind = ObjLabel typ; env} :: _ -> Some (typ, env) - | {Completion.kind = Field ({typ}, _); env} :: _ -> Some (typ, env) - | _ -> None - type get_completions_for_context_path_mode = Regular | Pipe let completions_get_completion_type ~full ~state completions = @@ -1222,7 +1216,7 @@ and get_completions_for_context_path ~state ~debug ~full ~opens ~raw_opens ~pos else None) | None -> []) | None -> []) - | CPPipe {context_path = cp; id = prefix; lhs_loc; in_jsx; synthetic} -> ( + | CPPipe {context_path = cp; id = prefix; lhs_loc; in_jsx} -> ( if Debug.verbose () then print_endline "[ctx_path]--> CPPipe"; (* The environment at the cursor is the environment we're completing from. *) let env_at_cursor = env in @@ -1295,7 +1289,7 @@ and get_completions_for_context_path ~state ~debug ~full ~opens ~raw_opens ~pos completions_for_pipe_from_completion_path ~state ~env_completion_is_made_from ~opens ~pos ~scope ~debug ~prefix ~env ~raw_opens ~full completion_path - |> Type_utils.filter_pipeable_functions ~env ~state ~full ~synthetic + |> Type_utils.filter_pipeable_functions ~state ~full ~target_type_id:main_type_id |> List.filter (fun (c : Completion.t) -> (* If we're completing from the current module then we need to care about scope. @@ -1330,8 +1324,8 @@ and get_completions_for_context_path ~state ~debug ~full ~opens ~raw_opens ~pos ~env_completion_is_made_from ~opens ~pos ~scope ~debug ~prefix ~env ~raw_opens ~full completion_path) |> List.flatten - |> Type_utils.filter_pipeable_functions ~synthetic:true ~state ~env - ~full ~target_type_id:main_type_id + |> Type_utils.filter_pipeable_functions ~state ~full + ~target_type_id:main_type_id in (* Extra completions can be drawn from the @editor.completeFrom attribute. Here we @@ -1344,8 +1338,8 @@ and get_completions_for_context_path ~state ~debug ~full ~opens ~raw_opens ~pos ~env_completion_is_made_from ~opens ~pos ~scope ~debug ~prefix ~env ~raw_opens ~full completion_path) |> List.flatten - |> Type_utils.filter_pipeable_functions ~synthetic:true ~state ~env - ~full ~target_type_id:main_type_id + |> Type_utils.filter_pipeable_functions ~state ~full + ~target_type_id:main_type_id in (* Add JSX completion items if we're in a JSX context. *) let jsx_completions = @@ -1358,8 +1352,8 @@ and get_completions_for_context_path ~state ~debug ~full ~opens ~raw_opens ~pos let current_module_completions = get_completions_for_path ~state ~debug ~completion_context:Value ~exact:false ~opens:[] ~full ~pos ~env:env_at_cursor ~scope [prefix] - |> Type_utils.filter_pipeable_functions ~synthetic:true ~state ~env - ~full ~target_type_id:main_type_id + |> Type_utils.filter_pipeable_functions ~state ~full + ~target_type_id:main_type_id in jsx_completions @ pipe_completions @ extra_completions @ current_module_completions @ globally_configured_completions)) @@ -1587,12 +1581,15 @@ let print_constructor_args ~mode ~as_snippet args_len = if List.length !args > 0 then "(" ^ (!args |> String.concat ", ") ^ ")" else "" -let rec complete_typed_value ?(type_arg_context : type_arg_context option) - ~raw_opens ~full ~state ~prefix ~completion_context ~mode +let rec complete_typed_value ~raw_opens ~full ~state ~prefix ~completion_context ~mode (t : Shared_types.completion_type) = let empty_case = empty_case ~mode in let print_constructor_args = print_constructor_args ~mode in - let create = Completion.create ?type_arg_context in + let create ?deprecated ?(docstring = []) ?(includes_snippets = false) + ?insert_text ?sort_text name ~kind ~env = + Completion.create ?deprecated ~docstring ~includes_snippets + ?insert_text ?sort_text name ~kind ~env + in let get_record_completions ~env ~fields ~extracted_type = (* As we're completing for a record, we'll need a hint (completionContext) here to figure out whether we should complete for a record field, or @@ -2148,10 +2145,10 @@ let rec process_completable ~state ~debug ~full ~scope ~env ~pos ~for_hover in match typ |> Type_utils.resolve_nested ~env ~full ~nested ~state with | None -> [] - | Some (typ, _env, completion_context, type_arg_context) -> + | Some (typ, _env, completion_context, _type_arg_context) -> typ - |> complete_typed_value ?type_arg_context ~raw_opens ~mode:Expression - ~full ~prefix ~completion_context ~state) + |> complete_typed_value ~raw_opens ~mode:Expression ~full ~prefix + ~completion_context ~state) | CdecoratorPayload (ModuleWithImportAttributes {prefix; nested}) -> ( let mk_field ~name ~primitive = { @@ -2191,10 +2188,10 @@ let rec process_completable ~state ~debug ~full ~scope ~env ~pos ~for_hover in match typ |> Type_utils.resolve_nested ~env ~full ~nested ~state with | None -> [] - | Some (typ, _env, completion_context, type_arg_context) -> + | Some (typ, _env, completion_context, _type_arg_context) -> typ - |> complete_typed_value ?type_arg_context ~raw_opens ~mode:Expression - ~full ~prefix ~completion_context ~state) + |> complete_typed_value ~raw_opens ~mode:Expression ~full ~prefix + ~completion_context ~state) | CdecoratorPayload (Module prefix) -> let package_json_path = Utils.find_package_json (full.package.root_path |> Uri.from_path) @@ -2363,12 +2360,11 @@ let rec process_completable ~state ~debug ~full ~scope ~env ~pos ~for_hover ~state) with | None -> fallback_or_empty () - | Some (typ, _env, completion_context, type_arg_context) -> + | Some (typ, _env, completion_context, _type_arg_context) -> let items = typ - |> complete_typed_value ?type_arg_context ~raw_opens - ~mode:(Pattern pattern_mode) ~full ~prefix ~completion_context - ~state + |> complete_typed_value ~raw_opens ~mode:(Pattern pattern_mode) ~full + ~prefix ~completion_context ~state in fallback_or_empty ~items ()) | None -> fallback_or_empty ()) @@ -2429,7 +2425,7 @@ let rec process_completable ~state ~debug ~full ~scope ~env ~pos ~for_hover in items_for_raw_jsx_prop_value @ regular_completions) else regular_completions - | Some (typ, _env, completion_context, type_arg_context) -> ( + | Some (typ, _env, completion_context, _type_arg_context) -> ( if Debug.verbose () then print_endline "[process_completable]--> found type in nested expression \ @@ -2445,8 +2441,8 @@ let rec process_completable ~state ~debug ~full ~scope ~env ~pos ~for_hover in let items = typ - |> complete_typed_value ?type_arg_context ~raw_opens ~mode:Expression - ~full ~prefix ~completion_context ~state + |> complete_typed_value ~raw_opens ~mode:Expression ~full ~prefix + ~completion_context ~state |> List.map (fun (c : Completion.t) -> if wrap_insert_text_in_braces then { diff --git a/analysis/src/debug.ml b/analysis/src/debug.ml index a7002fa56cd..1a795545b3c 100644 --- a/analysis/src/debug.ml +++ b/analysis/src/debug.ml @@ -2,11 +2,6 @@ type debug_level = Off | Regular | Verbose let debug_level = ref Off -let log s = - match !debug_level with - | Regular | Verbose -> print_endline s - | Off -> () - let debug_print_env (env : Shared_types.Query_env.t) = env.path_rev @ [env.file.module_name] |> List.rev |> String.concat "." diff --git a/analysis/src/loc.ml b/analysis/src/loc.ml index abb5669ed1a..1ed5f86d697 100644 --- a/analysis/src/loc.ml +++ b/analysis/src/loc.ml @@ -21,9 +21,3 @@ let range_of_loc (loc : t) = let start = loc |> start |> mk_position in let end_ = loc |> end_ |> mk_position in Lsp.Types.Range.create ~start ~end_ - -let is_inside (x : t) (y : t) = - x.loc_start.pos_cnum >= y.loc_start.pos_cnum - && x.loc_end.pos_cnum <= y.loc_end.pos_cnum - && x.loc_start.pos_lnum >= y.loc_start.pos_lnum - && x.loc_end.pos_lnum <= y.loc_end.pos_lnum diff --git a/analysis/src/packages.ml b/analysis/src/packages.ml index 3c6d6d530d2..584b8e119c9 100644 --- a/analysis/src/packages.ml +++ b/analysis/src/packages.ml @@ -12,27 +12,6 @@ let make_paths_for_module ~project_files_and_paths ~dependencies_files_and_paths Hashtbl.replace paths_for_module mod_name paths); paths_for_module -let override_rescript_version = ref None - -let get_rescript_version () = - match !override_rescript_version with - | Some override_rescript_version -> override_rescript_version - | None -> ( - (* TODO: Include patch stuff when needed *) - let default_version = (11, 0) in - try - let value = Sys.getenv "RESCRIPT_VERSION" in - let version = - match value |> String.split_on_char '.' with - | major :: minor :: _rest -> ( - match (int_of_string_opt major, int_of_string_opt minor) with - | Some major, Some minor -> (major, minor) - | _ -> default_version) - | _ -> default_version - in - version - with Not_found -> default_version) - let new_bs_package ~root_path = let rescript_json = Filename.concat root_path "rescript.json" in @@ -45,7 +24,6 @@ let new_bs_package ~root_path = match Yojson_helpers.from_string_opt raw with | Some config -> ( let namespace = Find_files.get_namespace config in - let rescript_version = get_rescript_version () in let suffix = match config |> Yojson_helpers.get "suffix" with | Some (`String suffix) -> suffix @@ -175,7 +153,6 @@ let new_bs_package ~root_path = { generic_jsx_module; suffix; - rescript_version; root_path; project_files; dependencies_files; diff --git a/analysis/src/process_cmt.ml b/analysis/src/process_cmt.ml index 4e6cca03bf5..f7098b84555 100644 --- a/analysis/src/process_cmt.ml +++ b/analysis/src/process_cmt.ml @@ -418,14 +418,6 @@ let for_signature ~name ~env sig_items = let deprecated = Process_attributes.find_deprecated_attribute attributes in {Module.name; docstring; exported; items; deprecated} -let for_tree_module_type ~name ~env {Typedtree.mty_desc} = - match mty_desc with - | Tmty_ident _ -> None - | Tmty_signature {sig_items} -> - let contents = for_signature ~name ~env sig_items in - Some (Module.Structure contents) - | _ -> None - let rec get_module_path mod_desc = match mod_desc with | Typedtree.Tmod_ident (path, _lident) -> Some path diff --git a/analysis/src/semantic_tokens.ml b/analysis/src/semantic_tokens.ml index 10532f81ee6..8e1337483c5 100644 --- a/analysis/src/semantic_tokens.ml +++ b/analysis/src/semantic_tokens.ml @@ -91,9 +91,6 @@ module Token = struct in Array.concat arrays - let array_to_json_string arr = - let items = Array.map string_of_int arr |> Array.to_list in - "[" ^ String.concat "," items ^ "]" end let is_lowercase_id id = diff --git a/analysis/src/shared_types.ml b/analysis/src/shared_types.ml index 173a6bfb7a7..b4337792ee4 100644 --- a/analysis/src/shared_types.ml +++ b/analysis/src/shared_types.ml @@ -26,16 +26,6 @@ module Module_path = struct in loop module_path [tip_name] - let to_path_with_prefix module_path prefix : path = - let rec loop module_path current = - match module_path with - | File _ -> current - | IncludedModule (_, inner) -> loop inner current - | ExportedModule {name; module_path = inner} -> - loop inner (name :: current) - | NotVisible -> current - in - prefix :: loop module_path [] end type field = { @@ -310,7 +300,6 @@ module Query_env : sig Or A.B.D or A.D or D if it's in one of its parents. *) val path_from_env : t -> path -> bool * path - val to_string : t -> string end = struct type t = { file: File.t; @@ -319,9 +308,6 @@ end = struct parent: t option; } - let to_string {file; path_rev} = - file.module_name :: List.rev path_rev |> String.concat "." - let from_file (file : File.t) = {file; exported = file.structure.exported; path_rev = []; parent = None} @@ -534,7 +520,6 @@ and package = { paths_for_module: (file, paths) Hashtbl.t; namespace: string option; opens: path list; - rescript_version: int * int; autocomplete: file list Misc.String_map.t; } @@ -852,16 +837,14 @@ module Completion = struct docstring: string list; kind: kind; detail: string option; - type_arg_context: type_arg_context option; - data: (string * string) list option; additional_text_edits: Lsp.Types.TextEdit.t list option; synthetic: bool; (** Whether this item is an made up, synthetic item or not. *) } - let create ?(synthetic = false) ?additional_text_edits ?data ?type_arg_context + let create ?(synthetic = false) ?additional_text_edits ?(includes_snippets = false) ?insert_text ~kind ~env ?sort_text - ?deprecated ?filter_text ?detail ?(docstring = []) name = + ?deprecated ?detail ?(docstring = []) name = { name; env; @@ -873,10 +856,8 @@ module Completion = struct insert_text_format = (if includes_snippets then Some Lsp.Types.InsertTextFormat.Snippet else None); - filter_text; + filter_text = None; detail; - type_arg_context; - data; additional_text_edits; synthetic; } diff --git a/analysis/src/type_utils.ml b/analysis/src/type_utils.ml index fd0c125a703..91c64377779 100644 --- a/analysis/src/type_utils.ml +++ b/analysis/src/type_utils.ml @@ -449,8 +449,7 @@ let rec extract_type ?(print_opening_debug = true) |> List.map (fun (label, field) -> { name = label; - display_name = - Utils.print_maybe_exotic_ident ~allow_uident:true label; + display_name = Utils.print_maybe_exotic_ident label; args = (* Multiple arguments are represented as a Ttuple, while a single argument is just the type expression itself. *) (match field with @@ -977,11 +976,6 @@ let rec context_path_from_core_type (core_type : Parsetree.core_type) = }) | _ -> None -let unwrap_completion_type_if_option (t : Shared_types.completion_type) = - match t with - | Toption (_, ExtractedType unwrapped) -> unwrapped - | _ -> t - module Codegen = struct let mk_fail_with_exp () = Ast_helper.Exp.apply @@ -1210,8 +1204,8 @@ let make_additional_text_edits_for_removing_dot pos_of_dot = ] (** Turns a completion into a pipe completion. *) -let transform_completion_to_pipe_completion ?(synthetic = false) ~env - ?pos_of_dot (completion : Completion.t) = +let transform_completion_to_pipe_completion ~synthetic ~env ?pos_of_dot + (completion : Completion.t) = let name = completion.name in let name_with_pipe = "->" ^ name in Some @@ -1274,33 +1268,23 @@ let rec find_root_type_id ~full ~env ~state (t : Types.type_expr) = | _ -> None (** Filters out completions that are not pipeable from a list of completions. *) -let filter_pipeable_functions ~env ~state ~full ?synthetic ?target_type_id - ?pos_of_dot completions = - match target_type_id with - | None -> completions - | Some target_type_id -> - completions - |> List.filter_map (fun (completion : Completion.t) -> - let this_completion_item_type_id = - match completion.kind with - | Value t -> ( - match - get_first_fn_unlabelled_arg_type ~full ~env:completion.env - ~state t - with - | None -> None - | Some (t, env_from_labelled_arg) -> - find_root_type_id ~full ~env:env_from_labelled_arg ~state t) - | _ -> None - in - match this_completion_item_type_id with - | Some main_type_id when main_type_id = target_type_id -> ( - match pos_of_dot with - | None -> Some completion - | Some pos_of_dot -> - transform_completion_to_pipe_completion ?synthetic ~env - ~pos_of_dot completion) - | _ -> None) +let filter_pipeable_functions ~state ~full ~target_type_id completions = + completions + |> List.filter_map (fun (completion : Completion.t) -> + let this_completion_item_type_id = + match completion.kind with + | Value t -> ( + match + get_first_fn_unlabelled_arg_type ~full ~env:completion.env ~state t + with + | None -> None + | Some (t, env_from_labelled_arg) -> + find_root_type_id ~full ~env:env_from_labelled_arg ~state t) + | _ -> None + in + match this_completion_item_type_id with + | Some main_type_id when main_type_id = target_type_id -> Some completion + | _ -> None) let remove_current_module_if_needed ~env_completion_is_made_from completion_path = diff --git a/analysis/src/utils.ml b/analysis/src/utils.ml index 18a26e3241b..142e5aa2861 100644 --- a/analysis/src/utils.ml +++ b/analysis/src/utils.ml @@ -244,14 +244,14 @@ let rec flatten_any_namespace_in_path path = (parts |> List.rev) @ flatten_any_namespace_in_path tail else head :: flatten_any_namespace_in_path tail -let print_maybe_exotic_ident ?(allow_uident = false) txt = +let print_maybe_exotic_ident txt = let len = String.length txt in let rec loop i = if i == len then txt else if i == 0 then match String.unsafe_get txt i with - | 'A' .. 'Z' when allow_uident -> loop (i + 1) + | 'A' .. 'Z' -> loop (i + 1) | 'a' .. 'z' | '_' -> loop (i + 1) | _ -> "\"" ^ txt ^ "\"" else diff --git a/compiler/bsc/rescript_compiler_main.ml b/compiler/bsc/rescript_compiler_main.ml index 24023535e0c..0270d5654f7 100644 --- a/compiler/bsc/rescript_compiler_main.ml +++ b/compiler/bsc/rescript_compiler_main.ml @@ -52,7 +52,7 @@ let setup_outcome_printer () = Lazy.force Res_outcome_printer.setup let setup_runtime_path path = Runtime_package.path := path -let process_file sourcefile ?kind ppf = +let process_file sourcefile ppf = (* This is a better default then "", it will be changed later The {!Location.input_name} relies on that we write the binary ast properly @@ -60,11 +60,8 @@ let process_file sourcefile ?kind ppf = setup_outcome_printer (); Error_message_utils_support.setup (); let kind = - match kind with - | None -> - Ext_file_extensions.classify_input - (Ext_filename.get_extension_maybe sourcefile) - | Some kind -> kind + Ext_file_extensions.classify_input + (Ext_filename.get_extension_maybe sourcefile) in let res = match kind with diff --git a/compiler/common/bs_loc.ml b/compiler/common/bs_loc.ml index ff7df2bf54c..9e0a8a6d425 100644 --- a/compiler/common/bs_loc.ml +++ b/compiler/common/bs_loc.ml @@ -28,14 +28,4 @@ type t = Location.t = { loc_ghost: bool; } -let is_ghost x = x.loc_ghost - -let merge (l : t) (r : t) = - if is_ghost l then r - else if is_ghost r then l - else - match (l, r) with - | {loc_start; _}, {loc_end; _} (* TODO: improve*) -> - {loc_start; loc_end; loc_ghost = false} - (* let none = Location.none *) diff --git a/compiler/common/bs_loc.mli b/compiler/common/bs_loc.mli index de22c2d9806..34147fadbd0 100644 --- a/compiler/common/bs_loc.mli +++ b/compiler/common/bs_loc.mli @@ -28,6 +28,4 @@ type t = Location.t = { loc_ghost: bool; } -(* val is_ghost : t -> bool *) -val merge : t -> t -> t (* val none : t *) diff --git a/compiler/common/js_config.ml b/compiler/common/js_config.ml index 9e2b6f598ca..9ce10a50fbd 100644 --- a/compiler/common/js_config.ml +++ b/compiler/common/js_config.ml @@ -40,7 +40,6 @@ let diagnose = ref false let no_builtin_ppx = ref false let tool_name = "ReScript" let check_div_by_zero = ref true -let get_check_div_by_zero () = !check_div_by_zero let syntax_only = ref false let binary_ast = ref false let test_ast_conversion = ref false diff --git a/compiler/common/js_config.mli b/compiler/common/js_config.mli index f19b3c6126c..c4b353bae96 100644 --- a/compiler/common/js_config.mli +++ b/compiler/common/js_config.mli @@ -57,8 +57,6 @@ val no_builtin_ppx : bool ref val check_div_by_zero : bool ref (** check-div-by-zero option *) -val get_check_div_by_zero : unit -> bool - val tool_name : string val syntax_only : bool ref diff --git a/compiler/core/cmd_ppx_apply.ml b/compiler/core/cmd_ppx_apply.ml index 111eae078d2..7186aadfa34 100644 --- a/compiler/core/cmd_ppx_apply.ml +++ b/compiler/core/cmd_ppx_apply.ml @@ -93,7 +93,7 @@ let rewrite kind ppxs ast = out | _ -> assert false -let apply_rewriters_str ?(restore = true) ~tool_name ast = +let apply_rewriters_str ~restore ~tool_name ast = match !Clflags.all_ppx with | [] -> if !Js_config.test_ast_conversion then @@ -105,7 +105,7 @@ let apply_rewriters_str ?(restore = true) ~tool_name ast = |> rewrite Ml ppxs |> Ml_binary.ast0_to_structure |> Ast_mapper.drop_ppx_context_str ~restore -let apply_rewriters_sig ?(restore = true) ~tool_name ast = +let apply_rewriters_sig ~restore ~tool_name ast = match !Clflags.all_ppx with | [] -> if !Js_config.test_ast_conversion then @@ -117,8 +117,8 @@ let apply_rewriters_sig ?(restore = true) ~tool_name ast = |> rewrite Mli ppxs |> Ml_binary.ast0_to_signature |> Ast_mapper.drop_ppx_context_sig ~restore -let apply_rewriters ?restore ~tool_name (type a) (kind : a Ml_binary.kind) +let apply_rewriters ~restore ~tool_name (type a) (kind : a Ml_binary.kind) (ast : a) : a = match kind with - | Ml_binary.Ml -> apply_rewriters_str ?restore ~tool_name ast - | Ml_binary.Mli -> apply_rewriters_sig ?restore ~tool_name ast + | Ml_binary.Ml -> apply_rewriters_str ~restore ~tool_name ast + | Ml_binary.Mli -> apply_rewriters_sig ~restore ~tool_name ast diff --git a/compiler/core/j.ml b/compiler/core/j.ml index f20b22ec727..cbb4c7214ee 100644 --- a/compiler/core/j.ml +++ b/compiler/core/j.ml @@ -33,7 +33,6 @@ type mutable_flag = Js_op.mutable_flag type binop = Js_op.binop -type int_op = Js_op.int_op type kind = Js_op.kind type property = Js_op.property type number = Js_op.number @@ -93,9 +92,6 @@ and expression_desc = | Seq of expression * expression | Cond of expression * expression * expression | Bin of binop * expression * expression - (* [int_op] will guarantee return [int32] bits - https://developer.mozilla.org/en/docs/Web/JavaScript/Reference/Operators/Bitwise_Operators *) - (* | Int32_bin of int_op * expression * expression *) | FlatCall of expression * expression (* f.apply(null,args) -- Fully applied guaranteed TODO: once we know args's shape -- diff --git a/compiler/core/js_analyzer.mli b/compiler/core/js_analyzer.mli index 786c29fece1..d9bc5a334e7 100644 --- a/compiler/core/js_analyzer.mli +++ b/compiler/core/js_analyzer.mli @@ -55,8 +55,6 @@ val no_side_effect_statement : J.statement -> bool val eq_expression : J.expression -> J.expression -> bool -val eq_statement : J.statement -> J.statement -> bool - val eq_block : J.block -> J.block -> bool val rev_flatten_seq : J.expression -> J.block diff --git a/compiler/core/js_cmj_format.ml b/compiler/core/js_cmj_format.ml index e17a41ef3e0..a9d4b23af3c 100644 --- a/compiler/core/js_cmj_format.ml +++ b/compiler/core/js_cmj_format.ml @@ -74,15 +74,6 @@ let from_file name : t = close_in ic; v -let from_file_with_digest name : t * Digest.t = - let ic = open_in_bin name in - let digest = Digest.input ic in - let v : t = input_value ic in - close_in ic; - (v, digest) - -let from_string s : t = Marshal.from_string s Ext_digest.length - let for_sure_not_changed (name : string) (header : string) = if Sys.file_exists name then ( let ic = open_in_bin name in diff --git a/compiler/core/js_cmj_format.mli b/compiler/core/js_cmj_format.mli index d55872968f5..1ad879c6eff 100644 --- a/compiler/core/js_cmj_format.mli +++ b/compiler/core/js_cmj_format.mli @@ -80,10 +80,6 @@ val single_na : arity val from_file : string -> t -val from_file_with_digest : string -> t * Digest.t - -val from_string : string -> t - (* Note writing the file if its content is not changed *) diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index 6f6da8b605c..1f2441e0bae 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -1712,13 +1712,6 @@ and statements top cxt f b = (fun cxt f s -> statement top cxt f s) (if top then P.at_least_two_lines else P.newline) -let string_of_block (block : J.block) = - let buffer = Buffer.create 50 in - let f = P.from_buffer buffer in - let (_ : cxt) = statements true Ext_pp_scope.empty f block in - P.flush f (); - Buffer.contents buffer - let string_of_expression (e : J.expression) = let buffer = Buffer.create 50 in let f = P.from_buffer buffer in diff --git a/compiler/core/js_dump.mli b/compiler/core/js_dump.mli index 469a79ff5d5..88da12c1edb 100644 --- a/compiler/core/js_dump.mli +++ b/compiler/core/js_dump.mli @@ -24,8 +24,3 @@ val statements : bool -> Ext_pp_scope.t -> Ext_pp.t -> J.block -> Ext_pp_scope.t (** Print JS IR to vanilla Javascript code Called by module {!Js_dump_program} *) - -val string_of_block : J.block -> string -(** 2 functions Only used for debugging *) - -val string_of_expression : J.expression -> string diff --git a/compiler/core/js_dump_lit.ml b/compiler/core/js_dump_lit.ml index a3ac8452465..996b4cf8e70 100644 --- a/compiler/core/js_dump_lit.ml +++ b/compiler/core/js_dump_lit.ml @@ -74,14 +74,8 @@ let code_point_at = "codePointAt" let new_ = "new" -let array = "Array" - let question = "?" -let plusplus = "++" - -let minusminus = "--" - let semi = ";" let else_ = "else" @@ -106,14 +100,6 @@ let start_block = "start_block" let end_block = "end_block" -let json = "JSON" - -let stringify = "stringify" - -let console = "console" - -let define = "define" - let break = "break" let continue = "continue" @@ -130,20 +116,12 @@ let debugger = "debugger" let tag = "TAG" -let bind = "bind" - -let math = "Math" - let apply = "apply" let null = "null" let undefined = "undefined" -let string_cap = "String" - -let from_charcode = "fromCharCode" - let eq = "=" let le = "<=" @@ -152,21 +130,9 @@ let lt = "<" let ge = ">=" -let gt = ">" - let plus_plus = "++" (* FIXME: use (i = i + 1 | 0) instead *) let minus_minus = "--" -let caml_block_create = "__" - -(** debug symbols *) - -let block_poly_var = "polyVar" - -let block_variant = "variant" - -let block_simple_variant = "simpleVariant" - let case = "case" diff --git a/compiler/core/js_exp_make.ml b/compiler/core/js_exp_make.ml index 530765477ed..a0c7615c79c 100644 --- a/compiler/core/js_exp_make.ml +++ b/compiler/core/js_exp_make.ml @@ -54,12 +54,12 @@ and is_pure_sub_exp (x : t) = remove_pure_sub_exp x = None (* let mk ?comment exp : t = {expression_desc = exp ; comment } *) -let var ?comment id : t = {expression_desc = Var (Id id); comment} +let var id : t = {expression_desc = Var (Id id); comment = None} (* only used in property access, Invariant: it should not call an external module .. *) -let js_global ?comment (v : string) = var ?comment (Ext_ident.create_js v) +let js_global (v : string) = var (Ext_ident.create_js v) let undefined : t = {expression_desc = Undefined {is_unit = false}; comment = None} let nil : t = {expression_desc = Null; comment = None} @@ -67,19 +67,13 @@ let nil : t = {expression_desc = Null; comment = None} let call ?comment ~info e0 args : t = {expression_desc = Call (e0, args, info); comment} -(* TODO: optimization when es is known at compile time - to be an array -*) -let flat_call ?comment e0 es : t = - {expression_desc = FlatCall (e0, es); comment} - -let tagged_template ?comment call_expr string_args value_args : t = +let tagged_template call_expr string_args value_args : t = { expression_desc = Tagged_template (call_expr, string_args, value_args); - comment; + comment = None; } -let runtime_var_dot ?comment (x : string) (e1 : string) : J.expression = +let runtime_var_dot (x : string) (e1 : string) : J.expression = { expression_desc = Var @@ -90,14 +84,13 @@ let runtime_var_dot ?comment (x : string) (e1 : string) : J.expression = dynamic_import = false; }, Some e1 )); - comment; + comment = None; } -let ml_var_dot ?comment ?(dynamic_import = false) (id : Ident.t) e : - J.expression = +let ml_var_dot ?(dynamic_import = false) (id : Ident.t) e : J.expression = { expression_desc = Var (Qualified ({id; kind = Ml; dynamic_import}, Some e)); - comment; + comment = None; } (** @@ -106,8 +99,8 @@ let ml_var_dot ?comment ?(dynamic_import = false) (id : Ident.t) e : var http = require("http") ]} *) -let external_var_field ?import_attributes ?comment ~external_name:name - (id : Ident.t) ~field ~default : t = +let external_var_field ?import_attributes ~external_name:name (id : Ident.t) + ~field ~default : t = { expression_desc = Var @@ -118,10 +111,10 @@ let external_var_field ?import_attributes ?comment ~external_name:name dynamic_import = false; }, Some field )); - comment; + comment = None; } -let external_var ?import_attributes ?comment ~external_name (id : Ident.t) : t = +let external_var ?import_attributes ~external_name (id : Ident.t) : t = { expression_desc = Var @@ -134,13 +127,13 @@ let external_var ?import_attributes ?comment ~external_name (id : Ident.t) : t = dynamic_import = false; }, None )); - comment; + comment = None; } -let ml_module_as_var ?comment ?(dynamic_import = false) (id : Ident.t) : t = +let ml_module_as_var ?(dynamic_import = false) (id : Ident.t) : t = { expression_desc = Var (Qualified ({id; kind = Ml; dynamic_import}, None)); - comment; + comment = None; } (* Static_index .....................**) @@ -154,18 +147,16 @@ let pure_runtime_call module_name fn_name args = (runtime_var_dot module_name fn_name) args -let runtime_ref module_name fn_name = runtime_var_dot module_name fn_name +let str ?(delim = J.DNone) txt : t = + {expression_desc = Str {txt; delim}; comment = None} -let str ?(delim = J.DNone) ?comment txt : t = - {expression_desc = Str {txt; delim}; comment} - -let raw_js_code ?comment info s : t = +let raw_js_code info s : t = { expression_desc = Raw_js_code {code = String.trim s; code_info = info}; - comment; + comment = None; } -let array ?comment mt es : t = {expression_desc = Array (es, mt); comment} +let array mt es : t = {expression_desc = Array (es, mt); comment = None} let some_comment = None let optional_block e : J.expression = @@ -177,8 +168,8 @@ let optional_not_nest_block e : J.expression = (** used in normal property like [e.length], no dependency introduced *) -let dot ?comment (e0 : t) (e1 : string) : t = - {expression_desc = Static_index (e0, e1, None); comment} +let dot (e0 : t) (e1 : string) : t = + {expression_desc = Static_index (e0, e1, None); comment = None} let module_access (e : t) (name : string) (pos : int32) = let name = Ext_ident.convert name in @@ -190,29 +181,32 @@ let module_access (e : t) (name : string) (pos : int32) = {expression_desc = Static_index (e, name, Some pos); comment = None}) | _ -> {expression_desc = Static_index (e, name, Some pos); comment = None} -let make_block ?comment (tag : t) (tag_info : J.tag_info) (es : t list) +let make_block (tag : t) (tag_info : J.tag_info) (es : t list) (mutable_flag : J.mutable_flag) : t = - {expression_desc = Caml_block (es, mutable_flag, tag, tag_info); comment} + { + expression_desc = Caml_block (es, mutable_flag, tag, tag_info); + comment = None; + } module L = Literals (* ATTENTION: this is relevant to how we encode string, boolean *) -let typeof ?comment (e : t) : t = +let typeof (e : t) : t = match e.expression_desc with - | Number _ | Length _ -> str ?comment L.js_type_number - | Str _ -> str ?comment L.js_type_string - | Array _ -> str ?comment L.js_type_object - | Bool _ -> str ?comment L.js_type_boolean - | _ -> {expression_desc = Typeof e; comment} + | Number _ | Length _ -> str L.js_type_number + | Str _ -> str L.js_type_string + | Array _ -> str L.js_type_object + | Bool _ -> str L.js_type_boolean + | _ -> {expression_desc = Typeof e; comment = None} -let instanceof ?comment (e0 : t) (e1 : t) : t = - {expression_desc = Bin (InstanceOf, e0, e1); comment} +let instanceof (e0 : t) (e1 : t) : t = + {expression_desc = Bin (InstanceOf, e0, e1); comment = None} let is_array (e0 : t) : t = let f = str "Array.isArray" ~delim:DNoQuotes in {expression_desc = Call (f, [e0], Js_call_info.ml_full_call); comment = None} -let new_ ?comment e0 args : t = {expression_desc = New (e0, Some args); comment} +let new_ e0 args : t = {expression_desc = New (e0, Some args); comment = None} let unit : t = {expression_desc = Undefined {is_unit = true}; comment = None} @@ -235,7 +229,7 @@ let unit : t = {expression_desc = Undefined {is_unit = true}; comment = None} [Js_fun_env.empty] is a mutable state .. *) -let ocaml_fun ?comment ?immutable_mask ?directive ~return_unit ~async +let ocaml_fun ?immutable_mask ?directive ~return_unit ~async ~one_unit_arg params body : t = let params = if one_unit_arg then [] else params in let len = List.length params in @@ -251,10 +245,10 @@ let ocaml_fun ?comment ?immutable_mask ?directive ~return_unit ~async async; directive; }; - comment; + comment = None; } -let method_ ?comment ?immutable_mask ~async ~return_unit params body : t = +let method_ ~async ~return_unit params body : t = let len = List.length params in { expression_desc = @@ -263,16 +257,16 @@ let method_ ?comment ?immutable_mask ~async ~return_unit params body : t = is_method = true; params; body; - env = Js_fun_env.make ?immutable_mask len; + env = Js_fun_env.make len; return_unit; async; directive = None; }; - comment; + comment = None; } (** ATTENTION: This is coupuled with {!Caml_obj.caml_update_dummy} *) -let dummy_obj ?comment (info : Lam_tag_info.t) : t = +let dummy_obj (info : Lam_tag_info.t) : t = (* TODO: for record it is [{}] for other it is [[]] @@ -280,9 +274,9 @@ let dummy_obj ?comment (info : Lam_tag_info.t) : t = match info with | Blk_record _ | Blk_module _ | Blk_constructor _ | Blk_record_inlined _ | Blk_poly_var _ | Blk_extension | Blk_record_ext _ -> - {comment; expression_desc = Object (None, [])} + {comment = None; expression_desc = Object (None, [])} | Blk_tuple | Blk_module_export _ -> - {comment; expression_desc = Array ([], Mutable)} + {comment = None; expression_desc = Array ([], Mutable)} | Blk_some | Blk_some_not_nested -> assert false (* TODO: complete @@ -340,8 +334,11 @@ let nine_int_literal : t = let int ?comment ?c i : t = {expression_desc = Number (Int {i; c}); comment} -let bigint ?comment sign i : t = - {expression_desc = Number (BigInt {positive = sign; value = i}); comment} +let bigint sign i : t = + { + expression_desc = Number (BigInt {positive = sign; value = i}); + comment = None; + } let zero_bigint_literal : t = { @@ -367,23 +364,23 @@ let true_ : t = {comment = None; expression_desc = Bool true} let false_ : t = {comment = None; expression_desc = Bool false} let bool v = if v then true_ else false_ -let float ?comment f : t = {expression_desc = Number (Float {f}); comment} +let float f : t = {expression_desc = Number (Float {f}); comment = None} let zero_float_lit : t = {expression_desc = Number (Float {f = "0."}); comment = None} -let float_mod ?comment e1 e2 : J.expression = - {comment; expression_desc = Bin (Mod, e1, e2)} +let float_mod e1 e2 : J.expression = + {comment = None; expression_desc = Bin (Mod, e1, e2)} -let array_index ?comment (e0 : t) (e1 : t) : t = +let array_index (e0 : t) (e1 : t) : t = match (e0.expression_desc, e1.expression_desc) with | Array (l, _), Number (Int {i; _}) (* Float i -- should not appear here *) when no_side_effect e0 -> ( match Ext_list.nth_opt l (Int32.to_int i) with - | None -> {expression_desc = Array_index (e0, e1); comment} + | None -> {expression_desc = Array_index (e0, e1); comment = None} | Some x -> x (* FIX #3084*)) - | _ -> {expression_desc = Array_index (e0, e1); comment} + | _ -> {expression_desc = Array_index (e0, e1); comment = None} let array_index_by_int ?comment (e : t) (pos : int32) : t = match e.expression_desc with @@ -468,38 +465,7 @@ let extension_access (e : t) name (pos : int32) : t = in {expression_desc = Static_index (e, name, Some pos); comment = None} -let string_index ?comment (e0 : t) (e1 : t) : t = - match (e0.expression_desc, e1.expression_desc) with - | Str {txt}, Number (Int {i; _}) -> - (* Don't optimize {j||j} *) - let i = Int32.to_int i in - if i >= 0 && i < String.length txt then - (* TODO: check exception when i is out of range.. - RangeError? - *) - str (String.make 1 txt.[i]) - else {expression_desc = String_index (e0, e1); comment} - | _ -> {expression_desc = String_index (e0, e1); comment} - -let assign ?comment e0 e1 : t = {expression_desc = Bin (Eq, e0, e1); comment} - -let assign_by_exp (e : t) index value : t = - match e.expression_desc with - | Array _ - (* - Temporary block -- address not held - Optimize cases like this which is really - rare {[ - (ref x) := 3 - ]} - *) - | Caml_block _ - when no_side_effect e && no_side_effect index -> - value - | _ -> assign {expression_desc = Array_index (e, index); comment = None} value - -let assign_by_int ?comment e0 (index : int32) value = - assign_by_exp e0 (int ?comment index) value +let assign e0 e1 : t = {expression_desc = Bin (Eq, e0, e1); comment = None} let record_assign (e : t) (pos : int32) (name : string) (value : t) = match e.expression_desc with @@ -539,26 +505,25 @@ let extension_assign (e : t) (pos : int32) name (value : t) = (* This is a property access not external module *) -let array_length ?comment (e : t) : t = +let array_length (e : t) : t = match e.expression_desc with (* TODO: use array instead? *) | (Array (l, _) | Caml_block (l, _, _, _)) when no_side_effect e -> - int ?comment (Int32.of_int (List.length l)) - | _ -> {expression_desc = Length (e, Array); comment} + int (Int32.of_int (List.length l)) + | _ -> {expression_desc = Length (e, Array); comment = None} -let string_length ?comment (e : t) : t = +let string_length (e : t) : t = match e.expression_desc with - | Str {txt; delim = DNone} -> int ?comment (Int32.of_int (String.length txt)) + | Str {txt; delim = DNone} -> int (Int32.of_int (String.length txt)) (* No optimization for {j||j}*) - | _ -> {expression_desc = Length (e, String); comment} + | _ -> {expression_desc = Length (e, String); comment = None} -let function_length ?comment (e : t) : t = +let function_length (e : t) : t = match e.expression_desc with | Fun {is_method; params} -> let params_length = List.length params in - int ?comment - (Int32.of_int (if is_method then params_length - 1 else params_length)) - | _ -> {expression_desc = Length (e, Function); comment} + int (Int32.of_int (if is_method then params_length - 1 else params_length)) + | _ -> {expression_desc = Length (e, Function); comment = None} (** no dependency introduced *) (* let js_global_dot ?comment (x : string) (e1 : string) : t = @@ -586,8 +551,8 @@ let rec string_append ?comment (e : t) (el : t) : t = {(concat a b ~delim) with comment} | _, _ -> {comment; expression_desc = String_append (e, el)} -let obj ?comment ?dup properties : t = - {expression_desc = Object (dup, properties); comment} +let obj ?dup properties : t = + {expression_desc = Object (dup, properties); comment = None} let str_equal (txt0 : string) (delim0 : External_arg_spec.delim) txt1 delim1 = if delim0 = delim1 then @@ -640,7 +605,7 @@ let bin ?comment (op : J.binop) (e0 : t) (e1 : t) : t = is not used: benefit is not clear | Int_of_boolean e10, Bin(And, {expression_desc = Int_of_boolean e20 }, e3) -> - and_ ?comment + and_ { e1 with expression_desc = J.Int_of_boolean { expression_desc = Bin (And, e10,e20); comment = None} @@ -1105,7 +1070,7 @@ let simplify_or (e1 : t) (e2 : t) : t option = if no_side_effect e1 && no_side_effect e2 then simplify_or_ ~n:0 e1 e2 else None -let and_ ?comment (e1 : t) (e2 : t) : t = +let and_ (e1 : t) (e2 : t) : t = match (e1.expression_desc, e2.expression_desc) with | Var i, Var j when Js_op_util.same_vident i j -> e1 | Var i, Bin (And, {expression_desc = Var j; _}, _) @@ -1123,9 +1088,9 @@ let and_ ?comment (e1 : t) (e2 : t) : t = | _, _ -> ( match simplify_and e1 e2 with | Some e -> e - | None -> {expression_desc = Bin (And, e1, e2); comment}) + | None -> {expression_desc = Bin (And, e1, e2); comment = None}) -let or_ ?comment (e1 : t) (e2 : t) = +let or_ (e1 : t) (e2 : t) = match (e1.expression_desc, e2.expression_desc) with | Var i, Var j when Js_op_util.same_vident i j -> e1 | Var i, Bin (Or, {expression_desc = Var j; _}, _) @@ -1137,7 +1102,7 @@ let or_ ?comment (e1 : t) (e2 : t) = | _, _ -> ( match simplify_or e1 e2 with | Some e -> e - | None -> {expression_desc = Bin (Or, e1, e2); comment}) + | None -> {expression_desc = Bin (Or, e1, e2); comment = None}) let in_ (prop : t) (obj : t) : t = {expression_desc = In (prop, obj); comment = None} @@ -1250,7 +1215,7 @@ let rec float_equal ?comment (e0 : t) (e1 : t) : t = | Number (Float {f = f0; _}), Number (Float {f = f1}) when f0 = f1 -> true_ | _ -> {expression_desc = Bin (EqEqEq, e0, e1); comment} -let int_equal = float_equal +let int_equal e0 e1 = float_equal e0 e1 let tag_type = function | Ast_untagged_variants.String s -> str s ~delim:DStarJ @@ -1314,8 +1279,8 @@ let is_int_tag ?has_null_undefined_other e = call plain [dot] *) -let tag ?comment ?(name = Js_dump_lit.tag) e : t = - {expression_desc = Caml_block_tag (e, name); comment} +let tag ?(name = Js_dump_lit.tag) e : t = + {expression_desc = Caml_block_tag (e, name); comment = None} (* according to the compiler, [Btype.hash_variant], it's reduced to 31 bits for hash @@ -1330,11 +1295,10 @@ let tag ?comment ?(name = Js_dump_lit.tag) e : t = *) (* Note that [lsr] or [bor] are js semantics *) -let rec int32_bor ?comment (e1 : J.expression) (e2 : J.expression) : - J.expression = +let rec int32_bor (e1 : J.expression) (e2 : J.expression) : J.expression = match (e1.expression_desc, e2.expression_desc) with | Number (Int {i = i1}), Number (Int {i = i2}) -> - int ?comment (Int32.logor i1 i2) + int (Int32.logor i1 i2) | _, Bin (Lsr, e2, {expression_desc = Number (Int {i = 0l}); _}) -> int32_bor e1 e2 | Bin (Lsr, e1, {expression_desc = Number (Int {i = 0l}); _}), _ -> @@ -1346,33 +1310,29 @@ let rec int32_bor ?comment (e1 : J.expression) (e2 : J.expression) : | ( Bin (Bor, e1, {expression_desc = Number (Int {i = 0l}); _}), Number (Int {i = 0l}) ) -> int32_bor e1 e2 - | _ -> {comment; expression_desc = Bin (Bor, e1, e2)} + | _ -> {comment = None; expression_desc = Bin (Bor, e1, e2)} -let to_int32 ?comment (e : J.expression) : J.expression = - int32_bor ?comment e zero_int_literal +let to_int32 (e : J.expression) : J.expression = + int32_bor e zero_int_literal (* TODO: if we already know the input is int32, [x|0] can be reduced into [x] *) -let string_comp (cmp : Lam_compat.comparison) ?comment (e0 : t) (e1 : t) = +let string_comp (cmp : Lam_compat.comparison) (e0 : t) (e1 : t) = match (e0.expression_desc, e1.expression_desc) with | Str {txt = a0; delim = d0}, Str {txt = a1; delim = d1} -> ( match (cmp, str_equal a0 d0 a1 d1) with | Ceq, Some b -> bool b | Cneq, Some b -> bool (b = false) - | _ -> bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1) - | _ -> bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1 - -let string_equal ?comment (e0 : t) (e1 : t) : t = string_comp Ceq ?comment e0 e1 + | _ -> bin (Lam_compile_util.jsop_of_comp cmp) e0 e1) + | _ -> bin (Lam_compile_util.jsop_of_comp cmp) e0 e1 -let is_type_number ?comment (e : t) : t = - string_equal ?comment (typeof e) (str "number") +let string_equal (e0 : t) (e1 : t) : t = string_comp Ceq e0 e1 -let is_type_string ?comment (e : t) : t = - string_equal ?comment (typeof e) (str "string") +let is_type_number (e : t) : t = string_equal (typeof e) (str "number") let is_type_object (e : t) : t = string_equal (typeof e) (str "object") -let obj_length ?comment e : t = - to_int32 {expression_desc = Length (e, Caml_block); comment} +let obj_length e : t = + to_int32 {expression_desc = Length (e, Caml_block); comment = None} let compare_int_aux (cmp : Lam_compat.comparison) (l : int) r = match cmp with @@ -1411,7 +1371,7 @@ let rec int_comp (cmp : Lam_compat.comparison) ?comment (e0 : t) (e1 : t) = true_ | _ -> bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1 -let bool_comp (cmp : Lam_compat.comparison) ?comment (e0 : t) (e1 : t) = +let bool_comp (cmp : Lam_compat.comparison) (e0 : t) (e1 : t) = match (e0, e1) with | {expression_desc = Bool l}, {expression_desc = Bool r} -> bool @@ -1428,21 +1388,17 @@ let bool_comp (cmp : Lam_compat.comparison) ?comment (e0 : t) (e1 : t) = | Clt -> seq rest false_ | Cge -> seq rest true_ | Cle | Cgt | Ceq | Cneq -> - bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1) + bin (Lam_compile_util.jsop_of_comp cmp) e0 e1) | rest, {expression_desc = Bool true} | {expression_desc = Bool false}, rest -> ( match cmp with | Cle -> seq rest true_ | Cgt -> seq rest false_ | Clt | Cge | Ceq | Cneq -> - bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1) - | _, _ -> bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1 + bin (Lam_compile_util.jsop_of_comp cmp) e0 e1) + | _, _ -> bin (Lam_compile_util.jsop_of_comp cmp) e0 e1 -let float_comp cmp ?comment e0 e1 = - bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1 - -let js_comp cmp ?comment e0 e1 = - bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1 +let js_comp cmp e0 e1 = bin (Lam_compile_util.jsop_of_comp cmp) e0 e1 let rec int32_lsr ?comment (e1 : J.expression) (e2 : J.expression) : J.expression = @@ -1514,15 +1470,15 @@ let rec is_out ?comment (e : t) (range : t) : t = is_out ?comment e range | _, _ -> int_comp ?comment Cgt e range -let rec float_add ?comment (e1 : t) (e2 : t) = +let rec float_add (e1 : t) (e2 : t) = match (e1.expression_desc, e2.expression_desc) with - | Number (Int {i; _}), Number (Int {i = j; _}) -> int ?comment (Int32.add i j) + | Number (Int {i; _}), Number (Int {i = j; _}) -> int (Int32.add i j) | _, Number (Int {i = j; c}) when j < 0l -> - float_minus ?comment e1 + float_minus e1 {e2 with expression_desc = Number (Int {i = Int32.neg j; c})} | ( Bin (Plus, a1, {expression_desc = Number (Int {i = k; _})}), Number (Int {i = j; _}) ) -> - {comment; expression_desc = Bin (Plus, a1, int (Int32.add k j))} + {comment = None; expression_desc = Bin (Plus, a1, int (Int32.add k j))} (* bin ?comment Plus a1 (int (k + j)) *) (* TODO remove commented code ?? *) (* | Bin(Plus, a0 , ({expression_desc = Number (Int a1)} )), *) @@ -1540,63 +1496,57 @@ let rec float_add ?comment (e1 : t) (e2 : t) = (* | Number _, _ *) (* -> *) (* bin ?comment Plus e2 e1 *) - | _ -> {comment; expression_desc = Bin (Plus, e1, e2)} + | _ -> {comment = None; expression_desc = Bin (Plus, e1, e2)} (* bin ?comment Plus e1 e2 *) (* associative is error prone due to overflow *) -and float_minus ?comment (e1 : t) (e2 : t) : t = +and float_minus (e1 : t) (e2 : t) : t = match (e1.expression_desc, e2.expression_desc) with - | Number (Int {i; _}), Number (Int {i = j; _}) -> int ?comment (Int32.sub i j) - | _ -> {comment; expression_desc = Bin (Minus, e1, e2)} + | Number (Int {i; _}), Number (Int {i = j; _}) -> int (Int32.sub i j) + | _ -> {comment = None; expression_desc = Bin (Minus, e1, e2)} (* bin ?comment Minus e1 e2 *) -let unchecked_int32_add ?comment e1 e2 = float_add ?comment e1 e2 -let int32_add ?comment e1 e2 = to_int32 (float_add ?comment e1 e2) +let int32_add e1 e2 = to_int32 (float_add e1 e2) let offset e1 (offset : int) = if offset = 0 then e1 else int32_add e1 (small_int offset) -let int32_minus ?comment e1 e2 : J.expression = - to_int32 (float_minus ?comment e1 e2) - -let unchecked_int32_minus ?comment e1 e2 : J.expression = - float_minus ?comment e1 e2 +let int32_minus e1 e2 : J.expression = to_int32 (float_minus e1 e2) -let float_div ?comment e1 e2 = bin ?comment Div e1 e2 -let float_pow ?comment e1 e2 = bin ?comment Pow e1 e2 -let float_notequal ?comment e1 e2 = bin ?comment NotEqEq e1 e2 +let float_div e1 e2 = bin Div e1 e2 +let float_pow e1 e2 = bin Pow e1 e2 -let int32_asr ?comment e1 e2 : J.expression = - {comment; expression_desc = Bin (Asr, e1, e2)} +let int32_asr e1 e2 : J.expression = + {comment = None; expression_desc = Bin (Asr, e1, e2)} (** Division by zero is undefined behavior*) -let int32_div ~checked ?comment (e1 : t) (e2 : t) : t = +let int32_div ~checked (e1 : t) (e2 : t) : t = match (e1.expression_desc, e2.expression_desc) with | Length _, Number (Int {i = 2l}) -> int32_asr e1 one_int_literal | e1_desc, Number (Int {i = i1}) when i1 <> 0l -> ( match e1_desc with | Number (Int {i = i0}) -> int (Int32.div i0 i1) - | _ -> to_int32 (float_div ?comment e1 e2)) + | _ -> to_int32 (float_div e1 e2)) | _, _ -> if checked then runtime_call Primitive_modules.int "div" [e1; e2] - else to_int32 (float_div ?comment e1 e2) + else to_int32 (float_div e1 e2) -let int32_mod ~checked ?comment e1 (e2 : t) : J.expression = +let int32_mod ~checked e1 (e2 : t) : J.expression = match e2.expression_desc with | Number (Int {i}) when i <> 0l -> - {comment; expression_desc = Bin (Mod, e1, e2)} + {comment = None; expression_desc = Bin (Mod, e1, e2)} | _ -> if checked then runtime_call Primitive_modules.int "mod_" [e1; e2] - else {comment; expression_desc = Bin (Mod, e1, e2)} + else {comment = None; expression_desc = Bin (Mod, e1, e2)} -let float_mul ?comment e1 e2 = bin ?comment Mul e1 e2 +let float_mul e1 e2 = bin Mul e1 e2 -let int32_lsl ?comment (e1 : J.expression) (e2 : J.expression) : J.expression = +let int32_lsl (e1 : J.expression) (e2 : J.expression) : J.expression = match (e1, e2) with | ( {expression_desc = Number (Int {i = i0})}, {expression_desc = Number (Int {i = i1})} ) -> - int ?comment (Int32.shift_left i0 (Int32.to_int i1)) - | _ -> {comment; expression_desc = Bin (Lsl, e1, e2)} + int (Int32.shift_left i0 (Int32.to_int i1)) + | _ -> {comment = None; expression_desc = Bin (Lsl, e1, e2)} let is_pos_pow n = let exception E in @@ -1608,7 +1558,7 @@ let is_pos_pow n = in try aux 0 n with E -> -1 -let int32_mul ?comment (e1 : J.expression) (e2 : J.expression) : J.expression = +let int32_mul (e1 : J.expression) (e2 : J.expression) : J.expression = match (e1, e2) with | {expression_desc = Number (Int {i = 0l}); _}, x when no_side_effect x -> zero_int_literal @@ -1621,35 +1571,31 @@ let int32_mul ?comment (e1 : J.expression) (e2 : J.expression) : J.expression = | {expression_desc = Number (Int {i = i0}); _}, e -> let i = is_pos_pow i0 in if i >= 0 then int32_lsl e (small_int i) - else to_int32 (float_mul ?comment e1 e2) - | _ -> to_int32 (float_mul ?comment e1 e2) + else to_int32 (float_mul e1 e2) + | _ -> to_int32 (float_mul e1 e2) -let unchecked_int32_mul ?comment e1 e2 : J.expression = - {comment; expression_desc = Bin (Mul, e1, e2)} - -let int_bnot ?comment (e : t) : J.expression = +let int_bnot (e : t) : J.expression = match e.expression_desc with - | Number (Int {i}) -> int ?comment (Int32.lognot i) - | _ -> {comment; expression_desc = Js_bnot e} + | Number (Int {i}) -> int (Int32.lognot i) + | _ -> {comment = None; expression_desc = Js_bnot e} -let int32_pow ?comment (e1 : t) (e2 : t) : J.expression = +let int32_pow (e1 : t) (e2 : t) : J.expression = match (e1.expression_desc, e2.expression_desc) with | Number (Int {i = i1}), Number (Int {i = i2}) -> - int ?comment (Ext_int.int32_pow i1 i2) - | _ -> to_int32 (float_pow ?comment e1 e2) + int (Ext_int.int32_pow i1 i2) + | _ -> to_int32 (float_pow e1 e2) -let rec int32_bxor ?comment (e1 : t) (e2 : t) : J.expression = +let rec int32_bxor (e1 : t) (e2 : t) : J.expression = match (e1.expression_desc, e2.expression_desc) with | Number (Int {i = i1}), Number (Int {i = i2}) -> - int ?comment (Int32.logxor i1 i2) + int (Int32.logxor i1 i2) | _, Bin (Lsr, e2, {expression_desc = Number (Int {i = 0l}); _}) -> int32_bxor e1 e2 | Bin (Lsr, e1, {expression_desc = Number (Int {i = 0l}); _}), _ -> int32_bxor e1 e2 - | _ -> {comment; expression_desc = Bin (Bxor, e1, e2)} + | _ -> {comment = None; expression_desc = Bin (Bxor, e1, e2)} -let rec int32_band ?comment (e1 : J.expression) (e2 : J.expression) : - J.expression = +let rec int32_band (e1 : J.expression) (e2 : J.expression) : J.expression = match e1.expression_desc with | Bin (Bor, a, {expression_desc = Number (Int {i = 0l})}) -> (* Note that in JS @@ -1657,14 +1603,14 @@ let rec int32_band ?comment (e1 : J.expression) (e2 : J.expression) : {[ (-1 >>> 0 | 0 ) & 0xffffff ]} *) int32_band a e2 - | _ -> {comment; expression_desc = Bin (Band, e1, e2)} + | _ -> {comment = None; expression_desc = Bin (Band, e1, e2)} (* let int32_bin ?comment op e1 e2 : J.expression = *) (* {expression_desc = Int32_bin(op,e1, e2); comment} *) -let bigint_op ?comment op (e1 : t) (e2 : t) = bin ?comment op e1 e2 +let bigint_op op (e1 : t) (e2 : t) = bin op e1 e2 -let bigint_comp (cmp : Lam_compat.comparison) ?comment (e0 : t) (e1 : t) = +let bigint_comp (cmp : Lam_compat.comparison) (e0 : t) (e1 : t) = let normalize s = let len = String.length s in let buf = Buffer.create len in @@ -1689,25 +1635,25 @@ let bigint_comp (cmp : Lam_compat.comparison) ?comment (e0 : t) (e1 : t) = Number (BigInt {positive = p1; value = v1}), Number (BigInt {positive = p2; value = v2}) ) -> not (bool (p1 = p2 && String.equal (normalize v1) (normalize v2))) - | _ -> bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1 + | _ -> bin (Lam_compile_util.jsop_of_comp cmp) e0 e1 -let bigint_div ~checked ?comment (e0 : t) (e1 : t) = +let bigint_div ~checked (e0 : t) (e1 : t) = if checked then runtime_call Primitive_modules.bigint "div" [e0; e1] - else bigint_op ?comment Div e0 e1 + else bigint_op Div e0 e1 -let bigint_mod ~checked ?comment (e0 : t) (e1 : t) = +let bigint_mod ~checked (e0 : t) (e1 : t) = if checked then runtime_call Primitive_modules.bigint "mod_" [e0; e1] - else bigint_op ?comment Mod e0 e1 + else bigint_op Mod e0 e1 (* TODO -- alpha conversion remember to add parens.. *) -let of_block ?comment ?e block : t = +let of_block ?e block : t = let return_unit = false in (* This case is not hit that much*) call ~info:Js_call_info.ml_full_call { - comment; + comment = None; expression_desc = Fun { @@ -1717,7 +1663,8 @@ let of_block ?comment ?e block : t = (match e with | None -> block | Some e -> - Ext_list.append block [{J.statement_desc = Return e; comment}]); + Ext_list.append block + [{J.statement_desc = Return e; comment = None}]); env = Js_fun_env.make 0; return_unit; async = false; @@ -1726,21 +1673,19 @@ let of_block ?comment ?e block : t = } [] -let is_null ?comment (x : t) = triple_equal ?comment x nil -let is_undef ?comment x = triple_equal ?comment x undefined - +let is_null (x : t) = triple_equal x nil let is_null_undefined_constant (x : t) = match x.expression_desc with | Null | Undefined _ -> true | _ -> false -let is_null_undefined ?comment (x : t) : t = +let is_null_undefined (x : t) : t = match x.expression_desc with | Null | Undefined _ -> true_ | Number _ | Array _ | Caml_block _ -> false_ - | _ -> {comment; expression_desc = Is_null_or_undefined x} + | _ -> {comment = None; expression_desc = Is_null_or_undefined x} -let eq_null_undefined_boolean ?comment (a : t) (b : t) = +let eq_null_undefined_boolean (a : t) (b : t) = (* [a == b] when either a or b is null or undefined *) match (a.expression_desc, b.expression_desc) with | ( (Null | Undefined _), @@ -1753,9 +1698,9 @@ let eq_null_undefined_boolean ?comment (a : t) (b : t) = false_ | Null, Undefined _ | Undefined _, Null -> false_ | Null, Null | Undefined _, Undefined _ -> true_ - | _ -> {expression_desc = Bin (EqEqEq, a, b); comment} + | _ -> {expression_desc = Bin (EqEqEq, a, b); comment = None} -let neq_null_undefined_boolean ?comment (a : t) (b : t) = +let neq_null_undefined_boolean (a : t) (b : t) = (* [a != b] when either a or b is null or undefined *) match (a.expression_desc, b.expression_desc) with | ( (Null | Undefined _), @@ -1768,7 +1713,7 @@ let neq_null_undefined_boolean ?comment (a : t) (b : t) = true_ | Null, Null | Undefined _, Undefined _ -> false_ | Null, Undefined _ | Undefined _, Null -> true_ - | _ -> {expression_desc = Bin (NotEqEq, a, b); comment} + | _ -> {expression_desc = Bin (NotEqEq, a, b); comment = None} let make_exception (s : string) = pure_runtime_call Primitive_modules.exceptions Literals.create [str s] diff --git a/compiler/core/js_exp_make.mli b/compiler/core/js_exp_make.mli index d37d55ea9a8..f5925ee6b98 100644 --- a/compiler/core/js_exp_make.mli +++ b/compiler/core/js_exp_make.mli @@ -41,22 +41,19 @@ type t = J.expression val remove_pure_sub_exp : t -> t option -val var : ?comment:string -> J.ident -> t +val var : J.ident -> t -val js_global : ?comment:string -> string -> t - -val runtime_var_dot : ?comment:string -> string -> string -> t +val js_global : string -> t (* val runtime_var_vid : string -> string -> J.vident *) val ml_var_dot : - ?comment:string -> ?dynamic_import:bool -> Ident.t -> string -> t + ?dynamic_import:bool -> Ident.t -> string -> t (** [ml_var_dot ocaml_module name] *) val external_var_field : ?import_attributes:External_ffi_types.import_attributes -> - ?comment:string -> external_name:string -> Ident.t -> field:string -> @@ -68,12 +65,11 @@ val external_var_field : val external_var : ?import_attributes:External_ffi_types.import_attributes -> - ?comment:string -> external_name:string -> Ident.t -> t -val ml_module_as_var : ?comment:string -> ?dynamic_import:bool -> Ident.t -> t +val ml_module_as_var : ?dynamic_import:bool -> Ident.t -> t val runtime_call : string -> @@ -84,21 +80,9 @@ val runtime_call : (* args *) t -val pure_runtime_call : - string -> - (* module_name *) - string -> - (* fn_name *) - t list -> - (* args *) - t - -val runtime_ref : string -> string -> t - -val str : ?delim:J.delim -> ?comment:string -> string -> t +val str : ?delim:J.delim -> string -> t val ocaml_fun : - ?comment:string -> ?immutable_mask:bool array -> ?directive:string -> return_unit:bool -> @@ -109,8 +93,6 @@ val ocaml_fun : t val method_ : - ?comment:string -> - ?immutable_mask:bool array -> async:bool -> return_unit:bool -> J.ident list -> @@ -123,9 +105,9 @@ val int : ?comment:string -> ?c:int -> int32 -> t val small_int : int -> t -val bigint : ?comment:string -> bool -> string -> t +val bigint : bool -> string -> t -val float : ?comment:string -> string -> t +val float : string -> t (* val empty_string_literal : t *) (* TODO: we can do hash consing for small integers *) @@ -141,15 +123,15 @@ val is_out : ?comment:string -> t -> t -> t *) -val dot : ?comment:string -> t -> string -> t +val dot : t -> string -> t val module_access : t -> string -> int32 -> t -val array_length : ?comment:string -> t -> t +val array_length : t -> t -val string_length : ?comment:string -> t -> t +val string_length : t -> t -val function_length : ?comment:string -> t -> t +val function_length : t -> t val string_append : ?comment:string -> t -> t -> t (** @@ -164,9 +146,7 @@ val string_append : ?comment:string -> t -> t -> t (* val bind_call : ?comment:string -> J.expression -> string -> J.expression list -> t *) (* val js_global_dot : ?comment:string -> string -> string -> t *) -val string_index : ?comment:string -> t -> t -> t - -val array_index : ?comment:string -> t -> t -> t +val array_index : t -> t -> t val array_index_by_int : ?comment:string -> t -> Int32.t -> t @@ -188,17 +168,7 @@ val poly_var_value_access : t -> t val extension_assign : t -> int32 -> string -> t -> t -val assign_by_int : ?comment:string -> t -> int32 -> t -> t -(** - [assign_by_int e i v] - if the expression [e] is a temporay block - which has no side effect, - write to it does not really make sense, - optimize it away *) - -val assign_by_exp : t -> t -> t -> t - -val assign : ?comment:string -> t -> t -> t +val assign : t -> t -> t val tag_type : Ast_untagged_variants.tag_type -> t @@ -207,19 +177,17 @@ val emit_check : t Ast_untagged_variants.Dynamic_checks.t -> t val triple_equal : ?comment:string -> t -> t -> t (* TODO: reduce [triple_equal] use *) -val float_equal : ?comment:string -> t -> t -> t - -val int_equal : ?comment:string -> t -> t -> t +val int_equal : t -> t -> t -val int_bnot : ?comment:string -> t -> t +val int_bnot : t -> t -val string_equal : ?comment:string -> t -> t -> t +val string_equal : t -> t -> t -val eq_null_undefined_boolean : ?comment:string -> t -> t -> t +val eq_null_undefined_boolean : t -> t -> t -val neq_null_undefined_boolean : ?comment:string -> t -> t -> t +val neq_null_undefined_boolean : t -> t -> t -val is_type_number : ?comment:string -> t -> t +val is_type_number : t -> t val is_int_tag : ?has_null_undefined_other:bool * bool * bool -> t -> t @@ -229,98 +197,82 @@ val is_a_literal_case : t -> t -val is_type_string : ?comment:string -> t -> t - val is_type_object : t -> t -val typeof : ?comment:string -> t -> t -val instanceof : ?comment:string -> t -> t -> t +val typeof : t -> t val is_array : t -> t -val to_int32 : ?comment:string -> t -> t - -val unchecked_int32_add : ?comment:string -> t -> t -> t +val to_int32 : t -> t -val int32_add : ?comment:string -> t -> t -> t +val int32_add : t -> t -> t val offset : t -> int -> t -val unchecked_int32_minus : ?comment:string -> t -> t -> t - -val int32_minus : ?comment:string -> t -> t -> t +val int32_minus : t -> t -> t -val int32_mul : ?comment:string -> t -> t -> t +val int32_mul : t -> t -> t -val unchecked_int32_mul : ?comment:string -> t -> t -> t +val int32_div : checked:bool -> t -> t -> t -val int32_div : checked:bool -> ?comment:string -> t -> t -> t +val int32_mod : checked:bool -> t -> t -> t -val int32_mod : checked:bool -> ?comment:string -> t -> t -> t +val int32_pow : t -> t -> t -val int32_pow : ?comment:string -> t -> t -> t - -val int32_lsl : ?comment:string -> t -> t -> t +val int32_lsl : t -> t -> t val int32_lsr : ?comment:string -> t -> t -> t -val int32_asr : ?comment:string -> t -> t -> t - -val int32_bxor : ?comment:string -> t -> t -> t +val int32_asr : t -> t -> t -val int32_band : ?comment:string -> t -> t -> t +val int32_bxor : t -> t -> t -val int32_bor : ?comment:string -> t -> t -> t +val int32_band : t -> t -> t -val float_add : ?comment:string -> t -> t -> t +val int32_bor : t -> t -> t -val float_minus : ?comment:string -> t -> t -> t +val float_add : t -> t -> t -val float_mul : ?comment:string -> t -> t -> t +val float_minus : t -> t -> t -val float_div : ?comment:string -> t -> t -> t +val float_mul : t -> t -> t -val float_notequal : ?comment:string -> t -> t -> t +val float_div : t -> t -> t -val float_mod : ?comment:string -> t -> t -> t +val float_mod : t -> t -> t -val float_pow : ?comment:string -> t -> t -> t +val float_pow : t -> t -> t val int_comp : Lam_compat.comparison -> ?comment:string -> t -> t -> t -val bool_comp : Lam_compat.comparison -> ?comment:string -> t -> t -> t - -val string_comp : Lam_compat.comparison -> ?comment:string -> t -> t -> t +val bool_comp : Lam_compat.comparison -> t -> t -> t -val float_comp : Lam_compat.comparison -> ?comment:string -> t -> t -> t +val string_comp : Lam_compat.comparison -> t -> t -> t -val bigint_op : ?comment:string -> Js_op.binop -> t -> t -> t +val bigint_op : Js_op.binop -> t -> t -> t -val bigint_comp : Lam_compat.comparison -> ?comment:string -> t -> t -> t +val bigint_comp : Lam_compat.comparison -> t -> t -> t -val bigint_div : checked:bool -> ?comment:string -> t -> t -> t +val bigint_div : checked:bool -> t -> t -> t -val bigint_mod : checked:bool -> ?comment:string -> t -> t -> t +val bigint_mod : checked:bool -> t -> t -> t -val js_comp : Lam_compat.comparison -> ?comment:string -> t -> t -> t +val js_comp : Lam_compat.comparison -> t -> t -> t val not : t -> t val call : ?comment:string -> info:Js_call_info.t -> t -> t list -> t -val flat_call : ?comment:string -> t -> t -> t +val tagged_template : t -> t list -> t list -> t -val tagged_template : ?comment:string -> t -> t list -> t list -> t +val new_ : J.expression -> J.expression list -> t -val new_ : ?comment:string -> J.expression -> J.expression list -> t - -val array : ?comment:string -> J.mutable_flag -> J.expression list -> t +val array : J.mutable_flag -> J.expression list -> t val optional_block : J.expression -> J.expression val optional_not_nest_block : J.expression -> J.expression val make_block : - ?comment:string -> J.expression -> (* tag *) J.tag_info -> @@ -333,7 +285,7 @@ val seq : ?comment:string -> t -> t -> t val fuse_to_seq : t -> t list -> t -val obj : ?comment:string -> ?dup:J.expression -> J.property_map -> t +val obj : ?dup:J.expression -> J.property_map -> t val true_ : t @@ -346,40 +298,38 @@ val unit : t val undefined : t -val tag : ?comment:string -> ?name:string -> J.expression -> t +val tag : ?name:string -> J.expression -> t (** Note that this is coupled with how we encode block, if we use the `Object.defineProperty(..)` since the array already hold the length, this should be a nop *) -val obj_length : ?comment:string -> J.expression -> t +val obj_length : J.expression -> t -val and_ : ?comment:string -> t -> t -> t +val and_ : t -> t -> t -val or_ : ?comment:string -> t -> t -> t +val or_ : t -> t -> t val in_ : t -> t -> t (** we don't expose a general interface, since a general interface is generally not safe *) -val dummy_obj : ?comment:string -> Lam_tag_info.t -> t +val dummy_obj : Lam_tag_info.t -> t (** used combined with [caml_update_dummy]*) -val of_block : ?comment:string -> ?e:J.expression -> J.statement list -> t +val of_block : ?e:J.expression -> J.statement list -> t (** convert a block to expresion by using IIFE *) -val raw_js_code : ?comment:string -> Js_raw_info.code_info -> string -> t +val raw_js_code : Js_raw_info.code_info -> string -> t val nil : t -val is_null : ?comment:string -> t -> t - -val is_undef : ?comment:string -> t -> t +val is_null : t -> t val is_null_undefined_constant : J.expression -> bool -val is_null_undefined : ?comment:string -> t -> t +val is_null_undefined : t -> t val make_exception : string -> t diff --git a/compiler/core/js_implementation.ml b/compiler/core/js_implementation.ml index df6ab959d12..9c579c901cd 100644 --- a/compiler/core/js_implementation.ml +++ b/compiler/core/js_implementation.ml @@ -67,12 +67,8 @@ let after_parsing_sig ppf outputprefix ast = initial_env sg; process_with_gentype (outputprefix ^ ".cmti")) -let interface ~parser ppf ?outputprefix fname = - let outputprefix = - match outputprefix with - | None -> Config_util.output_prefix fname - | Some x -> x - in +let interface ~parser ppf fname = + let outputprefix = Config_util.output_prefix fname in Res_compmisc.init_path (); parser fname |> Cmd_ppx_apply.apply_rewriters ~restore:false ~tool_name:Js_config.tool_name @@ -154,12 +150,8 @@ let after_parsing_impl ppf outputprefix (ast : Parsetree.structure) = Lam_compile_main.lambda_as_module js_program outputprefix); process_with_gentype (outputprefix ^ ".cmt")) -let implementation ~parser ppf ?outputprefix fname = - let outputprefix = - match outputprefix with - | None -> Config_util.output_prefix fname - | Some x -> x - in +let implementation ~parser ppf fname = + let outputprefix = Config_util.output_prefix fname in Res_compmisc.init_path (); parser fname |> Cmd_ppx_apply.apply_rewriters ~restore:false ~tool_name:Js_config.tool_name diff --git a/compiler/core/js_implementation.mli b/compiler/core/js_implementation.mli index 3b97cf23dbe..b4a1b5938b2 100644 --- a/compiler/core/js_implementation.mli +++ b/compiler/core/js_implementation.mli @@ -27,22 +27,16 @@ val interface : parser:(string -> Parsetree.signature) -> Format.formatter -> - ?outputprefix:string -> string -> unit (** This module defines a function to compile the program directly into [js] - given [filename] and [outputprefix], + given [filename], it will be useful if we don't care about bytecode output(generating js only). *) val interface_mliast : Format.formatter -> string -> unit -(* val after_parsing_impl : - Format.formatter -> - string -> - Parsetree.structure -> - unit *) -(** [after_parsing_impl ppf sourcefile outputprefix ast ] +(** [after_parsing_impl ppf sourcefile outputprefix ast] Make sure you need run {!Res_compmisc.init_path} for set up Used in eval *) @@ -50,10 +44,9 @@ val interface_mliast : Format.formatter -> string -> unit val implementation : parser:(string -> Parsetree.structure) -> Format.formatter -> - ?outputprefix:string -> string -> unit -(** [implementation ppf sourcefile outprefix] compiles to JS directly *) +(** [implementation ppf sourcefile] compiles to JS directly *) val implementation_mlast : Format.formatter -> string -> unit diff --git a/compiler/core/js_of_lam_block.ml b/compiler/core/js_of_lam_block.ml index 850e8ad2f94..ef11c715d7e 100644 --- a/compiler/core/js_of_lam_block.ml +++ b/compiler/core/js_of_lam_block.ml @@ -45,13 +45,8 @@ let field (field_info : Lam_compat.field_dbg_info) e (i : int32) = | Fld_record {name} -> E.record_access e name i | Fld_module {name} -> E.module_access e name i -let field_by_exp e i = E.array_index e i - let set_field (field_info : Lam_compat.set_field_dbg_info) e i e0 = match field_info with | Fld_record_extension_set name -> E.extension_assign e i name e0 | Fld_record_inline_set name | Fld_record_set name -> E.record_assign e i name e0 - -(* This dynamism commes from oo compilaton, it should not happen in record *) -let set_field_by_exp self index value = E.assign_by_exp self index value diff --git a/compiler/core/js_of_lam_block.mli b/compiler/core/js_of_lam_block.mli index 903baa7ee47..4718461dfb6 100644 --- a/compiler/core/js_of_lam_block.mli +++ b/compiler/core/js_of_lam_block.mli @@ -33,14 +33,9 @@ val make_block : val field : Lam_compat.field_dbg_info -> J.expression -> int32 -> J.expression -val field_by_exp : J.expression -> J.expression -> J.expression - val set_field : Lam_compat.set_field_dbg_info -> J.expression -> int32 -> J.expression -> J.expression - -val set_field_by_exp : - J.expression -> J.expression -> J.expression -> J.expression diff --git a/compiler/core/js_of_lam_option.ml b/compiler/core/js_of_lam_option.ml index 61cbcae2723..ef9afc1fa3e 100644 --- a/compiler/core/js_of_lam_option.ml +++ b/compiler/core/js_of_lam_option.ml @@ -24,8 +24,6 @@ module E = Js_exp_make -type option_unwrap_time = Static_unwrapped | Runtime_maybe_unwrapped - (** Another way: {[ | Var _ -> @@ -103,6 +101,4 @@ let some = E.optional_block let null_to_opt e = E.econd (E.is_null e) none (some e) -let undef_to_opt e = E.econd (E.is_undef e) none (some e) - let null_undef_to_opt e = E.econd (E.is_null_undefined e) none (some e) diff --git a/compiler/core/js_of_lam_option.mli b/compiler/core/js_of_lam_option.mli index c09d0f5fdf8..1acdb952aed 100644 --- a/compiler/core/js_of_lam_option.mli +++ b/compiler/core/js_of_lam_option.mli @@ -22,8 +22,6 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type option_unwrap_time = Static_unwrapped | Runtime_maybe_unwrapped - val val_from_option : J.expression -> J.expression (** Given [Some a ], return [a] *) @@ -41,12 +39,8 @@ val destruct_optional : J.expression -> 'a -val some : J.expression -> J.expression - val is_not_none : J.expression -> J.expression val null_to_opt : J.expression -> J.expression -val undef_to_opt : J.expression -> J.expression - val null_undef_to_opt : J.expression -> J.expression diff --git a/compiler/core/js_of_lam_string.ml b/compiler/core/js_of_lam_string.ml index 765a9d3ee71..2805e0976ce 100644 --- a/compiler/core/js_of_lam_string.ml +++ b/compiler/core/js_of_lam_string.ml @@ -31,9 +31,6 @@ module E = Js_exp_make let const_char (i : int) = E.int ~c:i (Int32.of_int @@ i) -(* string [s[i]] expects to return a [ocaml_char] *) -let ref_string e e1 = E.string_index e e1 - (** Note that [String.fromCharCode] also works, but it only work for small arrays, however, for {bytes_to_string} it is likely the bytes diff --git a/compiler/core/js_of_lam_string.mli b/compiler/core/js_of_lam_string.mli index 68feda72ad2..1d6624270a0 100644 --- a/compiler/core/js_of_lam_string.mli +++ b/compiler/core/js_of_lam_string.mli @@ -28,6 +28,4 @@ [string] is Immutable, so there is not [set_string] method *) -val ref_string : J.expression -> J.expression -> J.expression - val const_char : int -> J.expression diff --git a/compiler/core/js_op.ml b/compiler/core/js_op.ml index 769af321afc..9c83ef9128d 100644 --- a/compiler/core/js_op.ml +++ b/compiler/core/js_op.ml @@ -38,7 +38,6 @@ type binop = | Le | Gt | Ge - | Bnot | Bor | Bxor | Band @@ -88,36 +87,6 @@ type binop = So in Js, [-1 >>>0] will be the largest Uint32, while [-1>>0] will remain [-1] and [-1 >>> 0 >> 0 ] will be [-1] *) -type int_op = - | Bor - | Bxor - | Band - | Lsl - | Lsr - | Asr - | Plus - (* for [+], given two numbers - x + y | 0 - *) - | Minus - (* x - y | 0 *) - | Mul - (* *) - | Div - (* x / y | 0 *) - | Mod - (* x % y *) - | Pow (* x ** y | 0 *) - -(* https://developer.mozilla.org/en-US/docs/Web/JavaScript/Guide/Expressions_and_Operators#Bitwise_operators - {[ - ~ - ]} - ~0xff -> -256 - design; make sure each operation type is consistent -*) -type level = Log | Info | Warn | Error - type kind = | Ml | Runtime @@ -131,8 +100,6 @@ type property = Lam_compat.let_kind = Strict | Alias | StrictOpt | Variable type property_name = Lit of string | Symbol_name -type 'a access = Getter | Setter - (* literal char *) type float_lit = {f: string} [@@unboxed] @@ -153,14 +120,6 @@ type mutable_flag = Mutable | Immutable | NA type direction_flag = Upto | Downto | Up -(* - {[ - let rec x = 1 :: y - and y = 1 :: x - ]} -*) -type recursive_info = SingleRecursive | NonRecursie | NA - type used_stats = | Dead_pure (* only [Dead] should be taken serious, @@ -186,7 +145,6 @@ type used_stats = | NA type ident_info = { - (* mutable recursive_info : recursive_info; *) mutable used_stats: used_stats; } @@ -194,7 +152,7 @@ type exports = Ident.t list type tag_info = Lam_tag_info.t -type length_object = Array | String | Bytes | Function | Caml_block +type length_object = Array | String | Function | Caml_block (** TODO: define constant - for better constant folding *) (* type constant = *) diff --git a/compiler/core/js_op_util.ml b/compiler/core/js_op_util.ml index 8d2d8636396..38cad31bf89 100644 --- a/compiler/core/js_op_util.ml +++ b/compiler/core/js_op_util.ml @@ -39,23 +39,12 @@ let op_prec (op : Js_op.binop) = | Bxor -> (6, 6, 6) | Band -> (7, 7, 7) | Lsl | Lsr | Asr -> (10, 10, 11) - | Bnot | Plus | Minus -> (11, 11, 12) - | Mul | Div | Mod -> (12, 12, 13) - | Pow -> (13, 14, 12) - -let op_int_prec (op : Js_op.int_op) = - match op with - | Bor -> (5, 5, 5) - | Bxor -> (6, 6, 6) - | Band -> (7, 7, 7) - | Lsl | Lsr | Asr -> (10, 10, 11) | Plus | Minus -> (11, 11, 12) | Mul | Div | Mod -> (12, 12, 13) | Pow -> (13, 14, 12) let op_str (op : Js_op.binop) = match op with - | Bnot -> "~" | Bor -> "|" | Bxor -> "^" | Band -> "&" @@ -79,32 +68,6 @@ let op_str (op : Js_op.binop) = | Ge -> ">=" | InstanceOf -> "instanceof" -let op_int_str (op : Js_op.int_op) = - match op with - | Bor -> "|" - | Bxor -> "^" - | Band -> "&" - | Lsl -> "<<" - | Lsr -> ">>>" - | Asr -> ">>" - | Plus -> "+" - | Minus -> "-" - | Mul -> "*" - | Div -> "/" - | Mod -> "%" - | Pow -> "**" - -let str_of_used_stats x = - match (x : Js_op.used_stats) with - | Js_op.Dead_pure -> "Dead_pure" - | Dead_non_pure -> "Dead_non_pure" - | Exported -> "Exported" - | Once_pure -> "Once_pure" - | Used -> "Used" - | Scanning_pure -> "Scanning_pure" - | Scanning_non_pure -> "Scanning_non_pure" - | NA -> "NA" - let update_used_stats (ident_info : J.ident_info) used_stats = match ident_info.used_stats with | Dead_pure | Dead_non_pure | Exported -> () diff --git a/compiler/core/js_op_util.mli b/compiler/core/js_op_util.mli index db11b3ec08c..8ed1ba9b4ef 100644 --- a/compiler/core/js_op_util.mli +++ b/compiler/core/js_op_util.mli @@ -28,12 +28,6 @@ val op_prec : Js_op.binop -> int * int * int val op_str : Js_op.binop -> string -val op_int_prec : Js_op.int_op -> int * int * int - -val op_int_str : Js_op.int_op -> string - -val str_of_used_stats : Js_op.used_stats -> string - val update_used_stats : J.ident_info -> Js_op.used_stats -> unit val same_vident : J.vident -> J.vident -> bool diff --git a/compiler/core/js_output.ml b/compiler/core/js_output.ml index 0269ff1c17a..c11f5d80a2f 100644 --- a/compiler/core/js_output.ml +++ b/compiler/core/js_output.ml @@ -140,5 +140,3 @@ let append_output (x : t) (y : t) : t = (* Fold right is more efficient *) let concat (xs : t list) : t = Ext_list.fold_right xs dummy (fun x acc -> append_output x acc) - -let to_string x = Js_dump.string_of_block (output_as_block x) diff --git a/compiler/core/js_output.mli b/compiler/core/js_output.mli index 19204e18772..1fe7430ce81 100644 --- a/compiler/core/js_output.mli +++ b/compiler/core/js_output.mli @@ -75,5 +75,3 @@ val output_of_block_and_expression : *) val concat : t list -> t - -val to_string : t -> string diff --git a/compiler/core/js_packages_info.ml b/compiler/core/js_packages_info.ml index dccb649c5a6..12579018ac7 100644 --- a/compiler/core/js_packages_info.ml +++ b/compiler/core/js_packages_info.ml @@ -88,35 +88,12 @@ let from_name (name : string) : t = let is_empty (x : t) = x.name = Pkg_empty -let string_of_module_system (ms : module_system) = - match ms with - | Commonjs -> "CommonJS" - | Esmodule -> "ESModule" - let module_system_of_string package_name : module_system option = match package_name with | "commonjs" -> Some Commonjs | "esmodule" -> Some Esmodule | _ -> None -let dump_package_info (fmt : Format.formatter) - ({module_system = ms; path = name; suffix} : package_info) = - Format.fprintf fmt "@[%s@ %s@ %s@]" (string_of_module_system ms) name suffix - -let dump_package_name fmt (x : package_name) = - match x with - | Pkg_empty -> Format.fprintf fmt "@empty_pkg@" - | Pkg_normal s -> Format.pp_print_string fmt s - | Pkg_runtime -> Format.pp_print_string fmt "@runtime" - -let dump_packages_info (fmt : Format.formatter) - ({name; module_systems = ls} : t) = - Format.fprintf fmt "@[%a;@ @[%a@]@]" dump_package_name name - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.pp_print_space fmt ()) - dump_package_info) - ls - type package_found_info = { rel_path: string; pkg_rel_path: string; @@ -156,20 +133,6 @@ let query_package_infos ({name; module_systems} : t) Package_found {rel_path; pkg_rel_path; suffix = k.suffix} | None -> Package_not_found) -let get_js_path (x : t) (module_system : module_system) : string = - match - Ext_list.find_first x.module_systems (fun k -> - compatible k.module_system module_system) - with - | Some k -> k.path - | None -> assert false - -(* for a single pass compilation, [output_dir] - can be cached -*) -let get_output_dir (info : t) ~package_dir module_system = - Filename.concat package_dir (get_js_path info module_system) - let add_npm_package_path (packages_info : t) (s : string) : t = if is_empty packages_info then Bsc_args.bad_arg "Set package name first using -bs-package-name" diff --git a/compiler/core/js_packages_info.mli b/compiler/core/js_packages_info.mli index 6e5c551df88..78c77b7a707 100644 --- a/compiler/core/js_packages_info.mli +++ b/compiler/core/js_packages_info.mli @@ -48,8 +48,6 @@ val from_name : string -> t val is_empty : t -> bool -val dump_packages_info : Format.formatter -> t -> unit - val add_npm_package_path : t -> string -> t (** used by command line option e.g [-bs-package-output commonjs:xx/path] @@ -66,8 +64,6 @@ type info_query = | Package_not_found | Package_found of package_found_info -val get_output_dir : t -> package_dir:string -> module_system -> string - val query_package_infos : t -> module_system -> info_query (** Note here we compare the package info by order in theory, we can compare it by set semantics diff --git a/compiler/core/js_record_fold.ml b/compiler/core/js_record_fold.ml index d3e0de74358..6279874c1dc 100644 --- a/compiler/core/js_record_fold.ml +++ b/compiler/core/js_record_fold.ml @@ -60,9 +60,6 @@ let module_id : 'a. ('a, module_id) fn = let st = _self.ident _self st _x0 in st -let required_modules : 'a. ('a, required_modules) fn = - fun _self st arg -> list _self.module_id _self st arg - let vident : 'a. ('a, vident) fn = fun _self st -> function | Id _x0 -> @@ -311,12 +308,6 @@ let program : 'a. ('a, program) fn = let st = _self.block _self st _x0 in st -let deps_program : 'a. ('a, deps_program) fn = - fun _self st {program = _x0; modules = _x1; side_effect = _x2} -> - let st = _self.program _self st _x0 in - let st = required_modules _self st _x1 in - st - let super : 'state iter = { ident; diff --git a/compiler/core/js_record_iter.ml b/compiler/core/js_record_iter.ml index da86618ae3c..a12b017f0ab 100644 --- a/compiler/core/js_record_iter.ml +++ b/compiler/core/js_record_iter.ml @@ -58,9 +58,6 @@ let ident : ident fn = unknown let module_id : module_id fn = fun _self {id = _x0; kind = _x1} -> _self.ident _self _x0 -let required_modules : required_modules fn = - fun _self arg -> list _self.module_id _self arg - let vident : vident fn = fun _self -> function | Id _x0 -> _self.ident _self _x0 @@ -226,11 +223,6 @@ let program : program fn = fun _self {block = _x0; exports = _x1; export_set = _x2} -> _self.block _self _x0 -let deps_program : deps_program fn = - fun _self {program = _x0; modules = _x1; side_effect = _x2} -> - _self.program _self _x0; - required_modules _self _x1 - let super : iter = { ident; diff --git a/compiler/core/js_record_map.ml b/compiler/core/js_record_map.ml index 26551861718..a88ceebd096 100644 --- a/compiler/core/js_record_map.ml +++ b/compiler/core/js_record_map.ml @@ -60,9 +60,6 @@ let module_id : module_id fn = let _x0 = _self.ident _self _x0 in {id = _x0; kind = _x1; dynamic_import = _x2} -let required_modules : required_modules fn = - fun _self arg -> list _self.module_id _self arg - let vident : vident fn = fun _self -> function | Id _x0 -> @@ -308,12 +305,6 @@ let program : program fn = let _x0 = _self.block _self _x0 in {block = _x0; exports = _x1; export_set = _x2} -let deps_program : deps_program fn = - fun _self {program = _x0; modules = _x1; side_effect = _x2} -> - let _x0 = _self.program _self _x0 in - let _x1 = required_modules _self _x1 in - {program = _x0; modules = _x1; side_effect = _x2} - let super : iter = { ident; diff --git a/compiler/core/js_stmt_make.ml b/compiler/core/js_stmt_make.ml index c0edf8bc321..36c71a918b6 100644 --- a/compiler/core/js_stmt_make.ml +++ b/compiler/core/js_stmt_make.ml @@ -26,59 +26,50 @@ module E = Js_exp_make type t = J.statement -let return_stmt ?comment e : t = {statement_desc = Return e; comment} +let return_stmt e : t = {statement_desc = Return e; comment = None} let empty_stmt : t = {statement_desc = Block []; comment = None} (* let empty_block : J.block = [] *) -let throw_stmt ?comment v : t = {statement_desc = Throw v; comment} +let throw_stmt v : t = {statement_desc = Throw v; comment = None} (* avoid nested block *) -let rec block ?comment (b : J.block) : t = +let rec block (b : J.block) : t = match b with | [{statement_desc = Block bs}] -> block bs | [b] -> b | [] -> empty_stmt - | _ -> {statement_desc = Block b; comment} + | _ -> {statement_desc = Block b; comment = None} (* It's a statement, we can discard some values *) -let rec exp ?comment (e : E.t) : t = +let rec exp (e : E.t) : t = match e.expression_desc with | Seq ({expression_desc = Number _ | Undefined _}, b) | Seq (b, {expression_desc = Number _ | Undefined _}) -> - exp ?comment b + exp b | Number _ | Undefined _ -> block [] (* TODO: we can do more *) (* | _ when is_pure e -> block [] *) - | _ -> {statement_desc = Exp e; comment} + | _ -> {statement_desc = Exp e; comment = None} -let declare_variable ?comment ?ident_info ~kind (ident : Ident.t) : t = +let declare_variable ~kind (ident : Ident.t) : t = let property : J.property = kind in - let ident_info : J.ident_info = - match ident_info with - | None -> {used_stats = NA} - | Some x -> x - in { - statement_desc = Variable {ident; value = None; property; ident_info}; - comment; + statement_desc = + Variable {ident; value = None; property; ident_info = {used_stats = NA}}; + comment = None; } -let define_variable ?comment ?ident_info ~kind (v : Ident.t) - (exp : J.expression) : t = +let define_variable ~kind (v : Ident.t) (exp : J.expression) : t = match exp.expression_desc with - | Undefined _ -> declare_variable ?comment ?ident_info ~kind v + | Undefined _ -> declare_variable ~kind v | _ -> let property : J.property = kind in - let ident_info : J.ident_info = - match ident_info with - | None -> {used_stats = NA} - | Some x -> x - in { statement_desc = - Variable {ident = v; value = Some exp; property; ident_info}; - comment; + Variable + {ident = v; value = Some exp; property; ident_info = {used_stats = NA}}; + comment = None; } (* let alias_variable ?comment ~exp (v:Ident.t) : t= @@ -88,8 +79,8 @@ let define_variable ?comment ?ident_info ~kind (v : Ident.t) ident_info = {used_stats = NA } }; comment} *) -let int_switch ?(comment : string option) - ?(declaration : (J.property * Ident.t) option) ?(default : J.block option) +let int_switch ?(declaration : (J.property * Ident.t) option) + ?(default : J.block option) (e : J.expression) (clauses : (int * J.case_clause) list) : t = match e.expression_desc with | Number (Int {i; _}) -> ( @@ -119,22 +110,26 @@ let int_switch ?(comment : string option) }; ] ) when Ident.same did id -> - define_variable ?comment ~kind id e0 + define_variable ~kind id e0 | Some (kind, did), _ -> - block (declare_variable ?comment ~kind did :: continuation) + block (declare_variable ~kind did :: continuation) | None, _ -> block continuation) | _ -> ( match declaration with | Some (kind, did) -> block [ - declare_variable ?comment ~kind did; - {statement_desc = J.Int_switch (e, clauses, default); comment}; + declare_variable ~kind did; + { + statement_desc = J.Int_switch (e, clauses, default); + comment = None; + }; ] - | None -> {statement_desc = J.Int_switch (e, clauses, default); comment}) + | None -> + {statement_desc = J.Int_switch (e, clauses, default); comment = None}) -let string_switch ?(comment : string option) - ?(declaration : (J.property * Ident.t) option) ?(default : J.block option) +let string_switch ?(declaration : (J.property * Ident.t) option) + ?(default : J.block option) (e : J.expression) (clauses : (Ast_untagged_variants.tag_type * J.case_clause) list) : t = match e.expression_desc with @@ -169,19 +164,23 @@ let string_switch ?(comment : string option) }; ] ) when Ident.same did id -> - define_variable ?comment ~kind id e0 + define_variable ~kind id e0 | Some (kind, did), _ -> - block @@ (declare_variable ?comment ~kind did :: continuation) + block @@ (declare_variable ~kind did :: continuation) | None, _ -> block continuation) | _ -> ( match declaration with | Some (kind, did) -> block [ - declare_variable ?comment ~kind did; - {statement_desc = String_switch (e, clauses, default); comment}; + declare_variable ~kind did; + { + statement_desc = String_switch (e, clauses, default); + comment = None; + }; ] - | None -> {statement_desc = String_switch (e, clauses, default); comment}) + | None -> + {statement_desc = String_switch (e, clauses, default); comment = None}) let rec block_last_is_return_throw_or_continue (x : J.block) = match x with @@ -230,24 +229,24 @@ let rec block_last_is_return_throw_or_continue (x : J.block) = ]} Not clear the benefit *) -let if_ ?comment ?declaration ?else_ (e : J.expression) (then_ : J.block) : t = +let if_ ?declaration ?else_ (e : J.expression) (then_ : J.block) : t = let declared = ref false in - let rec aux ?comment (e : J.expression) (ifso : J.block) (ifnot : J.block) : t - = + let rec aux (e : J.expression) (ifso : J.block) (ifnot : J.block) : t = match (e.expression_desc, ifnot) with | Bool boolean, _ -> block (if boolean then ifso else ifnot) - | Js_not pred_not, _ :: _ -> aux ?comment pred_not ifnot ifso + | Js_not pred_not, _ :: _ -> aux pred_not ifnot ifso | _ -> ( match (ifso, ifnot) with | [], [] -> exp e - | [], _ -> aux ?comment (E.not e) ifnot [] (*Make sure no infinite loop*) + | [], _ -> aux (E.not e) ifnot [] (*Make sure no infinite loop*) | ( [{statement_desc = Return ret_ifso; _}], [{statement_desc = Return ret_ifnot; _}] ) -> return_stmt (E.econd e ret_ifso ret_ifnot) | _, [{statement_desc = Return _}] -> - block ({statement_desc = If (E.not e, ifnot, []); comment} :: ifso) + block + ({statement_desc = If (E.not e, ifnot, []); comment = None} :: ifso) | _, _ when block_last_is_return_throw_or_continue ifso -> - block ({statement_desc = If (e, ifso, []); comment} :: ifnot) + block ({statement_desc = If (e, ifso, []); comment = None} :: ifnot) | ( [ { statement_desc = @@ -289,20 +288,20 @@ let if_ ?comment ?declaration ?else_ (e : J.expression) (then_ : J.block) : t = exp (E.econd e exp_ifso exp_ifnot) | [{statement_desc = If (pred1, ifso1, ifnot1)}], _ when Js_analyzer.eq_block ifnot1 ifnot -> - aux ?comment (E.and_ e pred1) ifso1 ifnot1 + aux (E.and_ e pred1) ifso1 ifnot1 | [{statement_desc = If (pred1, ifso1, ifnot1)}], _ when Js_analyzer.eq_block ifso1 ifnot -> - aux ?comment (E.and_ e (E.not pred1)) ifnot1 ifso1 + aux (E.and_ e (E.not pred1)) ifnot1 ifso1 | _, [{statement_desc = If (pred1, ifso1, else_)}] when Js_analyzer.eq_block ifso ifso1 -> - aux ?comment (E.or_ e pred1) ifso else_ + aux (E.or_ e pred1) ifso else_ | _, [{statement_desc = If (pred1, ifso1, ifnot1)}] when Js_analyzer.eq_block ifso ifnot1 -> - aux ?comment (E.or_ e (E.not pred1)) ifso ifso1 - | _ -> {statement_desc = If (e, ifso, ifnot); comment}) + aux (E.or_ e (E.not pred1)) ifso ifso1 + | _ -> {statement_desc = If (e, ifso, ifnot); comment = None}) in let if_block = - aux ?comment e then_ + aux e then_ (match else_ with | None -> [] | Some v -> v) @@ -311,29 +310,32 @@ let if_ ?comment ?declaration ?else_ (e : J.expression) (then_ : J.block) : t = | true, _ | _, None -> if_block | false, Some (kind, id) -> block (declare_variable ~kind id :: [if_block]) -let assign ?comment id e : t = - {statement_desc = J.Exp (E.assign (E.var id) e); comment} +let assign id e : t = + {statement_desc = J.Exp (E.assign (E.var id) e); comment = None} -let while_ ?comment ?label (e : E.t) (st : J.block) : t = - {statement_desc = While (label, e, st); comment} +let while_ ?label (e : E.t) (st : J.block) : t = + {statement_desc = While (label, e, st); comment = None} -let for_ ?comment ?label for_ident_expression finish_ident_expression id - direction (b : J.block) : t = +let for_ ?label for_ident_expression finish_ident_expression id direction + (b : J.block) : t = { statement_desc = ForRange (label, for_ident_expression, finish_ident_expression, id, direction, b); - comment; + comment = None; } -let for_of ?comment ?label iterable_expression id (b : J.block) : t = - {statement_desc = ForOf (label, id, iterable_expression, b); comment} +let for_of ?label iterable_expression id (b : J.block) : t = + {statement_desc = ForOf (label, id, iterable_expression, b); comment = None} -let for_await_of ?comment ?label iterable_expression id (b : J.block) : t = - {statement_desc = ForAwaitOf (label, id, iterable_expression, b); comment} +let for_await_of ?label iterable_expression id (b : J.block) : t = + { + statement_desc = ForAwaitOf (label, id, iterable_expression, b); + comment = None; + } -let try_ ?comment ?with_ ?finally body : t = - {statement_desc = Try (body, with_, finally); comment} +let try_ ?with_ body : t = + {statement_desc = Try (body, with_, None); comment = None} let break_ ?label () : t = {statement_desc = Break label; comment = None} diff --git a/compiler/core/js_stmt_make.mli b/compiler/core/js_stmt_make.mli index d58ced95248..2139e36f578 100644 --- a/compiler/core/js_stmt_make.mli +++ b/compiler/core/js_stmt_make.mli @@ -30,10 +30,9 @@ type t = J.statement (* val empty_stmt : t *) -val throw_stmt : ?comment:string -> J.expression -> t +val throw_stmt : J.expression -> t val if_ : - ?comment:string -> ?declaration:Lam_compat.let_kind * Ident.t -> (* when it's not None, we also need make a variable declaration in the begininnig, however, we can optmize such case @@ -43,14 +42,13 @@ val if_ : J.block -> t -val block : ?comment:string -> J.block -> t +val block : J.block -> t (** turn a block into a single statement, avoid nested block *) val int_switch : - ?comment:string -> ?declaration:Lam_compat.let_kind * Ident.t -> ?default:J.block -> J.expression -> @@ -73,25 +71,17 @@ val int_switch : *) val string_switch : - ?comment:string -> ?declaration:Lam_compat.let_kind * Ident.t -> ?default:J.block -> J.expression -> (Ast_untagged_variants.tag_type * J.case_clause) list -> t -val declare_variable : - ?comment:string -> - ?ident_info:J.ident_info -> - kind:Lam_compat.let_kind -> - Ident.t -> - t +val declare_variable : kind:Lam_compat.let_kind -> Ident.t -> t (** Just declaration without initialization *) (*** Declaration with initialization *) val define_variable : - ?comment:string -> - ?ident_info:J.ident_info -> kind:Lam_compat.let_kind -> Ident.t -> J.expression -> @@ -104,7 +94,7 @@ val define_variable : Ident.t -> t *) -val assign : ?comment:string -> J.ident -> J.expression -> t +val assign : J.ident -> J.expression -> t (** Used in cases like {[ @@ -130,10 +120,9 @@ val assign : ?comment:string -> J.ident -> J.expression -> t J.ident -> t *) -val while_ : ?comment:string -> ?label:J.label -> J.expression -> J.block -> t +val while_ : ?label:J.label -> J.expression -> J.block -> t val for_ : - ?comment:string -> ?label:J.label -> J.for_ident_expression option -> J.finish_ident_expression -> @@ -142,22 +131,16 @@ val for_ : J.block -> t -val for_of : - ?comment:string -> ?label:J.label -> J.expression -> J.ident -> J.block -> t +val for_of : ?label:J.label -> J.expression -> J.ident -> J.block -> t val for_await_of : - ?comment:string -> ?label:J.label -> J.expression -> J.ident -> J.block -> t + ?label:J.label -> J.expression -> J.ident -> J.block -> t -val try_ : - ?comment:string -> - ?with_:J.ident * J.block -> - ?finally:J.block -> - J.block -> - t +val try_ : ?with_:J.ident * J.block -> J.block -> t -val exp : ?comment:string -> J.expression -> t +val exp : J.expression -> t -val return_stmt : ?comment:string -> J.expression -> t +val return_stmt : J.expression -> t (* val return_unit : t list *) (** for ocaml function which returns unit diff --git a/compiler/core/lam.ml b/compiler/core/lam.ml index 15875608b97..7ba275d1071 100644 --- a/compiler/core/lam.ml +++ b/compiler/core/lam.ml @@ -114,165 +114,8 @@ module Types = struct (* | Lsend of Lam_compat.meth_kind * t * t * t list * Location.t *) end -module X = struct - type lambda_switch = Types.lambda_switch = { - sw_consts_full: bool; - sw_consts: (int * t) list; - sw_blocks_full: bool; - sw_blocks: (int * t) list; - sw_failaction: t option; - sw_names: Ast_untagged_variants.switch_names option; - } - - and prim_info = Types.prim_info = { - primitive: Lam_primitive.t; - args: t list; - loc: Location.t; - } - - and apply = Types.apply = { - ap_func: t; - ap_args: t list; - ap_info: ap_info; - ap_transformed_jsx: bool; - } - - and lfunction = Types.lfunction = { - arity: int; - params: ident list; - body: t; - attr: Lambda.function_attribute; - } - - and t = Types.t = - | Lvar of ident - | Lglobal_module of ident * bool - | Lconst of Lam_constant.t - | Lapply of apply - | Lfunction of lfunction - | Llet of Lam_compat.let_kind * ident * t * t - | Lletrec of (ident * t) list * t - | Lprim of prim_info - | Lswitch of t * lambda_switch - | Lstringswitch of t * (string * t) list * t option - | Lstaticraise of int * t list - | Lstaticcatch of t * (int * ident list) * t - | Ltrywith of t * ident * t - | Lifthenelse of t * t * t - | Lsequence of t * t - | Lbreak - | Lcontinue - | Lwhile of t * t - | Lfor of ident * t * t * Asttypes.direction_flag * t - | Lfor_of of ident * t * t - | Lfor_await_of of ident * t * t - | Lassign of ident * t - (* | Lsend of Lam_compat.meth_kind * t * t * t list * Location.t *) -end - include Types -(** apply [f] to direct successor which has type [Lam.t] *) - -let inner_map (l : t) (f : t -> X.t) : X.t = - match l with - | Lvar (_ : ident) | Lconst (_ : Lam_constant.t) -> ((* Obj.magic *) l : X.t) - | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} -> - let ap_func = f ap_func in - let ap_args = Ext_list.map ap_args f in - Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} - | Lfunction {body; arity; params; attr} -> - let body = f body in - Lfunction {body; arity; params; attr} - | Llet (str, id, arg, body) -> - let arg = f arg in - let body = f body in - Llet (str, id, arg, body) - | Lletrec (decl, body) -> - let body = f body in - let decl = Ext_list.map_snd decl f in - Lletrec (decl, body) - | Lglobal_module _ -> (l : X.t) - | Lprim {args; primitive; loc} -> - let args = Ext_list.map args f in - Lprim {args; primitive; loc} - | Lswitch - ( arg, - { - sw_consts; - sw_consts_full; - sw_blocks; - sw_blocks_full; - sw_failaction; - sw_names; - } ) -> - let arg = f arg in - let sw_consts = Ext_list.map_snd sw_consts f in - let sw_blocks = Ext_list.map_snd sw_blocks f in - let sw_failaction = Ext_option.map sw_failaction f in - Lswitch - ( arg, - { - sw_consts; - sw_blocks; - sw_failaction; - sw_blocks_full; - sw_consts_full; - sw_names; - } ) - | Lstringswitch (arg, cases, default) -> - let arg = f arg in - let cases = Ext_list.map_snd cases f in - let default = Ext_option.map default f in - Lstringswitch (arg, cases, default) - | Lstaticraise (id, args) -> - let args = Ext_list.map args f in - Lstaticraise (id, args) - | Lstaticcatch (e1, vars, e2) -> - let e1 = f e1 in - let e2 = f e2 in - Lstaticcatch (e1, vars, e2) - | Ltrywith (e1, exn, e2) -> - let e1 = f e1 in - let e2 = f e2 in - Ltrywith (e1, exn, e2) - | Lifthenelse (e1, e2, e3) -> - let e1 = f e1 in - let e2 = f e2 in - let e3 = f e3 in - Lifthenelse (e1, e2, e3) - | Lsequence (e1, e2) -> - let e1 = f e1 in - let e2 = f e2 in - Lsequence (e1, e2) - | Lbreak -> Lbreak - | Lcontinue -> Lcontinue - | Lwhile (e1, e2) -> - let e1 = f e1 in - let e2 = f e2 in - Lwhile (e1, e2) - | Lfor (v, e1, e2, dir, e3) -> - let e1 = f e1 in - let e2 = f e2 in - let e3 = f e3 in - Lfor (v, e1, e2, dir, e3) - | Lfor_of (v, e1, e2) -> - let e1 = f e1 in - let e2 = f e2 in - Lfor_of (v, e1, e2) - | Lfor_await_of (v, e1, e2) -> - let e1 = f e1 in - let e2 = f e2 in - Lfor_await_of (v, e1, e2) - | Lassign (id, e) -> - let e = f e in - Lassign (id, e) -(* | Lsend (k, met, obj, args, loc) -> - let met = f met in - let obj = f obj in - let args = Ext_list.map args f in - Lsend(k,met,obj,args,loc) *) - exception Not_simple_form (** diff --git a/compiler/core/lam.mli b/compiler/core/lam.mli index f6a398d677b..408e4567615 100644 --- a/compiler/core/lam.mli +++ b/compiler/core/lam.mli @@ -91,8 +91,6 @@ and t = private we should use record for trivial debugger info *) -val inner_map : t -> (t -> t) -> t - val handle_bs_non_obj_ffi : ?transformed_jsx:bool -> External_arg_spec.params -> @@ -135,9 +133,6 @@ val switch : t -> lambda_switch -> t val stringswitch : t -> (string * t) list -> t option -> t (** constant folding*) -(* val true_ : t *) -val false_ : t - val unit : t val sequor : t -> t -> t diff --git a/compiler/core/lam_analysis.ml b/compiler/core/lam_analysis.ml index 29a8d3a1602..5a9babd5c1d 100644 --- a/compiler/core/lam_analysis.ml +++ b/compiler/core/lam_analysis.ml @@ -45,7 +45,7 @@ let rec no_side_effects (lam : Lam.t) : bool = | [_; Lconst cst] -> not_zero_constant cst | _ -> false) | Pcreate_extension _ | Ptypeof | Pis_null | Pis_not_none | Psome - | Psome_not_nest | Pis_undefined | Pis_null_undefined | Pnull_to_opt + | Psome_not_nest | Pis_null_undefined | Pnull_to_opt | Pnull_undefined_to_opt | Pjs_fn_make _ | Pjs_fn_make_unit | Pjs_object_create _ | Pimport (* TODO: check *) @@ -93,8 +93,8 @@ let rec no_side_effects (lam : Lam.t) : bool = true (* A tagged template invokes its tag at runtime, so it always has side effects. *) - | Ptagged_template | Pjs_apply | Pjs_runtime_apply | Pjs_call _ | Pinit_mod - | Pupdate_mod | Pjs_unsafe_downgrade _ | Pdebugger | Pjs_fn_method + | Ptagged_template | Pjs_apply | Pjs_call _ | Pinit_mod | Pupdate_mod + | Pjs_unsafe_downgrade _ | Pdebugger | Pjs_fn_method (* Await promise *) | Pawait (* TODO *) diff --git a/compiler/core/lam_arity.ml b/compiler/core/lam_arity.ml index 7998426f08d..1f407fddf9f 100644 --- a/compiler/core/lam_arity.ml +++ b/compiler/core/lam_arity.ml @@ -32,36 +32,6 @@ type t = *) | Arity_na -let equal (x : t) y = - match x with - | Arity_na -> y = Arity_na - | Arity_info (xs, a) -> ( - match y with - | Arity_info (ys, b) -> - a = b && Ext_list.for_all2_no_exn xs ys (fun x y -> x = y) - | Arity_na -> false) - -let pp = Format.fprintf - -let print (fmt : Format.formatter) (x : t) = - match x with - | Arity_na -> pp fmt "?" - | Arity_info (ls, tail) -> - pp fmt "@["; - pp fmt "["; - Format.pp_print_list - ~pp_sep:(fun fmt () -> pp fmt ",") - (fun fmt x -> Format.pp_print_int fmt x) - fmt ls; - if tail then pp fmt "@ *"; - pp fmt "]@]" - -let print_arities_tbl (fmt : Format.formatter) - (arities_tbl : (Ident.t, t ref) Hashtbl.t) = - Hashtbl.fold - (fun (i : Ident.t) (v : t ref) _ -> pp fmt "@[%s -> %a@]@." i.name print !v) - arities_tbl () - let merge (n : int) (x : t) : t = match x with | Arity_na -> Arity_info ([n], false) diff --git a/compiler/core/lam_arity.mli b/compiler/core/lam_arity.mli index 29772c0dd42..a14d317c463 100644 --- a/compiler/core/lam_arity.mli +++ b/compiler/core/lam_arity.mli @@ -32,12 +32,6 @@ type t = private *) | Arity_na -val equal : t -> t -> bool - -val print : Format.formatter -> t -> unit - -val print_arities_tbl : Format.formatter -> (Ident.t, t ref) Hashtbl.t -> unit - val merge : int -> t -> t val non_function_arity_info : t diff --git a/compiler/core/lam_compat.ml b/compiler/core/lam_compat.ml index a652d74ca43..68d52813266 100644 --- a/compiler/core/lam_compat.ml +++ b/compiler/core/lam_compat.ml @@ -51,15 +51,6 @@ let cmp_float (cmp : comparison) (a : float) b : bool = | Clt -> a < b | Cge -> a >= b -let cmp_int (cmp : comparison) (a : int) b : bool = - match cmp with - | Ceq -> a = b - | Cneq -> a <> b - | Cgt -> a > b - | Cle -> a <= b - | Clt -> a < b - | Cge -> a >= b - type let_kind = Lambda.let_kind = Strict | Alias | StrictOpt | Variable type field_dbg_info = Lambda.field_dbg_info = diff --git a/compiler/core/lam_compat.mli b/compiler/core/lam_compat.mli index 4d67d95242e..25cd677eda7 100644 --- a/compiler/core/lam_compat.mli +++ b/compiler/core/lam_compat.mli @@ -49,6 +49,4 @@ val cmp_int32 : comparison -> int32 -> int32 -> bool val cmp_float : comparison -> float -> float -> bool -val cmp_int : comparison -> int -> int -> bool - val eq_comparison : comparison -> comparison -> bool diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index 97f6bec84e5..6cd1d02b1d9 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -233,8 +233,8 @@ type initialization = J.block let compile output_prefix = let rec compile_external_field (* Like [List.empty]*) - ?(dynamic_import = false) (lamba_cxt : Lam_compile_context.t) - (id : Ident.t) name : Js_output.t = + ~dynamic_import (lamba_cxt : Lam_compile_context.t) (id : Ident.t) name : + Js_output.t = match Lam_compile_env.query_external_id_info ~dynamic_import id name with | {persistent_closed_lambda = Some lam} when Lam_util.not_function lam -> compile_lambda lamba_cxt lam @@ -269,7 +269,7 @@ let compile output_prefix = for the function, generative module or functor can be a function, however it can not be global -- global can only module *) - and compile_external_field_apply ?(dynamic_import = false) + and compile_external_field_apply ~dynamic_import (appinfo : Lam.apply) (module_id : Ident.t) (field_name : string) (lambda_cxt : Lam_compile_context.t) : Js_output.t = let ident_info = diff --git a/compiler/core/lam_compile_primitive.ml b/compiler/core/lam_compile_primitive.ml index e6a7a86a6e3..5f7b7bc435e 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -80,10 +80,6 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) trim can not be done before syntax checking otherwise location is incorrect *) - | Pjs_runtime_apply -> ( - match args with - | [f; args] -> E.flat_call f args - | _ -> assert false) | Pjs_apply -> ( match args with | fn :: rest -> E.call ~info:call_info fn rest @@ -146,7 +142,6 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) | Pfn_arity -> E.function_length (Ext_list.singleton_exn args) | Pobjsize -> E.obj_length (Ext_list.singleton_exn args) | Pis_null -> E.is_null (Ext_list.singleton_exn args) - | Pis_undefined -> E.is_undef (Ext_list.singleton_exn args) | Pis_null_undefined -> E.is_null_undefined (Ext_list.singleton_exn args) | Ptypeof -> E.typeof (Ext_list.singleton_exn args) | Pjs_unsafe_downgrade _ | Pdebugger | Pjs_fn_make _ | Pjs_fn_make_unit diff --git a/compiler/core/lam_constant_convert.ml b/compiler/core/lam_constant_convert.ml index a5764124949..a7217de481f 100644 --- a/compiler/core/lam_constant_convert.ml +++ b/compiler/core/lam_constant_convert.ml @@ -52,8 +52,7 @@ let rec convert_constant (const : Lambda.structured_constant) : Lam_constant.t = Const_int { i = Int32.of_int i; - comment = - Pt_constructor {cstr_name = {name; tag_type}; const; non_const}; + comment = Pt_constructor {cstr_name = {name; tag_type}}; } | Pt_variant {name} -> if Ext_string.is_valid_hash_number name then diff --git a/compiler/core/lam_id_kind.ml b/compiler/core/lam_id_kind.ml index b7967fb15ff..759b1317c97 100644 --- a/compiler/core/lam_id_kind.ml +++ b/compiler/core/lam_id_kind.ml @@ -33,13 +33,12 @@ type rec_flag = Lam_rec | Lam_non_rec | Lam_self_rec type element = NA | SimpleForm of Lam.t -type boxed_nullable = Undefined | Null | Null_undefined +type boxed_nullable = Null | Null_undefined type t = | Normal_optional of Lam.t (* Some [x] *) | OptionalBlock of Lam.t * boxed_nullable | ImmutableBlock of element array - | MutableBlock of element array | Constant of Lam_constant.t | Module of Ident.t (** TODO: static module vs first class module *) | FunctionId of { @@ -49,7 +48,6 @@ type t = *) lambda: (Lam.t * rec_flag) option; } - | Exception | Parameter (** For this case, it can help us determine whether it should be inlined or not *) | NA @@ -65,12 +63,9 @@ let print fmt (kind : t) = | ImmutableBlock arr -> pp fmt "Imm(%d)" (Array.length arr) | Normal_optional _ -> pp fmt "Some" | OptionalBlock (_, Null) -> pp fmt "?Null" - | OptionalBlock (_, Undefined) -> pp fmt "?Undefined" | OptionalBlock (_, Null_undefined) -> pp fmt "?Nullable" - | MutableBlock arr -> pp fmt "Mutable(%d)" (Array.length arr) | Constant _ -> pp fmt "Constant" | Module id -> pp fmt "%s/%d" id.name id.stamp | FunctionId _ -> pp fmt "FunctionID" - | Exception -> pp fmt "Exception" | Parameter -> pp fmt "Parameter" | NA -> pp fmt "NA" diff --git a/compiler/core/lam_id_kind.mli b/compiler/core/lam_id_kind.mli index 040a63a417e..b240bd3c3cb 100644 --- a/compiler/core/lam_id_kind.mli +++ b/compiler/core/lam_id_kind.mli @@ -33,7 +33,7 @@ type rec_flag = type element = NA | SimpleForm of Lam.t -type boxed_nullable = Undefined | Null | Null_undefined +type boxed_nullable = Null | Null_undefined (** {[ let v/2 = Pnull_to_opt u]} @@ -51,14 +51,12 @@ type t = | Normal_optional of Lam.t | OptionalBlock of Lam.t * boxed_nullable | ImmutableBlock of element array - | MutableBlock of element array | Constant of Lam_constant.t | Module of Ident.t (** TODO: static module vs first class module *) | FunctionId of { mutable arity: Lam_arity.t; lambda: (Lam.t * rec_flag) option; } - | Exception | Parameter (** For this case, it can help us determine whether it should be inlined or not *) | NA diff --git a/compiler/core/lam_iter.ml b/compiler/core/lam_iter.ml index eae83894b77..f5902d82faa 100644 --- a/compiler/core/lam_iter.ml +++ b/compiler/core/lam_iter.ml @@ -26,68 +26,6 @@ type t = Lam.t type ident = Ident.t -let inner_iter (l : t) (f : t -> unit) : unit = - match l with - | Lvar (_ : ident) | Lconst (_ : Lam_constant.t) -> () - | Lapply {ap_func; ap_args; ap_info = _} -> - f ap_func; - List.iter f ap_args - | Lfunction {body; arity = _; params = _} -> f body - | Llet (_str, _id, arg, body) -> - f arg; - f body - | Lletrec (decl, body) -> - f body; - Ext_list.iter_snd decl f - | Lswitch - ( arg, - { - sw_consts; - sw_consts_full = _; - sw_blocks; - sw_blocks_full = _; - sw_failaction; - } ) -> - f arg; - Ext_list.iter_snd sw_consts f; - Ext_list.iter_snd sw_blocks f; - Ext_option.iter sw_failaction f - | Lstringswitch (arg, cases, default) -> - f arg; - Ext_list.iter_snd cases f; - Ext_option.iter default f - | Lglobal_module _ -> () - | Lprim {args; primitive = _; loc = _} -> List.iter f args - | Lstaticraise (_id, args) -> List.iter f args - | Lstaticcatch (e1, _vars, e2) -> - f e1; - f e2 - | Ltrywith (e1, _exn, e2) -> - f e1; - f e2 - | Lifthenelse (e1, e2, e3) -> - f e1; - f e2; - f e3 - | Lsequence (e1, e2) -> - f e1; - f e2 - | Lbreak | Lcontinue -> () - | Lwhile (e1, e2) -> - f e1; - f e2 - | Lfor (_v, e1, e2, _dir, e3) -> - f e1; - f e2; - f e3 - | Lfor_of (_v, e1, e2) -> - f e1; - f e2 - | Lfor_await_of (_v, e1, e2) -> - f e1; - f e2 - | Lassign (_id, e) -> f e - let inner_exists (l : t) (f : t -> bool) : bool = match l with | Lvar (_ : ident) | Lglobal_module _ | Lconst (_ : Lam_constant.t) -> false diff --git a/compiler/core/lam_iter.mli b/compiler/core/lam_iter.mli index fd52fcf9cc3..0077b5a860d 100644 --- a/compiler/core/lam_iter.mli +++ b/compiler/core/lam_iter.mli @@ -22,6 +22,4 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val inner_iter : Lam.t -> (Lam.t -> unit) -> unit - val inner_exists : Lam.t -> (Lam.t -> bool) -> bool diff --git a/compiler/core/lam_module_ident.ml b/compiler/core/lam_module_ident.ml index e92cdb4db0d..dd90d47d860 100644 --- a/compiler/core/lam_module_ident.ml +++ b/compiler/core/lam_module_ident.ml @@ -24,8 +24,6 @@ type t = J.module_id = {id: Ident.t; kind: Js_op.kind; dynamic_import: bool} -let id x = x.id - let of_ml ?(dynamic_import = false) id = {id; kind = Ml; dynamic_import} let of_runtime id = {id; kind = Runtime; dynamic_import = false} diff --git a/compiler/core/lam_module_ident.mli b/compiler/core/lam_module_ident.mli index 46ae23b06c6..639c4083551 100644 --- a/compiler/core/lam_module_ident.mli +++ b/compiler/core/lam_module_ident.mli @@ -31,8 +31,6 @@ type t = J.module_id = { dynamic_import: bool; } -val id : t -> Ident.t - val name : t -> string val of_ml : ?dynamic_import:bool -> Ident.t -> t diff --git a/compiler/core/lam_pass_alpha_conversion.ml b/compiler/core/lam_pass_alpha_conversion.ml index 7965cfc6011..9427d17028c 100644 --- a/compiler/core/lam_pass_alpha_conversion.ml +++ b/compiler/core/lam_pass_alpha_conversion.ml @@ -23,7 +23,7 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = - let rec populate_apply_info ?(ap_transformed_jsx = false) + let rec populate_apply_info ~ap_transformed_jsx (args_arity : int list) (len : int) (fn : Lam.t) (args : Lam.t list) ap_info : Lam.t = match args_arity with diff --git a/compiler/core/lam_pass_count.ml b/compiler/core/lam_pass_count.ml index 53bdf406ddf..0e3aa02b0ad 100644 --- a/compiler/core/lam_pass_count.ml +++ b/compiler/core/lam_pass_count.ml @@ -36,13 +36,6 @@ let absorb_info (x : used_info) (y : used_info) = x.times <- x0 + y0; if captured then x.captured <- true -let pp_info fmt (x : used_info) = - Format.fprintf fmt "(:%d)" x.captured x.times - -let pp_occ_tbl fmt tbl = - Hash_ident.iter tbl (fun k v -> - Format.fprintf fmt "@[%a@ %a@]@." Ident.print k pp_info v) - (* The global table [occ] associates to each let-bound identifier the number of its uses (as a reference): - 0 if never used diff --git a/compiler/core/lam_pass_count.mli b/compiler/core/lam_pass_count.mli index 547551b0dc6..727aaa40cf5 100644 --- a/compiler/core/lam_pass_count.mli +++ b/compiler/core/lam_pass_count.mli @@ -26,5 +26,3 @@ type occ_tbl = used_info Hash_ident.t val dummy_info : unit -> used_info val collect_occurs : Lam.t -> occ_tbl - -val pp_occ_tbl : Format.formatter -> occ_tbl -> unit diff --git a/compiler/core/lam_pass_lets_dce.ml b/compiler/core/lam_pass_lets_dce.ml index 503e90c1f81..18606751ca6 100644 --- a/compiler/core/lam_pass_lets_dce.ml +++ b/compiler/core/lam_pass_lets_dce.ml @@ -219,5 +219,4 @@ let apply_lets occ lambda = let simplify_lets (lam : Lam.t) : Lam.t = let occ = Lam_pass_count.collect_occurs lam in - (* Ext_log.dwarn ~__POS__ "@[%a@]@." Lam_pass_count.pp_occ_tbl occ ; *) apply_lets occ lam diff --git a/compiler/core/lam_pass_remove_alias.ml b/compiler/core/lam_pass_remove_alias.ml index 52a88ad02eb..30d8a45b2f7 100644 --- a/compiler/core/lam_pass_remove_alias.ml +++ b/compiler/core/lam_pass_remove_alias.ml @@ -35,9 +35,9 @@ let id_is_for_sure_true_in_boolean (tbl : Lam_stats.ident_tbl) id = | Some (Constant (Const_js_false | Const_js_null | Const_js_undefined _)) -> Eval_false | Some - ( Normal_optional _ | ImmutableBlock _ | MutableBlock _ | Constant _ - | Module _ | FunctionId _ | Exception | Parameter | NA - | OptionalBlock (_, (Undefined | Null | Null_undefined)) ) + ( Normal_optional _ | ImmutableBlock _ | Constant _ | Module _ + | FunctionId _ | Parameter | NA | OptionalBlock (_, (Null | Null_undefined)) + ) | None -> Eval_unknown @@ -85,17 +85,12 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = -> ( match Hash_ident.find_opt meta.ident_tbl id with | Some (Constant c) when is_const_some c -> simpl l2 - | Some (ImmutableBlock _ | MutableBlock _ | Normal_optional _) -> simpl l2 + | Some (ImmutableBlock _ | Normal_optional _) -> simpl l2 | Some (OptionalBlock (l, Null)) -> Lam.if_ (Lam.not_ Location.none (Lam.prim ~primitive:Pis_null ~args:[l] Location.none)) (simpl l2) (simpl l3) - | Some (OptionalBlock (l, Undefined)) -> - Lam.if_ - (Lam.not_ Location.none - (Lam.prim ~primitive:Pis_undefined ~args:[l] Location.none)) - (simpl l2) (simpl l3) | Some (OptionalBlock (l, Null_undefined)) -> Lam.if_ (Lam.not_ Location.none diff --git a/compiler/core/lam_primitive.ml b/compiler/core/lam_primitive.ml index 974aff095b0..ac0439907bd 100644 --- a/compiler/core/lam_primitive.ml +++ b/compiler/core/lam_primitive.ml @@ -26,13 +26,6 @@ type ident = Ident.t -type record_representation = - | Record_regular - | Record_inlined of {tag: int; name: string; num_nonconsts: int} - (* Inlined record *) - | Record_extension -(* Inlined record under extension *) - type t = (* Operations on heap blocks *) | Pmakeblock of int * Lam_tag_info.t * Asttypes.mutable_flag @@ -150,7 +143,6 @@ type t = | Pisout of int | Pjscomp of Lam_compat.comparison | Pjs_apply (*[f;arg0;arg1; arg2; ... argN]*) - | Pjs_runtime_apply (* [f; [...]] *) | Pdebugger | Pjs_unsafe_downgrade of {name: string; setter: bool} | Pinit_mod @@ -166,7 +158,6 @@ type t = | Pnull_to_opt | Pnull_undefined_to_opt | Pis_null - | Pis_undefined | Pis_null_undefined | Pimport | Ptypeof @@ -224,9 +215,9 @@ let eq_primitive_approx (lhs : t) (rhs : t) = (* promise *) | Pawait (* etc *) - | Pjs_apply | Pjs_runtime_apply | Pval_from_option | Pval_from_option_not_nest + | Pjs_apply | Pval_from_option | Pval_from_option_not_nest | Pnull_to_opt | Pnull_undefined_to_opt | Pis_null | Pis_not_none | Psome - | Psome_not_nest | Pis_undefined | Pis_null_undefined | Pimport | Ptypeof + | Psome_not_nest | Pis_null_undefined | Pimport | Ptypeof | Pfn_arity | Pis_poly_var_block | Pdebugger | Pinit_mod | Pupdate_mod | Pduprecord | Pmakearray | Parraylength | Parrayrefu | Parraysetu | Parrayrefs | Parraysets | Pjs_fn_make_unit | Pjs_fn_method | Phash diff --git a/compiler/core/lam_primitive.mli b/compiler/core/lam_primitive.mli index 8c0d26a89e1..f41c4acc94c 100644 --- a/compiler/core/lam_primitive.mli +++ b/compiler/core/lam_primitive.mli @@ -24,13 +24,6 @@ type ident = Ident.t -type record_representation = - | Record_regular - | Record_inlined of {tag: int; name: string; num_nonconsts: int} - (* Inlined record *) - | Record_extension -(* Inlined record under extension *) - type t = | Pmakeblock of int * Lam_tag_info.t * Asttypes.mutable_flag | Pfield of int * Lambda.field_dbg_info @@ -144,7 +137,6 @@ type t = | Pisout of int | Pjscomp of Lam_compat.comparison | Pjs_apply (*[f;arg0;arg1; arg2; ... argN]*) - | Pjs_runtime_apply (* [f; [...]] *) | Pdebugger | Pjs_unsafe_downgrade of {name: string; setter: bool} | Pinit_mod @@ -156,7 +148,6 @@ type t = | Pnull_to_opt | Pnull_undefined_to_opt | Pis_null - | Pis_undefined | Pis_null_undefined | Pimport | Ptypeof diff --git a/compiler/core/lam_print.ml b/compiler/core/lam_print.ml index 9408b11aea4..9cc41032226 100644 --- a/compiler/core/lam_print.ml +++ b/compiler/core/lam_print.ml @@ -50,7 +50,6 @@ let primitive ppf (prim : Lam_primitive.t) = | Pinit_mod -> fprintf ppf "init_mod!" | Pupdate_mod -> fprintf ppf "update_mod!" | Pjs_apply -> fprintf ppf "#apply" - | Pjs_runtime_apply -> fprintf ppf "#runtime_apply" (* Debug-only dump, exercised solely under -drawlambda/-dlambda. *) | Ptagged_template -> fprintf ppf "#tagged_template" [@coverage off] | Pjs_unsafe_downgrade {name; setter} -> @@ -70,7 +69,6 @@ let primitive ppf (prim : Lam_primitive.t) = | Psome_not_nest -> fprintf ppf "[some-not-nest]" | Pval_from_option -> fprintf ppf "[?unbox]" | Pval_from_option_not_nest -> fprintf ppf "[?unbox-not-nest]" - | Pis_undefined -> fprintf ppf "[?undefined]" | Pis_null_undefined -> fprintf ppf "[?null?undefined]" | Pimport -> fprintf ppf "[import]" | Pmakeblock (tag, _, Immutable) -> fprintf ppf "makeblock %i" tag @@ -493,5 +491,3 @@ let serialize (filename : string) (lam : Lam.t) : unit = Format.set_margin old let lambda_to_string = Format.asprintf "%a" lambda - -let primitive_to_string = Format.asprintf "%a" primitive diff --git a/compiler/core/lam_print.mli b/compiler/core/lam_print.mli index 383013368f4..d62dd6f6832 100644 --- a/compiler/core/lam_print.mli +++ b/compiler/core/lam_print.mli @@ -24,10 +24,6 @@ val lambda : Format.formatter -> Lam.t -> unit -val primitive : Format.formatter -> Lam_primitive.t -> unit - val serialize : string -> Lam.t -> unit val lambda_to_string : Lam.t -> string - -val primitive_to_string : Lam_primitive.t -> string diff --git a/compiler/core/lam_util.cppo.ml b/compiler/core/lam_util.cppo.ml index 9d7334930c9..cdd045aca4c 100644 --- a/compiler/core/lam_util.cppo.ml +++ b/compiler/core/lam_util.cppo.ml @@ -255,10 +255,6 @@ let dump ext lam = -let is_function (lam : Lam.t) = - match lam with - | Lfunction _ -> true | _ -> false - let not_function (lam : Lam.t) = match lam with | Lfunction _ -> false | _ -> true diff --git a/compiler/core/lam_util.mli b/compiler/core/lam_util.mli index 25e257665b5..6c6f6a0429b 100644 --- a/compiler/core/lam_util.mli +++ b/compiler/core/lam_util.mli @@ -58,5 +58,3 @@ val dump : string -> Lam.t -> unit (** [dump] when {!Js_config.is_same_file}*) val not_function : Lam.t -> bool - -val is_function : Lam.t -> bool diff --git a/compiler/depends/binary_ast.mli b/compiler/depends/binary_ast.mli index 97c98cb12bf..3b4d875c60f 100644 --- a/compiler/depends/binary_ast.mli +++ b/compiler/depends/binary_ast.mli @@ -26,8 +26,6 @@ type _ kind = Ml : Parsetree.structure kind | Mli : Parsetree.signature kind val read_ast_exn : fname:string -> 'a kind -> 'a -val magic_sep_char : char - val write_ast : sourcefile:string -> output:string -> 'a kind -> 'a -> unit (** Check out {!Bsb_depfile_gen} for set decoding diff --git a/compiler/depends/bs_exception.ml b/compiler/depends/bs_exception.ml index bd1e498d9c1..7f2d34f7094 100644 --- a/compiler/depends/bs_exception.ml +++ b/compiler/depends/bs_exception.ml @@ -25,12 +25,7 @@ type error = | Cmj_not_found of string | Js_not_found of string - | Bs_cyclic_depends of string list - | Bs_duplicated_module of string * string | Bs_duplicate_exports of string (* gpr_974 *) - | Bs_package_not_found of string - | Bs_main_not_exist of string - | Bs_invalid_path of string | Missing_ml_dependency of string | Dependency_script_module_dependent_not of string (** TODO: we need add location handling *) @@ -52,22 +47,7 @@ let report_error ppf = function s | Js_not_found s -> Format.fprintf ppf "%s not found, needed in script mode " s - | Bs_cyclic_depends str -> - Format.fprintf ppf "Cyclic depends : @[%a@]" - (Format.pp_print_list ~pp_sep:Format.pp_print_space Format.pp_print_string) - str | Bs_duplicate_exports str -> Format.fprintf ppf "%s is exported twice" str - | Bs_duplicated_module (a, b) -> - Format.fprintf ppf - "The build system does not support two files with same names yet %s, %s" a - b - | Bs_main_not_exist main -> Format.fprintf ppf "File %s not found " main - | Bs_package_not_found package -> - Format.fprintf ppf - "Package %s not found or %s/lib/ocaml does not exist or set \ - npm_config_prefix correctly" - package package - | Bs_invalid_path path -> Format.pp_print_string ppf ("Invalid path: " ^ path) let () = Location.register_error_of_exn (function diff --git a/compiler/depends/bs_exception.mli b/compiler/depends/bs_exception.mli index 53efde0a03b..a0fc7a75956 100644 --- a/compiler/depends/bs_exception.mli +++ b/compiler/depends/bs_exception.mli @@ -25,12 +25,7 @@ type error = | Cmj_not_found of string | Js_not_found of string - | Bs_cyclic_depends of string list - | Bs_duplicated_module of string * string | Bs_duplicate_exports of string (* gpr_974 *) - | Bs_package_not_found of string - | Bs_main_not_exist of string - | Bs_invalid_path of string | Missing_ml_dependency of string | Dependency_script_module_dependent_not of string (* diff --git a/compiler/ext/bsc_args.ml b/compiler/ext/bsc_args.ml index 1f907eb26b7..a7f41e2d3aa 100644 --- a/compiler/ext/bsc_args.ml +++ b/compiler/ext/bsc_args.ml @@ -26,17 +26,15 @@ type anon_fun = rev_args:string list -> unit type string_action = | String_call of (string -> unit) - | String_set of string ref | String_optional_set of string option ref | String_list_add of string list ref type unit_action = | Unit_call of (unit -> unit) - | Unit_lazy of unit lazy_t | Unit_set of bool ref | Unit_clear of bool ref -type spec = Unit_dummy | Unit of unit_action | String of string_action +type spec = Unit of unit_action | String of string_action exception Bad = Arg.Bad @@ -96,9 +94,10 @@ let stop_raise ~usage ~(error : error) (speclist : t) = usage_b b ~usage speclist; bad_arg (Ext_buffer.contents b) -let parse_exn ~usage ~argv ?(start = 1) ?(finish = Array.length argv) - (speclist : t) (anonfun : rev_args:string list -> unit) = +let parse_exn ~usage ~argv ?(start = 1) (speclist : t) + (anonfun : rev_args:string list -> unit) = let current = ref start in + let finish = Array.length argv in let rev_list = ref [] in while !current < finish do let s = argv.(!current) in @@ -107,13 +106,11 @@ let parse_exn ~usage ~argv ?(start = 1) ?(finish = Array.length argv) match Ext_spec.assoc3 speclist s with | Some action -> ( match action with - | Unit_dummy -> () | Unit r -> ( match r with | Unit_set r -> r := true | Unit_clear r -> r := false - | Unit_call f -> f () - | Unit_lazy f -> Lazy.force f) + | Unit_call f -> f ()) | String f -> ( if !current >= finish then stop_raise ~usage ~error:(Missing s) speclist @@ -122,7 +119,6 @@ let parse_exn ~usage ~argv ?(start = 1) ?(finish = Array.length argv) incr current; match f with | String_call f -> f arg - | String_set u -> u := arg | String_optional_set s -> s := Some arg | String_list_add s -> s := arg :: !s)) | None -> stop_raise ~usage ~error:(Unknown s) speclist diff --git a/compiler/ext/bsc_args.mli b/compiler/ext/bsc_args.mli index 05bf9e66cca..c66b2a5a649 100644 --- a/compiler/ext/bsc_args.mli +++ b/compiler/ext/bsc_args.mli @@ -26,17 +26,15 @@ type anon_fun = rev_args:string list -> unit type string_action = | String_call of (string -> unit) - | String_set of string ref | String_optional_set of string option ref | String_list_add of string list ref type unit_action = | Unit_call of (unit -> unit) - | Unit_lazy of unit lazy_t | Unit_set of bool ref | Unit_clear of bool ref -type spec = Unit_dummy | Unit of unit_action | String of string_action +type spec = Unit of unit_action | String of string_action type t = (string * spec * string) array @@ -48,7 +46,6 @@ val parse_exn : usage:string -> argv:string array -> ?start:int -> - ?finish:int -> t -> (rev_args:string list -> unit) -> unit diff --git a/compiler/ext/ext_array.ml b/compiler/ext/ext_array.ml index 9a416e5b0ab..1aaaa19a686 100644 --- a/compiler/ext/ext_array.ml +++ b/compiler/ext/ext_array.ml @@ -35,18 +35,6 @@ let reverse_range a i len = a.!(i + len - 1 - k) <- t done -let reverse_in_place a = reverse_range a 0 (Array.length a) - -let reverse a = - let b_len = Array.length a in - if b_len = 0 then [||] - else - let b = Array.copy a in - for i = 0 to b_len - 1 do - Array.unsafe_set b i (Array.unsafe_get a (b_len - 1 - i)) - done; - b - let reverse_of_list = function | [] -> [||] | hd :: tl -> @@ -60,49 +48,6 @@ let reverse_of_list = function in fill (len - 1) tl -let filter a f = - let arr_len = Array.length a in - let rec aux acc i = - if i = arr_len then reverse_of_list acc - else - let v = Array.unsafe_get a i in - if f v then aux (v :: acc) (i + 1) else aux acc (i + 1) - in - aux [] 0 - -let filter_map a (f : _ -> _ option) = - let arr_len = Array.length a in - let rec aux acc i = - if i = arr_len then reverse_of_list acc - else - let v = Array.unsafe_get a i in - match f v with - | Some v -> aux (v :: acc) (i + 1) - | None -> aux acc (i + 1) - in - aux [] 0 - -let filter_mapi a (f : _ -> _ -> _ option) = - let arr_len = Array.length a in - let rec aux acc i = - if i = arr_len then reverse_of_list acc - else - let v = Array.unsafe_get a i in - match f i v with - | Some v -> aux (v :: acc) (i + 1) - | None -> aux acc (i + 1) - in - aux [] 0 - -let range from to_ = - if from > to_ then invalid_arg "Ext_array.range" - else Array.init (to_ - from + 1) (fun i -> i + from) - -let map2i f a b = - let len = Array.length a in - if len <> Array.length b then invalid_arg "Ext_array.map2i" - else Array.mapi (fun i a -> f i a (Array.unsafe_get b i)) a - let rec tolist_f_aux a f i res = if i < 0 then res else @@ -111,18 +56,6 @@ let rec tolist_f_aux a f i res = let to_list_f a f = tolist_f_aux a f (Array.length a - 1) [] -let rec tolist_aux a f i res = - if i < 0 then res - else - tolist_aux a f (i - 1) - (match f a.!(i) with - | Some v -> v :: res - | None -> res) - -let to_list_map a f = tolist_aux a f (Array.length a - 1) [] - -let to_list_map_acc a acc f = tolist_aux a f (Array.length a - 1) acc - let of_list_map a f = match a with | [] -> [||] @@ -171,44 +104,6 @@ let of_list_map a f = in fill 5 tl -(** - {[ - # rfind_with_index [|1;2;3|] (=) 2;; - - : int = 1 - # rfind_with_index [|1;2;3|] (=) 1;; - - : int = 0 - # rfind_with_index [|1;2;3|] (=) 3;; - - : int = 2 - # rfind_with_index [|1;2;3|] (=) 4;; - - : int = -1 - ]} -*) -let rfind_with_index arr cmp v = - let len = Array.length arr in - let rec aux i = - if i < 0 then i - else if cmp (Array.unsafe_get arr i) v then i - else aux (i - 1) - in - aux (len - 1) - -type 'a split = No_split | Split of 'a array * 'a array - -let find_with_index arr cmp v = - let len = Array.length arr in - let rec aux i len = - if i >= len then -1 - else if cmp (Array.unsafe_get arr i) v then i - else aux (i + 1) len - in - aux 0 len - -let find_and_split arr cmp v : _ split = - let i = find_with_index arr cmp v in - if i < 0 then No_split - else - Split (Array.sub arr 0 i, Array.sub arr (i + 1) (Array.length arr - i - 1)) - (** TODO: available since 4.03, use {!Array.exists} *) let exists a p = @@ -220,14 +115,6 @@ let exists a p = in loop 0 -let is_empty arr = Array.length arr = 0 - -let rec unsafe_loop index len p xs ys = - if index >= len then true - else - p (Array.unsafe_get xs index) (Array.unsafe_get ys index) - && unsafe_loop (succ index) len p xs ys - let for_alli a p = let n = Array.length a in let rec loop i = @@ -237,11 +124,6 @@ let for_alli a p = in loop 0 -let for_all2_no_exn xs ys p = - let len_xs = Array.length xs in - let len_ys = Array.length ys in - len_xs = len_ys && unsafe_loop 0 len_xs p xs ys - let map a f = let open Array in let l = length a in @@ -266,6 +148,3 @@ let fold_left a x f = r := f !r (unsafe_get a i) done; !r - -let get_or arr i cb = - if i >= 0 && i < Array.length arr then Array.unsafe_get arr i else cb () diff --git a/compiler/ext/ext_array.mli b/compiler/ext/ext_array.mli index b55bd1a09e7..05d29b799c1 100644 --- a/compiler/ext/ext_array.mli +++ b/compiler/ext/ext_array.mli @@ -25,42 +25,14 @@ val reverse_range : 'a array -> int -> int -> unit (** Some utilities for {!Array} operations *) -val reverse_in_place : 'a array -> unit - -val reverse : 'a array -> 'a array - val reverse_of_list : 'a list -> 'a array -val filter : 'a array -> ('a -> bool) -> 'a array - -val filter_map : 'a array -> ('a -> 'b option) -> 'b array - -val filter_mapi : 'a array -> (int -> 'a -> 'b option) -> 'b array - -val range : int -> int -> int array - -val map2i : (int -> 'a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array - val to_list_f : 'a array -> ('a -> 'b) -> 'b list -val to_list_map : 'a array -> ('a -> 'b option) -> 'b list - -val to_list_map_acc : 'a array -> 'b list -> ('a -> 'b option) -> 'b list - val of_list_map : 'a list -> ('a -> 'b) -> 'b array -val rfind_with_index : 'a array -> ('a -> 'b -> bool) -> 'b -> int - -type 'a split = No_split | Split of 'a array * 'a array - -val find_and_split : 'a array -> ('a -> 'b -> bool) -> 'b -> 'a split - val exists : 'a array -> ('a -> bool) -> bool -val is_empty : 'a array -> bool - -val for_all2_no_exn : 'a array -> 'b array -> ('a -> 'b -> bool) -> bool - val for_alli : 'a array -> (int -> 'a -> bool) -> bool val map : 'a array -> ('a -> 'b) -> 'b array @@ -68,5 +40,3 @@ val map : 'a array -> ('a -> 'b) -> 'b array val iter : 'a array -> ('a -> unit) -> unit val fold_left : 'b array -> 'a -> ('a -> 'b -> 'a) -> 'a - -val get_or : 'a array -> int -> (unit -> 'a) -> 'a diff --git a/compiler/ext/ext_basic_hash_stubs.c b/compiler/ext/ext_basic_hash_stubs.c index 4937997fecd..80f1f58d7e1 100644 --- a/compiler/ext/ext_basic_hash_stubs.c +++ b/compiler/ext/ext_basic_hash_stubs.c @@ -179,38 +179,7 @@ CAMLprim value caml_stale_file(value path) } #endif - -CAMLprim value caml_sys_is_directory_no_exn(value name) -{ - CAMLparam1(name); -#ifdef _WIN32 - struct _stati64 st; -#else - struct stat st; -#endif - char_os * p; - int ret; - - - if(!caml_string_is_c_safe(name)){ - CAMLreturn(Val_false); - } - - p = caml_stat_strdup_to_os(String_val(name)); - caml_enter_blocking_section(); - ret = stat_os(p, &st); - caml_leave_blocking_section(); - caml_stat_free(p); - - if (ret == -1) CAMLreturn(Val_false); -#ifdef S_ISDIR - CAMLreturn(Val_bool(S_ISDIR(st.st_mode))); -#else - CAMLreturn(Val_bool(st.st_mode & S_IFDIR)); -#endif -} /* local variables: */ /* compile-command: "ocamlopt.opt -c ext_basic_hash_stubs.c" */ /* end: */ - diff --git a/compiler/ext/ext_buffer.ml b/compiler/ext/ext_buffer.ml index b88b3b8b8c6..60f3e138568 100644 --- a/compiler/ext/ext_buffer.ml +++ b/compiler/ext/ext_buffer.ml @@ -41,8 +41,6 @@ let length b = b.position let is_empty b = b.position = 0 -let clear b = b.position <- 0 - (* let reset b = b.position <- 0; b.buffer <- b.initial_buffer; b.length <- Bytes.length b.buffer *) @@ -123,10 +121,6 @@ let add_char_string b c s = let output_buffer oc b = output oc b.buffer 0 b.position -external unsafe_string : bytes -> int -> int -> Digest.t = "caml_md5_string" - -let digest b = unsafe_string b.buffer 0 b.position - let rec not_equal_aux (b : bytes) (s : string) i len = if i >= len then false else @@ -138,6 +132,7 @@ let not_equal (b : t) (s : string) = let b_len = b.position in let s_len = String.length s in b_len <> s_len || not_equal_aux b.buffer s 0 s_len +[@@live] (** It could be one byte, two bytes, three bytes and four bytes @@ -149,6 +144,7 @@ let add_int_1 (b : t) (x : int) = if pos >= b.length then resize b 1; Bytes.unsafe_set b.buffer pos c; b.position <- pos + 1 +[@@live] let add_int_2 (b : t) (x : int) = let c1 = Char.unsafe_chr (x land 0xff) in @@ -159,6 +155,7 @@ let add_int_2 (b : t) (x : int) = Bytes.unsafe_set b_buffer pos c1; Bytes.unsafe_set b_buffer (pos + 1) c2; b.position <- pos + 2 +[@@live] let add_int_3 (b : t) (x : int) = let c1 = Char.unsafe_chr (x land 0xff) in @@ -171,6 +168,7 @@ let add_int_3 (b : t) (x : int) = Bytes.unsafe_set b_buffer (pos + 1) c2; Bytes.unsafe_set b_buffer (pos + 2) c3; b.position <- pos + 3 +[@@live] let add_int_4 (b : t) (x : int) = let c1 = Char.unsafe_chr (x land 0xff) in @@ -185,3 +183,4 @@ let add_int_4 (b : t) (x : int) = Bytes.unsafe_set b_buffer (pos + 2) c3; Bytes.unsafe_set b_buffer (pos + 3) c4; b.position <- pos + 4 +[@@live] diff --git a/compiler/ext/ext_buffer.mli b/compiler/ext/ext_buffer.mli index e42861df887..2f0587f0a7b 100644 --- a/compiler/ext/ext_buffer.mli +++ b/compiler/ext/ext_buffer.mli @@ -47,9 +47,6 @@ val length : t -> int val is_empty : t -> bool -val clear : t -> unit -(** Empty the buffer. *) - val add_char : t -> char -> unit (** [add_char b c] appends the character [c] at the end of the buffer [b]. *) @@ -83,17 +80,15 @@ val output_buffer : out_channel -> t -> unit (** [output_buffer oc b] writes the current contents of buffer [b] on the output channel [oc]. *) -val digest : t -> Digest.t - -val not_equal : t -> string -> bool +val not_equal : t -> string -> bool [@@live] -val add_int_1 : t -> int -> unit +val add_int_1 : t -> int -> unit [@@live] -val add_int_2 : t -> int -> unit +val add_int_2 : t -> int -> unit [@@live] -val add_int_3 : t -> int -> unit +val add_int_3 : t -> int -> unit [@@live] -val add_int_4 : t -> int -> unit +val add_int_4 : t -> int -> unit [@@live] val add_string_char : t -> string -> char -> unit diff --git a/compiler/ext/ext_digest.ml b/compiler/ext/ext_digest.ml index b2143a3bba5..a0a53e599f4 100644 --- a/compiler/ext/ext_digest.ml +++ b/compiler/ext/ext_digest.ml @@ -23,5 +23,3 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let length = 16 - -let hex_length = 32 diff --git a/compiler/ext/ext_digest.mli b/compiler/ext/ext_digest.mli index 150f643444c..2f1808a79be 100644 --- a/compiler/ext/ext_digest.mli +++ b/compiler/ext/ext_digest.mli @@ -23,5 +23,3 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) val length : int - -val hex_length : int diff --git a/compiler/ext/ext_filename.ml b/compiler/ext/ext_filename.ml index fd7c64c4267..136c55dbbb8 100644 --- a/compiler/ext/ext_filename.ml +++ b/compiler/ext/ext_filename.ml @@ -28,14 +28,6 @@ let is_dir_sep_win_cygwin c = c = '/' || c = '\\' || c = ':' let is_dir_sep = if Sys.unix then is_dir_sep_unix else is_dir_sep_win_cygwin -let chop_extension_maybe name = - let rec search_dot i = - if i < 0 || is_dir_sep (String.unsafe_get name i) then name - else if String.unsafe_get name i = '.' then String.sub name 0 i - else search_dot (i - 1) - in - search_dot (String.length name - 1) - let get_extension_maybe name = let name_len = String.length name in let rec search_dot name i name_len = @@ -55,6 +47,7 @@ let chop_all_extensions_maybe name = else search_dot (i - 1) last in search_dot (String.length name - 1) None +[@@live] let new_extension name (ext : string) = let rec search_dot name i ext = @@ -86,7 +79,10 @@ let module_name name = let name_len = String.length name in search_dot (name_len - 1) name -type module_info = {module_name: string; case: bool} +type module_info = { + module_name: string; [@live] + case: bool; [@live] +} let rec valid_module_name_aux name off len = if off >= len then true @@ -130,3 +126,4 @@ let as_module ~basename = in let name_len = String.length basename in search_dot (name_len - 1) basename name_len +[@@live] diff --git a/compiler/ext/ext_filename.mli b/compiler/ext/ext_filename.mli index 5c678310b9e..8373a0ea2da 100644 --- a/compiler/ext/ext_filename.mli +++ b/compiler/ext/ext_filename.mli @@ -33,18 +33,19 @@ val is_dir_sep : char -> bool -val chop_extension_maybe : string -> string - (* return an empty string if no extension found *) val get_extension_maybe : string -> string val new_extension : string -> string -> string -val chop_all_extensions_maybe : string -> string +val chop_all_extensions_maybe : string -> string [@@live] (* OCaml specific abstraction*) val module_name : string -> string -type module_info = {module_name: string; case: bool} +type module_info = { + module_name: string; [@live] + case: bool; [@live] +} -val as_module : basename:string -> module_info option +val as_module : basename:string -> module_info option [@@live] diff --git a/compiler/ext/ext_fmt.ml b/compiler/ext/ext_fmt.ml index ea59637c491..7658c4dfd3f 100644 --- a/compiler/ext/ext_fmt.ml +++ b/compiler/ext/ext_fmt.ml @@ -6,5 +6,3 @@ let with_file_as_pp filename f = v) let failwithf ~loc fmt = Format.ksprintf (fun s -> failwith (loc ^ s)) fmt - -let invalid_argf fmt = Format.ksprintf invalid_arg fmt diff --git a/compiler/ext/ext_ident.ml b/compiler/ext/ext_ident.ml index 8a7910ca381..9dfcc9ba168 100644 --- a/compiler/ext/ext_ident.ml +++ b/compiler/ext/ext_ident.ml @@ -38,8 +38,6 @@ let is_js (i : Ident.t) = i.flags land js_flag <> 0 let is_js_or_global (i : Ident.t) = i.flags land (8 lor 1) <> 0 -let is_js_object (i : Ident.t) = i.flags land js_object_flag <> 0 - let make_js_object (i : Ident.t) = i.flags <- i.flags lor js_object_flag (* It's a js function hard coded by js api, so when printing, @@ -52,8 +50,6 @@ let create = Ident.create (* FIXME: no need for `$' operator *) let create_tmp ?(name = Literals.tmp) () = create name -let js_module_table : Ident.t Hash_string.t = Hash_string.create 31 - (* This is for a js exeternal module, we can change it when printing for example {[ @@ -81,7 +77,7 @@ let js_module_table : Ident.t Hash_string.t = Hash_string.create 31 | v -> (* v *) Ident.rename v *) -let[@inline] convert ?(op = false) (c : char) : string = +let[@inline] convert_char ~op (c : char) : string = match c with | '*' -> "$star" | '\'' -> "$p" @@ -146,7 +142,7 @@ let name_mangle name = for j = 0 to len - 1 do let c = String.unsafe_get name j in if no_escape c then Ext_buffer.add_char buffer c - else Ext_buffer.add_string buffer (convert ~op:(i = 0) c) + else Ext_buffer.add_string buffer (convert_char ~op:(i = 0) c) done; Ext_buffer.contents buffer @@ -169,8 +165,6 @@ let convert (name : string) = *) let make_unused () = create "_" -let reset () = Hash_string.clear js_module_table - (* Has to be total order, [x < y] and [x > y] should be consistent flags are not relevant here diff --git a/compiler/ext/ext_ident.mli b/compiler/ext/ext_ident.mli index ff21fca3c56..9172b27a868 100644 --- a/compiler/ext/ext_ident.mli +++ b/compiler/ext/ext_ident.mli @@ -26,8 +26,6 @@ val is_js : Ident.t -> bool -val is_js_object : Ident.t -> bool - val create_js : string -> Ident.t (** create identifiers for predefined [js] global variables *) @@ -35,16 +33,12 @@ val create : string -> Ident.t val make_js_object : Ident.t -> unit -val reset : unit -> unit - val create_tmp : ?name:string -> unit -> Ident.t val make_unused : unit -> Ident.t val is_uident : string -> bool -val is_uppercase_exotic : string -> bool - val unwrap_uppercase_exotic : string -> string val convert : string -> string diff --git a/compiler/ext/ext_io.ml b/compiler/ext/ext_io.ml index ffb84a49d93..0ba82d5fc28 100644 --- a/compiler/ext/ext_io.ml +++ b/compiler/ext/ext_io.ml @@ -40,9 +40,6 @@ let rev_lines_of_chann chan = in loop [] chan -let rev_lines_of_file file = - Ext_pervasives.finally ~clean:close_in (open_in_bin file) rev_lines_of_chann - let write_file f content = Ext_pervasives.finally ~clean:close_out (open_out_bin f) (fun oc -> output_string oc content) diff --git a/compiler/ext/ext_io.mli b/compiler/ext/ext_io.mli index edbebfca7cd..17edaaf379d 100644 --- a/compiler/ext/ext_io.mli +++ b/compiler/ext/ext_io.mli @@ -24,8 +24,6 @@ val load_file : string -> string -val rev_lines_of_file : string -> string list - val rev_lines_of_chann : in_channel -> string list val write_file : string -> string -> unit diff --git a/compiler/ext/ext_js_file_kind.ml b/compiler/ext/ext_js_file_kind.ml index 2efce680a8c..225047474c7 100644 --- a/compiler/ext/ext_js_file_kind.ml +++ b/compiler/ext/ext_js_file_kind.ml @@ -22,5 +22,3 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type case = Upper | Little - -type t = {case: case; suffix: string} [@@warning "-69"] diff --git a/compiler/ext/ext_list.ml b/compiler/ext/ext_list.ml index e7681aee305..bdb72042c5e 100644 --- a/compiler/ext/ext_list.ml +++ b/compiler/ext/ext_list.ml @@ -75,10 +75,6 @@ let rec arr_list_combine_unsafe arr l i j acc f = | h :: tl -> (f arr.!(i), h) :: arr_list_combine_unsafe arr tl (i + 1) j acc f -let combine_array_append arr l acc f = - let len = Array.length arr in - arr_list_combine_unsafe arr l 0 len acc f - let combine_array arr l f = let len = Array.length arr in arr_list_combine_unsafe arr l 0 len [] f @@ -97,20 +93,6 @@ let array_list_filter_map arr l f = let len = Array.length arr in arr_list_filter_map_unasfe arr l 0 len [] f -let rec map_split_opt (xs : 'a list) (f : 'a -> 'b option * 'c option) : - 'b list * 'c list = - match xs with - | [] -> ([], []) - | x :: xs -> ( - let c, d = f x in - let cs, ds = map_split_opt xs f in - ( (match c with - | Some c -> c :: cs - | None -> cs), - match d with - | Some d -> d :: ds - | None -> ds )) - let rec map_snd l f = match l with | [] -> [] @@ -284,41 +266,6 @@ let rec fold_right3 l r last acc f = (f a3 b3 c3 (f a4 b4 c4 (fold_right3 arest brest crest acc f))))) | _, _, _ -> invalid_arg "Ext_list.fold_right2" -let rec map2i l r f = - match (l, r) with - | [], [] -> [] - | [a0], [b0] -> [f 0 a0 b0] - | [a0; a1], [b0; b1] -> - let c0 = f 0 a0 b0 in - let c1 = f 1 a1 b1 in - [c0; c1] - | [a0; a1; a2], [b0; b1; b2] -> - let c0 = f 0 a0 b0 in - let c1 = f 1 a1 b1 in - let c2 = f 2 a2 b2 in - [c0; c1; c2] - | [a0; a1; a2; a3], [b0; b1; b2; b3] -> - let c0 = f 0 a0 b0 in - let c1 = f 1 a1 b1 in - let c2 = f 2 a2 b2 in - let c3 = f 3 a3 b3 in - [c0; c1; c2; c3] - | [a0; a1; a2; a3; a4], [b0; b1; b2; b3; b4] -> - let c0 = f 0 a0 b0 in - let c1 = f 1 a1 b1 in - let c2 = f 2 a2 b2 in - let c3 = f 3 a3 b3 in - let c4 = f 4 a4 b4 in - [c0; c1; c2; c3; c4] - | a0 :: a1 :: a2 :: a3 :: a4 :: arest, b0 :: b1 :: b2 :: b3 :: b4 :: brest -> - let c0 = f 0 a0 b0 in - let c1 = f 1 a1 b1 in - let c2 = f 2 a2 b2 in - let c3 = f 3 a3 b3 in - let c4 = f 4 a4 b4 in - c0 :: c1 :: c2 :: c3 :: c4 :: map2i arest brest f - | _, _ -> invalid_arg "Ext_list.map2" - let rec map2 l r f = match (l, r) with | [], [] -> [] @@ -367,26 +314,6 @@ let rec filter_map xs (f : 'a -> 'b option) = | None -> filter_map ys f | Some z -> z :: filter_map ys f) -let rec exclude (xs : 'a list) (p : 'a -> bool) : 'a list = - match xs with - | [] -> [] - | x :: xs -> if p x then exclude xs p else x :: exclude xs p - -let rec exclude_with_val l p = - match l with - | [] -> None - | a0 :: xs -> ( - if p a0 then Some (exclude xs p) - else - match xs with - | [] -> None - | a1 :: rest -> ( - if p a1 then Some (a0 :: exclude rest p) - else - match exclude_with_val rest p with - | None -> None - | Some rest -> Some (a0 :: a1 :: rest))) - let rec same_length xs ys = match (xs, ys) with | [], [] -> true @@ -441,24 +368,6 @@ let rec small_split_at n acc l = let split_at l n = small_split_at n [] l -let rec split_at_last_aux acc x = - match x with - | [] -> invalid_arg "Ext_list.split_at_last" - | [x] -> (rev acc, x) - | y0 :: ys -> split_at_last_aux (y0 :: acc) ys - -let split_at_last (x : 'a list) = - match x with - | [] -> invalid_arg "Ext_list.split_at_last" - | [a0] -> ([], a0) - | [a0; a1] -> ([a0], a1) - | [a0; a1; a2] -> ([a0; a1], a2) - | [a0; a1; a2; a3] -> ([a0; a1; a2], a3) - | [a0; a1; a2; a3; a4] -> ([a0; a1; a2; a3], a4) - | a0 :: a1 :: a2 :: a3 :: a4 :: rest -> - let rev, last = split_at_last_aux [] rest in - (a0 :: a1 :: a2 :: a3 :: a4 :: rev, last) - (** can not do loop unroll due to state combination *) @@ -473,15 +382,6 @@ let filter_mapi xs f = in aux 0 xs -let rec filter_map2 xs ys (f : 'a -> 'b -> 'c option) = - match (xs, ys) with - | [], [] -> [] - | u :: us, v :: vs -> ( - match f u v with - | None -> filter_map2 us vs f (* idea: rec f us vs instead? *) - | Some z -> z :: filter_map2 us vs f) - | _ -> invalid_arg "Ext_list.filter_map2" - let rec rev_map_append l1 l2 f = match l1 with | [] -> l2 @@ -506,8 +406,6 @@ let rec flat_map_aux f acc append lx = let flat_map lx f = flat_map_aux f [] [] lx -let flat_map_append lx append f = flat_map_aux f [] append lx - let rec length_compare l n = if n < 0 then `Gt else @@ -546,14 +444,6 @@ and aux eq (x : 'a) (xss : 'a list list) : 'a list list = let stable_group lst eq = group eq lst |> rev -let rec drop h n = - if n < 0 then invalid_arg "Ext_list.drop" - else if n = 0 then h - else - match h with - | [] -> invalid_arg "Ext_list.drop" - | _ :: tl -> drop tl (n - 1) - let rec find_first x p = match x with | [] -> None @@ -746,11 +636,6 @@ let rec fold_left l accu f = | [] -> accu | a :: l -> fold_left l (f accu a) f -let reduce_from_left lst fn = - match lst with - | first :: rest -> fold_left rest first fn - | _ -> invalid_arg "Ext_list.reduce_from_left" - let rec fold_left2 l1 l2 accu f = match (l1, l2) with | [], [] -> accu @@ -762,11 +647,6 @@ let singleton_exn xs = | [x] -> x | _ -> assert false -let rec mem_string (xs : string list) (x : string) = - match xs with - | [] -> false - | a :: l -> a = x || mem_string l x - let filter lst p = let rec find ~p accu lst = match lst with diff --git a/compiler/ext/ext_list.mli b/compiler/ext/ext_list.mli index c5e65149e96..0a6c16ec7ef 100644 --- a/compiler/ext/ext_list.mli +++ b/compiler/ext/ext_list.mli @@ -28,14 +28,8 @@ val map_combine : 'a list -> 'b list -> ('a -> 'c) -> ('c * 'b) list val combine_array : 'a array -> 'b list -> ('a -> 'c) -> ('c * 'b) list -val combine_array_append : - 'a array -> 'b list -> ('c * 'b) list -> ('a -> 'c) -> ('c * 'b) list - val has_string : string list -> string -> bool -val map_split_opt : - 'a list -> ('a -> 'b option * 'c option) -> 'b list * 'c list - val mapi : 'a list -> (int -> 'a -> 'b) -> 'b list val mapi_append : 'a list -> (int -> 'a -> 'b) -> 'b list -> 'b list @@ -70,25 +64,12 @@ val fold_right3 : val map2 : 'a list -> 'b list -> ('a -> 'b -> 'c) -> 'c list -val map2i : 'a list -> 'b list -> (int -> 'a -> 'b -> 'c) -> 'c list - val fold_left_with_offset : 'a list -> 'acc -> int -> ('a -> 'acc -> int -> 'acc) -> 'acc val filter_map : 'a list -> ('a -> 'b option) -> 'b list (** @unused *) -val exclude : 'a list -> ('a -> bool) -> 'a list -(** [exclude p l] is the opposite of [filter p l] *) - -val exclude_with_val : 'a list -> ('a -> bool) -> 'a list option -(** [excludes p l] - return a tuple [excluded,newl] - where [exluded] is true indicates that at least one - element is removed,[newl] is the new list where all [p x] for [x] is false - -*) - val same_length : 'a list -> 'b list -> bool val init : int -> (int -> 'a) -> 'a list @@ -99,17 +80,8 @@ val split_at : 'a list -> int -> 'a list * 'a list otherwise, it will raise *) -val split_at_last : 'a list -> 'a list * 'a -(** [split_at_last l] - It is equivalent to [split_at (List.length l - 1) l ] -*) - val filter_mapi : 'a list -> ('a -> int -> 'b option) -> 'b list -val filter_map2 : 'a list -> 'b list -> ('a -> 'b -> 'c option) -> 'c list - -val length_compare : 'a list -> int -> [`Gt | `Eq | `Lt] - val length_ge : 'a list -> int -> bool (** @@ -131,8 +103,6 @@ val rev_map_append : 'a list -> 'b list -> ('a -> 'b) -> 'b list val flat_map : 'a list -> ('a -> 'b list) -> 'b list -val flat_map_append : 'a list -> 'b list -> ('a -> 'b list) -> 'b list - val stable_group : 'a list -> ('a -> 'a -> bool) -> 'a list list (** [stable_group eq lst] @@ -149,12 +119,6 @@ val stable_group : 'a list -> ('a -> 'a -> bool) -> 'a list list which could be improved later *) -val drop : 'a list -> int -> 'a list -(** [drop n list] - raise when [n] is negative - raise when list's length is less than [n] -*) - val find_first : 'a list -> ('a -> bool) -> 'a option val find_first_not : 'a list -> ('a -> bool) -> 'a option @@ -189,9 +153,6 @@ val for_all2_no_exn : 'a list -> 'b list -> ('a -> 'b -> bool) -> bool val split_map : 'a list -> ('a -> 'b * 'c) -> 'b list * 'c list (** [f] is applied follow the list order *) -val reduce_from_left : 'a list -> ('a -> 'a -> 'a) -> 'a -(** [fn] is applied from left to right *) - val sort_via_array : 'a list -> ('a -> 'a -> int) -> 'a list val sort_via_arrayf : 'a list -> ('a -> 'a -> int) -> ('a -> 'b) -> 'b list @@ -225,8 +186,6 @@ val fold_left : 'a list -> 'b -> ('b -> 'a -> 'b) -> 'b val singleton_exn : 'a list -> 'a -val mem_string : string list -> string -> bool - val filter : 'a list -> ('a -> bool) -> 'a list val array_list_filter_map : diff --git a/compiler/ext/ext_obj.ml b/compiler/ext/ext_obj.ml index c81e86f232f..825d8a5363d 100644 --- a/compiler/ext/ext_obj.ml +++ b/compiler/ext/ext_obj.ml @@ -98,29 +98,4 @@ let rec dump r = ^ "|]" | _ -> opaque (Printf.sprintf "unknown: tag %d size %d" t s) -let dump v = dump (Obj.repr v) - -let dump_endline ?(__LOC__ = "") v = - print_endline __LOC__; - print_endline (dump v) - -let pp_any fmt v = Format.fprintf fmt "@[%s@]" (dump v) - -let bt () = - let raw_bt = Printexc.backtrace_slots (Printexc.get_raw_backtrace ()) in - match raw_bt with - | None -> () - | Some raw_bt -> - let acc = ref [] in - for i = Array.length raw_bt - 1 downto 0 do - let slot = raw_bt.(i) in - match Printexc.Slot.location slot with - | None -> () - | Some bt -> ( - match !acc with - | [] -> acc := [bt] - | hd :: _ -> if hd <> bt then acc := bt :: !acc) - done; - Ext_list.iter !acc (fun bt -> - Printf.eprintf "File \"%s\", line %d, characters %d-%d\n" bt.filename - bt.line_number bt.start_char bt.end_char) +let dump v = dump (Obj.repr v) [@@live] diff --git a/compiler/ext/ext_obj.mli b/compiler/ext/ext_obj.mli index dddf4735ab2..54895324911 100644 --- a/compiler/ext/ext_obj.mli +++ b/compiler/ext/ext_obj.mli @@ -21,10 +21,4 @@ * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val dump : 'a -> string - -val dump_endline : ?__LOC__:string -> 'a -> unit - -val pp_any : Format.formatter -> 'a -> unit - -val bt : unit -> unit +val dump : 'a -> string [@@live] diff --git a/compiler/ext/ext_pp.ml b/compiler/ext/ext_pp.ml index f9237c271a7..aaca8bb0c0d 100644 --- a/compiler/ext/ext_pp.ml +++ b/compiler/ext/ext_pp.ml @@ -28,8 +28,6 @@ module L = struct let indent_str = " " end -let indent_length = String.length L.indent_str - type t = { output_string: string -> unit; output_char: char -> unit; @@ -90,8 +88,6 @@ let force_newline t = let space t = string t L.space -let nspace t n = string t (String.make n ' ') - let group t i action = if i = 0 then action () else diff --git a/compiler/ext/ext_pp.mli b/compiler/ext/ext_pp.mli index aaf2176214a..271eae3725e 100644 --- a/compiler/ext/ext_pp.mli +++ b/compiler/ext/ext_pp.mli @@ -35,14 +35,10 @@ type t } *) -val indent_length : int - val string : t -> string -> unit val space : t -> unit -val nspace : t -> int -> unit - val group : t -> int -> (unit -> 'a) -> 'a (** [group] will record current indentation and indent futher diff --git a/compiler/ext/ext_pp_scope.ml b/compiler/ext/ext_pp_scope.ml index f074a411f00..317d38afb3a 100644 --- a/compiler/ext/ext_pp_scope.ml +++ b/compiler/ext/ext_pp_scope.ml @@ -29,15 +29,6 @@ type t = int Map_int.t Map_string.t *) let empty : t = Map_string.empty -let rec print fmt v = - Format.fprintf fmt "@[{"; - Map_string.iter v (fun k m -> - Format.fprintf fmt "%s: @[%a@],@ " k print_int_map m); - Format.fprintf fmt "}@]" - -and print_int_map fmt m = - Map_int.iter m (fun k v -> Format.fprintf fmt "%d - %d" k v) - let add_ident ~mangled:name (stamp : int) (cxt : t) : int * t = match Map_string.find_opt cxt name with | None -> (0, Map_string.add cxt name (Map_int.add Map_int.empty stamp 0)) diff --git a/compiler/ext/ext_pp_scope.mli b/compiler/ext/ext_pp_scope.mli index 460a0354d36..2eae91087f2 100644 --- a/compiler/ext/ext_pp_scope.mli +++ b/compiler/ext/ext_pp_scope.mli @@ -33,8 +33,6 @@ type t val empty : t -val print : Format.formatter -> t -> unit - val sub_scope : t -> Set_ident.t -> t val merge : t -> Set_ident.t -> t diff --git a/compiler/ext/ext_ref.ml b/compiler/ext/ext_ref.ml index e0afb7892d0..3550d4fc67d 100644 --- a/compiler/ext/ext_ref.ml +++ b/compiler/ext/ext_ref.ml @@ -22,13 +22,6 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -let non_exn_protect r v body = - let old = !r in - r := v; - let res = body () in - r := old; - res - let protect r v body = let old = !r in try @@ -39,39 +32,3 @@ let protect r v body = with x -> r := old; raise x - -let non_exn_protect2 r1 r2 v1 v2 body = - let old1 = !r1 in - let old2 = !r2 in - r1 := v1; - r2 := v2; - let res = body () in - r1 := old1; - r2 := old2; - res - -let protect2 r1 r2 v1 v2 body = - let old1 = !r1 in - let old2 = !r2 in - try - r1 := v1; - r2 := v2; - let res = body () in - r1 := old1; - r2 := old2; - res - with x -> - r1 := old1; - r2 := old2; - raise x - -let protect_list rvs body = - let olds = Ext_list.map rvs (fun (x, _) -> !x) in - let () = List.iter (fun (x, y) -> x := y) rvs in - try - let res = body () in - List.iter2 (fun (x, _) old -> x := old) rvs olds; - res - with e -> - List.iter2 (fun (x, _) old -> x := old) rvs olds; - raise e diff --git a/compiler/ext/ext_ref.mli b/compiler/ext/ext_ref.mli index 94a47dcf08d..8ca93af1e91 100644 --- a/compiler/ext/ext_ref.mli +++ b/compiler/ext/ext_ref.mli @@ -22,19 +22,4 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -(** [non_exn_protect ref value f] assusme [f()] - would not raise -*) - -val non_exn_protect : 'a ref -> 'a -> (unit -> 'b) -> 'b - val protect : 'a ref -> 'a -> (unit -> 'b) -> 'b - -val protect2 : 'a ref -> 'b ref -> 'a -> 'b -> (unit -> 'c) -> 'c - -val non_exn_protect2 : 'a ref -> 'b ref -> 'a -> 'b -> (unit -> 'c) -> 'c -(** [non_exn_protect2 refa refb va vb f ] - assume [f ()] would not raise -*) - -val protect_list : ('a ref * 'a) list -> (unit -> 'b) -> 'b diff --git a/compiler/ext/ext_scc.ml b/compiler/ext/ext_scc.ml index d640d68714a..7d13269b93a 100644 --- a/compiler/ext/ext_scc.ml +++ b/compiler/ext/ext_scc.ml @@ -99,3 +99,4 @@ let graph_check v = let v = graph v in ( Int_vec_vec.length v, Int_vec_vec.fold_left (fun acc x -> Vec_int.length x :: acc) [] v ) +[@@live] diff --git a/compiler/ext/ext_scc.mli b/compiler/ext/ext_scc.mli index b72bc8228e7..ca84b10bd63 100644 --- a/compiler/ext/ext_scc.mli +++ b/compiler/ext/ext_scc.mli @@ -38,5 +38,5 @@ val graph : Vec_int.t array -> Int_vec_vec.t [Array.length] of the input *) -val graph_check : node array -> int * int list +val graph_check : node array -> int * int list [@@live] (** Used for unit test *) diff --git a/compiler/ext/ext_sys.cppo.ml b/compiler/ext/ext_sys.cppo.ml index 917d397550e..021a93fc6a5 100644 --- a/compiler/ext/ext_sys.cppo.ml +++ b/compiler/ext/ext_sys.cppo.ml @@ -22,15 +22,5 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -(** TODO: not exported yet, wait for Windows Fix*) -#ifdef BROWSER -let is_directory_no_exn f = - try Sys.is_directory f with _ -> false -#else -external is_directory_no_exn : string -> bool = "caml_sys_is_directory_no_exn" -#endif - - let is_windows_or_cygwin = Sys.win32 || Sys.cygwin - diff --git a/compiler/ext/ext_sys.mli b/compiler/ext/ext_sys.mli index f884380ae84..9959f6a34cd 100644 --- a/compiler/ext/ext_sys.mli +++ b/compiler/ext/ext_sys.mli @@ -22,6 +22,4 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val is_directory_no_exn : string -> bool - val is_windows_or_cygwin : bool diff --git a/compiler/ext/ext_utf8.ml b/compiler/ext/ext_utf8.ml index 04846c1e527..7edd8aed3a0 100644 --- a/compiler/ext/ext_utf8.ml +++ b/compiler/ext/ext_utf8.ml @@ -96,6 +96,7 @@ let decode_utf8_string s = in decode_utf8_cont s 0 (String.length s); List.rev !lst +[@@live] (** To decode {j||j} we need verify in the ast so that we have better error location, then we do the decode later diff --git a/compiler/ext/ext_utf8.mli b/compiler/ext/ext_utf8.mli index e1beadec594..a72256f1671 100644 --- a/compiler/ext/ext_utf8.mli +++ b/compiler/ext/ext_utf8.mli @@ -26,8 +26,6 @@ type byte = Single of int | Cont of int | Leading of int * int | Invalid val classify : char -> byte -val follow : string -> int -> int -> int -> int * int - val next : string -> remaining:int -> int -> int (** return [-1] if failed @@ -35,6 +33,6 @@ val next : string -> remaining:int -> int -> int exception Invalid_utf8 of string -val decode_utf8_string : string -> int list +val decode_utf8_string : string -> int list [@@live] val encode_codepoint : int -> string diff --git a/compiler/ext/ext_util.ml b/compiler/ext/ext_util.ml index 58b8ad2a177..0b6ca038895 100644 --- a/compiler/ext/ext_util.ml +++ b/compiler/ext/ext_util.ml @@ -33,14 +33,6 @@ let rec power_2_above x n = else if x * 2 > Sys.max_array_length then x else power_2_above (x * 2) n -let stats_to_string - ({num_bindings; num_buckets; max_bucket_length; bucket_histogram} : - Hashtbl.statistics) = - Printf.sprintf "bindings: %d,buckets: %d, longest: %d, hist:[%s]" num_bindings - num_buckets max_bucket_length - (String.concat "," - (Array.to_list (Array.map string_of_int bucket_histogram))) - let string_of_int_as_char (i : int) : string = if i <= 255 && i >= 0 then Format.asprintf "%C" (Char.unsafe_chr i) else diff --git a/compiler/ext/ext_util.mli b/compiler/ext/ext_util.mli index 720e5b19b24..ab641063ef3 100644 --- a/compiler/ext/ext_util.mli +++ b/compiler/ext/ext_util.mli @@ -24,6 +24,4 @@ val power_2_above : int -> int -> int -val stats_to_string : Hashtbl.statistics -> string - val string_of_int_as_char : int -> string diff --git a/compiler/ext/hash_set_poly.mli b/compiler/ext/hash_set_poly.mli index 1539d3f7bf5..7bee1e76a20 100644 --- a/compiler/ext/hash_set_poly.mli +++ b/compiler/ext/hash_set_poly.mli @@ -26,10 +26,6 @@ type 'a t val create : int -> 'a t -val clear : 'a t -> unit - -val reset : 'a t -> unit - (* val copy : 'a t -> 'a t *) val add : 'a t -> 'a -> unit @@ -40,8 +36,6 @@ val mem : 'a t -> 'a -> bool val iter : 'a t -> ('a -> unit) -> unit -val to_list : 'a t -> 'a list - val length : 'a t -> int (* val stats: 'a t -> Hashtbl.statistics *) diff --git a/compiler/ext/ident.ml b/compiler/ext/ident.ml index a5ca80e840f..91c193af48d 100644 --- a/compiler/ext/ident.ml +++ b/compiler/ext/ident.ml @@ -41,8 +41,6 @@ let rename i = let name i = i.name -let unique_name i = i.name ^ "_" ^ string_of_int i.stamp - let unique_toplevel_name i = i.name ^ "/" ^ string_of_int i.stamp let persistent i = i.stamp = 0 @@ -222,17 +220,3 @@ let compare x y = else let c = compare x.name y.name in if c <> 0 then c else compare x.flags y.flags - -let output oc id = output_string oc (unique_name id) -let hash i = Char.code i.name.[0] lxor i.stamp - -let original_equal = equal -include Identifiable.Make (struct - type nonrec t = t - let compare = compare - let output = output - let print = print - let hash = hash - let equal = same -end) -let equal = original_equal diff --git a/compiler/ext/ident.mli b/compiler/ext/ident.mli index d73cff6f6eb..269e2bd30b6 100644 --- a/compiler/ext/ident.mli +++ b/compiler/ext/ident.mli @@ -17,7 +17,8 @@ type t = {stamp: int; name: string; mutable flags: int} -include Identifiable.S with type t := t +val print : Format.formatter -> t -> unit +val equal : t -> t -> bool (* Notes: - [equal] compares identifiers by name - [compare x y] is 0 if [same x y] is true. @@ -29,7 +30,6 @@ val create_persistent : string -> t val create_predef_exn : string -> t val rename : t -> t val name : t -> string -val unique_name : t -> string val unique_toplevel_name : t -> string val persistent : t -> bool val same : t -> t -> bool diff --git a/compiler/ext/identifiable.ml b/compiler/ext/identifiable.ml deleted file mode 100644 index bd6133c87e3..00000000000 --- a/compiler/ext/identifiable.ml +++ /dev/null @@ -1,250 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -module type Thing = sig - type t - - include Hashtbl.HashedType with type t := t - include Map.OrderedType with type t := t - - val output : out_channel -> t -> unit - val print : Format.formatter -> t -> unit -end - -module type Set = sig - module T : Set.OrderedType - include Set.S with type elt = T.t and type t = Set.Make(T).t - - val output : out_channel -> t -> unit - val print : Format.formatter -> t -> unit - val to_string : t -> string - val of_list : elt list -> t - val map : (elt -> elt) -> t -> t -end - -module type Map = sig - module T : Map.OrderedType - include Map.S with type key = T.t and type 'a t = 'a Map.Make(T).t - - val filter_map : (key -> 'a -> 'b option) -> 'a t -> 'b t - val of_list : (key * 'a) list -> 'a t - - val disjoint_union : - ?eq:('a -> 'a -> bool) -> - ?print:(Format.formatter -> 'a -> unit) -> - 'a t -> - 'a t -> - 'a t - - val union_right : 'a t -> 'a t -> 'a t - - val union_left : 'a t -> 'a t -> 'a t - - val union_merge : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t - val rename : key t -> key -> key - val map_keys : (key -> key) -> 'a t -> 'a t - val keys : 'a t -> Set.Make(T).t - val data : 'a t -> 'a list - val of_set : (key -> 'a) -> Set.Make(T).t -> 'a t - val transpose_keys_and_data : key t -> key t - val transpose_keys_and_data_set : key t -> Set.Make(T).t t - val print : - (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit -end - -module type Tbl = sig - module T : sig - type t - include Map.OrderedType with type t := t - include Hashtbl.HashedType with type t := t - end - include Hashtbl.S with type key = T.t and type 'a t = 'a Hashtbl.Make(T).t - - val to_list : 'a t -> (T.t * 'a) list - val of_list : (T.t * 'a) list -> 'a t - - val to_map : 'a t -> 'a Map.Make(T).t - val of_map : 'a Map.Make(T).t -> 'a t - val memoize : 'a t -> (key -> 'a) -> key -> 'a - val map : 'a t -> ('a -> 'b) -> 'b t -end - -module Pair (A : Thing) (B : Thing) : Thing with type t = A.t * B.t = struct - type t = A.t * B.t - - let compare (a1, b1) (a2, b2) = - let c = A.compare a1 a2 in - if c <> 0 then c else B.compare b1 b2 - - let output oc (a, b) = Printf.fprintf oc " (%a, %a)" A.output a B.output b - let hash (a, b) = Hashtbl.hash (A.hash a, B.hash b) - let equal (a1, b1) (a2, b2) = A.equal a1 a2 && B.equal b1 b2 - let print ppf (a, b) = Format.fprintf ppf " (%a, @ %a)" A.print a B.print b -end - -module Make_map (T : Thing) = struct - include Map.Make (T) - - let filter_map f t = - fold - (fun id v map -> - match f id v with - | None -> map - | Some r -> add id r map) - t empty - - let of_list l = List.fold_left (fun map (id, v) -> add id v map) empty l - - let disjoint_union ?eq ?print m1 m2 = - union - (fun id v1 v2 -> - let ok = - match eq with - | None -> false - | Some eq -> eq v1 v2 - in - if not ok then - let err = - match print with - | None -> Format.asprintf "Map.disjoint_union %a" T.print id - | Some print -> - Format.asprintf "Map.disjoint_union %a => %a <> %a" T.print id - print v1 print v2 - in - Misc.fatal_error err - else Some v1) - m1 m2 - - let union_right m1 m2 = - merge - (fun _id x y -> - match (x, y) with - | None, None -> None - | None, Some v | Some v, None | Some _, Some v -> Some v) - m1 m2 - - let union_left m1 m2 = union_right m2 m1 - - let union_merge f m1 m2 = - let aux _ m1 m2 = - match (m1, m2) with - | None, m | m, None -> m - | Some m1, Some m2 -> Some (f m1 m2) - in - merge aux m1 m2 - - let rename m v = try find v m with Not_found -> v - - let map_keys f m = of_list (List.map (fun (k, v) -> (f k, v)) (bindings m)) - - let print f ppf s = - let elts ppf s = - iter (fun id v -> Format.fprintf ppf "@ (@[%a@ %a@])" T.print id f v) s - in - Format.fprintf ppf "@[<1>{@[%a@ @]}@]" elts s - - module T_set = Set.Make (T) - - let keys map = fold (fun k _ set -> T_set.add k set) map T_set.empty - - let data t = List.map snd (bindings t) - - let of_set f set = T_set.fold (fun e map -> add e (f e) map) set empty - - let transpose_keys_and_data map = fold (fun k v m -> add v k m) map empty - let transpose_keys_and_data_set map = - fold - (fun k v m -> - let set = - match find v m with - | exception Not_found -> T_set.singleton k - | set -> T_set.add k set - in - add v set m) - map empty -end - -module Make_set (T : Thing) = struct - include Set.Make (T) - - let output oc s = - Printf.fprintf oc " ( "; - iter (fun v -> Printf.fprintf oc "%a " T.output v) s; - Printf.fprintf oc ")" - - let print ppf s = - let elts ppf s = iter (fun e -> Format.fprintf ppf "@ %a" T.print e) s in - Format.fprintf ppf "@[<1>{@[%a@ @]}@]" elts s - - let to_string s = Format.asprintf "%a" print s - - let of_list l = - match l with - | [] -> empty - | [t] -> singleton t - | t :: q -> List.fold_left (fun acc e -> add e acc) (singleton t) q - - let map f s = of_list (List.map f (elements s)) -end - -module Make_tbl (T : Thing) = struct - include Hashtbl.Make (T) - - module T_map = Make_map (T) - - let to_list t = fold (fun key datum elts -> (key, datum) :: elts) t [] - - let of_list elts = - let t = create 42 in - List.iter (fun (key, datum) -> add t key datum) elts; - t - - let to_map v = fold T_map.add v T_map.empty - - let of_map m = - let t = create (T_map.cardinal m) in - T_map.iter (fun k v -> add t k v) m; - t - - let memoize t f key = - try find t key - with Not_found -> - let r = f key in - add t key r; - r - - let map t f = of_map (T_map.map f (to_map t)) -end - -module type S = sig - type t - - module T : Thing with type t = t - include Thing with type t := T.t - - module Set : Set with module T := T - module Map : Map with module T := T - module Tbl : Tbl with module T := T -end - -module Make (T : Thing) = struct - module T = T - include T - - module Set = Make_set (T) - module Map = Make_map (T) - module Tbl = Make_tbl (T) -end diff --git a/compiler/ext/identifiable.mli b/compiler/ext/identifiable.mli deleted file mode 100644 index 9dd8defd9e4..00000000000 --- a/compiler/ext/identifiable.mli +++ /dev/null @@ -1,106 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Uniform interface for common data structures over various things. *) - -module type Thing = sig - type t - - include Hashtbl.HashedType with type t := t - include Map.OrderedType with type t := t - - val output : out_channel -> t -> unit - val print : Format.formatter -> t -> unit -end - -module Pair : functor (A : Thing) (B : Thing) -> Thing with type t = A.t * B.t - -module type Set = sig - module T : Set.OrderedType - include Set.S with type elt = T.t and type t = Set.Make(T).t - - val output : out_channel -> t -> unit - val print : Format.formatter -> t -> unit - val to_string : t -> string - val of_list : elt list -> t - val map : (elt -> elt) -> t -> t -end - -module type Map = sig - module T : Map.OrderedType - include Map.S with type key = T.t and type 'a t = 'a Map.Make(T).t - - val filter_map : (key -> 'a -> 'b option) -> 'a t -> 'b t - val of_list : (key * 'a) list -> 'a t - - val disjoint_union : - ?eq:('a -> 'a -> bool) -> - ?print:(Format.formatter -> 'a -> unit) -> - 'a t -> - 'a t -> - 'a t - (** [disjoint_union m1 m2] contains all bindings from [m1] and - [m2]. If some binding is present in both and the associated - value is not equal, a Fatal_error is raised *) - - val union_right : 'a t -> 'a t -> 'a t - (** [union_right m1 m2] contains all bindings from [m1] and [m2]. If - some binding is present in both, the one from [m2] is taken *) - - val union_left : 'a t -> 'a t -> 'a t - (** [union_left m1 m2 = union_right m2 m1] *) - - val union_merge : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t - val rename : key t -> key -> key - val map_keys : (key -> key) -> 'a t -> 'a t - val keys : 'a t -> Set.Make(T).t - val data : 'a t -> 'a list - val of_set : (key -> 'a) -> Set.Make(T).t -> 'a t - val transpose_keys_and_data : key t -> key t - val transpose_keys_and_data_set : key t -> Set.Make(T).t t - val print : - (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit -end - -module type Tbl = sig - module T : sig - type t - include Map.OrderedType with type t := t - include Hashtbl.HashedType with type t := t - end - include Hashtbl.S with type key = T.t and type 'a t = 'a Hashtbl.Make(T).t - - val to_list : 'a t -> (T.t * 'a) list - val of_list : (T.t * 'a) list -> 'a t - - val to_map : 'a t -> 'a Map.Make(T).t - val of_map : 'a Map.Make(T).t -> 'a t - val memoize : 'a t -> (key -> 'a) -> key -> 'a - val map : 'a t -> ('a -> 'b) -> 'b t -end - -module type S = sig - type t - - module T : Thing with type t = t - include Thing with type t := T.t - - module Set : Set with module T := T - module Map : Map with module T := T - module Tbl : Tbl with module T := T -end - -module Make (T : Thing) : S with type t := T.t diff --git a/compiler/ext/js_reserved_map.cppo.ml b/compiler/ext/js_reserved_map.cppo.ml index 6daaff97601..53ecb3c3154 100644 --- a/compiler/ext/js_reserved_map.cppo.ml +++ b/compiler/ext/js_reserved_map.cppo.ml @@ -113,27 +113,6 @@ let js_keywords = STbl.of_array [| let is_js_keyword s = STbl.mem js_keywords s -(** Identifiers with special meanings. - - They can have different meanings depending on the context when used as identifier names, so it should be done carefully. - - See https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Lexical_grammar#identifiers_with_special_meanings - - However, these names are actually used with no problems today. (Except `arguments` and `eval`) - *) -let js_special_words = STbl.of_array [| - "arguments"; - "as"; - "async"; - "eval"; - "from"; - "get"; - "of"; - "set"; -|] - -let is_js_special_word s = STbl.mem js_special_words s - (** Identifier names _might_ need to care about *) let js_globals = STbl.of_array [| (* JavaScript standards built-ins diff --git a/compiler/ext/js_reserved_map.mli b/compiler/ext/js_reserved_map.mli index 5ee19826fae..25b0e10fd19 100644 --- a/compiler/ext/js_reserved_map.mli +++ b/compiler/ext/js_reserved_map.mli @@ -24,6 +24,4 @@ val is_js_keyword : string -> bool -val is_js_special_word : string -> bool - val is_js_global : string -> bool diff --git a/compiler/ext/literals.ml b/compiler/ext/literals.ml index 884a1934b90..6e5ada10725 100644 --- a/compiler/ext/literals.ml +++ b/compiler/ext/literals.ml @@ -22,8 +22,6 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -let js_array_ctor = "Array" - let js_type_number = "number" let js_type_string = "string" @@ -32,12 +30,6 @@ let js_type_object = "object" let js_type_boolean = "boolean" -let js_undefined = "undefined" - -let js_prop_length = "length" - -let prim = "prim" - let param = "param" let partial_arg = "partial_arg" @@ -46,79 +38,26 @@ let tmp = "tmp" let create = "create" (* {!Caml_exceptions.create}*) -let runtime = "runtime" (* runtime directory *) - -let stdlib = "stdlib" - let setter_suffix = "#=" let setter_suffix_len = String.length setter_suffix -let debugger = "debugger" - -let fn_run = "fn_run" - -let method_run = "method_run" - -let fn_method = "fn_method" - -let fn_mk = "fn_mk" -(*let js_fn_runmethod = "js_fn_runmethod"*) - -(** nodejs *) -let node_modules = "node_modules" - -let node_modules_length = String.length "node_modules" - -let package_json = "package.json" - -(* Name of the library file created for each external dependency. *) -let library_file = "lib" - -let suffix_a = ".a" - let suffix_cmj = ".cmj" -let suffix_cmo = ".cmo" - -let suffix_cma = ".cma" - let suffix_cmi = ".cmi" -let suffix_cmx = ".cmx" - -let suffix_cmxa = ".cmxa" - -let suffix_mll = ".mll" - let suffix_res = ".res" let suffix_resi = ".resi" let suffix_mlmap = ".mlmap" -let suffix_cmt = ".cmt" - -let suffix_cmti = ".cmti" - let suffix_ast = ".ast" let suffix_iast = ".iast" -let suffix_d = ".d" - let suffix_js = ".js" -let suffix_gen_js = ".gen.js" - -let suffix_gen_tsx = ".gen.tsx" - -let esmodule = "esmodule" - -let commonjs = "commonjs" - -let unused_attribute = "Unused attribute " - (** Used when produce node compatible paths *) let node_sep = "/" @@ -129,8 +68,6 @@ let node_current = "." let gentype_import1 = "genType.import" let gentype_import2 = "gentype.import" -let sourcedirs_meta = ".sourcedirs.json" - (* Note the build system should check the validity of filenames espeically, it should not contain '-' *) diff --git a/compiler/ext/map_gen.ml b/compiler/ext/map_gen.ml index 7c8af834dd3..2881b5255d7 100644 --- a/compiler/ext/map_gen.ml +++ b/compiler/ext/map_gen.ml @@ -269,23 +269,6 @@ let rec join l v d r = else if rh > lh + 2 then bal (join l v d xr.l) xr.k xr.v xr.r else unsafe_node v d l r (calc_height lh rh)) -(* Merge two trees l and r into one. - All elements of l must precede the elements of r. - No assumption on the heights of l and r. *) - -let concat t1 t2 = - match (t1, t2) with - | Empty, t -> t - | t, Empty -> t - | _, _ -> - let x, d = min_binding_exn t2 in - join t1 x d (remove_min_binding t2) - -let concat_or_join t1 v d t2 = - match d with - | Some d -> join t1 v d t2 - | None -> concat t1 t2 - module type S = sig type key diff --git a/compiler/ext/map_gen.mli b/compiler/ext/map_gen.mli index c5038ffc42f..d2f3fd237a6 100644 --- a/compiler/ext/map_gen.mli +++ b/compiler/ext/map_gen.mli @@ -7,10 +7,6 @@ val cardinal : ('a, 'b) t -> int val bindings : ('a, 'b) t -> ('a * 'b) list -val fill_array_with_f : ('a, 'b) t -> int -> 'c array -> ('a -> 'b -> 'c) -> int - -val fill_array_aux : ('a, 'b) t -> int -> ('a * 'b) array -> int - val to_sorted_array : ('key, 'a) t -> ('key * 'a) array val to_sorted_array_with_f : ('a, 'b) t -> ('a -> 'b -> 'c) -> 'c array @@ -48,10 +44,6 @@ val exists : ('a, 'b) t -> ('a -> 'b -> bool) -> bool val join : ('a, 'b) t -> 'a -> 'b -> ('a, 'b) t -> ('a, 'b) t -val concat : ('a, 'b) t -> ('a, 'b) t -> ('a, 'b) t - -val concat_or_join : ('a, 'b) t -> 'a -> 'b option -> ('a, 'b) t -> ('a, 'b) t - module type S = sig type key diff --git a/compiler/ext/misc.ml b/compiler/ext/misc.ml index 46f99d25d3c..e9ed2fe68aa 100644 --- a/compiler/ext/misc.ml +++ b/compiler/ext/misc.ml @@ -22,8 +22,6 @@ let fatal_error msg = prerr_endline msg; raise Fatal_error -let fatal_errorf fmt = Format.kasprintf fatal_error fmt - (* Exceptions *) let try_finally work cleanup = @@ -58,25 +56,9 @@ let rec map_end f l1 l2 = | [] -> l2 | hd :: tl -> f hd :: map_end f tl l2 -let rec map_left_right f = function - | [] -> [] - | hd :: tl -> - let res = f hd in - res :: map_left_right f tl - -let rec for_all2 pred l1 l2 = - match (l1, l2) with - | [], [] -> true - | hd1 :: tl1, hd2 :: tl2 -> pred hd1 hd2 && for_all2 pred tl1 tl2 - | _, _ -> false - let rec replicate_list elem n = if n <= 0 then [] else elem :: replicate_list elem (n - 1) -let rec list_remove x = function - | [] -> [] - | hd :: tl -> if hd = x then tl else hd :: list_remove x tl - let rec split_last = function | [] -> assert false | [x] -> ([], x) @@ -89,35 +71,6 @@ let may_map = Stdlib.Option.map (* File functions *) -let find_in_path path name = - if not (Filename.is_implicit name) then - if Sys.file_exists name then name else raise Not_found - else - let rec try_dir = function - | [] -> raise Not_found - | dir :: rem -> - let fullname = Filename.concat dir name in - if Sys.file_exists fullname then fullname else try_dir rem - in - try_dir path - -let find_in_path_rel path name = - let rec simplify s = - let open Filename in - let base = basename s in - let dir = dirname s in - if dir = s then dir - else if base = current_dir_name then simplify dir - else concat (simplify dir) base - in - let rec try_dir = function - | [] -> raise Not_found - | dir :: rem -> - let fullname = simplify (Filename.concat dir name) in - if Sys.file_exists fullname then fullname else try_dir rem - in - try_dir path - let find_in_path_uncap path name = let uname = String.uncapitalize_ascii name in let rec try_dir = function @@ -151,44 +104,6 @@ let create_hashtable init = Array.iter (fun (key, data) -> Hashtbl.add tbl key data) init; tbl -(* File copy *) - -let copy_file ic oc = - let buff = Bytes.create 0x1000 in - let rec copy () = - let n = input ic buff 0 0x1000 in - if n = 0 then () - else ( - output oc buff 0 n; - copy ()) - in - copy () - -let copy_file_chunk ic oc len = - let buff = Bytes.create 0x1000 in - let rec copy n = - if n <= 0 then () - else - let r = input ic buff 0 (min n 0x1000) in - if r = 0 then raise End_of_file - else ( - output oc buff 0 r; - copy (n - r)) - in - copy len - -let string_of_file ic = - let b = Buffer.create 0x10000 in - let buff = Bytes.create 0x1000 in - let rec copy () = - let n = input ic buff 0 0x1000 in - if n = 0 then Buffer.contents b - else ( - Buffer.add_subbytes b buff 0 n; - copy ()) - in - copy () - let output_to_bin_file_directly filename fn = let oc = open_out_bin filename in match fn filename oc with @@ -199,124 +114,22 @@ let output_to_bin_file_directly filename fn = close_out oc; raise e -let output_to_file_via_temporary ?(mode = [Open_text]) filename fn = - let temp_filename, oc = - Filename.open_temp_file ~mode ~perms:0o666 - ~temp_dir:(Filename.dirname filename) - (Filename.basename filename) - ".tmp" - in - (* The 0o666 permissions will be modified by the umask. It's just - like what [open_out] and [open_out_bin] do. - With temp_dir = dirname filename, we ensure that the returned - temp file is in the same directory as filename itself, making - it safe to rename temp_filename to filename later. - With prefix = basename filename, we are almost certain that - the first generated name will be unique. A fixed prefix - would work too but might generate more collisions if many - files are being produced simultaneously in the same directory. *) - match fn temp_filename oc with - | res -> ( - close_out oc; - try - Sys.rename temp_filename filename; - res - with exn -> - remove_file temp_filename; - raise exn) - | exception exn -> - close_out oc; - remove_file temp_filename; - raise exn - -(* Integer operations *) - -let rec log2 n = if n <= 1 then 0 else 1 + log2 (n asr 1) - -let align n a = if n >= 0 then (n + a - 1) land -a else n land -a - -let no_overflow_add a b = a lxor b lor (a lxor lnot (a + b)) < 0 - -let no_overflow_sub a b = a lxor lnot b lor (b lxor (a - b)) < 0 - -let no_overflow_mul a b = b <> 0 && a * b / b = a - -let no_overflow_lsl a k = - 0 <= k && k < Sys.word_size && min_int asr k <= a && a <= max_int asr k - module Int_literal_converter = struct (* To convert integer literals, allowing max_int + 1 (PR#4210) *) let cvt_int_aux str neg of_string = if String.length str = 0 || str.[0] = '-' then of_string str else neg (of_string ("-" ^ str)) let int s = cvt_int_aux s ( ~- ) int_of_string - let int32 s = cvt_int_aux s Int32.neg Int32.of_string - let int64 s = cvt_int_aux s Int64.neg Int64.of_string end (* String operations *) -let chop_extensions file = - let dirname = Filename.dirname file and basename = Filename.basename file in - try - let pos = String.index basename '.' in - let basename = String.sub basename 0 pos in - if Filename.is_implicit file && dirname = Filename.current_dir_name then - basename - else Filename.concat dirname basename - with Not_found -> file - -let search_substring pat str start = - let rec search i j = - if j >= String.length pat then i - else if i + j >= String.length str then raise Not_found - else if str.[i + j] = pat.[j] then search i (j + 1) - else search (i + 1) 0 - in - search start 0 - -let replace_substring ~before ~after str = - let rec search acc curr = - match search_substring before str curr with - | next -> - let prefix = String.sub str curr (next - curr) in - search (prefix :: acc) (next + String.length before) - | exception Not_found -> - let suffix = String.sub str curr (String.length str - curr) in - List.rev (suffix :: acc) - in - String.concat after (search [] 0) - -let rev_split_words s = - let rec split1 res i = - if i >= String.length s then res - else - match s.[i] with - | ' ' | '\t' | '\r' | '\n' -> split1 res (i + 1) - | _ -> split2 res i (i + 1) - and split2 res i j = - if j >= String.length s then String.sub s i (j - i) :: res - else - match s.[j] with - | ' ' | '\t' | '\r' | '\n' -> - split1 (String.sub s i (j - i) :: res) (j + 1) - | _ -> split2 res i (j + 1) - in - split1 [] 0 - let get_ref r = let v = !r in r := []; v -let fst3 (x, _, _) = x -let snd3 (_, x, _) = x -let thd3 (_, _, x) = x - -let fst4 (x, _, _, _) = x let snd4 (_, x, _, _) = x -let thd4 (_, _, x, _) = x -let for4 (_, _, _, x) = x let edit_distance a b cutoff = let la, lb = (String.length a, String.length b) in @@ -397,15 +210,11 @@ let did_you_mean ppf get_choices = (if rest = [] then "" else " or ") last -let cut_at s c = - let pos = String.index s c in - (String.sub s 0 pos, String.sub s (pos + 1) (String.length s - pos - 1)) - -module String_set = Set.Make (struct +module String_map = Map.Make (struct type t = string let compare = compare end) -module String_map = Map.Make (struct +module String_set = Set.Make (struct type t = string let compare = compare end) @@ -413,28 +222,22 @@ end) (* Color handling *) module Color = struct (* use ANSI color codes, see https://en.wikipedia.org/wiki/ANSI_escape_code *) - type color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White + type color = Red | Yellow | Magenta | Cyan type style = | FG of color (* foreground *) - | BG of color (* background *) | Bold | Reset | Dim let ansi_of_color = function - | Black -> "0" | Red -> "1" - | Green -> "2" | Yellow -> "3" - | Blue -> "4" | Magenta -> "5" | Cyan -> "6" - | White -> "7" let code_of_style = function | FG c -> "3" ^ ansi_of_color c - | BG c -> "4" ^ ansi_of_color c | Bold -> "1" | Reset -> "0" | Dim -> "2" @@ -454,8 +257,6 @@ module Color = struct {warning = [Bold; FG Magenta]; error = [Bold; FG Red]; loc = [Bold]} let cur_styles = ref default_styles - let get_styles () = !cur_styles - let set_styles s = cur_styles := s (* map a tag to a style, if the tag is known. @raise Not_found otherwise *) @@ -538,43 +339,11 @@ let normalise_eol s = done; Buffer.contents b -let delete_eol_spaces src = - let len_src = String.length src in - let dst = Bytes.create len_src in - let rec loop i_src i_dst = - if i_src = len_src then i_dst - else - match src.[i_src] with - | ' ' | '\t' -> loop_spaces 1 (i_src + 1) i_dst - | c -> - Bytes.set dst i_dst c; - loop (i_src + 1) (i_dst + 1) - and loop_spaces spaces i_src i_dst = - if i_src = len_src then i_dst - else - match src.[i_src] with - | ' ' | '\t' -> loop_spaces (spaces + 1) (i_src + 1) i_dst - | '\n' -> - Bytes.set dst i_dst '\n'; - loop (i_src + 1) (i_dst + 1) - | _ -> - for n = 0 to spaces do - Bytes.set dst (i_dst + n) src.[i_src - spaces + n] - done; - loop (i_src + 1) (i_dst + spaces + 1) - in - let stop = loop 0 0 in - Bytes.sub_string dst 0 stop - type hook_info = {sourcefile: string} exception HookExnWrapper of {error: exn; hook_name: string; hook_info: hook_info} -exception HookExn of exn - -let raise_direct_hook_exn e = raise (HookExn e) - module type HookSig = sig type t diff --git a/compiler/ext/misc.mli b/compiler/ext/misc.mli index 6dc9294833a..f890e42cc76 100644 --- a/compiler/ext/misc.mli +++ b/compiler/ext/misc.mli @@ -16,7 +16,6 @@ (* Miscellaneous useful types and functions *) val fatal_error : string -> 'a -val fatal_errorf : ('a, Format.formatter, unit, 'b) format4 -> 'a exception Fatal_error val try_finally : (unit -> 'a) -> (unit -> unit) -> 'a @@ -24,22 +23,10 @@ val try_finally : (unit -> 'a) -> (unit -> unit) -> 'a val map_end : ('a -> 'b) -> 'a list -> 'b list -> 'b list (* [map_end f l t] is [map f l @ t], just more efficient. *) -val map_left_right : ('a -> 'b) -> 'a list -> 'b list -(* Like [List.map], with guaranteed left-to-right evaluation order *) - -val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool -(* Same as [List.for_all] but for a binary predicate. - In addition, this [for_all2] never fails: given two lists - with different lengths, it returns false. *) - val replicate_list : 'a -> int -> 'a list (* [replicate_list elem n] is the list with [n] elements all identical to [elem]. *) -val list_remove : 'a -> 'a list -> 'a list -(* [list_remove x l] returns a copy of [l] with the first - element equal to [x] removed. *) - val split_last : 'a list -> 'a list * 'a (* Return the last element and the other elements of the given list. *) @@ -53,12 +40,6 @@ val protect_refs : ref_and_value list -> (unit -> 'a) -> 'a while executing [f]. The previous contents of the references is restored even if [f] raises an exception. *) -val find_in_path : string list -> string -> string -(* Search a file in a list of directories. *) - -val find_in_path_rel : string list -> string -> string -(* Search a relative file in a list of directories. *) - val find_in_path_uncap : string list -> string -> string (* Same, but search also for uncapitalized name, i.e. if name is Foo.ml, allow /path/Foo.ml and /path/foo.ml @@ -75,106 +56,17 @@ val create_hashtable : ('a * 'b) array -> ('a, 'b) Hashtbl.t (* Create a hashtable of the given size and fills it with the given bindings. *) -val copy_file : in_channel -> out_channel -> unit -(* [copy_file ic oc] reads the contents of file [ic] and copies - them to [oc]. It stops when encountering EOF on [ic]. *) - -val copy_file_chunk : in_channel -> out_channel -> int -> unit -(* [copy_file_chunk ic oc n] reads [n] bytes from [ic] and copies - them to [oc]. It raises [End_of_file] when encountering - EOF on [ic]. *) - -val string_of_file : in_channel -> string -(* [string_of_file ic] reads the contents of file [ic] and copies - them to a string. It stops when encountering EOF on [ic]. *) - val output_to_bin_file_directly : string -> (string -> out_channel -> 'a) -> 'a -val output_to_file_via_temporary : - ?mode:open_flag list -> string -> (string -> out_channel -> 'a) -> 'a -(* Produce output in temporary file, then rename it - (as atomically as possible) to the desired output file name. - [output_to_file_via_temporary filename fn] opens a temporary file - which is passed to [fn] (name + output channel). When [fn] returns, - the channel is closed and the temporary file is renamed to - [filename]. *) - -val log2 : int -> int -(* [log2 n] returns [s] such that [n = 1 lsl s] - if [n] is a power of 2*) - -val align : int -> int -> int -(* [align n a] rounds [n] upwards to a multiple of [a] - (a power of 2). *) - -val no_overflow_add : int -> int -> bool -(* [no_overflow_add n1 n2] returns [true] if the computation of - [n1 + n2] does not overflow. *) - -val no_overflow_sub : int -> int -> bool -(* [no_overflow_sub n1 n2] returns [true] if the computation of - [n1 - n2] does not overflow. *) - -val no_overflow_mul : int -> int -> bool -(* [no_overflow_mul n1 n2] returns [true] if the computation of - [n1 * n2] does not overflow. *) - -val no_overflow_lsl : int -> int -> bool -(* [no_overflow_lsl n k] returns [true] if the computation of - [n lsl k] does not overflow. *) - module Int_literal_converter : sig val int : string -> int - val int32 : string -> int32 - val int64 : string -> int64 end -val chop_extensions : string -> string -(* Return the given file name without its extensions. The extensions - is the longest suffix starting with a period and not including - a directory separator, [.xyz.uvw] for instance. - - Return the given name if it does not contain an extension. *) - -val search_substring : string -> string -> int -> int -(* [search_substring pat str start] returns the position of the first - occurrence of string [pat] in string [str]. Search starts - at offset [start] in [str]. Raise [Not_found] if [pat] - does not occur. *) - -val replace_substring : before:string -> after:string -> string -> string -(* [replace_substring ~before ~after str] replaces all - occurrences of [before] with [after] in [str] and returns - the resulting string. *) - -val rev_split_words : string -> string list -(* [rev_split_words s] splits [s] in blank-separated words, and returns - the list of words in reverse order. *) - val get_ref : 'a list ref -> 'a list (* [get_ref lr] returns the content of the list reference [lr] and reset its content to the empty list. *) -val fst3 : 'a * 'b * 'c -> 'a -val snd3 : 'a * 'b * 'c -> 'b -val thd3 : 'a * 'b * 'c -> 'c - -val fst4 : 'a * 'b * 'c * 'd -> 'a val snd4 : 'a * 'b * 'c * 'd -> 'b -val thd4 : 'a * 'b * 'c * 'd -> 'c -val for4 : 'a * 'b * 'c * 'd -> 'd - -val edit_distance : string -> string -> int -> int option -(** [edit_distance a b cutoff] computes the edit distance between - strings [a] and [b]. To help efficiency, it uses a cutoff: if the - distance [d] is smaller than [cutoff], it returns [Some d], else - [None]. - - The distance algorithm currently used is Damerau-Levenshtein: it - computes the number of insertion, deletion, substitution of - letters, or swapping of adjacent letters to go from one word to the - other. The particular algorithm may change in the future. -*) val spellcheck : string list -> string -> string list (** [spellcheck env name] takes a list of names [env] that exist in @@ -195,42 +87,11 @@ val did_you_mean : Format.formatter -> (unit -> string list) -> unit the failure even if producing the hint is slow. *) -val cut_at : string -> char -> string * string -(** [String.cut_at s c] returns a pair containing the sub-string before - the first occurrence of [c] in [s], and the sub-string after the - first occurrence of [c] in [s]. - [let (before, after) = String.cut_at s c in - before ^ String.make 1 c ^ after] is the identity if [s] contains [c]. - - Raise [Not_found] if the character does not appear in the string - @since 4.01 -*) - -module String_set : Set.S with type elt = string module String_map : Map.S with type key = string -(* TODO: replace all custom instantiations of StringSet/StringMap in various - compiler modules with this one. *) +module String_set : Set.S with type elt = string (* Color handling *) module Color : sig - type color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White - - type style = - | FG of color (* foreground *) - | BG of color (* background *) - | Bold - | Reset - | Dim - - val ansi_of_style_l : style list -> string - (* ANSI escape sequence for the given style *) - - type styles = {error: style list; warning: style list; loc: style list} - - val default_styles : styles - val get_styles : unit -> styles - val set_styles : styles -> unit - type setting = Auto | Always | Never val setup : setting option -> unit @@ -247,11 +108,6 @@ val normalise_eol : string -> string removed. Intended for pre-processing text which will subsequently be printed on a channel which performs EOL transformations (i.e. Windows) *) -val delete_eol_spaces : string -> string -(** [delete_eol_spaces s] returns a fresh copy of [s] with any end of - line spaces removed. Intended to normalize the output of the - toplevel for tests. *) - (** {1 Hook machinery} Hooks machinery: @@ -267,10 +123,6 @@ exception (** An exception raised by a hook will be wrapped into a [HookExnWrapper] constructor by the hook machinery. *) -val raise_direct_hook_exn : exn -> 'a -(** A hook can use [raise_unwrapped_hook_exn] to raise an exception that will - not be wrapped into a {!HookExnWrapper}. *) - module type HookSig = sig type t val add_hook : string -> (hook_info -> t -> t) -> unit diff --git a/compiler/ext/ordered_hash_map_gen.ml b/compiler/ext/ordered_hash_map_gen.ml index b85ce6e96bb..469902c735a 100644 --- a/compiler/ext/ordered_hash_map_gen.ml +++ b/compiler/ext/ordered_hash_map_gen.ml @@ -153,8 +153,3 @@ let fold h init f = !accu let elements set = fold set [] (fun k _ _ acc -> k :: acc) - -let rec bucket_length acc (x : _ bucket) = - match x with - | Empty -> 0 - | Cons rhs -> bucket_length (acc + 1) rhs.next diff --git a/compiler/ext/set_gen.ml b/compiler/ext/set_gen.ml index 0fd5e66f41f..9f5f2b3ba42 100644 --- a/compiler/ext/set_gen.ml +++ b/compiler/ext/set_gen.ml @@ -250,20 +250,6 @@ let internal_concat t1 t2 = | t, Empty -> t | _, _ -> internal_join t1 (min_exn t2) (remove_min_elt t2) -let rec partition x p = - match x with - | Empty -> (empty, empty) - | Leaf v -> - let pv = p v in - if pv then (x, empty) else (empty, x) - | Node {l; v; r} -> - (* call [p] in the expected left-to-right order *) - let lt, lf = partition l p in - let pv = p v in - let rt, rf = partition r p in - if pv then (internal_join lt v rt, internal_concat lf rf) - else (internal_concat lt rt, internal_join lf v rf) - let of_sorted_array l = let rec sub start n l = if n = 0 then empty @@ -311,10 +297,6 @@ let is_ordered ~cmp tree = in is_ordered_min_max tree <> `No -let invariant ~cmp t = - check t; - is_ordered ~cmp t - module type S = sig type elt diff --git a/compiler/ext/set_gen.mli b/compiler/ext/set_gen.mli index f3f39f01910..8e294fbbd2d 100644 --- a/compiler/ext/set_gen.mli +++ b/compiler/ext/set_gen.mli @@ -27,8 +27,6 @@ val check : 'a t -> unit val bal : 'a t -> 'a -> 'a t -> 'a t -val remove_min_elt : 'a t -> 'a t - val singleton : 'a -> 'a t val internal_merge : 'a t -> 'a t -> 'a t @@ -37,14 +35,10 @@ val internal_join : 'a t -> 'a -> 'a t -> 'a t val internal_concat : 'a t -> 'a t -> 'a t -val partition : 'a t -> ('a -> bool) -> 'a t * 'a t - val of_sorted_array : 'a array -> 'a t val is_ordered : cmp:('a -> 'a -> int) -> 'a t -> bool -val invariant : cmp:('a -> 'a -> int) -> 'a t -> bool - module type S = sig type elt diff --git a/compiler/ext/warnings.ml b/compiler/ext/warnings.ml index 7acd96d03ce..3c4d294d36a 100644 --- a/compiler/ext/warnings.ml +++ b/compiler/ext/warnings.ml @@ -40,7 +40,6 @@ type t = | Nonreturning_statement (* 21 *) | Preprocessor of string (* 22 *) | Useless_record_with (* 23 *) - | Bad_module_name of string (* 24 *) | All_clauses_guarded (* 8, used to be 25 *) | Unused_var of string (* 26 *) | Unused_var_strict of string (* 27 *) @@ -93,7 +92,6 @@ let number = function | Nonreturning_statement -> 21 | Preprocessor _ -> 22 | Useless_record_with -> 23 - | Bad_module_name _ -> 24 | All_clauses_guarded -> 8 (* used to be 25 *) | Unused_var _ -> 26 | Unused_var_strict _ -> 27 @@ -185,19 +183,6 @@ let is_active x = (not !disabled) && !current.active.(number x) let is_error x = (not !disabled) && !current.error.(number x) -let mk_lazy f = - let state = backup () in - lazy - (let prev = backup () in - restore state; - try - let r = f () in - restore prev; - r - with exn -> - restore prev; - raise exn) - let parse_opt error active flags s = let set i = flags.(i) <- true in let clear i = flags.(i) <- false in @@ -308,12 +293,6 @@ let message = function | Useless_record_with -> "All the fields are already explicitly listed in this record. You can \ remove the `...` spread." - | Bad_module_name modname -> - "This file's name is potentially invalid. The build systems conventionally \ - turn a file name into a module name by upper-casing the first letter. " - ^ modname ^ " isn't a valid module name.\n" - ^ "Note: some build systems might e.g. turn kebab-case into CamelCase \ - module, which is why this isn't a hard error." | All_clauses_guarded -> "this pattern-matching is not exhaustive.\n\ All clauses in this pattern-matching are guarded." diff --git a/compiler/ext/warnings.mli b/compiler/ext/warnings.mli index 5ebdfa4b248..23b032bfaf7 100644 --- a/compiler/ext/warnings.mli +++ b/compiler/ext/warnings.mli @@ -33,7 +33,6 @@ type t = | Nonreturning_statement (* 21 *) | Preprocessor of string (* 22 *) | Useless_record_with (* 23 *) - | Bad_module_name of string (* 24 *) | All_clauses_guarded (* 8, used to be 25 *) | Unused_var of string (* 26 *) | Unused_var_strict of string (* 27 *) @@ -74,8 +73,6 @@ val without_warnings : (unit -> 'a) -> 'a val is_active : t -> bool -val is_error : t -> bool - type reporting_information = { number: int; message: string; @@ -99,14 +96,8 @@ val backup : unit -> state val restore : state -> unit -val mk_lazy : (unit -> 'a) -> 'a Lazy.t -(** Like [Lazy.of_fun], but the function is applied with - the warning settings at the time [mk_lazy] is called. *) - val has_warnings : bool ref -val nerrors : int ref - val message : t -> string val number : t -> int diff --git a/compiler/frontend/ast_compatible.ml b/compiler/frontend/ast_compatible.ml index 8d6ac2d4277..2e5db92bc31 100644 --- a/compiler/frontend/ast_compatible.ml +++ b/compiler/frontend/ast_compatible.ml @@ -30,11 +30,11 @@ open Parsetree let default_loc = Location.none -let apply_simple ?(loc = default_loc) ?(attrs = []) (fn : expression) - (args : expression list) : expression = +let apply_simple ?(loc = default_loc) (fn : expression) (args : expression list) + : expression = { pexp_loc = loc; - pexp_attributes = attrs; + pexp_attributes = []; pexp_desc = Pexp_apply { @@ -59,10 +59,10 @@ let app1 ?(loc = default_loc) ?(attrs = []) fn arg1 : expression = }; } -let app2 ?(loc = default_loc) ?(attrs = []) fn arg1 arg2 : expression = +let app2 fn arg1 arg2 : expression = { - pexp_loc = loc; - pexp_attributes = attrs; + pexp_loc = default_loc; + pexp_attributes = []; pexp_desc = Pexp_apply { @@ -73,24 +73,10 @@ let app2 ?(loc = default_loc) ?(attrs = []) fn arg1 arg2 : expression = }; } -let app3 ?(loc = default_loc) ?(attrs = []) fn arg1 arg2 arg3 : expression = - { - pexp_loc = loc; - pexp_attributes = attrs; - pexp_desc = - Pexp_apply - { - funct = fn; - args = [(Nolabel, arg1); (Nolabel, arg2); (Nolabel, arg3)]; - partial = false; - transformed_jsx = false; - }; - } - -let fun_ ?(loc = default_loc) ?(attrs = []) ?(async = false) ~arity pat exp = +let fun_ ~arity pat exp = { - pexp_loc = loc; - pexp_attributes = attrs; + pexp_loc = default_loc; + pexp_attributes = []; pexp_desc = Pexp_fun { @@ -99,30 +85,15 @@ let fun_ ?(loc = default_loc) ?(attrs = []) ?(async = false) ~arity pat exp = lhs = pat; rhs = exp; arity; - async; + async = false; }; } -let const_exp_string ?(loc = default_loc) ?(attrs = []) ?delimiter (s : string) - : expression = - { - pexp_loc = loc; - pexp_attributes = attrs; - pexp_desc = Pexp_constant (Pconst_string (s, delimiter)); - } - -let const_exp_int ?(loc = default_loc) ?(attrs = []) (s : int) : expression = +let apply_labels ?(loc = default_loc) fn (args : (string * expression) list) : + expression = { pexp_loc = loc; - pexp_attributes = attrs; - pexp_desc = Pexp_constant (Pconst_integer (string_of_int s, None)); - } - -let apply_labels ?(loc = default_loc) ?(attrs = []) fn - (args : (string * expression) list) : expression = - { - pexp_loc = loc; - pexp_attributes = attrs; + pexp_attributes = []; pexp_desc = Pexp_apply { @@ -150,13 +121,6 @@ let rec_type_sig ?(loc = default_loc) rf tds : signature_item = tds) } *) -let const_exp_int_list_as_array xs = - Ast_helper.Exp.array (Ext_list.map xs (fun x -> const_exp_int x)) - -(* let const_exp_string_list_as_array xs = - Ast_helper.Exp.array - (Ext_list.map xs (fun x -> const_exp_string x ) ) *) - type object_field = Parsetree.object_field let object_field l attrs ty = Parsetree.Otag (l, attrs, ty) diff --git a/compiler/frontend/ast_compatible.mli b/compiler/frontend/ast_compatible.mli index 77f6e686704..9d8ac938473 100644 --- a/compiler/frontend/ast_compatible.mli +++ b/compiler/frontend/ast_compatible.mli @@ -28,39 +28,16 @@ type attrs = Parsetree.attribute list open Parsetree -val const_exp_string : - ?loc:Location.t -> ?attrs:attrs -> ?delimiter:string -> string -> expression - -val const_exp_int : ?loc:Location.t -> ?attrs:attrs -> int -> expression - -val const_exp_int_list_as_array : int list -> expression - val apply_simple : - ?loc:Location.t -> ?attrs:attrs -> expression -> expression list -> expression + ?loc:Location.t -> expression -> expression list -> expression val app1 : ?loc:Location.t -> ?attrs:attrs -> expression -> expression -> expression -val app2 : - ?loc:Location.t -> - ?attrs:attrs -> - expression -> - expression -> - expression -> - expression - -val app3 : - ?loc:Location.t -> - ?attrs:attrs -> - expression -> - expression -> - expression -> - expression -> - expression +val app2 : expression -> expression -> expression -> expression val apply_labels : ?loc:Location.t -> - ?attrs:attrs -> expression -> (string * expression) list -> (* [(label,e)] [label] is strictly interpreted as label *) @@ -72,9 +49,6 @@ val apply_labels : *) val fun_ : - ?loc:Location.t -> - ?attrs:attrs -> - ?async:bool -> arity:int option -> pattern -> expression -> diff --git a/compiler/frontend/ast_core_type.ml b/compiler/frontend/ast_core_type.ml index ee05b07ef8b..84442e5f0e1 100644 --- a/compiler/frontend/ast_core_type.ml +++ b/compiler/frontend/ast_core_type.ml @@ -114,16 +114,6 @@ let rec get_uncurry_arity_aux (ty : t) acc = | Ptyp_poly (_, ty) -> get_uncurry_arity_aux ty acc | _ -> acc -(** - {[ unit -> 'b ]} return arity 1 - {[ unit -> 'a1 -> a2']} arity 2 - {[ 'a1 -> 'a2 -> ... 'aN -> 'b ]} return arity N -*) -let get_uncurry_arity (ty : t) = - match ty.ptyp_desc with - | Ptyp_arrow {ret = rest} -> Some (get_uncurry_arity_aux rest 1) - | _ -> None - let get_curry_arity (ty : t) = match ty.ptyp_desc with | Ptyp_arrow {arity = Some arity} -> arity @@ -150,9 +140,3 @@ let list_of_arrow (ty : t) : t * Parsetree.arg list = | _ -> (ty, List.rev acc) in aux ty [] - -let add_last_obj (ty : t) (obj : t) = - let result, params = list_of_arrow ty in - Typ.arrows ~loc:obj.ptyp_loc - (params @ [{lbl = Nolabel; typ = obj; attrs = []}]) - result diff --git a/compiler/frontend/ast_core_type.mli b/compiler/frontend/ast_core_type.mli index dfa1f017526..76f0b44ee0d 100644 --- a/compiler/frontend/ast_core_type.mli +++ b/compiler/frontend/ast_core_type.mli @@ -41,15 +41,7 @@ val make_obj : loc:Location.t -> Parsetree.object_field list -> t val is_user_option : t -> bool -val get_uncurry_arity : t -> int option -(** - returns 0 when it can not tell arity from the syntax - None -- means not a function -*) - val list_of_arrow : t -> t * Parsetree.arg list (** fails when Ptyp_poly *) -val add_last_obj : t -> t -> t - val is_arity_one : t -> bool diff --git a/compiler/frontend/ast_derive.ml b/compiler/frontend/ast_derive.ml index e6b3c14b0c5..2be46c30b32 100644 --- a/compiler/frontend/ast_derive.ml +++ b/compiler/frontend/ast_derive.ml @@ -27,7 +27,6 @@ type tdcls = Parsetree.type_declaration list type gen = { structure_gen: tdcls -> Asttypes.rec_flag -> Ast_structure.t; signature_gen: tdcls -> Asttypes.rec_flag -> Ast_signature.t; - expression_gen: (Parsetree.core_type -> Parsetree.expression) option; } (* the first argument is [config] payload diff --git a/compiler/frontend/ast_derive.mli b/compiler/frontend/ast_derive.mli index 4355525a2c0..f13aaffab13 100644 --- a/compiler/frontend/ast_derive.mli +++ b/compiler/frontend/ast_derive.mli @@ -27,7 +27,6 @@ type tdcls = Parsetree.type_declaration list type gen = { structure_gen: tdcls -> Asttypes.rec_flag -> Ast_structure.t; signature_gen: tdcls -> Asttypes.rec_flag -> Ast_signature.t; - expression_gen: (Parsetree.core_type -> Parsetree.expression) option; } val register : string -> (Parsetree.expression option -> gen) -> unit diff --git a/compiler/frontend/ast_derive_js_mapper.ml b/compiler/frontend/ast_derive_js_mapper.ml index ffb5dbd6eca..6ec3ec0d803 100644 --- a/compiler/frontend/ast_derive_js_mapper.ml +++ b/compiler/frontend/ast_derive_js_mapper.ml @@ -131,9 +131,9 @@ let build_map (row_fields : Parsetree.row_field list) = in (data, rev_data, !has_bs_as) -let app1 = Ast_compatible.app1 +let app1 fn arg = Ast_compatible.app1 fn arg -let app2 = Ast_compatible.app2 +let app2 fn arg1 arg2 = Ast_compatible.app2 fn arg1 arg2 let ( ->~ ) a b = Ast_helper.Typ.arrows [{attrs = []; lbl = Nolabel; typ = a}] b @@ -354,5 +354,4 @@ let init () = [] in Ext_list.flat_map tdcls handle_tdcl); - expression_gen = None; }) diff --git a/compiler/frontend/ast_derive_projector.ml b/compiler/frontend/ast_derive_projector.ml index 3d2c7d19620..36efb81ceba 100644 --- a/compiler/frontend/ast_derive_projector.ml +++ b/compiler/frontend/ast_derive_projector.ml @@ -173,5 +173,4 @@ let init () = [] in Ext_list.flat_map tdcls handle_tdcl); - expression_gen = None; }) diff --git a/compiler/frontend/ast_exp_handle_external.ml b/compiler/frontend/ast_exp_handle_external.ml index 73818242f31..375d5e98bc0 100644 --- a/compiler/frontend/ast_exp_handle_external.ml +++ b/compiler/frontend/ast_exp_handle_external.ml @@ -22,50 +22,6 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -(** - {[ - Js.undefinedToOption - (if Js.typeof x = "undefined" then undefined - else x ) - - ]} - - @deprecated -*) -let handle_external loc (x : string) : Parsetree.expression = - let raw_exp : Ast_exp.t = - let str_exp = - Ast_compatible.const_exp_string ~loc x ~delimiter:Ext_string.empty - in - { - str_exp with - pexp_desc = - Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_expr"] - ~pval_type: - (Ast_helper.Typ.arrows - [{attrs = []; lbl = Nolabel; typ = Ast_helper.Typ.any ()}] - (Ast_helper.Typ.any ())) - [str_exp]; - } - in - let empty = - (* FIXME: the empty delimiter does not make sense*) - Ast_helper.Exp.ident ~loc - {txt = Ldot (Ldot (Lident "Js", "Undefined"), "empty"); loc} - in - let undefined_typeof = - Ast_helper.Exp.ident {loc; txt = Ldot (Lident "Js", "undefinedToOption")} - in - let typeof = Ast_helper.Exp.ident {loc; txt = Ldot (Lident "Js", "typeof")} in - - Ast_compatible.app1 ~loc undefined_typeof - (Ast_helper.Exp.ifthenelse ~loc - (Ast_compatible.app2 ~loc - (Ast_helper.Exp.ident ~loc {loc; txt = Lident "=="}) - (Ast_compatible.app1 ~loc typeof raw_exp) - (Ast_compatible.const_exp_string ~loc "undefined")) - empty (Some raw_exp)) - let handle_debugger loc (payload : Ast_payload.t) = match payload with | PStr [] -> diff --git a/compiler/frontend/ast_exp_handle_external.mli b/compiler/frontend/ast_exp_handle_external.mli index c3ff047268c..74829c3547c 100644 --- a/compiler/frontend/ast_exp_handle_external.mli +++ b/compiler/frontend/ast_exp_handle_external.mli @@ -22,8 +22,6 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val handle_external : Location.t -> string -> Parsetree.expression - val handle_debugger : Location.t -> Ast_payload.t -> Parsetree.expression_desc val handle_ffi : loc:Location.t -> payload:Ast_payload.t -> Parsetree.expression diff --git a/compiler/frontend/ast_external_mk.ml b/compiler/frontend/ast_external_mk.ml index 3ec65e16124..08191a7c93a 100644 --- a/compiler/frontend/ast_external_mk.ml +++ b/compiler/frontend/ast_external_mk.ml @@ -22,10 +22,11 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -let local_external_apply loc ?(pval_attributes = []) ~(pval_prim : string list) - ~(pval_type : Parsetree.core_type) ?(local_module_name = "J") - ?(local_fun_name = "unsafe_expr") (args : Parsetree.expression list) : +let local_external_apply loc ~(pval_prim : string list) + ~(pval_type : Parsetree.core_type) (args : Parsetree.expression list) : Parsetree.expression_desc = + let local_module_name = "J" in + let local_fun_name = "unsafe_expr" in Pexp_letmodule ( {txt = local_module_name; loc}, { @@ -40,7 +41,7 @@ let local_external_apply loc ?(pval_attributes = []) ~(pval_prim : string list) pval_type; pval_loc = loc; pval_prim; - pval_attributes; + pval_attributes = []; }; pstr_loc = loc; }; @@ -59,9 +60,10 @@ let local_external_apply loc ?(pval_attributes = []) ~(pval_prim : string list) : Parsetree.expression) args ~loc ) -let local_external_obj loc ?(pval_attributes = []) ~pval_prim ~pval_type - ?(local_module_name = "J") ?(local_fun_name = "unsafe_expr") args : +let local_external_obj loc ~pval_prim ~pval_type args : Parsetree.expression_desc = + let local_module_name = "J" in + let local_fun_name = "unsafe_expr" in Pexp_letmodule ( {txt = local_module_name; loc}, { @@ -76,7 +78,7 @@ let local_external_obj loc ?(pval_attributes = []) ~pval_prim ~pval_type pval_type; pval_loc = loc; pval_prim; - pval_attributes; + pval_attributes = []; }; pstr_loc = loc; }; @@ -94,37 +96,3 @@ let local_external_obj loc ?(pval_attributes = []) ~pval_prim ~pval_type } : Parsetree.expression) args ~loc ) - -let local_extern_cont_to_obj loc ?(pval_attributes = []) ~pval_prim ~pval_type - ?(local_module_name = "J") ?(local_fun_name = "unsafe_expr") - (cb : Parsetree.expression -> 'a) : Parsetree.expression_desc = - Pexp_letmodule - ( {txt = local_module_name; loc}, - { - pmod_desc = - Pmod_structure - [ - { - pstr_desc = - Pstr_primitive - { - pval_name = {txt = local_fun_name; loc}; - pval_type; - pval_loc = loc; - pval_prim; - pval_attributes; - }; - pstr_loc = loc; - }; - ]; - pmod_loc = loc; - pmod_attributes = []; - }, - cb - { - pexp_desc = - Pexp_ident - {txt = Ldot (Lident local_module_name, local_fun_name); loc}; - pexp_attributes = []; - pexp_loc = loc; - } ) diff --git a/compiler/frontend/ast_external_mk.mli b/compiler/frontend/ast_external_mk.mli index 550bb3aa8d1..6c212073478 100644 --- a/compiler/frontend/ast_external_mk.mli +++ b/compiler/frontend/ast_external_mk.mli @@ -24,11 +24,8 @@ val local_external_apply : Location.t -> - ?pval_attributes:Parsetree.attributes -> pval_prim:string list -> pval_type:Parsetree.core_type -> - ?local_module_name:string -> - ?local_fun_name:string -> Parsetree.expression list -> Parsetree.expression_desc (** @@ -44,21 +41,8 @@ val local_external_apply : val local_external_obj : Location.t -> - ?pval_attributes:Parsetree.attributes -> pval_prim:string list -> pval_type:Parsetree.core_type -> - ?local_module_name:string -> - ?local_fun_name:string -> (string * Parsetree.expression) list -> (* [ (label, exp )]*) Parsetree.expression_desc - -val local_extern_cont_to_obj : - Location.t -> - ?pval_attributes:Parsetree.attributes -> - pval_prim:string list -> - pval_type:Parsetree.core_type -> - ?local_module_name:string -> - ?local_fun_name:string -> - (Parsetree.expression -> Parsetree.expression) -> - Parsetree.expression_desc diff --git a/compiler/frontend/ast_literal.ml b/compiler/frontend/ast_literal.ml index 50ea292d53d..eda0e09274a 100644 --- a/compiler/frontend/ast_literal.ml +++ b/compiler/frontend/ast_literal.ml @@ -22,16 +22,10 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open Ast_helper - let predef_prefix_ident : Longident.t = Lident "*predef*" let predef_option : Longident.t = Ldot (predef_prefix_ident, "option") -let predef_some : Longident.t = Ldot (predef_prefix_ident, "Some") - -let predef_none : Longident.t = Ldot (predef_prefix_ident, "None") - module Lid = struct type t = Longident.t @@ -43,21 +37,15 @@ module Lid = struct let type_int : t = Lident "int" (* use *predef* *) - let type_bigint : t = Lident "bigint" (* use *predef* *) - - let type_exn : t = Lident "exn" (* use *predef* *) - let type_bool : t = Lident "bool" (* use *predef* *) - let pervasives : t = Lident Primitive_modules.pervasives - (* FIXME: Use primitive module *) let js_oo : t = Lident "Js_OO" (* FIXME: Use primitive module *) let js_meth_callback : t = Ldot (js_oo, "Callback") - let ignore_id : t = Ldot (pervasives, "ignore") + let ignore_id : t = Ldot (Lident Primitive_modules.pervasives, "ignore") let hidden_field n : t = Lident ("I" ^ n) @@ -81,23 +69,13 @@ module No_loc = struct let type_unit = Ast_helper.Typ.mk (Ptyp_constr ({txt = Lid.type_unit; loc}, [])) - let type_exn = - Ast_helper.Typ.mk (Ptyp_constr ({txt = Lid.type_unit; loc}, [])) - let type_int = Ast_helper.Typ.mk (Ptyp_constr ({txt = Lid.type_int; loc}, [])) - let type_bigint = - Ast_helper.Typ.mk (Ptyp_constr ({txt = Lid.type_bigint; loc}, [])) - let type_string = Ast_helper.Typ.mk (Ptyp_constr ({txt = Lid.type_string; loc}, [])) let type_bool = Ast_helper.Typ.mk (Ptyp_constr ({txt = Lid.type_bool; loc}, [])) - - let type_any = Ast_helper.Typ.any () - - let pat_unit = Pat.construct {txt = Lid.val_unit; loc} None end type 'a lit = ?loc:Location.t -> unit -> 'a @@ -119,12 +97,6 @@ let type_unit ?loc () = | Some loc -> Ast_helper.Typ.mk ~loc (Ptyp_constr ({txt = Lid.type_unit; loc}, [])) -let type_exn ?loc () = - match loc with - | None -> No_loc.type_exn - | Some loc -> - Ast_helper.Typ.mk ~loc (Ptyp_constr ({txt = Lid.type_exn; loc}, [])) - let type_string ?loc () = match loc with | None -> No_loc.type_string @@ -146,19 +118,3 @@ let type_int ?loc () = let type_float = Ast_helper.Typ.mk (Ptyp_constr ({txt = Lident "float"; loc = Location.none}, [])) - -let type_bigint ?loc () = - match loc with - | None -> No_loc.type_bigint - | Some loc -> - Ast_helper.Typ.mk ~loc (Ptyp_constr ({txt = Lid.type_bigint; loc}, [])) - -let type_any ?loc () = - match loc with - | None -> No_loc.type_any - | Some loc -> Ast_helper.Typ.any ~loc () - -let pat_unit ?loc () = - match loc with - | None -> No_loc.pat_unit - | Some loc -> Pat.construct ~loc {txt = Lid.val_unit; loc} None diff --git a/compiler/frontend/ast_literal.mli b/compiler/frontend/ast_literal.mli index 82d57261715..4425fb846d9 100644 --- a/compiler/frontend/ast_literal.mli +++ b/compiler/frontend/ast_literal.mli @@ -26,23 +26,9 @@ type 'a lit = ?loc:Location.t -> unit -> 'a val predef_option : Longident.t -val predef_some : Longident.t - -val predef_none : Longident.t - module Lid : sig type t = Longident.t - val val_unit : t - - val type_unit : t - - val type_int : t - - val type_bigint : t - - val pervasives : t - val js_oo : t val js_meth_callback : t @@ -70,8 +56,6 @@ val val_unit : expression_lit val type_unit : core_type_lit -val type_exn : core_type_lit - val type_string : core_type_lit val type_bool : core_type_lit @@ -79,9 +63,3 @@ val type_bool : core_type_lit val type_int : core_type_lit val type_float : Parsetree.core_type - -val type_bigint : core_type_lit - -val type_any : core_type_lit - -val pat_unit : pattern_lit diff --git a/compiler/frontend/ast_pat.ml b/compiler/frontend/ast_pat.ml index 12b99ace36f..9022be76c7d 100644 --- a/compiler/frontend/ast_pat.ml +++ b/compiler/frontend/ast_pat.ml @@ -24,30 +24,6 @@ type t = Parsetree.pattern -let is_unit_cont ~yes ~no (p : t) = - match p with - | {ppat_desc = Ppat_construct ({txt = Lident "()"}, None)} -> yes - | _ -> no - -(** [arity_of_fun pat e] tells the arity of - expression [fun pat -> e] -*) -let arity_of_fun (pat : Parsetree.pattern) (e : Parsetree.expression) = - let rec aux (e : Parsetree.expression) = - match e.pexp_desc with - | Pexp_fun {rhs = e} -> 1 + aux e (*FIXME error on optional*) - (* | Pexp_fun _ - -> Location.raise_errorf - ~loc:e.pexp_loc "Label is not allowed in JS object" *) - | _ -> 0 - in - is_unit_cont ~yes:0 ~no:1 pat + aux e - -let rec labels_of_fun (e : Parsetree.expression) = - match e.pexp_desc with - | Pexp_fun {arg_label = l; rhs = e} -> l :: labels_of_fun e - | _ -> [] - let rec is_single_variable_pattern_conservative (p : t) = match p.ppat_desc with | Parsetree.Ppat_any -> Some "" diff --git a/compiler/frontend/ast_pat.mli b/compiler/frontend/ast_pat.mli index 3689c09fc50..8aee23b7d39 100644 --- a/compiler/frontend/ast_pat.mli +++ b/compiler/frontend/ast_pat.mli @@ -24,12 +24,4 @@ type t = Parsetree.pattern -val is_unit_cont : yes:'a -> no:'a -> t -> 'a - -val arity_of_fun : t -> Parsetree.expression -> int -(** [arity_of_fun pat e] tells the arity of - expression [fun pat -> e]*) - -val labels_of_fun : Parsetree.expression -> Asttypes.arg_label list - val is_single_variable_pattern_conservative : t -> string option diff --git a/compiler/frontend/ast_polyvar.ml b/compiler/frontend/ast_polyvar.ml index 5d04a5beb89..efc87e02e2e 100644 --- a/compiler/frontend/ast_polyvar.ml +++ b/compiler/frontend/ast_polyvar.ml @@ -37,27 +37,6 @@ let map_row_fields_into_ints ptyp_loc (row_fields : Parsetree.row_field list) = in List.rev acc -(** Note this is okay with enums, for variants, - the underlying representation may change due to - unbox -*) -let map_constructor_declarations_into_ints - (row_fields : Parsetree.constructor_declaration list) = - let mark = ref `nothing in - let _, acc = - Ext_list.fold_left row_fields (0, []) (fun (i, acc) rtag -> - let attrs = rtag.pcd_attributes in - match Ast_attributes.iter_process_bs_int_as attrs with - | Some j -> - if j <> i then if i = 0 then mark := `offset j else mark := `complex; - (j + 1, j :: acc) - | None -> (i + 1, i :: acc)) - in - match !mark with - | `nothing -> `Offset 0 - | `offset j -> `Offset j - | `complex -> `New (List.rev acc) - (** It also check in-consistency of cases like {[ [`a | `c of int ] ]} *) diff --git a/compiler/frontend/ast_polyvar.mli b/compiler/frontend/ast_polyvar.mli index af509f56aa8..814e670b9a0 100644 --- a/compiler/frontend/ast_polyvar.mli +++ b/compiler/frontend/ast_polyvar.mli @@ -26,9 +26,6 @@ val map_row_fields_into_ints : Location.t -> Parsetree.row_field list -> (string * int) list (** side effect: it will mark used attributes `as` *) -val map_constructor_declarations_into_ints : - Parsetree.constructor_declaration list -> [`Offset of int | `New of int list] - val map_row_fields_into_strings : Location.t -> Parsetree.row_field list -> External_arg_spec.attr diff --git a/compiler/frontend/ast_structure.ml b/compiler/frontend/ast_structure.ml index b4152e884e3..844232d9378 100644 --- a/compiler/frontend/ast_structure.ml +++ b/compiler/frontend/ast_structure.ml @@ -49,5 +49,3 @@ let constraint_ ?(loc = Location.none) (stru : t) (sign : Ast_signature.t) = Str.include_ ~loc (Incl.mk ~loc (Mod.constraint_ ~loc (Mod.structure ~loc stru) (Mty.signature ~loc sign))) - -let dummy_item loc : item = Str.eval ~loc (Ast_literal.val_unit ~loc ()) diff --git a/compiler/frontend/ast_structure.mli b/compiler/frontend/ast_structure.mli index 240cbc3ee9e..dd0a406c56d 100644 --- a/compiler/frontend/ast_structure.mli +++ b/compiler/frontend/ast_structure.mli @@ -36,5 +36,3 @@ val fuse_all : ?loc:Ast_helper.loc -> t -> item item *) val constraint_ : ?loc:Ast_helper.loc -> t -> Ast_signature.t -> item - -val dummy_item : Location.t -> item diff --git a/compiler/frontend/ast_utf8_string.ml b/compiler/frontend/ast_utf8_string.ml index 75b17029346..737415d9439 100644 --- a/compiler/frontend/ast_utf8_string.ml +++ b/compiler/frontend/ast_utf8_string.ml @@ -186,6 +186,7 @@ let transform_test s = let buf = Buffer.create (s_len * 2) in check_and_transform 0 buf s 0 s_len; Buffer.contents buf +[@@live] let transform loc s = let s_len = String.length s in diff --git a/compiler/frontend/ast_utf8_string.mli b/compiler/frontend/ast_utf8_string.mli index 588125f4250..86999287e20 100644 --- a/compiler/frontend/ast_utf8_string.mli +++ b/compiler/frontend/ast_utf8_string.mli @@ -26,13 +26,11 @@ type error type exn += Error of int (* offset *) * error -val pp_error : Format.formatter -> error -> unit - (* module Interp : sig *) (* val check_and_transform : int -> string -> int -> cxt -> unit *) (* val transform_test : string -> segments *) (* end *) -val transform_test : string -> string +val transform_test : string -> string [@@live] val transform : Location.t -> string -> string diff --git a/compiler/frontend/ast_utf8_string_interp.ml b/compiler/frontend/ast_utf8_string_interp.ml index e3e65018a77..af78ac1d059 100644 --- a/compiler/frontend/ast_utf8_string_interp.ml +++ b/compiler/frontend/ast_utf8_string_interp.ml @@ -39,14 +39,19 @@ type kind = String | Var of int * int *) type pos = { - lnum: int; - offset: int; - byte_bol: int; + lnum: int; [@live] + offset: int; [@live] + byte_bol: int; [@live] (* Note it actually needs to be in sync with OCaml's lexing semantics *) } (** Note the position is about code point *) -type segment = {start: pos; finish: pos; kind: kind; content: string} +type segment = { + start: pos; [@live] + finish: pos; [@live] + kind: kind; [@live] + content: string; [@live] +} type segments = segment list type cxt = { @@ -87,6 +92,7 @@ let valid_identifier s = (** Note [Var] kind can not be mpty *) let empty_segment {content} = Ext_string.is_empty content +[@@live] let update_newline ~byte_bol loc cxt = cxt.pos_lnum <- cxt.pos_lnum + 1; @@ -269,6 +275,7 @@ let transform_test s = in check_and_transform 0 s 0 cxt; List.rev cxt.segments +[@@live] module Delim = struct let parse_processed = function @@ -287,7 +294,6 @@ module Delim = struct | _ -> Unrecognized let escaped_j_delimiter = "*j" (* not user level syntax allowed *) - let escaped_back_quote_delimiter = "bq" let some_escaped_back_quote_delimiter = Some "bq" let some_escaped_j_delimiter = Some escaped_j_delimiter end @@ -334,8 +340,4 @@ let transform_pat (p : Parsetree.pattern) s delim : Parsetree.pattern = } | Unrecognized -> p -let is_unicode_string opt = - Ext_string.equal opt Delim.escaped_j_delimiter - || Ext_string.equal opt Delim.escaped_back_quote_delimiter - let parse_processed_delim = Delim.parse_processed diff --git a/compiler/frontend/ast_utf8_string_interp.mli b/compiler/frontend/ast_utf8_string_interp.mli index bc0b13c93ee..e6f4ef15090 100644 --- a/compiler/frontend/ast_utf8_string_interp.mli +++ b/compiler/frontend/ast_utf8_string_interp.mli @@ -34,10 +34,19 @@ type error = private | Unmatched_paren | Invalid_syntax_of_var of string -type pos = {lnum: int; offset: int; byte_bol: int} +type pos = { + lnum: int; [@live] + offset: int; [@live] + byte_bol: int; [@live] +} (** Note the position is about code point *) -type segment = {start: pos; finish: pos; kind: kind; content: string} +type segment = { + start: pos; [@live] + finish: pos; [@live] + kind: kind; [@live] + content: string; [@live] +} type segments = segment list type cxt = { @@ -53,10 +62,9 @@ type cxt = { type exn += Error of pos * pos * error -val empty_segment : segment -> bool -val transform_test : string -> segment list +val empty_segment : segment -> bool [@@live] +val transform_test : string -> segment list [@@live] val transform_exp : Parsetree.expression -> string -> string -> Parsetree.expression val transform_pat : Parsetree.pattern -> string -> string -> Parsetree.pattern -val is_unicode_string : string -> bool val parse_processed_delim : string option -> External_arg_spec.delim option diff --git a/compiler/frontend/bs_syntaxerr.ml b/compiler/frontend/bs_syntaxerr.ml index 062e38ff93c..d47a1c3fd02 100644 --- a/compiler/frontend/bs_syntaxerr.ml +++ b/compiler/frontend/bs_syntaxerr.ml @@ -22,8 +22,6 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type untagged_variant = OnlyOneUnknown | AtMostOneObject | AtMostOneArray - type error = | Unsupported_predicates | Duplicated_bs_deriving diff --git a/compiler/frontend/bs_syntaxerr.mli b/compiler/frontend/bs_syntaxerr.mli index 3f457b0d5c1..8d3f0977a28 100644 --- a/compiler/frontend/bs_syntaxerr.mli +++ b/compiler/frontend/bs_syntaxerr.mli @@ -22,8 +22,6 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type untagged_variant = OnlyOneUnknown | AtMostOneObject | AtMostOneArray - type error = | Unsupported_predicates | Duplicated_bs_deriving diff --git a/compiler/frontend/external_arg_spec.mli b/compiler/frontend/external_arg_spec.mli index 6c79a3380ab..c5e3f63a9c1 100644 --- a/compiler/frontend/external_arg_spec.mli +++ b/compiler/frontend/external_arg_spec.mli @@ -57,8 +57,6 @@ val cst_int : int -> cst val cst_string : string -> delim -> cst -val empty_label : label - (* val empty_lit : cst -> label *) val obj_label : string -> label diff --git a/compiler/frontend/lam_constant.ml b/compiler/frontend/lam_constant.ml index c5bab8ffa9d..571e634159a 100644 --- a/compiler/frontend/lam_constant.ml +++ b/compiler/frontend/lam_constant.ml @@ -24,19 +24,16 @@ type constructor_tag = { cstr_name: Ast_untagged_variants.tag; - const: int; - non_const: int; } type pointer_info = | None | Pt_constructor of constructor_tag | Pt_assertfalse - | Some of string let string_of_pointer_info (x : pointer_info) : string option = match x with - | Some name | Pt_constructor {cstr_name = {name}; _} -> Some name + | Pt_constructor {cstr_name = {name}} -> Some name | Pt_assertfalse -> Some "assert_false" | None -> None diff --git a/compiler/frontend/lam_constant.mli b/compiler/frontend/lam_constant.mli index 846e29d7439..008d738b1d1 100644 --- a/compiler/frontend/lam_constant.mli +++ b/compiler/frontend/lam_constant.mli @@ -24,15 +24,12 @@ type constructor_tag = { cstr_name: Ast_untagged_variants.tag; - const: int; - non_const: int; } type pointer_info = | None | Pt_constructor of constructor_tag | Pt_assertfalse - | Some of string val string_of_pointer_info : pointer_info -> string option diff --git a/compiler/gentype/gentype_config.ml b/compiler/gentype/gentype_config.ml index dd0d8361afb..a130e855970 100644 --- a/compiler/gentype/gentype_config.ml +++ b/compiler/gentype/gentype_config.ml @@ -13,7 +13,6 @@ type module_resolution = type bs_version = int * int * int type t = { - bsb_project_root: string; bs_dependencies: string list; dep_paths: (string, string) Hashtbl.t; (** Map from package name to its install path, used to locate @@ -36,7 +35,6 @@ type t = { let default = { - bsb_project_root = ""; bs_dependencies = []; dep_paths = Hashtbl.create 0; emit_import_curry = false; @@ -158,7 +156,6 @@ let build_config ~namespace = tbl in { - bsb_project_root; bs_dependencies = !bs_dependencies_flag; dep_paths; emit_import_curry = false; diff --git a/compiler/gentype/paths.ml b/compiler/gentype/paths.ml index b5e7daaae58..2c825165397 100644 --- a/compiler/gentype/paths.ml +++ b/compiler/gentype/paths.ml @@ -1,7 +1,5 @@ open Gentype_common -let concat = Filename.concat - let handle_namespace cmt = let cut_after_dash s = match String.index s '-' with diff --git a/compiler/ml/annot.ml b/compiler/ml/annot.ml index 13a586592ec..e590aa47332 100644 --- a/compiler/ml/annot.ml +++ b/compiler/ml/annot.ml @@ -13,10 +13,6 @@ (* *) (**************************************************************************) -(* Data types for annotations (Stypes.ml) *) - -type call = Tail | Stack | Inline - type ident = | Iref_internal of Location.t (* defining occurrence *) | Iref_external diff --git a/compiler/ml/ast_async.ml b/compiler/ml/ast_async.ml index d5494ebfba0..21535a3d4b4 100644 --- a/compiler/ml/ast_async.ml +++ b/compiler/ml/ast_async.ml @@ -4,8 +4,7 @@ let rec dig_async_payload_from_function (expr : Parsetree.expression) = | Pexp_newtype (_, body) -> dig_async_payload_from_function body | _ -> false -let add_promise_type ?(loc = Location.none) ~async - (result : Parsetree.expression) = +let add_promise_type ~loc ~async (result : Parsetree.expression) = if async then let unsafe_async = Ast_helper.Exp.ident ~loc diff --git a/compiler/ml/ast_helper.ml b/compiler/ml/ast_helper.ml index d8d3b350cb4..8ba76ac6077 100644 --- a/compiler/ml/ast_helper.ml +++ b/compiler/ml/ast_helper.ml @@ -25,44 +25,26 @@ type attrs = attribute list let default_loc = ref Location.none -let with_default_loc l f = - let old = !default_loc in - default_loc := l; - try - let r = f () in - default_loc := old; - r - with exn -> - default_loc := old; - raise exn - module Const = struct - let integer ?suffix i = Pconst_integer (i, suffix) - let int ?suffix i = integer ?suffix (string_of_int i) - let int32 ?(suffix = 'l') i = integer ~suffix (Int32.to_string i) - let int64 ?(suffix = 'L') i = integer ~suffix (Int64.to_string i) - let nativeint ?(suffix = 'n') i = integer ~suffix (Nativeint.to_string i) - let float ?suffix f = Pconst_float (f, suffix) - let char c = Pconst_char (Char.code c) - let string ?quotation_delimiter s = Pconst_string (s, quotation_delimiter) + let int i = Pconst_integer (string_of_int i, None) + let string s = Pconst_string (s, None) end module Typ = struct let mk ?(loc = !default_loc) ?(attrs = []) d = {ptyp_desc = d; ptyp_loc = loc; ptyp_attributes = attrs} - let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]} let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a) let arrow ?loc ?attrs ~arity arg ret = mk ?loc ?attrs (Ptyp_arrow {arg; ret; arity}) - let arrows ?loc ?attrs args ret = + let arrows ?loc args ret = let arity = Some (List.length args) in let rec build_arrows arity_to_use = function | [] -> ret - | [arg] -> arrow ?loc ?attrs ~arity:arity_to_use arg ret + | [arg] -> arrow ?loc ~arity:arity_to_use arg ret | arg :: rest -> - arrow ?loc ?attrs ~arity:arity_to_use arg (build_arrows None rest) + arrow ?loc ~arity:arity_to_use arg (build_arrows None rest) in build_arrows arity args let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a) @@ -70,7 +52,7 @@ module Typ = struct let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b)) let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b)) let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c)) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b)) + let poly ~loc ?attrs a b = mk ~loc ?attrs (Ptyp_poly (a, b)) let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b)) let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a) @@ -131,7 +113,6 @@ end module Pat = struct let mk ?(loc = !default_loc) ?(attrs = []) d = {ppat_desc = d; ppat_loc = loc; ppat_attributes = attrs} - let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]} let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a) @@ -155,7 +136,6 @@ end module Exp = struct let mk ?(loc = !default_loc) ?(attrs = []) d = {pexp_desc = d; pexp_loc = loc; pexp_attributes = attrs} - let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]} let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) @@ -254,7 +234,6 @@ end module Mty = struct let mk ?(loc = !default_loc) ?(attrs = []) d = {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs} - let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]} let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a) let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a) @@ -268,7 +247,6 @@ end module Mod = struct let mk ?(loc = !default_loc) ?(attrs = []) d = {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} - let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]} let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x) let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x) @@ -416,22 +394,6 @@ module Te = struct pext_attributes = attrs; } - let decl ?(loc = !default_loc) ?(attrs = []) ?(args = Pcstr_tuple []) ?res - name = - { - pext_name = name; - pext_kind = Pext_decl (args, res); - pext_loc = loc; - pext_attributes = attrs; - } - - let rebind ?(loc = !default_loc) ?(attrs = []) name lid = - { - pext_name = name; - pext_kind = Pext_rebind lid; - pext_loc = loc; - pext_attributes = attrs; - } end module Jsx = struct diff --git a/compiler/ml/ast_helper.mli b/compiler/ml/ast_helper.mli index 6538c50419f..9c3f4f9ba1d 100644 --- a/compiler/ml/ast_helper.mli +++ b/compiler/ml/ast_helper.mli @@ -23,26 +23,11 @@ type str = string loc type loc = Location.t type attrs = attribute list -(** {1 Default locations} *) - -val default_loc : loc ref -(** Default value for all optional location arguments. *) - -val with_default_loc : loc -> (unit -> 'a) -> 'a -(** Set the [default_loc] within the scope of the execution - of the provided function. *) - (** {1 Constants} *) module Const : sig - val char : char -> constant - val string : ?quotation_delimiter:string -> string -> constant - val integer : ?suffix:char -> string -> constant - val int : ?suffix:char -> int -> constant - val int32 : ?suffix:char -> int32 -> constant - val int64 : ?suffix:char -> int64 -> constant - val nativeint : ?suffix:char -> nativeint -> constant - val float : ?suffix:char -> string -> constant + val string : string -> constant + val int : int -> constant end (** {1 Core language} *) @@ -50,13 +35,12 @@ end (** Type expressions *) module Typ : sig val mk : ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type - val attr : core_type -> attribute -> core_type val any : ?loc:loc -> ?attrs:attrs -> unit -> core_type val var : ?loc:loc -> ?attrs:attrs -> string -> core_type val arrow : ?loc:loc -> ?attrs:attrs -> arity:arity -> arg -> core_type -> core_type - val arrows : ?loc:loc -> ?attrs:attrs -> arg list -> core_type -> core_type + val arrows : ?loc:loc -> arg list -> core_type -> core_type val tuple : ?loc:loc -> ?attrs:attrs -> core_type list -> core_type val constr : ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type val object_ : @@ -69,7 +53,7 @@ module Typ : sig closed_flag -> label list option -> core_type - val poly : ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type + val poly : loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type val package : ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list -> core_type val extension : ?loc:loc -> ?attrs:attrs -> extension -> core_type @@ -89,7 +73,6 @@ end (** Patterns *) module Pat : sig val mk : ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern - val attr : pattern -> attribute -> pattern val any : ?loc:loc -> ?attrs:attrs -> unit -> pattern val var : ?loc:loc -> ?attrs:attrs -> str -> pattern @@ -118,7 +101,6 @@ end (** Expressions *) module Exp : sig val mk : ?loc:loc -> ?attrs:attrs -> expression_desc -> expression - val attr : expression -> attribute -> expression val ident : ?loc:loc -> ?attrs:attrs -> lid -> expression val constant : ?loc:loc -> ?attrs:attrs -> constant -> expression @@ -307,14 +289,6 @@ module Te : sig extension_constructor_kind -> extension_constructor - val decl : - ?loc:loc -> - ?attrs:attrs -> - ?args:constructor_arguments -> - ?res:core_type -> - str -> - extension_constructor - val rebind : ?loc:loc -> ?attrs:attrs -> str -> lid -> extension_constructor end module Jsx : sig @@ -327,7 +301,6 @@ end (** Module type expressions *) module Mty : sig val mk : ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type - val attr : module_type -> attribute -> module_type val ident : ?loc:loc -> ?attrs:attrs -> lid -> module_type val alias : ?loc:loc -> ?attrs:attrs -> lid -> module_type @@ -351,9 +324,6 @@ end (** Module expressions *) module Mod : sig - val mk : ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr - val attr : module_expr -> attribute -> module_expr - val ident : ?loc:loc -> ?attrs:attrs -> lid -> module_expr val structure : ?loc:loc -> ?attrs:attrs -> structure -> module_expr val functor_ : diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index c4e8f80bb35..0eadfebb204 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -76,7 +76,6 @@ type mapper = { } let map_fst f (x, y) = (f x, y) -let map_snd f (x, y) = (x, f y) let map_tuple f1 f2 (x, y) = (f1 x, f2 y) let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) let map_opt f = function diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index c204651070e..f47e319f64e 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -70,7 +70,6 @@ type mapper = { } let map_fst f (x, y) = (f x, y) -let map_snd f (x, y) = (x, f y) let map_tuple f1 f2 (x, y) = (f1 x, f2 y) let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) let map_opt f = function diff --git a/compiler/ml/ast_payload.ml b/compiler/ml/ast_payload.ml index eb953cd5831..a2474060c35 100644 --- a/compiler/ml/ast_payload.ml +++ b/compiler/ml/ast_payload.ml @@ -39,21 +39,6 @@ let is_single_string (x : t) = Some (name, dec) | _ -> None -let is_single_string_as_ast (x : t) : Parsetree.expression option = - match x with - (*TODO also need detect empty phrase case *) - | PStr - [ - { - pstr_desc = - Pstr_eval - (({pexp_desc = Pexp_constant (Pconst_string (_, _)); _} as e), _); - _; - }; - ] -> - Some e - | _ -> None - let is_single_int (x : t) : int option = match x with | PStr @@ -168,17 +153,6 @@ let raw_as_string_exp_exn ~(kind : Js_raw_info.raw_kind) ?is_function (x : t) : Some {e with pexp_desc = Pexp_constant (Pconst_string (str, None))} | _ -> None -let as_core_type loc (x : t) = - match x with - | PTyp x -> x - | _ -> Location.raise_errorf ~loc "except a core type" - -let as_ident (x : t) = - match x with - | PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_ident ident}, _)}] -> - Some ident - | _ -> None - type lid = string Asttypes.loc type label_expr = lid * Parsetree.expression diff --git a/compiler/ml/ast_payload.mli b/compiler/ml/ast_payload.mli index 493ad8efb69..35783d76dcb 100644 --- a/compiler/ml/ast_payload.mli +++ b/compiler/ml/ast_payload.mli @@ -35,8 +35,6 @@ type action = lid * Parsetree.expression option val is_single_string : t -> (string * string option) option -val is_single_string_as_ast : t -> Parsetree.expression option - val is_single_int : t -> int option val is_single_float : t -> string option @@ -54,10 +52,7 @@ val raw_as_string_exp_exn : Parsetree.expression option (** Convert %raw into expression *) -val as_core_type : Location.t -> t -> Parsetree.core_type - (* val as_empty_structure : t -> bool *) -val as_ident : t -> Longident.t Asttypes.loc option (* val raw_string_payload : Location.t -> string -> t *) val assert_strings : Location.t -> t -> string list @@ -88,7 +83,3 @@ val empty : t val table_dispatch : (Parsetree.expression option -> 'a) Map_string.t -> action -> 'a - -val unrecognized_config_record : Location.t -> string -> unit -(** Report to the user, as a warning, that the bs-attribute parser is bailing out. (This is to allow - external ppx, like ppx_deriving, to pick up where the builtin ppx leave off.) *) diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index 281c2f418c2..c847bc5e6db 100644 --- a/compiler/ml/ast_untagged_variants.ml +++ b/compiler/ml/ast_untagged_variants.ml @@ -166,13 +166,6 @@ let block_type_can_be_undefined = function false | UnknownType -> true -let tag_can_be_undefined tag = - match tag.tag_type with - | None -> false - | Some (String _ | Int _ | Float _ | BigInt _ | Bool _ | Null) -> false - | Some (Untagged block_type) -> block_type_can_be_undefined block_type - | Some Undefined -> true - let has_untagged (attrs : Parsetree.attributes) = Ext_list.exists attrs (function {txt}, _ -> txt = untagged) @@ -524,8 +517,6 @@ let check_well_formed ~env {is_untagged_def; cstrs} = let has_undefined_literal attrs = process_tag_type attrs = Some Undefined -let block_is_object ~env attrs = get_block_type ~env attrs = Some ObjectType - module Dynamic_checks = struct type op = EqEqEq | NotEqEq | Or | And type 'a t = @@ -547,7 +538,6 @@ module Dynamic_checks = struct let bin op x y = BinOp (op, x, y) let tag_type t = TagType t let typeof x = TypeOf x - let str s = String s |> tag_type let is_instance i x = IsInstanceOf (i, x) let not x = Not x let nil = Null |> tag_type diff --git a/compiler/ml/asttypes.ml b/compiler/ml/asttypes.ml index e12960a0058..1169f202a93 100644 --- a/compiler/ml/asttypes.ml +++ b/compiler/ml/asttypes.ml @@ -33,8 +33,6 @@ type private_flag = Private | Public type mutable_flag = Immutable | Mutable -type virtual_flag = Virtual | Concrete - type override_flag = Override | Fresh type closed_flag = Closed | Open @@ -59,11 +57,11 @@ module Noloc = struct | Optional of string (* ~(label=e) => ... *) end -let to_arg_label ?(loc = Location.none) lbl = +let to_arg_label lbl = match lbl with | Noloc.Nolabel -> Nolabel - | Labelled s -> Labelled {loc; txt = s} - | Optional s -> Optional {loc; txt = s} + | Labelled s -> Labelled {loc = Location.none; txt = s} + | Optional s -> Optional {loc = Location.none; txt = s} let to_noloc = function | Nolabel -> Noloc.Nolabel diff --git a/compiler/ml/bigint_utils.mli b/compiler/ml/bigint_utils.mli index 14b09a9efc9..c8fcf3b7dde 100644 --- a/compiler/ml/bigint_utils.mli +++ b/compiler/ml/bigint_utils.mli @@ -1,8 +1,4 @@ -val is_neg : string -> bool -val is_pos : string -> bool val to_string : bool -> string -> string -val remove_leading_sign : string -> bool * string -val remove_leading_zeros : string -> string val parse_bigint : string -> bool * string val is_valid : string -> bool val compare : bool * string -> bool * string -> int diff --git a/compiler/ml/btype.ml b/compiler/ml/btype.ml index dc72b0578f4..da2bcd94b9e 100644 --- a/compiler/ml/btype.ml +++ b/compiler/ml/btype.ml @@ -47,7 +47,7 @@ let newty2 level desc = incr new_id; {desc; level; id = !new_id} let newgenty desc = newty2 generic_level desc -let newgenvar ?name () = newgenty (Tvar name) +let newgenvar () = newgenty (Tvar None) (* let newmarkedvar level = incr new_id; { desc = Tvar; level = pivot_level - level; id = !new_id } @@ -409,12 +409,6 @@ let copy_row f fixed row keep more = row_name = name; } -let rec copy_kind = function - | Fvar {contents = Some k} -> copy_kind k - | Fvar _ -> Fvar (ref None) - | Fpresent -> Fpresent - | Fabsent -> assert false - let copy_commu c = if commu_repr c = Cok then Cok else Clink (ref Cunknown) (* Since univars may be used as row variables, we need to do some @@ -486,8 +480,6 @@ let mark_type_node ty = let ty = repr ty in if ty.level >= lowest_level then ty.level <- pivot_level - ty.level -let mark_type_params ty = iter_type_expr mark_type ty - let type_iterators = let it_type_expr it ty = let ty = repr ty in diff --git a/compiler/ml/btype.mli b/compiler/ml/btype.mli index 02a04a7e062..491bc8be165 100644 --- a/compiler/ml/btype.mli +++ b/compiler/ml/btype.mli @@ -34,7 +34,7 @@ val newty2 : int -> type_desc -> type_expr val newgenty : type_desc -> type_expr (* Create a generic type *) -val newgenvar : ?name:string -> unit -> type_expr +val newgenvar : unit -> type_expr (* Return a fresh generic variable *) (* Use Tsubst instead @@ -131,7 +131,6 @@ val copy_type_desc : val copy_row : (type_expr -> type_expr) -> bool -> row_desc -> bool -> type_expr -> row_desc -val copy_kind : field_kind -> field_kind val save_desc : type_expr -> type_desc -> unit (* Save a type description *) @@ -154,9 +153,6 @@ val mark_type : type_expr -> unit val mark_type_node : type_expr -> unit (* Mark a type node (but not its sons) *) -val mark_type_params : type_expr -> unit -(* Mark the sons of a type node *) - val unmark_type : type_expr -> unit val unmark_type_decl : type_declaration -> unit val unmark_extension_constructor : extension_constructor -> unit diff --git a/compiler/ml/clflags.ml b/compiler/ml/clflags.ml index f0cd88115e7..b9bc75c61fb 100644 --- a/compiler/ml/clflags.ml +++ b/compiler/ml/clflags.ml @@ -36,8 +36,6 @@ and dump_typedtree = ref false (* -dtypedtree *) and dump_rawlambda = ref false (* -drawlambda *) -and dump_lambda = ref false (* -dlambda *) - and only_parse = ref false (* -only-parse *) and editor_mode = ref false (* -editor-mode *) diff --git a/compiler/ml/clflags.mli b/compiler/ml/clflags.mli index 0cb5f1ea3e5..c597b2a2d6a 100644 --- a/compiler/ml/clflags.mli +++ b/compiler/ml/clflags.mli @@ -20,7 +20,6 @@ val dump_source : bool ref val dump_parsetree : bool ref val dump_typedtree : bool ref val dump_rawlambda : bool ref -val dump_lambda : bool ref val dont_write_files : bool ref val keep_locs : bool ref val only_parse : bool ref diff --git a/compiler/ml/cmt_format.cppo.ml b/compiler/ml/cmt_format.cppo.ml index ff30fc00435..4b70c81d899 100644 --- a/compiler/ml/cmt_format.cppo.ml +++ b/compiler/ml/cmt_format.cppo.ml @@ -166,11 +166,11 @@ let add_saved_type b = saved_types := b :: !saved_types let get_saved_types () = !saved_types let set_saved_types l = saved_types := l -let record_deprecated_used ?deprecated_context ?migration_template ?migration_in_pipe_chain_template source_loc deprecated_text = +let record_deprecated_used ?deprecated_context ?migration_template + ?migration_in_pipe_chain_template source_loc _deprecated_text = deprecated_used := { Cmt_utils.source_loc; - deprecated_text; migration_template; migration_in_pipe_chain_template; context = deprecated_context; diff --git a/compiler/ml/cmt_format.mli b/compiler/ml/cmt_format.mli index 66589f088de..ded15fd0e17 100644 --- a/compiler/ml/cmt_format.mli +++ b/compiler/ml/cmt_format.mli @@ -70,16 +70,6 @@ type error = Not_a_typedtree of string exception Error of error -val read : string -> Cmi_format.cmi_infos option * cmt_infos option -(** [read filename] opens filename, and extract both the cmi_infos, if - it exists, and the cmt_infos, if it exists. Thus, it can be used - with .cmi, .cmt and .cmti files. - - .cmti files always contain a cmi_infos at the beginning. .cmt files - only contain a cmi_infos at the beginning if there is no associated - .cmti file. -*) - val read_cmt : string -> cmt_infos val read_cmi : string -> Cmi_format.cmi_infos @@ -99,10 +89,6 @@ val save_cmt : (** [save_cmt filename modname binary_annots sourcefile initial_env cmi] writes a cmt(i) file. *) -(* Miscellaneous functions *) - -val read_magic_number : in_channel -> string - val clear : unit -> unit val add_saved_type : binary_part -> unit @@ -112,14 +98,6 @@ val set_saved_types : binary_part list -> unit val record_value_dependency : Types.value_description -> Types.value_description -> unit -val record_deprecated_used : - ?deprecated_context:Cmt_utils.deprecated_used_context -> - ?migration_template:Parsetree.expression -> - ?migration_in_pipe_chain_template:Parsetree.expression -> - Location.t -> - string -> - unit - (* val is_magic_number : string -> bool diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/cmt_utils.ml index 3e08cd93b47..219503f1807 100644 --- a/compiler/ml/cmt_utils.ml +++ b/compiler/ml/cmt_utils.ml @@ -2,7 +2,6 @@ type deprecated_used_context = FunctionCall | Reference type deprecated_used = { source_loc: Location.t; - deprecated_text: string; migration_template: Parsetree.expression option; migration_in_pipe_chain_template: Parsetree.expression option; context: deprecated_used_context option; diff --git a/compiler/ml/consistbl.ml b/compiler/ml/consistbl.ml index 37047a26287..16a7ed64355 100644 --- a/compiler/ml/consistbl.ml +++ b/compiler/ml/consistbl.ml @@ -23,24 +23,14 @@ let clear = Hashtbl.clear exception Inconsistency of string * string * string -exception Not_available of string - let check tbl name crc source = try let old_crc, old_source = Hashtbl.find tbl name in if crc <> old_crc then raise (Inconsistency (name, source, old_source)) with Not_found -> Hashtbl.add tbl name (crc, source) -let check_noadd tbl name crc source = - try - let old_crc, old_source = Hashtbl.find tbl name in - if crc <> old_crc then raise (Inconsistency (name, source, old_source)) - with Not_found -> raise (Not_available name) - let set tbl name crc source = Hashtbl.add tbl name (crc, source) -let source tbl name = snd (Hashtbl.find tbl name) - let extract l tbl = let l = List.sort_uniq String.compare l in List.fold_left @@ -50,15 +40,3 @@ let extract l tbl = (name, Some crc) :: assc with Not_found -> (name, None) :: assc) [] l - -let filter p tbl = - let to_remove = ref [] in - Hashtbl.iter - (fun name _ -> if not (p name) then to_remove := name :: !to_remove) - tbl; - List.iter - (fun name -> - while Hashtbl.mem tbl name do - Hashtbl.remove tbl name - done) - !to_remove diff --git a/compiler/ml/consistbl.mli b/compiler/ml/consistbl.mli index cfee26f5d26..b030d0b05b2 100644 --- a/compiler/ml/consistbl.mli +++ b/compiler/ml/consistbl.mli @@ -29,34 +29,18 @@ val check : t -> string -> Digest.t -> string -> unit [source] is the name of the file from which the information comes from. This is used for error reporting. *) -val check_noadd : t -> string -> Digest.t -> string -> unit -(* Same as [check], but raise [Not_available] if no CRC was previously - associated with [name]. *) - val set : t -> string -> Digest.t -> string -> unit (* [set tbl name crc source] forcefully associates [name] with [crc] in [tbl], even if [name] already had a different CRC associated with [name] in [tbl]. *) -val source : t -> string -> string -(* [source tbl name] returns the file name associated with [name] - if the latter has an associated CRC in [tbl]. - Raise [Not_found] otherwise. *) - val extract : string list -> t -> (string * Digest.t option) list (* [extract tbl names] returns an associative list mapping each string in [names] to the CRC associated with it in [tbl]. If no CRC is associated with a name then it is mapped to [None]. *) -val filter : (string -> bool) -> t -> unit -(* [filter pred tbl] removes from [tbl] table all (name, CRC) pairs - such that [pred name] is [false]. *) - exception Inconsistency of string * string * string (* Raised by [check] when a CRC mismatch is detected. First string is the name of the compilation unit. Second string is the source that caused the inconsistency. Third string is the source that set the CRC. *) - -exception Not_available of string -(* Raised by [check_noadd] when a name doesn't have an associated CRC. *) diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index 32deb499be0..531926f0253 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -128,12 +128,6 @@ let begin_def () = saved_level := (!current_level, !nongen_level) :: !saved_level; incr current_level; nongen_level := !current_level -let begin_class_def () = - saved_level := (!current_level, !nongen_level) :: !saved_level; - incr current_level -let raise_nongen_level () = - saved_level := (!current_level, !nongen_level) :: !saved_level; - nongen_level := !current_level let end_def () = let cl, nl = List.hd !saved_level in saved_level := List.tl !saved_level; @@ -275,11 +269,6 @@ let is_datatype decl = type fields = (string * Types.field_kind * Types.type_expr) list (**** Object field manipulation. ****) -let object_fields ty = - match (repr ty).desc with - | Tobject (fields, _) -> fields - | _ -> assert false - let flatten_fields (ty : Types.type_expr) : fields * _ = let rec flatten (l : fields) ty = let ty = repr ty in @@ -328,64 +317,6 @@ let concrete_object ty = | Tvar _ -> false | _ -> true -(**** Close an object ****) - -let close_object ty = - let rec close ty = - let ty = repr ty in - match ty.desc with - | Tvar _ -> link_type ty (newty2 ty.level Tnil) - | Tfield (_, _, _, ty') -> close ty' - | _ -> assert false - in - match (repr ty).desc with - | Tobject (ty, _) -> close ty - | _ -> assert false - -(**** Row variable of an object type ****) - -let row_variable ty = - let rec find ty = - let ty = repr ty in - match ty.desc with - | Tfield (_, _, _, ty) -> find ty - | Tvar _ -> ty - | _ -> assert false - in - match (repr ty).desc with - | Tobject (fi, _) -> find fi - | _ -> assert false - -(**** Object name manipulation ****) -(* +++ Bientot obsolete *) - -let set_object_name id rv params ty = - match (repr ty).desc with - | Tobject (_fi, nm) -> set_name nm (Some (Path.Pident id, rv :: params)) - | _ -> assert false - -let remove_object_name ty = - match (repr ty).desc with - | Tobject (_, nm) -> set_name nm None - | Tconstr (_, _, _) -> () - | _ -> fatal_error "Ctype.remove_object_name" - -(**** Hiding of private methods ****) - -let hide_private_methods ty = - match (repr ty).desc with - | Tobject (fi, nm) -> - nm := None; - let fl, _ = flatten_fields fi in - List.iter - (function - | _, k, _ -> ( - match field_kind_repr k with - | Fvar r -> set_kind r Fabsent - | _ -> ())) - fl - | _ -> assert false - (*******************************) (* Operations on class types *) (*******************************) @@ -434,46 +365,36 @@ let rec filter_row_fields erase = function exception Non_closed of type_expr * bool let free_variables = ref [] -let really_closed = ref None let rec free_vars_rec real ty = let ty = repr ty in if ty.level >= lowest_level then ( ty.level <- pivot_level - ty.level; - match (ty.desc, !really_closed) with - | Tvar _, _ -> free_variables := (ty, real) :: !free_variables - | Tconstr (path, tl, _), Some env -> - (try - let _, body, _ = Env.find_type_expansion path env in - if (repr body).level <> generic_level then - free_variables := (ty, real) :: !free_variables - with Not_found -> ()); - List.iter (free_vars_rec true) tl + match ty.desc with + | Tvar _ -> free_variables := (ty, real) :: !free_variables (* Do not count "virtual" free variables | Tobject(ty, {contents = Some (_, p)}) -> free_vars_rec false ty; List.iter (free_vars_rec true) p *) - | Tobject (ty, _), _ -> free_vars_rec false ty - | Tfield (_, _, ty1, ty2), _ -> + | Tobject (ty, _) -> free_vars_rec false ty + | Tfield (_, _, ty1, ty2) -> free_vars_rec true ty1; free_vars_rec false ty2 - | Tvariant row, _ -> + | Tvariant row -> let row = row_repr row in iter_row (free_vars_rec true) row; if not (static_row row) then free_vars_rec false row.row_more | _ -> iter_type_expr (free_vars_rec true) ty) -let free_vars ?env ty = +let free_vars ty = free_variables := []; - really_closed := env; free_vars_rec true ty; let res = !free_variables in free_variables := []; - really_closed := None; res -let free_variables ?env ty = - let tl = List.map fst (free_vars ?env ty) in +let free_variables ty = + let tl = List.map fst (free_vars ty) in unmark_type ty; tl @@ -532,10 +453,6 @@ let closed_extension_constructor ext = unmark_extension_constructor ext; Some ty -type closed_class_failure = - | CC_Method of type_expr * bool * string * type_expr - | CC_Value of type_expr * bool * string * type_expr - (**********************) (* Type duplication *) (**********************) @@ -724,54 +641,11 @@ let generalize_expansive env ty = try generalize_expansive env !nongen_level (Hashtbl.create 7) ty with Unify ([(_, ty')] as tr) -> raise (Unify ((ty, ty') :: tr)) -let generalize_global ty = generalize_structure !global_level ty let generalize_structure ty = generalize_structure !current_level ty (* Correct the levels of type [ty]. *) let correct_levels ty = duplicate_type ty -(* Only generalize the type ty0 in ty *) -let limited_generalize ty0 ty = - let ty0 = repr ty0 in - - let graph = Hashtbl.create 17 in - let idx = ref lowest_level in - let roots = ref [] in - - let rec inverse pty ty = - let ty = repr ty in - if ty.level > !current_level || ty.level = generic_level then ( - decr idx; - Hashtbl.add graph !idx (ty, ref pty); - if ty.level = generic_level || ty == ty0 then roots := ty :: !roots; - set_level ty !idx; - iter_type_expr (inverse [ty]) ty) - else if ty.level < lowest_level then - let _, parents = Hashtbl.find graph ty.level in - parents := pty @ !parents - and generalize_parents ty = - let idx = ty.level in - if idx <> generic_level then ( - set_level ty generic_level; - List.iter generalize_parents !(snd (Hashtbl.find graph idx)); - (* Special case for rows: must generalize the row variable *) - match ty.desc with - | Tvariant row -> - let more = row_more row in - let lv = more.level in - if (lv < lowest_level || lv > !current_level) && lv <> generic_level - then set_level more generic_level - | _ -> ()) - in - - inverse [] ty; - if ty0.level < lowest_level then iter_type_expr (inverse []) ty0; - List.iter generalize_parents !roots; - Hashtbl.iter - (fun _ (ty, _) -> - if ty.level <> generic_level then set_level ty !current_level) - graph - (* Compute statically the free univars of all nodes in a type *) (* This avoids doing it repeatedly during instantiation *) @@ -994,13 +868,6 @@ let instance_def sch = cleanup_types (); ty -let generic_instance env sch = - let old = !current_level in - current_level := generic_level; - let ty = instance env sch in - current_level := old; - ty - let instance_list env schl = let env = gadt_env env in let tyl = List.map (fun t -> copy ?env t) schl in @@ -1066,13 +933,6 @@ let instance_parameterized_type ?keep_names sch_args sch = cleanup_types (); (ty_args, ty) -let instance_parameterized_type_2 sch_args sch_lst sch = - let ty_args = List.map simple_copy sch_args in - let ty_lst = List.map simple_copy sch_lst in - let ty = copy sch in - cleanup_types (); - (ty_args, ty_lst, ty) - let map_kind f = function | Type_abstract -> Type_abstract | Type_open -> Type_open @@ -2826,17 +2686,6 @@ let filter_method env name priv ty = | Tobject (f, _) -> filter_method_field env name priv f | _ -> raise (Unify []) -let check_filter_method env name priv ty = - ignore (filter_method env name priv ty) - -let filter_self_method env lab priv meths ty = - let ty' = filter_method env lab priv ty in - try Meths.find lab !meths - with Not_found -> - let pair = (Ident.create lab, ty') in - meths := Meths.add lab pair !meths; - pair - (***********************************) (* Matching between type schemes *) (***********************************) @@ -3299,23 +3148,6 @@ let equal env rename tyl1 tyl2 = (* Class type matching *) (*************************) -type class_match_failure = - | CM_Virtual_class - | CM_Parameter_arity_mismatch of int * int - | CM_Type_parameter_mismatch of Env.t * (type_expr * type_expr) list - | CM_Parameter_mismatch of Env.t * (type_expr * type_expr) list - | CM_Val_type_mismatch of string * Env.t * (type_expr * type_expr) list - | CM_Meth_type_mismatch of string * Env.t * (type_expr * type_expr) list - | CM_Non_mutable_value of string - | CM_Non_concrete_value of string - | CM_Missing_value of string - | CM_Missing_method of string - | CM_Hide_public of string - | CM_Hide_virtual of string * string - | CM_Public_method of string - | CM_Private_method of string - | CM_Virtual_method of string - (***************) (* Subtyping *) (***************) @@ -3560,8 +3392,8 @@ let enlarge_type env ty = let subtypes = Type_pairs.create 17 -let subtype_error ?ctx env trace = - raise (Subtype (expand_trace env (List.rev trace), [], ctx)) +let subtype_error env trace = + raise (Subtype (expand_trace env (List.rev trace), [], None)) let extract_concrete_typedecl_opt env t = match extract_concrete_typedecl env t with @@ -4059,12 +3891,6 @@ let unalias ty = | Tobject (ty, nm) -> newty2 ty.level (Tobject (unalias_object ty, nm)) | _ -> newty2 ty.level ty.desc -(* Return the arity (as for curried functions) of the given type. *) -let rec arity ty = - match (repr ty).desc with - | Tarrow (_, ret, _, _) -> 1 + arity ret - | _ -> 0 - (* Check whether an abbreviation expands to itself. *) let cyclic_abbrev env id ty = let rec check_cycle seen ty = @@ -4372,28 +4198,6 @@ let nondep_extension_constructor env mid ext = clear_hash (); raise Not_found -(* collapse conjunctive types in class parameters *) -let rec collapse_conj env visited ty = - let ty = repr ty in - if List.memq ty visited then () - else - let visited = ty :: visited in - match ty.desc with - | Tvariant row -> - let row = row_repr row in - List.iter - (fun (_l, fi) -> - match row_field_repr fi with - | Reither (c, t1 :: (_ :: _ as tl), m, e) -> - List.iter (unify env t1) tl; - set_row_field e (Reither (c, [t1], m, ref None)) - | _ -> ()) - row.row_fields; - iter_row (collapse_conj env visited) row - | _ -> iter_type_expr (collapse_conj env visited) ty - -let collapse_conj_params env params = List.iter (collapse_conj env []) params - let same_constr env t1 t2 = let t1 = expand_head env t1 in let t2 = expand_head env t2 in diff --git a/compiler/ml/ctype.mli b/compiler/ml/ctype.mli index 1e359ecc204..ac0a064dbee 100644 --- a/compiler/ml/ctype.mli +++ b/compiler/ml/ctype.mli @@ -67,8 +67,6 @@ val begin_def : unit -> unit val end_def : unit -> unit (* Lower the variable level by one at the end of a definition *) -val begin_class_def : unit -> unit -val raise_nongen_level : unit -> unit val reset_global_level : unit -> unit (* Reset the global level before typing an expression *) @@ -102,7 +100,6 @@ val none : type_expr val repr : type_expr -> type_expr (* Return the canonical representative of a type. *) -val object_fields : type_expr -> type_expr val flatten_fields : type_expr -> (string * field_kind * type_expr) list * type_expr @@ -115,18 +112,8 @@ val associate_fields : * (string * field_kind * type_expr) list * (string * field_kind * type_expr) list val opened_object : type_expr -> bool -val close_object : type_expr -> unit -val row_variable : type_expr -> type_expr -(* Return the row variable of an open object type *) - -val set_object_name : - Ident.t -> type_expr -> type_expr list -> type_expr -> unit -val remove_object_name : type_expr -> unit -val hide_private_methods : type_expr -> unit -val find_cltype_for_path : Env.t -> Path.t -> type_declaration * type_expr val lid_of_path : ?hash:string -> Path.t -> Longident.t -val sort_row_fields : (label * row_field) list -> (label * row_field) list val merge_row_fields : (label * row_field) list -> (label * row_field) list -> @@ -143,20 +130,12 @@ val generalize_expansive : Env.t -> type_expr -> unit (* Generalize the covariant part of a type, making contravariant branches non-generalizable *) -val generalize_global : type_expr -> unit -(* Generalize the structure of a type, lowering variables - to !global_level *) - val generalize_structure : type_expr -> unit (* Same, but variables are only lowered to !current_level *) val correct_levels : type_expr -> type_expr (* Returns a copy with decreasing levels *) -val limited_generalize : type_expr -> type_expr -> unit -(* Only generalize some part of the type - Make the remaining of the type non-generalizable *) - val instance : ?partial:bool -> Env.t -> type_expr -> type_expr (* Take an instance of a type scheme *) @@ -166,9 +145,6 @@ val instance : ?partial:bool -> Env.t -> type_expr -> type_expr val instance_def : type_expr -> type_expr (* use defaults *) -val generic_instance : Env.t -> type_expr -> type_expr -(* Same as instance, but new nodes at generic_level *) - val instance_list : Env.t -> type_expr list -> type_expr list (* Take an instance of a list of type schemes *) @@ -180,11 +156,6 @@ val instance_constructor : val instance_parameterized_type : ?keep_names:bool -> type_expr list -> type_expr -> type_expr list * type_expr -val instance_parameterized_type_2 : - type_expr list -> - type_expr list -> - type_expr -> - type_expr list * type_expr list * type_expr val instance_declaration : type_declaration -> type_declaration val instance_poly : ?keep_names:bool -> @@ -211,7 +182,6 @@ val expand_head_opt : Env.t -> type_expr -> type_expr (** The compiler's own version of [expand_head] necessary for type-based optimisations. *) -val full_expand : Env.t -> type_expr -> type_expr val extract_concrete_typedecl : Env.t -> type_expr -> Path.t * Path.t * type_declaration (* Return the original path of the types, and the first concrete @@ -242,47 +212,15 @@ val filter_arrow : val filter_method : Env.t -> string -> private_flag -> type_expr -> type_expr (* A special case of unification (with {m : 'a; 'b}). *) -val check_filter_method : Env.t -> string -> private_flag -> type_expr -> unit -(* A special case of unification (with {m : 'a; 'b}), returning unit. *) - val occur_in : Env.t -> type_expr -> type_expr -> bool val deep_occur : type_expr -> type_expr -> bool -val filter_self_method : - Env.t -> - string -> - private_flag -> - (Ident.t * type_expr) Meths.t ref -> - type_expr -> - Ident.t * type_expr val moregeneral : Env.t -> bool -> type_expr -> type_expr -> bool (* Check if the first type scheme is more general than the second. *) -val rigidify : type_expr -> type_expr list -(* "Rigidify" a type and return its type variable *) - -val all_distinct_vars : Env.t -> type_expr list -> bool -(* Check those types are all distinct type variables *) - val matches : Env.t -> type_expr -> type_expr -> bool (* Same as [moregeneral false], implemented using the two above functions and backtracking. Ignore levels *) -type class_match_failure = - | CM_Virtual_class - | CM_Parameter_arity_mismatch of int * int - | CM_Type_parameter_mismatch of Env.t * (type_expr * type_expr) list - | CM_Parameter_mismatch of Env.t * (type_expr * type_expr) list - | CM_Val_type_mismatch of string * Env.t * (type_expr * type_expr) list - | CM_Meth_type_mismatch of string * Env.t * (type_expr * type_expr) list - | CM_Non_mutable_value of string - | CM_Non_concrete_value of string - | CM_Missing_value of string - | CM_Missing_method of string - | CM_Hide_public of string - | CM_Hide_virtual of string * string - | CM_Public_method of string - | CM_Private_method of string - | CM_Virtual_method of string val equal : Env.t -> bool -> type_expr list -> type_expr list -> bool (* [equal env [x1...xn] tau [y1...yn] sigma] checks whether the parameterized types @@ -312,28 +250,18 @@ val nondep_extension_constructor : (* Same for extension constructor *) (*val correct_abbrev: Env.t -> Path.t -> type_expr list -> type_expr -> unit*) val cyclic_abbrev : Env.t -> Ident.t -> type_expr -> bool -val is_contractive : Env.t -> Path.t -> bool val normalize_type : Env.t -> type_expr -> unit val closed_schema : Env.t -> type_expr -> bool (* Check whether the given type scheme contains no non-generic type variables *) -val free_variables : ?env:Env.t -> type_expr -> type_expr list -(* If env present, then check for incomplete definitions too *) +val free_variables : type_expr -> type_expr list val closed_type_decl : type_declaration -> type_expr option val closed_extension_constructor : extension_constructor -> type_expr option -type closed_class_failure = - | CC_Method of type_expr * bool * string * type_expr - | CC_Value of type_expr * bool * string * type_expr val unalias : type_expr -> type_expr -val arity : type_expr -> int -(* Return the arity (as for curried functions) of the given type. *) - -val collapse_conj_params : Env.t -> type_expr list -> unit -(* Collapse conjunctive types in class parameters *) val get_current_level : unit -> int val wrap_trace_gadt_instances : Env.t -> ('a -> 'b) -> 'a -> 'b diff --git a/compiler/ml/datarepr.ml b/compiler/ml/datarepr.ml index 44e2ba9afa2..a33e2c57f19 100644 --- a/compiler/ml/datarepr.ml +++ b/compiler/ml/datarepr.ml @@ -256,20 +256,6 @@ let label_descrs ty_res lbls repres priv = in describe_labels 0 lbls -exception Constr_not_found - -let rec find_constr tag num_const num_nonconst = function - | [] -> raise Constr_not_found - | ({cd_args = Cstr_tuple []; _} as c) :: rem -> - if Types.equal_tag tag (Cstr_constant num_const) then c - else find_constr tag (num_const + 1) num_nonconst rem - | c :: rem -> - if Types.equal_tag tag (Cstr_block num_nonconst) || tag = Cstr_unboxed then - c - else find_constr tag num_const (num_nonconst + 1) rem - -let find_constr_by_tag tag cstrlist = find_constr tag 0 0 cstrlist - let constructors_of_type ty_path decl = match decl.type_kind with | Type_variant cstrs -> constructor_descrs ty_path decl cstrs diff --git a/compiler/ml/datarepr.mli b/compiler/ml/datarepr.mli index 47113d87e8e..bf60c253a8b 100644 --- a/compiler/ml/datarepr.mli +++ b/compiler/ml/datarepr.mli @@ -27,18 +27,5 @@ val labels_of_type : val constructors_of_type : Path.t -> type_declaration -> (Ident.t * constructor_description) list -exception Constr_not_found - -val find_constr_by_tag : - constructor_tag -> constructor_declaration list -> constructor_declaration - -val constructor_existentials : - constructor_arguments -> type_expr option -> type_expr list * type_expr list -(** Takes [cd_args] and [cd_res] from a [constructor_declaration] and - returns: - - the types of the constructor's arguments - - the existential variables introduced by the constructor - *) - (* Set the polymorphic variant row_name field *) val set_row_name : type_declaration -> Path.t -> unit diff --git a/compiler/ml/depend.ml b/compiler/ml/depend.ml index 3b00ff9e5a3..bf3b216da90 100644 --- a/compiler/ml/depend.ml +++ b/compiler/ml/depend.ml @@ -18,8 +18,6 @@ open Location open Longident open Parsetree -let pp_deps = ref [] - module String_set = Set.Make (struct type t = string let compare = compare @@ -36,8 +34,6 @@ let bound = Node (String_set.empty, String_map.empty) let get_map (Node (_s, m)) = m let make_leaf s = Node (String_set.singleton s, String_map.empty) let make_node m = Node (String_set.empty, m) -let rec weaken_map s (Node (s0, m0)) = - Node (String_set.union s s0, String_map.map (weaken_map s) m0) let rec collect_free (Node (s, m)) = String_map.fold (fun _ n -> String_set.union (collect_free n)) m s @@ -522,5 +518,3 @@ and add_struct_item (bv, m) item : _ String_map.t * _ String_map.t = and add_implementation bv l = if !Clflags.transparent_modules then ignore (add_structure_binding bv l) else ignore (add_structure bv l) - -and add_implementation_binding bv l = snd (add_structure_binding bv l) diff --git a/compiler/ml/depend.mli b/compiler/ml/depend.mli index aa41f121e5e..75106446056 100644 --- a/compiler/ml/depend.mli +++ b/compiler/ml/depend.mli @@ -20,20 +20,11 @@ module String_map : Map.S with type key = string type map_tree = Node of String_set.t * bound_map and bound_map = map_tree String_map.t -val make_leaf : string -> map_tree -val make_node : bound_map -> map_tree -val weaken_map : String_set.t -> map_tree -> map_tree val free_structure_names : String_set.t ref -(* dependencies found by preprocessing tools (plugins) *) -val pp_deps : string list ref - val open_module : bound_map -> Longident.t -> bound_map val add_signature : bound_map -> Parsetree.signature -> unit val add_implementation : bound_map -> Parsetree.structure -> unit - -val add_implementation_binding : bound_map -> Parsetree.structure -> bound_map -val add_signature_binding : bound_map -> Parsetree.signature -> bound_map diff --git a/compiler/ml/env.ml b/compiler/ml/env.ml index 0626ba55520..c4d16d23eb6 100644 --- a/compiler/ml/env.ml +++ b/compiler/ml/env.ml @@ -148,7 +148,6 @@ type summary = | Env_modtype of summary * Ident.t * modtype_declaration | Env_open of summary * Path.t | Env_functor_arg of summary * Ident.t - | Env_constraints of summary * type_declaration Path_map.t | Env_copy_types of summary * string list module Tycomp_tbl = struct @@ -227,21 +226,6 @@ module Tycomp_tbl = struct |> fold_name f next | None -> acc - let rec local_keys tbl acc = - let acc = Ident.fold_all (fun k _ accu -> k :: accu) tbl.current acc in - match tbl.opened with - | Some o -> local_keys o.next acc - | None -> acc - - let diff_keys is_local tbl1 tbl2 = - let keys2 = local_keys tbl2 [] in - Ext_list.filter keys2 (fun id -> - is_local (find_same id tbl2) - && - try - ignore (find_same id tbl1); - false - with Not_found -> true) end module Id_tbl = struct @@ -357,12 +341,6 @@ module Id_tbl = struct |> fold_name f next | None -> acc - let rec local_keys tbl acc = - let acc = Ident.fold_all (fun k _ accu -> k :: accu) tbl.current acc in - match tbl.opened with - | Some o -> local_keys o.next acc - | None -> acc - let rec iter f tbl = Ident.iter (fun id desc -> f id (Pident id, desc)) tbl.current; match tbl.opened with @@ -374,13 +352,6 @@ module Id_tbl = struct iter f next | None -> () - let diff_keys tbl1 tbl2 = - let keys2 = local_keys tbl2 [] in - Ext_list.filter keys2 (fun id -> - try - ignore (find_same id tbl1); - false - with Not_found -> true) end type type_descriptions = constructor_description list * label_description list @@ -506,19 +477,6 @@ let implicit_coercion env = let is_in_signature env = env.flags land in_signature_flag <> 0 let is_implicit_coercion env = env.flags land implicit_coercion_flag <> 0 -let is_ident = function - | Pident _ -> true - | Pdot _ | Papply _ -> false - -let is_local_ext = function - | {cstr_tag = Cstr_extension p} -> is_ident p - | _ -> false - -let diff env1 env2 = - Id_tbl.diff_keys env1.values env2.values - @ Tycomp_tbl.diff_keys is_local_ext env1.constrs env2.constrs - @ Id_tbl.diff_keys env1.modules env2.modules - type can_load_cmis = Can_load_cmis | Cannot_load_cmis of Env_lazy.log let can_load_cmis = ref Can_load_cmis @@ -601,7 +559,6 @@ type pers_struct = { ps_comps: module_components; ps_crcs: (string * Digest.t option) list; ps_filename: string; - ps_flags: pers_flags list; } [@@warning "-69"] @@ -679,7 +636,6 @@ let acknowledge_pers_struct check modname {Persistent_signature.filename; cmi} = ps_comps = comps; ps_crcs = crcs; ps_filename = filename; - ps_flags = flags; } in if ps.ps_name <> modname then @@ -1257,14 +1213,6 @@ let mark_constructor usage env name desc = let ty_name = Path.last ty_path in mark_constructor_used usage env ty_name ty_decl name -let lookup_label ?loc lid env = - match lookup_all_labels ?loc lid env with - | [] -> raise Not_found - | (desc, use) :: _ -> - mark_type_path env (ty_path desc.lbl_res); - use (); - desc - let lookup_all_labels ?loc lid env = try let lbls = lookup_all_labels ?loc lid env in @@ -1807,8 +1755,6 @@ let enter_value ?check = enter (store_value ?check) and enter_type = enter (store_type ~check:true) -and enter_extension = enter (store_extension ~check:true) - and enter_module_declaration ?arg id md env = add_module_declaration ?arg ~check:true id md env (* let (id, env) = enter store_module name md env in @@ -1879,8 +1825,7 @@ let open_signature slot root env0 = (* Open a signature from a file *) -let open_signature ?(used_slot = ref false) ?(loc = Location.none) - ?(toplevel = false) ovf root env = +let open_signature ?(loc = Location.none) ?(toplevel = false) ovf root env = if (not toplevel) && ovf = Asttypes.Fresh && (not loc.Location.loc_ghost) @@ -1888,7 +1833,7 @@ let open_signature ?(used_slot = ref false) ?(loc = Location.none) || Warnings.is_active (Warnings.Open_shadow_identifier ("", "")) || Warnings.is_active (Warnings.Open_shadow_label_constructor ("", ""))) then ( - let used = used_slot in + let used = ref false in Delayed_checks.add_delayed_check (fun () -> if not !used then ( used := true; @@ -1917,15 +1862,6 @@ let read_signature modname filename = let ps = read_pers_struct modname filename in Lazy.force ps.ps_sig -(* Return the CRC of the interface of the given compilation unit *) - -let crc_of_unit name = - let ps = find_pers_struct name in - let crco = try List.assoc name ps.ps_crcs with Not_found -> assert false in - match crco with - | None -> assert false - | Some crc -> crc - (* Return the list of imported interfaces with their CRCs *) let imports () = @@ -1972,7 +1908,6 @@ let save_signature_with_imports ?check_exists ~deprecated sg modname filename ps_comps = comps; ps_crcs = (cmi.cmi_name, Some crc) :: imports; ps_filename = filename; - ps_flags = cmi.cmi_flags; } in save_pers_struct crc ps; @@ -2067,12 +2002,6 @@ let initial_safe_string = (add_extension ~check:false) empty -(* Return the environment summary *) - -let summary env = - if Path_map.is_empty env.local_constraints then env.summary - else Env_constraints (env.summary, env.local_constraints) - let last_env = ref empty let last_reduced_env = ref empty @@ -2091,10 +2020,6 @@ let keep_only_summary env = last_reduced_env := new_env; new_env -let env_of_only_summary env_from_summary env = - let new_env = env_from_summary env.summary Subst.identity in - {new_env with local_constraints = env.local_constraints; flags = env.flags} - (* Error report *) open Format diff --git a/compiler/ml/env.mli b/compiler/ml/env.mli index 66b8e3192b4..2497d5ede09 100644 --- a/compiler/ml/env.mli +++ b/compiler/ml/env.mli @@ -29,7 +29,6 @@ type summary = | Env_modtype of summary * Ident.t * modtype_declaration | Env_open of summary * Path.t | Env_functor_arg of summary * Ident.t - | Env_constraints of summary * type_declaration Path_map.t | Env_copy_types of summary * string list type t @@ -37,7 +36,6 @@ type t val empty : t val initial_safe_string : t -val diff : t -> t -> Ident.t list val copy_local : from:t -> t -> t type type_descriptions = constructor_description list * label_description list @@ -71,7 +69,6 @@ val find_type_expansion_opt : (* Find the manifest type information associated to a type for the sake of the compiler's type-based optimisations. *) val find_modtype_expansion : Path.t -> t -> module_type -val add_functor_arg : Ident.t -> t -> t val is_functor_arg : Path.t -> t -> bool val normalize_path : Location.t option -> t -> Path.t -> Path.t @@ -101,7 +98,6 @@ val lookup_all_constructors : Longident.t -> t -> (constructor_description * (unit -> unit)) list -val lookup_label : ?loc:Location.t -> Longident.t -> t -> label_description val lookup_all_labels : ?loc:Location.t -> Longident.t -> @@ -147,7 +143,6 @@ val add_signature : signature -> t -> t Used to implement open. Returns None if the path refers to a functor, not a structure. *) val open_signature : - ?used_slot:bool ref -> ?loc:Location.t -> ?toplevel:bool -> Asttypes.override_flag -> @@ -164,7 +159,6 @@ val enter_value : t -> Ident.t * t val enter_type : string -> type_declaration -> t -> Ident.t * t -val enter_extension : string -> extension_constructor -> t -> Ident.t * t val enter_module : ?arg:bool -> string -> module_type -> t -> Ident.t * t val enter_module_declaration : ?arg:bool -> Ident.t -> module_declaration -> t -> t @@ -194,41 +188,18 @@ val save_signature : Cmi_format.cmi_infos (* Arguments: signature, module name, file name. *) -val save_signature_with_imports : - ?check_exists:unit -> - deprecated:string option -> - signature -> - string -> - string -> - (string * Digest.t option) list -> - Cmi_format.cmi_infos -(* Arguments: signature, module name, file name, - imported units with their CRCs. *) - -(* Return the CRC of the interface of the given compilation unit *) - -val crc_of_unit : string -> Digest.t - (* Return the set of compilation units imported, with their CRC *) val imports : unit -> (string * Digest.t option) list -(* Direct access to the table of imported compilation units with their CRC *) - -val crc_units : Consistbl.t -val add_import : string -> unit - (* Summaries -- compact representation of an environment, to be exported in debugging information. *) -val summary : t -> summary - (* Return an equivalent environment where all fields have been reset, except the summary. The initial environment can be rebuilt from the - summary, using Envaux.env_of_only_summary. *) + summary. *) val keep_only_summary : t -> t -val env_of_only_summary : (summary -> Subst.t -> t) -> t -> t (* Error report *) @@ -240,10 +211,6 @@ type error = exception Error of error -open Format - -val report_error : formatter -> error -> unit - val mark_value_used : t -> string -> value_description -> unit val mark_module_used : t -> string -> Location.t -> unit val mark_type_used : t -> string -> type_declaration -> unit diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index 76867174493..6313fd75566 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -17,9 +17,6 @@ module Parser : sig val reprint_source : (Parsetree.structure -> comment list -> string) ref - val parse_expr_at_loc : - Warnings.loc -> (Parsetree.expression * comment list) option - val reprint_expr_at_loc : ?mapper:(Parsetree.expression -> Parsetree.expression option) -> Warnings.loc -> @@ -91,7 +88,6 @@ type type_clash_context = } | ArrayValue | TaggedTemplateValue - | MaybeUnwrapOption | IfCondition | AssertCondition | IfReturn @@ -189,7 +185,7 @@ let error_expected_type_text ppf type_clash_context = fprintf ppf "But you're using @{await@} on this expression, so it is expected \ to be of type:" - | Some MaybeUnwrapOption | Some BracedIdent | None -> + | Some BracedIdent | None -> fprintf ppf "But it's expected to have type:" let is_record_type ~(extract_concrete_typedecl : extract_concrete_typedecl) ~env @@ -407,12 +403,6 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf "\n\n\ \ Ternaries (@{?@} and @{:@}) must return the same type in \ both branches." - | Some MaybeUnwrapOption, _ -> - fprintf ppf - "\n\n\ - \ Possible solutions:\n\ - \ - Unwrap the option to its underlying value using \ - `yourValue->Option.getOr(someDefaultValue)`" | Some ComparisonOperator, _ -> fprintf ppf "\n\n You can only compare things of the same type." | Some ArrayValue, _ -> @@ -840,15 +830,6 @@ let type_clash_context_for_function_argument ~label type_clash_context sarg0 = }) | type_clash_context -> type_clash_context -let type_clash_context_maybe_option ty_expected ty_res = - match (ty_expected, ty_res) with - | ( {Types.desc = Tconstr (expected_path, _, _)}, - {Types.desc = Tconstr (type_path, _, _)} ) - when Path.same Predef.path_option type_path - && Path.same expected_path Predef.path_option = false -> - Some MaybeUnwrapOption - | _ -> None - let type_clash_context_in_statement sexp = match sexp.Parsetree.pexp_desc with | Pexp_apply {transformed_jsx = false} -> Some (Statement FunctionCall) diff --git a/compiler/ml/includemod.ml b/compiler/ml/includemod.ml index d4c01d405e5..d3fa5031d44 100644 --- a/compiler/ml/includemod.ml +++ b/compiler/ml/includemod.ml @@ -141,41 +141,6 @@ let is_runtime_component = function | Sig_class () -> true -(* Print a coercion *) - -let rec print_list pr ppf = function - | [] -> () - | [a] -> pr ppf a - | a :: l -> - pr ppf a; - Format.fprintf ppf ";@ "; - print_list pr ppf l -let print_list pr ppf l = Format.fprintf ppf "[@[%a@]]" (print_list pr) l - -let rec print_coercion ppf c = - let pr fmt = Format.fprintf ppf fmt in - match c with - | Tcoerce_none -> pr "id" - | Tcoerce_structure (fl, nl, _) -> - pr "@[<2>struct@ %a@ %a@]" - (print_list print_coercion2) - fl - (print_list print_coercion3) - nl - | Tcoerce_functor (inp, out) -> - pr "@[<2>functor@ (%a)@ (%a)@]" print_coercion inp print_coercion out - | Tcoerce_primitive {pc_desc; pc_env = _; pc_type} -> - pr "prim %s@ (%a)" pc_desc.Primitive.prim_name Printtyp.raw_type_expr - pc_type - | Tcoerce_alias (p, c) -> - pr "@[<2>alias %a@ (%a)@]" Printtyp.path p print_coercion c - -and print_coercion2 ppf (n, c) = - Format.fprintf ppf "@[%d,@ %a@]" n print_coercion c - -and print_coercion3 ppf (i, n, c) = - Format.fprintf ppf "@[%s, %d,@ %a@]" (Ident.unique_name i) n print_coercion c - (* Simplify a structure coercion *) let simplify_structure_coercion cc id_pos_list runtime_fields = diff --git a/compiler/ml/includemod.mli b/compiler/ml/includemod.mli index 9399f2b63a9..ea810c5bb11 100644 --- a/compiler/ml/includemod.mli +++ b/compiler/ml/includemod.mli @@ -35,8 +35,6 @@ val type_declarations : type_declaration -> unit -val print_coercion : formatter -> module_coercion -> unit - type symptom = | Missing_field of Ident.t * Location.t * string (* kind *) | Value_descriptions of Ident.t * value_description * value_description diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 99f399aa0ac..08a1d2415a1 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -384,13 +384,11 @@ and lambda_switch = { (* Sharing key *) val make_key : lambda -> lambda option -val const_unit : structured_constant val lambda_assert_false : lambda val lambda_unit : lambda val lambda_module_alias : lambda val name_lambda : let_kind -> lambda -> (Ident.t -> lambda) -> lambda -val iter : (lambda -> unit) -> lambda -> unit module Ident_set : Set.S with type elt = Ident.t val free_variables : lambda -> Ident_set.t diff --git a/compiler/ml/location.ml b/compiler/ml/location.ml index fa2e806db07..78c1fc69040 100644 --- a/compiler/ml/location.ml +++ b/compiler/ml/location.ml @@ -180,13 +180,11 @@ type error = { if_highlight: string; (* alternative message if locations are highlighted *) } -let pp_ksprintf ?before k fmt = +let pp_ksprintf ~before k fmt = let buf = Buffer.create 64 in let ppf = Format.formatter_of_buffer buf in Misc.Color.set_color_tag_handling ppf; - (match before with - | None -> () - | Some f -> f ppf); + before ppf; kfprintf (fun _ -> pp_print_flush ppf (); @@ -202,9 +200,9 @@ let print_phanton_error_prefix ppf = (see super_error_reporter above) *) Format.pp_print_as ppf 2 "" -let errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") fmt = +let errorf ~loc ?(sub = []) fmt = pp_ksprintf ~before:print_phanton_error_prefix - (fun msg -> {loc; msg; sub; if_highlight}) + (fun msg -> {loc; msg; sub; if_highlight = ""}) fmt let error ?(loc = none) ?(sub = []) ?(if_highlight = "") msg = @@ -294,9 +292,9 @@ let () = | Error e -> Some e | _ -> None) -let raise_errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") = +let raise_errorf ?(loc = none) = pp_ksprintf ~before:print_phanton_error_prefix (fun msg -> - raise (Error {loc; msg; sub; if_highlight})) + raise (Error {loc; msg; sub = []; if_highlight = ""})) let deprecated ?(can_be_automigrated = false) ?(def = none) ?(use = none) loc msg = diff --git a/compiler/ml/location.mli b/compiler/ml/location.mli index 76f4db2bd81..b1ae6178a55 100644 --- a/compiler/ml/location.mli +++ b/compiler/ml/location.mli @@ -76,16 +76,13 @@ exception Error of error val error : ?loc:t -> ?sub:error list -> ?if_highlight:string -> string -> error val errorf : - ?loc:t -> + loc:t -> ?sub:error list -> - ?if_highlight:string -> ('a, Format.formatter, unit, error) format4 -> 'a val raise_errorf : ?loc:t -> - ?sub:error list -> - ?if_highlight:string -> ('a, Format.formatter, unit, 'b) format4 -> 'a diff --git a/compiler/ml/longident.mli b/compiler/ml/longident.mli index 26ed938e846..d0a724d6101 100644 --- a/compiler/ml/longident.mli +++ b/compiler/ml/longident.mli @@ -19,6 +19,5 @@ type t = Lident of string | Ldot of t * string | Lapply of t * t val cmp : t -> t -> int val flatten : t -> string list -val unflatten : string list -> t option val last : t -> string val parse : string -> t diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index 916646ea08a..70a84c5faff 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -448,14 +448,6 @@ end) let make_exit i = Lstaticraise (i, []) -(* Introduce a catch, if worth it *) -let make_catch d k = - match d with - | Lstaticraise (_, []) -> k d - | _ -> - let e = next_raise_count () in - Lstaticcatch (k (make_exit e), (e, []), d) - (* Introduce a catch, if worth it, delayed version *) let rec as_simple_exit = function | Lstaticraise (i, []) -> Some i @@ -1515,94 +1507,6 @@ let make_array_matching p def ctx = function let divide_array ctx pm = divide make_array_matching ( = ) get_key_array get_args_array ctx pm -(* - Specific string test sequence - Will be called by the bytecode compiler, from bytegen.ml. - The strategy is first dichotomic search (we perform 3-way tests - with compare_string), then sequence of equality tests - when there are less then T=strings_test_threshold static strings to match. - - Increasing T entails (slightly) less code, decreasing T - (slightly) favors runtime speed. - T=8 looks a decent tradeoff. -*) - -(* Utilities *) - -let strings_test_threshold = 8 - -let bind_sw arg k = - match arg with - | Lvar _ -> k arg - | _ -> - let id = Ident.create "switch" in - Llet (Strict, Pgenval, id, arg, k (Lvar id)) - -(* Sequential equality tests *) - -let make_string_test_sequence loc arg sw d = - let d, sw = - match d with - | None -> ( - match sw with - | (_, d) :: sw -> (d, sw) - | [] -> assert false) - | Some d -> (d, sw) - in - bind_sw arg (fun arg -> - List.fold_right - (fun (s, lam) k -> - Lifthenelse - ( Lprim (Pstringcomp Cneq, [arg; Lconst (Const_immstring s)], loc), - k, - lam )) - sw d) - -let rec split k xs = - match xs with - | [] -> assert false - | x0 :: xs -> - if k <= 1 then ([], x0, xs) - else - let xs, y0, ys = split (k - 2) xs in - (x0 :: xs, y0, ys) - -let zero_lam = Lconst (Const_base (Const_int 0)) - -let tree_way_test loc arg lt eq gt = - Lifthenelse - ( Lprim (Pintcomp Clt, [arg; zero_lam], loc), - lt, - Lifthenelse (Lprim (Pintcomp Clt, [zero_lam; arg], loc), gt, eq) ) - -(* Dichotomic tree *) - -let rec do_make_string_test_tree loc arg sw delta d = - let len = List.length sw in - if len <= strings_test_threshold + delta then - make_string_test_sequence loc arg sw d - else - let lt, (s, act), gt = split len sw in - bind_sw - (Lprim (Pstringcomp Ceq, [arg; Lconst (Const_immstring s)], loc)) - (fun r -> - tree_way_test loc r - (do_make_string_test_tree loc arg lt delta d) - act - (do_make_string_test_tree loc arg gt delta d)) - -(* Entry point *) -let expand_stringswitch loc arg sw d = - match d with - | None -> bind_sw arg (fun arg -> do_make_string_test_tree loc arg sw 0 None) - | Some e -> - bind_sw arg (fun arg -> - make_catch e (fun d -> do_make_string_test_tree loc arg sw 1 (Some d))) - -(**********************) -(* Generic test trees *) -(**********************) - (* Sharing *) (* Add handler, if shared *) @@ -2677,7 +2581,6 @@ let check_partial is_mutable pat_act_list = function then Partial else Total -let check_partial_list = check_partial (List.exists is_mutable) let check_partial = check_partial is_mutable (* have toplevel handler when appropriate *) @@ -2811,27 +2714,6 @@ let for_let loc param pat body = Llet (Strict, Pgenval, id, param, body) | _ -> simple_for_let loc param pat body -(* Handling of tupled functions and matchings *) - -(* Easy case since variables are available *) -let for_tupled_function loc paraml pats_act_list partial = - let partial = check_partial_list pats_act_list partial in - let raise_num = next_raise_count () in - let omegas = [List.map (fun _ -> omega) paraml] in - let pm = - { - cases = pats_act_list; - args = List.map (fun id -> (Lvar id, Strict)) paraml; - default = [(omegas, raise_num)]; - } - in - try - let lambda, total = - compile_match None partial (start_ctx (List.length paraml)) pm - in - check_total total lambda raise_num (partial_function loc) - with Unused -> partial_function loc () - let flatten_pattern size p = match p.pat_desc with | Tpat_tuple args -> args diff --git a/compiler/ml/matching.mli b/compiler/ml/matching.mli index 43d1d2cec3c..95fbd9e2826 100644 --- a/compiler/ml/matching.mli +++ b/compiler/ml/matching.mli @@ -56,21 +56,8 @@ val for_let : Location.t -> lambda -> pattern -> lambda -> lambda val for_multiple_match : Location.t -> lambda list -> (pattern * lambda) list -> partial -> lambda -val for_tupled_function : - Location.t -> - Ident.t list -> - (pattern list * lambda) list -> - partial -> - lambda - exception Cannot_flatten -val flatten_pattern : int -> pattern -> pattern list - -(* Expand stringswitch to string test tree *) -val expand_stringswitch : - Location.t -> lambda -> (string * lambda) list -> lambda option -> lambda - (* To be set by Lam_compile *) val names_from_construct_pattern : (pattern -> Ast_untagged_variants.switch_names option) ref diff --git a/compiler/ml/mtype.ml b/compiler/ml/mtype.ml index 4ed00e0054e..53cf218e7de 100644 --- a/compiler/ml/mtype.ml +++ b/compiler/ml/mtype.ml @@ -232,30 +232,6 @@ and type_paths_sig env p pos sg = | (Sig_typext _ | Sig_class _) :: rem -> type_paths_sig env p (pos + 1) rem | Sig_class_type _ :: rem -> type_paths_sig env p pos rem -let rec no_code_needed env mty = - match scrape env mty with - | Mty_ident _ -> false - | Mty_signature sg -> no_code_needed_sig env sg - | Mty_functor (_, _, _) -> false - | Mty_alias (Mta_absent, _) -> true - | Mty_alias (Mta_present, _) -> false - -and no_code_needed_sig env sg = - match sg with - | [] -> true - | Sig_value (_id, decl) :: rem -> ( - match decl.val_kind with - | Val_prim _ -> no_code_needed_sig env rem - | _ -> false) - | Sig_module (id, md, _) :: rem -> - no_code_needed env md.md_type - && no_code_needed_sig - (Env.add_module_declaration ~check:false id md env) - rem - | (Sig_type _ | Sig_modtype _ | Sig_class_type _) :: rem -> - no_code_needed_sig env rem - | (Sig_typext _ | Sig_class _) :: _ -> false - (* Check whether a module type may return types *) let rec contains_type env = function diff --git a/compiler/ml/mtype.mli b/compiler/ml/mtype.mli index 64198df4bd0..fec90b15d3a 100644 --- a/compiler/ml/mtype.mli +++ b/compiler/ml/mtype.mli @@ -37,11 +37,6 @@ val nondep_supertype : Env.t -> Ident.t -> module_type -> module_type in which the given ident does not appear. Raise [Not_found] if no such type exists. *) -val no_code_needed : Env.t -> module_type -> bool -val no_code_needed_sig : Env.t -> signature -> bool -(* Determine whether a module needs no implementation code, - i.e. consists only of type definitions. *) - val enrich_modtype : Env.t -> Path.t -> module_type -> module_type val enrich_typedecl : Env.t -> Path.t -> type_declaration -> type_declaration val type_paths : Env.t -> Path.t -> module_type -> Path.t list diff --git a/compiler/ml/oprint.ml b/compiler/ml/oprint.ml index 153d68fb183..339c673426d 100644 --- a/compiler/ml/oprint.ml +++ b/compiler/ml/oprint.ml @@ -16,10 +16,6 @@ open Format open Outcometree -exception Ellipsis - -let cautious f ppf arg = try f ppf arg with Ellipsis -> fprintf ppf "..." - let out_ident = ref pp_print_string let map_primitive_name = ref (fun x -> x) @@ -47,178 +43,6 @@ let value_ident ppf name = if parenthesized_ident name then fprintf ppf "( %s )" name else pp_print_string ppf name -(* Values *) - -let valid_float_lexeme s = - let l = String.length s in - let rec loop i = - if i >= l then s ^ "." - else - match s.[i] with - | '0' .. '9' | '-' -> loop (i + 1) - | _ -> s - in - loop 0 - -let float_repres f = - match classify_float f with - | FP_nan -> "nan" - | FP_infinite -> if f < 0.0 then "neg_infinity" else "infinity" - | _ -> - let float_val = - let s1 = Printf.sprintf "%.12g" f in - if f = float_of_string s1 then s1 - else - let s2 = Printf.sprintf "%.15g" f in - if f = float_of_string s2 then s2 else Printf.sprintf "%.18g" f - in - valid_float_lexeme float_val - -let parenthesize_if_neg ppf fmt v isneg = - if isneg then pp_print_char ppf '('; - fprintf ppf fmt v; - if isneg then pp_print_char ppf ')' - -let escape_string s = - (* Escape only C0 control characters (bytes <= 0x1F), DEL(0x7F), '\\' and '"' *) - let n = ref 0 in - for i = 0 to String.length s - 1 do - n := - !n - + - match String.unsafe_get s i with - | '\"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2 - | '\x00' .. '\x1F' | '\x7F' -> 4 - | _ -> 1 - done; - if !n = String.length s then s - else - let s' = Bytes.create !n in - n := 0; - for i = 0 to String.length s - 1 do - (match String.unsafe_get s i with - | ('\"' | '\\') as c -> - Bytes.unsafe_set s' !n '\\'; - incr n; - Bytes.unsafe_set s' !n c - | '\n' -> - Bytes.unsafe_set s' !n '\\'; - incr n; - Bytes.unsafe_set s' !n 'n' - | '\t' -> - Bytes.unsafe_set s' !n '\\'; - incr n; - Bytes.unsafe_set s' !n 't' - | '\r' -> - Bytes.unsafe_set s' !n '\\'; - incr n; - Bytes.unsafe_set s' !n 'r' - | '\b' -> - Bytes.unsafe_set s' !n '\\'; - incr n; - Bytes.unsafe_set s' !n 'b' - | ('\x00' .. '\x1F' | '\x7F') as c -> - let a = Char.code c in - Bytes.unsafe_set s' !n '\\'; - incr n; - Bytes.unsafe_set s' !n (Char.chr (48 + (a / 100))); - incr n; - Bytes.unsafe_set s' !n (Char.chr (48 + (a / 10 mod 10))); - incr n; - Bytes.unsafe_set s' !n (Char.chr (48 + (a mod 10))) - | c -> Bytes.unsafe_set s' !n c); - incr n - done; - Bytes.to_string s' - -let print_out_string ppf s = - let not_escaped = - (* let the user dynamically choose if strings should be escaped: *) - match Sys.getenv_opt "OCAMLTOP_UTF_8" with - | None -> true - | Some x -> ( - match bool_of_string_opt x with - | None -> true - | Some f -> f) - in - if not_escaped then fprintf ppf "\"%s\"" (escape_string s) - else fprintf ppf "%S" s - -let print_out_value ppf tree = - let rec print_tree_1 ppf = function - | Oval_constr (name, [param]) -> - fprintf ppf "@[<1>%a@ %a@]" print_ident name print_constr_param param - | Oval_constr (name, (_ :: _ as params)) -> - fprintf ppf "@[<1>%a@ (%a)@]" print_ident name - (print_tree_list print_tree_1 ",") - params - | Oval_variant (name, Some param) -> - fprintf ppf "@[<2>`%s@ %a@]" name print_constr_param param - | tree -> print_simple_tree ppf tree - and print_constr_param ppf = function - | Oval_int i -> parenthesize_if_neg ppf "%i" i (i < 0) - | Oval_int32 i -> parenthesize_if_neg ppf "%lil" i (i < 0l) - | Oval_int64 i -> parenthesize_if_neg ppf "%LiL" i (i < 0L) - | Oval_nativeint i -> parenthesize_if_neg ppf "%nin" i (i < 0n) - | Oval_float f -> parenthesize_if_neg ppf "%s" (float_repres f) (f < 0.0) - | Oval_string (_, _, Ostr_bytes) as tree -> - pp_print_char ppf '('; - print_simple_tree ppf tree; - pp_print_char ppf ')' - | tree -> print_simple_tree ppf tree - and print_simple_tree ppf = function - | Oval_int i -> fprintf ppf "%i" i - | Oval_int32 i -> fprintf ppf "%lil" i - | Oval_int64 i -> fprintf ppf "%LiL" i - | Oval_nativeint i -> fprintf ppf "%nin" i - | Oval_float f -> pp_print_string ppf (float_repres f) - | Oval_char c -> fprintf ppf "%C" c - | Oval_string (s, maxlen, kind) -> ( - try - let len = String.length s in - let s = if len > maxlen then String.sub s 0 maxlen else s in - (match kind with - | Ostr_bytes -> fprintf ppf "Bytes.of_string %S" s - | Ostr_string -> print_out_string ppf s); - if len > maxlen then - fprintf ppf "... (* string length %d; truncated *)" len - with Invalid_argument _ (* "String.create" *) -> - fprintf ppf "") - | Oval_list tl -> - fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree_1 ";") tl - | Oval_array tl -> - fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree_1 ";") tl - | Oval_constr (name, []) -> print_ident ppf name - | Oval_variant (name, None) -> fprintf ppf "`%s" name - | Oval_stuff s -> pp_print_string ppf s - | Oval_record fel -> - fprintf ppf "@[<1>{%a}@]" (cautious (print_fields true)) fel - | Oval_ellipsis -> raise Ellipsis - | Oval_printer f -> f ppf - | Oval_tuple tree_list -> - fprintf ppf "@[<1>(%a)@]" (print_tree_list print_tree_1 ",") tree_list - | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree_1) tree - and print_fields first ppf = function - | [] -> () - | (name, tree) :: fields -> - if not first then fprintf ppf ";@ "; - fprintf ppf "@[<1>%a@ =@ %a@]" print_ident name (cautious print_tree_1) - tree; - print_fields false ppf fields - and print_tree_list print_item sep ppf tree_list = - let rec print_list first ppf = function - | [] -> () - | tree :: tree_list -> - if not first then fprintf ppf "%s@ " sep; - print_item ppf tree; - print_list false ppf tree_list - in - cautious (print_list true) ppf tree_list - in - cautious print_tree_1 ppf tree - -let out_value = ref print_out_value - (* Types *) let rec print_list_init pr sep ppf = function @@ -320,8 +144,6 @@ and print_simple_out_type ppf = function fprintf ppf " %s type %s = %a" sep s print_out_type t) n tyl; fprintf ppf ")@]" - | Otyp_attribute (t, attr) -> - fprintf ppf "@[<1>(%a [@@%s])@]" print_out_type t attr.oattr_name and print_record_decl ppf lbls = fprintf ppf "{%a@;<1 -2>}" @@ -382,56 +204,13 @@ and print_out_label ppf (name, mut, opt, arg) = let out_type = ref print_out_type -(* Class types *) +(* Type parameters *) let type_parameter ppf (ty, (co, cn)) = fprintf ppf "%s%s" (if not cn then "+" else if not co then "-" else "") (if ty = "_" then ty else "'" ^ ty) -let print_out_class_params ppf = function - | [] -> () - | tyl -> - fprintf ppf "@[<1>[%a]@]@ " - (print_list type_parameter (fun ppf -> fprintf ppf ", ")) - tyl - -let rec print_out_class_type ppf = function - | Octy_constr (id, tyl) -> - let pr_tyl ppf = function - | [] -> () - | tyl -> fprintf ppf "@[<1>[%a]@]@ " (print_typlist !out_type ",") tyl - in - fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id - | Octy_arrow (lab, ty, cty) -> - fprintf ppf "@[%s%a ->@ %a@]" - (if lab <> "" then lab ^ ":" else "") - print_out_type_2 ty print_out_class_type cty - | Octy_signature (self_ty, csil) -> - let pr_param ppf = function - | Some ty -> fprintf ppf "@ @[(%a)@]" !out_type ty - | None -> () - in - fprintf ppf "@[@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty - (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ ")) - csil - -and print_out_class_sig_item ppf = function - | Ocsg_constraint (ty1, ty2) -> - fprintf ppf "@[<2>constraint %a =@ %a@]" !out_type ty1 !out_type ty2 - | Ocsg_method (name, priv, virt, ty) -> - fprintf ppf "@[<2>method %s%s%s :@ %a@]" - (if priv then "private " else "") - (if virt then "virtual " else "") - name !out_type ty - | Ocsg_value (name, mut, vr, ty) -> - fprintf ppf "@[<2>val %s%s%s :@ %a@]" - (if mut then "mutable " else "") - (if vr then "virtual " else "") - name !out_type ty - -let out_class_type = ref print_out_class_type - (* Signature *) let out_module_type = ref (fun _ -> failwith "Oprint.out_module_type") @@ -501,16 +280,6 @@ and print_out_signature ppf = function fprintf ppf "%a@ %a" !out_sig_item item print_out_signature items and print_out_sig_item ppf = function - | Osig_class (vir_flag, name, params, clt, rs) -> - fprintf ppf "@[<2>%s%s@ %a%s@ :@ %a@]" - (if rs = Orec_next then "and" else "class") - (if vir_flag then " virtual" else "") - print_out_class_params params name !out_class_type clt - | Osig_class_type (vir_flag, name, params, clt, rs) -> - fprintf ppf "@[<2>%s%s@ %a%s@ =@ %a@]" - (if rs = Orec_next then "and" else "class type") - (if vir_flag then " virtual" else "") - print_out_class_params params name !out_class_type clt | Osig_typext (ext, Oext_exception) -> fprintf ppf "@[<2>exception %a@]" print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr) @@ -548,10 +317,8 @@ and print_out_sig_item ppf = function fprintf ppf "@ \"%s\"" (!map_primitive_name s)) sl in - fprintf ppf "@[<2>%s %a :@ %a%a%a@]" kwd value_ident vd.oval_name !out_type + fprintf ppf "@[<2>%s %a :@ %a%a@]" kwd value_ident vd.oval_name !out_type vd.oval_type pr_prims vd.oval_prims - (fun ppf -> List.iter (fun a -> fprintf ppf "@ [@@@@%s]" a.oattr_name)) - vd.oval_attributes | Osig_ellipsis -> fprintf ppf "..." and print_out_type_decl kwd ppf td = @@ -677,56 +444,3 @@ let _ = out_module_type := print_out_module_type let _ = out_signature := print_out_signature let _ = out_sig_item := print_out_sig_item let _ = out_type_extension := print_out_type_extension - -(* Phrases *) - -let print_out_exception ppf exn outv = - match exn with - | Sys.Break -> fprintf ppf "Interrupted.@." - | Out_of_memory -> fprintf ppf "Out of memory during evaluation.@." - | Stack_overflow -> - fprintf ppf "Stack overflow during evaluation (looping recursion?).@." - | _ -> fprintf ppf "@[Exception:@ %a.@]@." !out_value outv - -let rec print_items ppf = function - | [] -> () - | (Osig_typext (ext, Oext_first), None) :: items -> - (* Gather together extension constructors *) - let rec gather_extensions acc items = - match items with - | (Osig_typext (ext, Oext_next), None) :: items -> - gather_extensions - ((ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr) - :: acc) - items - | _ -> (List.rev acc, items) - in - let exts, items = - gather_extensions - [(ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr)] - items - in - let te = - { - otyext_name = ext.oext_type_name; - otyext_params = ext.oext_type_params; - otyext_constructors = exts; - otyext_private = ext.oext_private; - } - in - fprintf ppf "@[%a@]" !out_type_extension te; - if items <> [] then fprintf ppf "@ %a" print_items items - | (tree, valopt) :: items -> - (match valopt with - | Some v -> fprintf ppf "@[<2>%a =@ %a@]" !out_sig_item tree !out_value v - | None -> fprintf ppf "@[%a@]" !out_sig_item tree); - if items <> [] then fprintf ppf "@ %a" print_items items - -let print_out_phrase ppf = function - | Ophr_eval (outv, ty) -> - fprintf ppf "@[- : %a@ =@ %a@]@." !out_type ty !out_value outv - | Ophr_signature [] -> () - | Ophr_signature items -> fprintf ppf "@[%a@]@." print_items items - | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv - -let out_phrase = ref print_out_phrase diff --git a/compiler/ml/oprint.mli b/compiler/ml/oprint.mli index 4bdd95ad7e9..2e68b914f06 100644 --- a/compiler/ml/oprint.mli +++ b/compiler/ml/oprint.mli @@ -19,13 +19,10 @@ open Outcometree val out_ident : (formatter -> string -> unit) ref val map_primitive_name : (string -> string) ref -val out_value : (formatter -> out_value -> unit) ref val out_type : (formatter -> out_type -> unit) ref -val out_class_type : (formatter -> out_class_type -> unit) ref val out_module_type : (formatter -> out_module_type -> unit) ref val out_sig_item : (formatter -> out_sig_item -> unit) ref val out_signature : (formatter -> out_sig_item list -> unit) ref val out_type_extension : (formatter -> out_type_extension -> unit) ref -val out_phrase : (formatter -> out_phrase -> unit) ref val parenthesized_ident : string -> bool diff --git a/compiler/ml/outcometree.ml b/compiler/ml/outcometree.ml index 13724209fa1..82444743925 100644 --- a/compiler/ml/outcometree.ml +++ b/compiler/ml/outcometree.ml @@ -13,42 +13,14 @@ (* *) (**************************************************************************) -(* Module [Outcometree]: results displayed by the toplevel *) - -(* These types represent messages that the toplevel displays as normal - results or errors. The real displaying is customisable using the hooks: - [Toploop.print_out_value] - [Toploop.print_out_type] - [Toploop.print_out_sig_item] - [Toploop.print_out_phrase] *) +(* Module [Outcometree]: type and signature output displayed by diagnostics and + editor tooling. The rendering is customizable through [Oprint] hooks. *) type out_ident = | Oide_apply of out_ident * out_ident | Oide_dot of out_ident * string | Oide_ident of string -type out_string = Ostr_string | Ostr_bytes - -type out_attribute = {oattr_name: string} - -type out_value = - | Oval_array of out_value list - | Oval_char of char - | Oval_constr of out_ident * out_value list - | Oval_ellipsis - | Oval_float of float - | Oval_int of int - | Oval_int32 of int32 - | Oval_int64 of int64 - | Oval_nativeint of nativeint - | Oval_list of out_value list - | Oval_printer of (Format.formatter -> unit) - | Oval_record of (out_ident * out_value) list - | Oval_string of string * int * out_string (* string, size-to-print, kind *) - | Oval_stuff of string - | Oval_tuple of out_value list - | Oval_variant of string * out_value option - type out_type = | Otyp_abstract | Otyp_open @@ -66,21 +38,11 @@ type out_type = | Otyp_variant of bool * out_variant * bool * string list option | Otyp_poly of string list * out_type | Otyp_module of string * string list * out_type list - | Otyp_attribute of out_type * out_attribute and out_variant = | Ovar_fields of (string * bool * out_type list) list | Ovar_typ of out_type -type out_class_type = - | Octy_constr of out_ident * out_type list - | Octy_arrow of string * out_type * out_class_type - | Octy_signature of out_type option * out_class_sig_item list -and out_class_sig_item = - | Ocsg_constraint of out_type * out_type - | Ocsg_method of string * bool * bool * out_type - | Ocsg_value of string * bool * bool * out_type - type out_module_type = | Omty_abstract | Omty_functor of string * out_module_type option * out_module_type @@ -88,18 +50,6 @@ type out_module_type = | Omty_signature of out_sig_item list | Omty_alias of out_ident and out_sig_item = - | Osig_class of - bool - * string - * (string * (bool * bool)) list - * out_class_type - * out_rec_status - | Osig_class_type of - bool - * string - * (string * (bool * bool)) list - * out_class_type - * out_rec_status | Osig_typext of out_extension_constructor * out_ext_status | Osig_modtype of string * out_module_type | Osig_module of string * out_module_type * out_rec_status @@ -135,12 +85,6 @@ and out_val_decl = { oval_name: string; oval_type: out_type; oval_prims: string list; - oval_attributes: out_attribute list; } and out_rec_status = Orec_not | Orec_first | Orec_next and out_ext_status = Oext_first | Oext_next | Oext_exception - -type out_phrase = - | Ophr_eval of out_value * out_type - | Ophr_signature of (out_sig_item * out_value option) list - | Ophr_exception of (exn * out_value) diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index 4ae23724fb4..c872db94365 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -947,15 +947,14 @@ let pat_of_constrs ex_pat cstrs = if cstrs = [] then raise Empty else orify_many (List.map (pat_of_constr ex_pat) cstrs) -let pats_of_type ?(always = false) env ty = +let pats_of_type env ty = let ty' = Ctype.expand_head env ty in match ty'.desc with | Tconstr (path, _, _) -> ( try match (Env.find_type path env).type_kind with | Type_variant cl - when always - || List.length cl = 1 + when List.length cl = 1 || List.for_all (fun cd -> cd.Types.cd_res <> None) cl -> let cstrs = fst (Env.find_type_descrs path env) in List.map (pat_of_constr (make_pat Tpat_any ty env)) cstrs @@ -2044,7 +2043,7 @@ let ppat_of_type env ty = (Conv.mkpat Parsetree.Ppat_any, Hashtbl.create 0, Hashtbl.create 0) | pats -> Conv.conv (orify_many pats) -let do_check_partial ?partial_match_warning_hint ?pred exhaust loc casel pss = +let do_check_partial ?partial_match_warning_hint ~pred exhaust loc casel pss = match pss with | [] -> (* @@ -2065,19 +2064,13 @@ let do_check_partial ?partial_match_warning_hint ?pred exhaust loc casel pss = match exhaust None pss (List.length ps) with | Rnone -> Total | Rsome [u] -> ( - let v = - match pred with - | Some pred -> - let pattern, constrs, labels = Conv.conv u in - let u' = pred constrs labels pattern in - (* pretty_pat u; - begin match u' with - None -> prerr_endline ": impossible" - | Some _ -> prerr_endline ": possible" - end; *) - u' - | None -> Some u - in + let pattern, constrs, labels = Conv.conv u in + let v = pred constrs labels pattern in + (* pretty_pat u; + begin match v with + None -> prerr_endline ": impossible" + | Some _ -> prerr_endline ": possible" + end; *) match v with | None -> Total | Some v -> diff --git a/compiler/ml/pprintast.ml b/compiler/ml/pprintast.ml index a2f0fd45305..212429aae9d 100644 --- a/compiler/ml/pprintast.ml +++ b/compiler/ml/pprintast.ml @@ -219,19 +219,15 @@ let option : let paren : 'a. - ?first:space_formatter -> - ?last:space_formatter -> bool -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit = - fun ?(first = ("" : _ format6)) ?(last = ("" : _ format6)) b fu f x -> + fun b fu f x -> if b then ( pp f "("; - pp f first; fu f x; - pp f last; pp f ")") else fu f x @@ -1355,21 +1351,5 @@ and label_x_expression_param ctxt f (l, e) = if Some lbl = simple_name then pp f "~%s" lbl else pp f "~%s:%a" lbl (simple_expr ctxt) e -let expression f x = pp f "@[%a@]" (expression reset_ctxt) x - -let string_of_expression x = - ignore (flush_str_formatter ()); - let f = str_formatter in - expression f x; - flush_str_formatter () - -let string_of_structure x = - ignore (flush_str_formatter ()); - let f = str_formatter in - structure reset_ctxt f x; - flush_str_formatter () - -let core_type = core_type reset_ctxt -let pattern = pattern reset_ctxt let signature = signature reset_ctxt let structure = structure reset_ctxt diff --git a/compiler/ml/pprintast.mli b/compiler/ml/pprintast.mli index fb26664584f..502d3743c2e 100644 --- a/compiler/ml/pprintast.mli +++ b/compiler/ml/pprintast.mli @@ -15,12 +15,6 @@ type space_formatter = (unit, Format.formatter, unit) format -val expression : Format.formatter -> Parsetree.expression -> unit -val string_of_expression : Parsetree.expression -> string - -val core_type : Format.formatter -> Parsetree.core_type -> unit -val pattern : Format.formatter -> Parsetree.pattern -> unit val signature : Format.formatter -> Parsetree.signature -> unit val structure : Format.formatter -> Parsetree.structure -> unit -val string_of_structure : Parsetree.structure -> string val string_of_int_as_char : int -> string diff --git a/compiler/ml/predef.ml b/compiler/ml/predef.ml index 348cb1ce337..aa63e8d7e44 100644 --- a/compiler/ml/predef.ml +++ b/compiler/ml/predef.ml @@ -137,12 +137,6 @@ and type_async_iterable t = and type_list t = newgenty (Tconstr (path_list, [t], ref Mnil)) -and type_option t = newgenty (Tconstr (path_option, [t], ref Mnil)) - -and type_result t1 t2 = newgenty (Tconstr (path_result, [t1; t2], ref Mnil)) - -and type_dict t = newgenty (Tconstr (path_dict, [t], ref Mnil)) - and type_bigint = newgenty (Tconstr (path_bigint, [], ref Mnil)) and type_string = newgenty (Tconstr (path_string, [], ref Mnil)) @@ -178,25 +172,10 @@ and ident_assert_failure = ident_create_predef_exn "Assert_failure" and ident_undefined_recursive_module = ident_create_predef_exn "Undefined_recursive_module" -let all_predef_exns = - [ - ident_match_failure; - ident_invalid_argument; - ident_failure; - ident_js_exn; - ident_not_found; - ident_end_of_file; - ident_division_by_zero; - ident_assert_failure; - ident_undefined_recursive_module; - ] - let path_match_failure = Pident ident_match_failure and path_assert_failure = Pident ident_assert_failure -and path_undefined_recursive_module = Pident ident_undefined_recursive_module - let decl_abstr = { type_params = []; @@ -436,11 +415,9 @@ let build_initial_env add_type add_exception empty_env = in add_type ident_char decl_type_char common -let builtin_values = - List.map - (fun id -> - Ident.make_global id; - (Ident.name id, id)) +let () = + List.iter + Ident.make_global [ ident_match_failure; ident_invalid_argument; diff --git a/compiler/ml/predef.mli b/compiler/ml/predef.mli index 802be290dee..945dc15b26a 100644 --- a/compiler/ml/predef.mli +++ b/compiler/ml/predef.mli @@ -27,10 +27,6 @@ val type_exn : type_expr val type_array : type_expr -> type_expr val type_iterable : type_expr -> type_expr val type_async_iterable : type_expr -> type_expr -val type_list : type_expr -> type_expr -val type_option : type_expr -> type_expr -val type_result : type_expr -> type_expr -> type_expr -val type_dict : type_expr -> type_expr val type_bigint : type_expr val type_extension_constructor : type_expr @@ -43,21 +39,17 @@ val path_bool : Path.t val path_unit : Path.t val path_exn : Path.t val path_array : Path.t -val path_iterable : Path.t -val path_async_iterable : Path.t val path_list : Path.t val path_option : Path.t val path_result : Path.t val path_dict : Path.t val path_bigint : Path.t -val path_extension_constructor : Path.t val path_promise : Path.t val path_tagged_template : Path.t val path_match_failure : Path.t val path_assert_failure : Path.t -val path_undefined_recursive_module : Path.t (* To build the initial environment. Since there is a nasty mutual recursion between predef and env, we break it by parameterizing @@ -69,19 +61,8 @@ val build_initial_env : 'a -> 'a -(* To initialize linker tables *) - -val builtin_values : (string * Ident.t) list val builtin_idents : (string * Ident.t) list -val ident_division_by_zero : Ident.t -(** All predefined exceptions, exposed as [Ident.t] for flambda (for - building value approximations). - The [Ident.t] for division by zero is also exported explicitly - so flambda can generate code to raise it. *) - -val all_predef_exns : Ident.t list - type test = For_sure_yes | For_sure_no | NA val type_is_builtin_path_but_option : Path.t -> test diff --git a/compiler/ml/primitive.ml b/compiler/ml/primitive.ml index f632606e9a4..9387bbc4378 100644 --- a/compiler/ml/primitive.ml +++ b/compiler/ml/primitive.ml @@ -59,4 +59,4 @@ let print p osig_val_decl = if p.prim_native_name <> "" then [p.prim_name; p.prim_native_name] else [p.prim_name] in - {osig_val_decl with oval_prims = prims; oval_attributes = []} + {osig_val_decl with oval_prims = prims} diff --git a/compiler/ml/printast.mli b/compiler/ml/printast.mli index 87da25385c9..6471a9509c0 100644 --- a/compiler/ml/printast.mli +++ b/compiler/ml/printast.mli @@ -19,6 +19,4 @@ open Format val interface : formatter -> signature_item list -> unit val implementation : formatter -> structure_item list -> unit -val expression : int -> formatter -> expression -> unit -val structure : int -> formatter -> structure -> unit val payload : int -> formatter -> payload -> unit diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index e30f3c867f2..9ef8bacfb29 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -403,6 +403,4 @@ and sequence ppf = function | Lsequence (l1, l2) -> fprintf ppf "%a@ %a" sequence l1 sequence l2 | l -> lam ppf l -let structured_constant = struct_const - let lambda = lam diff --git a/compiler/ml/printlambda.mli b/compiler/ml/printlambda.mli index d20fa3ece0f..b2942ca9851 100644 --- a/compiler/ml/printlambda.mli +++ b/compiler/ml/printlambda.mli @@ -17,5 +17,4 @@ open Lambda open Format -val structured_constant : formatter -> structured_constant -> unit val lambda : formatter -> lambda -> unit diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index da6a3b25b16..f54f6481933 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -908,7 +908,7 @@ and tree_of_constructor_arguments ?printing_context = function | Cstr_tuple l -> tree_of_typlist ?printing_context false l | Cstr_record l -> [Otyp_record (List.map tree_of_label l)] -and tree_of_constructor ?printing_context cd = +and tree_of_constructor ~printing_context cd = let name = Ident.name cd.cd_id in let nullary = Ast_untagged_variants.is_nullary_variant cd.cd_args in let repr = @@ -924,13 +924,13 @@ and tree_of_constructor ?printing_context cd = | Some (BigInt s) -> Some (Printf.sprintf "@as(%sn)" s) | Some (Untagged _) (* should never happen *) | None -> None in - let arg () = tree_of_constructor_arguments ?printing_context cd.cd_args in + let arg () = tree_of_constructor_arguments ~printing_context cd.cd_args in match cd.cd_res with | None -> (name, arg (), None, repr) | Some res -> let nm = !names in names := []; - let ret = tree_of_typexp ?printing_context false res in + let ret = tree_of_typexp ~printing_context false res in let args = arg () in names := nm; (name, args, Some ret, repr) @@ -947,33 +947,24 @@ and tree_of_label ?printing_context l = opt, tree_of_typexp ?printing_context false typ ) -and tree_of_constraints ?printing_context params = +and tree_of_constraints ~printing_context params = List.fold_right (fun ty list -> let ty' = unalias ty in if proxy ty != proxy ty' then - let tr = tree_of_typexp ?printing_context true ty in - (tr, tree_of_typexp ?printing_context true ty') :: list + let tr = tree_of_typexp ~printing_context true ty in + (tr, tree_of_typexp ~printing_context true ty') :: list else list) params [] -let typexp ?printing_context sch ppf ty = - !Oprint.out_type ppf (tree_of_typexp ?printing_context sch ty) +let typexp sch ppf ty = !Oprint.out_type ppf (tree_of_typexp sch ty) let type_expr ppf ty = typexp false ppf ty -and type_sch ppf ty = typexp true ppf ty - and type_scheme ppf ty = reset_and_mark_loops ty; typexp true ppf ty -(* Maxence *) -let type_scheme_max ?(b_reset_names = true) ppf ty = - if b_reset_names then reset_names (); - typexp true ppf ty -(* End Maxence *) - let tree_of_type_scheme ty = reset_and_mark_loops ty; tree_of_typexp true ty @@ -1048,9 +1039,7 @@ let tree_of_value_description id decl = (* Format.eprintf "@[%a@]@." raw_type_expr decl.val_type; *) let id = Ident.name id in let ty = tree_of_type_scheme decl.val_type in - let vd = - {oval_name = id; oval_type = ty; oval_prims = []; oval_attributes = []} - in + let vd = {oval_name = id; oval_type = ty; oval_prims = []} in let vd = match decl.val_kind with | Val_prim p -> Primitive.print p vd @@ -1173,42 +1162,13 @@ and tree_of_modtype_declaration id decl = in Osig_modtype (Ident.name id, mty) -and tree_of_module id ?ellipsis mty rs = - Osig_module (Ident.name id, tree_of_modtype ?ellipsis mty, tree_of_rec rs) +and tree_of_module id ~ellipsis mty rs = + Osig_module (Ident.name id, tree_of_modtype ~ellipsis mty, tree_of_rec rs) let modtype ppf mty = !Oprint.out_module_type ppf (tree_of_modtype mty) let modtype_declaration id ppf decl = !Oprint.out_sig_item ppf (tree_of_modtype_declaration id decl) -(* For the toplevel: merge with tree_of_signature? *) - -(* Refresh weak variable map in the toplevel *) -let refresh_weak () = - let refresh t name (m, s) = - if is_non_gen true (repr t) then - (Type_map.add t name m, String_set.add name s) - else (m, s) - in - let m, s = - Type_map.fold refresh !weak_var_map (Type_map.empty, String_set.empty) - in - named_weak_vars := s; - weak_var_map := m - -let print_items showval env x = - refresh_weak (); - let rec print showval env = function - | [] -> [] - | item :: rem as items -> - let _sg, rem = filter_rem_sig item rem in - hide_rec_items items; - let trees = trees_of_sigitem item in - List.map (fun d -> (d, showval env item)) trees @ print showval env rem - in - print showval env x - -(* Print a signature body (used by -i when compiling a .ml) *) - let print_signature ppf tree = fprintf ppf "@[%a@]" !Oprint.out_signature tree @@ -1500,8 +1460,8 @@ let unification_error env unif tr txt1 ppf txt2 = warn_on_missing_def env ppf t2) with exn -> raise exn) -let report_unification_error ppf env ?(unif = true) tr txt1 txt2 = - wrap_printing_env env (fun () -> unification_error env unif tr txt1 ppf txt2) +let report_unification_error ppf env tr txt1 txt2 = + wrap_printing_env env (fun () -> unification_error env true tr txt1 ppf txt2) let super_type_expansion ~tag t ppf t' = let tag = Format.String_tag tag in @@ -1560,10 +1520,9 @@ let super_unification_error ?print_extra_info unif tr txt1 ppf txt2 = | Some f -> f ppf t1 t2) with exn -> raise exn) -let super_report_unification_error ?print_extra_info ppf env ?(unif = true) tr - txt1 txt2 = +let super_report_unification_error ?print_extra_info ppf env tr txt1 txt2 = wrap_printing_env env (fun () -> - super_unification_error ?print_extra_info unif tr txt1 ppf txt2) + super_unification_error ?print_extra_info true tr txt1 ppf txt2) let trace fst keep_last txt ppf tr = trace_same_names tr; diff --git a/compiler/ml/printtyp.mli b/compiler/ml/printtyp.mli index 0fe84f38f1a..98bcf15d0c6 100644 --- a/compiler/ml/printtyp.mli +++ b/compiler/ml/printtyp.mli @@ -28,26 +28,21 @@ val ident : formatter -> Ident.t -> unit val tree_of_path : Path.t -> out_ident val path : formatter -> Path.t -> unit val string_of_path : Path.t -> string -val raw_type_expr : formatter -> type_expr -> unit val string_of_label : Asttypes.arg_label -> string val wrap_printing_env : Env.t -> (unit -> 'a) -> 'a (* Call the function using the environment for type path shortening *) (* This affects all the printing functions below *) -val reset : unit -> unit val mark_loops : type_expr -> unit val reset_and_mark_loops : type_expr -> unit val reset_and_mark_loops_list : type_expr list -> unit val type_expr : formatter -> type_expr -> unit val constructor_arguments : formatter -> constructor_arguments -> unit -val tree_of_type_scheme : type_expr -> out_type -val type_sch : formatter -> type_expr -> unit val type_scheme : formatter -> type_expr -> unit (* Maxence *) val reset_names : unit -> unit -val type_scheme_max : ?b_reset_names:bool -> formatter -> type_expr -> unit (* End Maxence *) val tree_of_value_description : Ident.t -> value_description -> out_sig_item @@ -59,23 +54,15 @@ val tree_of_extension_constructor : Ident.t -> extension_constructor -> ext_status -> out_sig_item val extension_constructor : Ident.t -> formatter -> extension_constructor -> unit -val tree_of_module : - Ident.t -> ?ellipsis:bool -> module_type -> rec_status -> out_sig_item val modtype : formatter -> module_type -> unit val signature : formatter -> signature -> unit -val tree_of_modtype_declaration : Ident.t -> modtype_declaration -> out_sig_item val tree_of_signature : Types.signature -> out_sig_item list val tree_of_typexp : ?printing_context:printing_context -> bool -> type_expr -> out_type val modtype_declaration : Ident.t -> formatter -> modtype_declaration -> unit -val type_expansion : type_expr -> Format.formatter -> type_expr -> unit -val prepare_expansion : type_expr * type_expr -> type_expr * type_expr -val trace : - bool -> bool -> string -> formatter -> (type_expr * type_expr) list -> unit val report_unification_error : formatter -> Env.t -> - ?unif:bool -> (type_expr * type_expr) list -> (formatter -> unit) -> (formatter -> unit) -> @@ -85,7 +72,6 @@ val super_report_unification_error : ?print_extra_info:(formatter -> type_expr -> type_expr -> unit) -> formatter -> Env.t -> - ?unif:bool -> (type_expr * type_expr) list -> (formatter -> unit) -> (formatter -> unit) -> @@ -110,8 +96,3 @@ val report_ambiguous_type_error : unit (* for toploop *) -val print_items : - (Env.t -> signature_item -> 'a option) -> - Env.t -> - signature_item list -> - (out_sig_item * 'a option) list diff --git a/compiler/ml/record_type_spread.ml b/compiler/ml/record_type_spread.ml index 0156db4b99c..f831f6af202 100644 --- a/compiler/ml/record_type_spread.ml +++ b/compiler/ml/record_type_spread.ml @@ -1,7 +1,5 @@ module String_map = Map.Make (String) -let t_equals t1 t2 = t1.Types.level = t2.Types.level && t1.id = t2.id - let substitute_types ~type_map (t : Types.type_expr) = if String_map.is_empty type_map then t else diff --git a/compiler/ml/stypes.ml b/compiler/ml/stypes.ml index 0584b169388..d57a8c8b75a 100644 --- a/compiler/ml/stypes.ml +++ b/compiler/ml/stypes.ml @@ -22,167 +22,25 @@ interesting in case of errors. *) -open Annot -open Lexing -open Location open Typedtree -let output_int oc i = output_string oc (string_of_int i) - type annotation = | Ti_pat of pattern | Ti_expr of expression - | Ti_class of unit | Ti_mod of module_expr - | An_call of Location.t * Annot.call | An_ident of Location.t * string * Annot.ident let get_location ti = match ti with | Ti_pat p -> p.pat_loc | Ti_expr e -> e.exp_loc - | Ti_class () -> assert false | Ti_mod m -> m.mod_loc - | An_call (l, _k) -> l | An_ident (l, _s, _k) -> l let annotations = ref ([] : annotation list) -let phrases = ref ([] : Location.t list) let record ti = if !Clflags.annotations && not (get_location ti).Location.loc_ghost then annotations := ti :: !annotations -let record_phrase loc = if !Clflags.annotations then phrases := loc :: !phrases - -(* comparison order: - the intervals are sorted by order of increasing upper bound - same upper bound -> sorted by decreasing lower bound -*) -let cmp_loc_inner_first loc1 loc2 = - match compare loc1.loc_end.pos_cnum loc2.loc_end.pos_cnum with - | 0 -> compare loc2.loc_start.pos_cnum loc1.loc_start.pos_cnum - | x -> x -let cmp_ti_inner_first ti1 ti2 = - cmp_loc_inner_first (get_location ti1) (get_location ti2) - -let print_position pp pos = - if pos = dummy_pos then output_string pp "--" - else ( - output_char pp '\"'; - output_string pp (String.escaped pos.pos_fname); - output_string pp "\" "; - output_int pp pos.pos_lnum; - output_char pp ' '; - output_int pp pos.pos_bol; - output_char pp ' '; - output_int pp pos.pos_cnum) - -let print_location pp loc = - print_position pp loc.loc_start; - output_char pp ' '; - print_position pp loc.loc_end - -let sort_filter_phrases () = - let ph = List.sort (fun x y -> cmp_loc_inner_first y x) !phrases in - let rec loop accu cur l = - match l with - | [] -> accu - | loc :: t -> - if - cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum - && cur.loc_end.pos_cnum >= loc.loc_end.pos_cnum - then loop accu cur t - else loop (loc :: accu) loc t - in - phrases := loop [] Location.none ph - -let rec printtyp_reset_maybe loc = - match !phrases with - | cur :: t when cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum -> - Printtyp.reset (); - phrases := t; - printtyp_reset_maybe loc - | _ -> () - -let call_kind_string k = - match k with - | Tail -> "tail" - | Stack -> "stack" - | Inline -> "inline" - -let print_ident_annot pp str k = - match k with - | Idef l -> - output_string pp "def "; - output_string pp str; - output_char pp ' '; - print_location pp l; - output_char pp '\n' - | Iref_internal l -> - output_string pp "int_ref "; - output_string pp str; - output_char pp ' '; - print_location pp l; - output_char pp '\n' - | Iref_external -> - output_string pp "ext_ref "; - output_string pp str; - output_char pp '\n' - -(* The format of the annotation file is documented in emacs/caml-types.el. *) - -let print_info pp prev_loc ti = - match ti with - | Ti_class _ | Ti_mod _ -> prev_loc - | Ti_pat {pat_loc = loc; pat_type = typ; pat_env = env} - | Ti_expr {exp_loc = loc; exp_type = typ; exp_env = env} -> - if loc <> prev_loc then ( - print_location pp loc; - output_char pp '\n'); - output_string pp "type(\n"; - printtyp_reset_maybe loc; - Printtyp.mark_loops typ; - Format.pp_print_string Format.str_formatter " "; - Printtyp.wrap_printing_env env (fun () -> - Printtyp.type_sch Format.str_formatter typ); - Format.pp_print_newline Format.str_formatter (); - let s = Format.flush_str_formatter () in - output_string pp s; - output_string pp ")\n"; - loc - | An_call (loc, k) -> - if loc <> prev_loc then ( - print_location pp loc; - output_char pp '\n'); - output_string pp "call(\n "; - output_string pp (call_kind_string k); - output_string pp "\n)\n"; - loc - | An_ident (loc, str, k) -> - if loc <> prev_loc then ( - print_location pp loc; - output_char pp '\n'); - output_string pp "ident(\n "; - print_ident_annot pp str k; - output_string pp ")\n"; - loc - -let get_info () = - let info = List.fast_sort cmp_ti_inner_first !annotations in - annotations := []; - info - -let dump filename = - if !Clflags.annotations then ( - let do_dump _temp_filename pp = - let info = get_info () in - sort_filter_phrases (); - ignore (List.fold_left (print_info pp) Location.none info) - in - (match filename with - | None -> do_dump "" stdout - | Some filename -> - Misc.output_to_file_via_temporary ~mode:[Open_text] filename do_dump); - phrases := []) - else annotations := [] +let record_phrase _loc = () diff --git a/compiler/ml/stypes.mli b/compiler/ml/stypes.mli index 3182f7eb9ae..14145cf51c9 100644 --- a/compiler/ml/stypes.mli +++ b/compiler/ml/stypes.mli @@ -22,14 +22,8 @@ open Typedtree type annotation = | Ti_pat of pattern | Ti_expr of expression - | Ti_class of unit | Ti_mod of module_expr - | An_call of Location.t * Annot.call | An_ident of Location.t * string * Annot.ident val record : annotation -> unit val record_phrase : Location.t -> unit -val dump : string option -> unit - -val get_location : annotation -> Location.t -val get_info : unit -> annotation list diff --git a/compiler/ml/subst.mli b/compiler/ml/subst.mli index 62ed5d51ab6..85cef795c61 100644 --- a/compiler/ml/subst.mli +++ b/compiler/ml/subst.mli @@ -54,8 +54,6 @@ val extension_constructor : t -> extension_constructor -> extension_constructor val modtype : t -> module_type -> module_type val signature : t -> signature -> signature val modtype_declaration : t -> modtype_declaration -> modtype_declaration -val module_declaration : t -> module_declaration -> module_declaration -val typexp : t -> Types.type_expr -> Types.type_expr (* A forward reference to be filled in ctype.ml. *) val ctype_apply_env_empty : diff --git a/compiler/ml/tbl.ml b/compiler/ml/tbl.ml index d37ba50e775..54fa8c9c092 100644 --- a/compiler/ml/tbl.ml +++ b/compiler/ml/tbl.ml @@ -63,27 +63,6 @@ let rec find_str (x : string) = function let c = compare x v in if c = 0 then d else find_str x (if c < 0 then l else r) -let rec mem x = function - | Empty -> false - | Node (l, v, _d, r, _) -> - let c = compare x v in - c = 0 || mem x (if c < 0 then l else r) - -let rec merge t1 t2 = - match (t1, t2) with - | Empty, t -> t - | t, Empty -> t - | Node (l1, v1, d1, r1, _h1), Node (l2, v2, d2, r2, _h2) -> - bal l1 v1 d1 (bal (merge r1 l2) v2 d2 r2) - -let rec remove x = function - | Empty -> Empty - | Node (l, v, d, r, _h) -> - let c = compare x v in - if c = 0 then merge l r - else if c < 0 then bal (remove x l) v d r - else bal l v d (remove x r) - let rec iter f = function | Empty -> () | Node (l, v, d, r, _) -> @@ -91,21 +70,7 @@ let rec iter f = function f v d; iter f r -let rec map f = function - | Empty -> Empty - | Node (l, v, d, r, h) -> Node (map f l, v, f v d, map f r, h) - let rec fold f m accu = match m with | Empty -> accu | Node (l, v, d, r, _) -> fold f r (f v d (fold f l accu)) - -open Format - -let print print_key print_data ppf tbl = - let print_tbl ppf tbl = - iter - (fun k d -> fprintf ppf "@[<2>%a ->@ %a;@]@ " print_key k print_data d) - tbl - in - fprintf ppf "@[[[%a]]@]" print_tbl tbl diff --git a/compiler/ml/tbl.mli b/compiler/ml/tbl.mli index 7d9296eb253..9b678307153 100644 --- a/compiler/ml/tbl.mli +++ b/compiler/ml/tbl.mli @@ -22,17 +22,5 @@ val empty : ('k, 'v) t val add : 'k -> 'v -> ('k, 'v) t -> ('k, 'v) t val find : 'k -> ('k, 'v) t -> 'v val find_str : string -> (string, 'v) t -> 'v -val mem : 'k -> ('k, 'v) t -> bool -val remove : 'k -> ('k, 'v) t -> ('k, 'v) t val iter : ('k -> 'v -> unit) -> ('k, 'v) t -> unit -val map : ('k -> 'v1 -> 'v2) -> ('k, 'v1) t -> ('k, 'v2) t val fold : ('k -> 'v -> 'acc -> 'acc) -> ('k, 'v) t -> 'acc -> 'acc - -open Format - -val print : - (formatter -> 'k -> unit) -> - (formatter -> 'v -> unit) -> - formatter -> - ('k, 'v) t -> - unit diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 69fbcab4729..ace39b7322e 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -988,9 +988,8 @@ and transl_case_try {c_lhs; c_guard; c_rhs} = and transl_cases_try cases = List.map transl_case_try cases -and transl_apply ?(inlined = Default_inline) - ?(uncurried_partial_application = None) ?(transformed_jsx = false) lam sargs - loc = +and transl_apply ~inlined ?(uncurried_partial_application = None) ~transformed_jsx + lam sargs loc = let lapply ap_func ap_args = Lapply { diff --git a/compiler/ml/translmod.mli b/compiler/ml/translmod.mli index 74ef747e105..9ff6fe6ef93 100644 --- a/compiler/ml/translmod.mli +++ b/compiler/ml/translmod.mli @@ -23,5 +23,3 @@ val transl_implementation : type error (* exception Error of Location.t * error *) - -val report_error : Format.formatter -> error -> unit diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index efaea72e882..4e0983f9c52 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -111,14 +111,9 @@ let type_module = (* Forward declaration, to be filled in by Typemod.type_open *) let type_open : - (?used_slot:bool ref -> - override_flag -> - Env.t -> - Location.t -> - Longident.t loc -> - Path.t * Env.t) + (override_flag -> Env.t -> Location.t -> Longident.t loc -> Path.t * Env.t) ref = - ref (fun ?used_slot:_ _ -> assert false) + ref (fun _ -> assert false) (* Forward declaration, to be filled in by Typemod.type_package *) @@ -1711,14 +1706,14 @@ let type_pat ?(allow_existentials = false) ?constrs ?labels ?(mode = Normal) (* this function is passed to Partial.parmatch to type check gadt nonexhaustiveness *) -let partial_pred ~lev ?mode ?explode env expected_ty constrs labels p = +let partial_pred ~lev ?mode ~explode env expected_ty constrs labels p = let env = ref env in let state = save_state env in try reset_pattern None true; let typed_p = Ctype.with_passive_variants - (type_pat ~allow_existentials:true ~lev ~constrs ~labels ?mode ?explode + (type_pat ~allow_existentials:true ~lev ~constrs ~labels ?mode ~explode env p) expected_ty in @@ -1740,7 +1735,7 @@ let check_partial ?(lev = get_current_level ()) ?partial_match_warning_hint env (partial_pred ~lev ~explode env expected_ty) loc cases -let check_unused ?(lev = get_current_level ()) env expected_ty cases = +let check_unused ~lev env expected_ty cases = Parmatch.check_unused (fun constrs labels spat -> partial_pred ~lev ~mode:Split_or ~explode:5 env expected_ty constrs labels @@ -4618,7 +4613,8 @@ let find_arity_suggestion env function_name target_arity = open Format let longident = Printtyp.longident -let super_report_unification_error = Printtyp.super_report_unification_error +let super_report_unification_error ?print_extra_info ppf env trace = + Printtyp.super_report_unification_error ?print_extra_info ppf env trace let report_ambiguous_type_error = Printtyp.report_ambiguous_type_error let report_subtyping_error = Printtyp.report_subtyping_error diff --git a/compiler/ml/typecore.mli b/compiler/ml/typecore.mli index cf87fe7361c..ea791cd00f5 100644 --- a/compiler/ml/typecore.mli +++ b/compiler/ml/typecore.mli @@ -17,9 +17,6 @@ open Asttypes open Types -open Format - -val is_nonexpansive : Typedtree.expression -> bool val type_binding : context:Error_message_utils.type_clash_context option -> @@ -33,26 +30,11 @@ val type_expression : Env.t -> Parsetree.expression -> Typedtree.expression -val check_partial : - ?lev:int -> - ?partial_match_warning_hint:string -> - Env.t -> - type_expr -> - Location.t -> - Typedtree.case list -> - Typedtree.partial val type_exp : Env.t -> Parsetree.expression -> context:Error_message_utils.type_clash_context option -> Typedtree.expression -val type_approx : Env.t -> Parsetree.expression -> type_expr - -val option_some : Typedtree.expression -> Typedtree.expression -val option_none : type_expr -> Location.t -> Typedtree.expression -val extract_option_type : Env.t -> type_expr -> type_expr -val iter_pattern : (Typedtree.pattern -> unit) -> Typedtree.pattern -> unit -val generalizable : int -> type_expr -> bool val id_of_pattern : Typedtree.pattern -> Ident.t option val name_pattern : string -> Typedtree.case list -> Ident.t @@ -134,20 +116,12 @@ type error = exception Error of Location.t * Env.t * error exception Error_forward of Location.error -val report_error : Env.t -> Location.t -> formatter -> error -> unit -(* Deprecated. Use Location.{error_of_exn, report_error}. *) - (* Forward declaration, to be filled in by Typemod.type_module *) val type_module : (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref (* Forward declaration, to be filled in by Typemod.type_open *) val type_open : - (?used_slot:bool ref -> - override_flag -> - Env.t -> - Location.t -> - Longident.t loc -> - Path.t * Env.t) + (override_flag -> Env.t -> Location.t -> Longident.t loc -> Path.t * Env.t) ref (* Forward declaration, to be filled in by Typemod.type_package *) @@ -158,5 +132,3 @@ val type_package : Longident.t list -> Typedtree.module_expr * type_expr list) ref - -val constant : Parsetree.constant -> (Asttypes.constant, error) result diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index 128b98b360a..e70c75344aa 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -22,8 +22,6 @@ open Primitive open Types open Typetexp -type native_repr_kind = Unboxed | Untagged - type error = | Repeated_parameter | Duplicate_constructor of string @@ -1257,7 +1255,7 @@ let compute_variance_gadt env check ((required, loc) as rloc) decl | {desc = Tconstr (_, tyl, _)} -> (* let tyl = List.map (Ctype.expand_head env) tyl in *) let tyl = List.map Ctype.repr tyl in - let fvl = List.map (Ctype.free_variables ?env:None) tyl in + let fvl = List.map Ctype.free_variables tyl in let _ = List.fold_left2 (fun (fv1, fv2) ty (c, n, _) -> diff --git a/compiler/ml/typedecl.mli b/compiler/ml/typedecl.mli index b9910bf8837..2bb43c4fdbc 100644 --- a/compiler/ml/typedecl.mli +++ b/compiler/ml/typedecl.mli @@ -50,7 +50,6 @@ val transl_with_constraint : Parsetree.type_declaration -> Typedtree.type_declaration -val abstract_type_decl : int -> type_declaration val approx_type_decl : Parsetree.type_declaration list -> (Ident.t * type_declaration) list val check_recmod_typedecl : @@ -64,8 +63,6 @@ val is_fixed_type : Parsetree.type_declaration -> bool val get_unboxed_type_representation : Env.t -> type_expr -> type_expr option val is_not_undefined_attr : Parsetree.attribute -> bool -type native_repr_kind = Unboxed | Untagged - type error exception Error of Location.t * error diff --git a/compiler/ml/typemod.ml b/compiler/ml/typemod.ml index 7abdb05d434..66ed7943d8d 100644 --- a/compiler/ml/typemod.ml +++ b/compiler/ml/typemod.ml @@ -85,9 +85,9 @@ let extract_sig_open env loc mty = (* Compute the environment after opening a module *) -let type_open_ ?used_slot ?toplevel ovf env loc lid = +let type_open_ ?toplevel ovf env loc lid = let path = Typetexp.lookup_module ~load:true env lid.loc lid.txt in - match Env.open_signature ~loc ?used_slot ?toplevel ovf path env with + match Env.open_signature ~loc ?toplevel ovf path env with | Some env -> (path, env) | None -> let md = Env.find_module path env in diff --git a/compiler/ml/typemod.mli b/compiler/ml/typemod.mli index 0f36cf6afd8..4f08d580c7e 100644 --- a/compiler/ml/typemod.mli +++ b/compiler/ml/typemod.mli @@ -18,12 +18,6 @@ open Types open Format -val type_module : Env.t -> Parsetree.module_expr -> Typedtree.module_expr -val type_structure : - Env.t -> - Parsetree.structure -> - Location.t -> - Typedtree.structure * Types.signature * Env.t val type_toplevel_phrase : Env.t -> Parsetree.structure -> Typedtree.structure * Types.signature * Env.t @@ -39,19 +33,13 @@ val type_implementation_more : Typedtree.structure * Typedtree.module_coercion * Env.t * Types.signature val transl_signature : Env.t -> Parsetree.signature -> Typedtree.signature -val check_nongen_schemes : Env.t -> Types.signature -> unit val type_open_ : - ?used_slot:bool ref -> ?toplevel:bool -> Asttypes.override_flag -> Env.t -> Location.t -> Longident.t Asttypes.loc -> Path.t * Env.t -val simplify_signature : signature -> signature - -val path_of_module : Typedtree.module_expr -> Path.t option - val save_signature : string -> Typedtree.signature -> diff --git a/compiler/ml/types.mli b/compiler/ml/types.mli index 598030ff12e..29d20e0755c 100644 --- a/compiler/ml/types.mli +++ b/compiler/ml/types.mli @@ -81,8 +81,7 @@ and type_desc = [Tobject (_, `Some (`A.ct', [t1;...;tn]')] ==> [(t1, ..., tn) A.ct]. where A.ct is the type of some class. - There are also special cases for so-called "class-types", cf. [Typeclass] - and [Ctype.set_object_name]: + There are also special cases for so-called "class-types", cf. [Typeclass]: [Tobject (Tfield(_,_,...(Tfield(_,_,rv)...), Some(`A.#ct`, [rv;t1;...;tn])] diff --git a/compiler/syntax/cli/res_cli.ml b/compiler/syntax/cli/res_cli.ml index 17234927076..2b8c04f9d1a 100644 --- a/compiler/syntax/cli/res_cli.ml +++ b/compiler/syntax/cli/res_cli.ml @@ -26,36 +26,22 @@ *) module Color = struct (* use ANSI color codes, see https://en.wikipedia.org/wiki/ANSI_escape_code *) - type[@warning "-37"] color = - | Black - | Red - | Green - | Yellow - | Blue - | Magenta - | Cyan - | White - - type[@warning "-37"] style = + type color = Red | Yellow | Magenta | Cyan + + type style = | FG of color (* foreground *) - | BG of color (* background *) | Bold | Reset | Dim let ansi_of_color = function - | Black -> "0" | Red -> "1" - | Green -> "2" | Yellow -> "3" - | Blue -> "4" | Magenta -> "5" | Cyan -> "6" - | White -> "7" let code_of_style = function | FG c -> "3" ^ ansi_of_color c - | BG c -> "4" ^ ansi_of_color c | Bold -> "1" | Reset -> "0" | Dim -> "2" @@ -132,25 +118,18 @@ module Color = struct let term = try Sys.getenv "TERM" with Not_found -> "" in term <> "dumb" && term <> "" && isatty stderr - type[@warning "-37"] setting = Auto | Always | Never - let setup = let first = ref true in (* initialize only once *) let formatter_l = [Format.std_formatter; Format.err_formatter; Format.str_formatter] in - fun o -> + fun () -> if !first then ( first := false; Format.set_mark_tags true; List.iter set_color_tag_handling formatter_l; - color_enabled := - match o with - | Some Always -> true - | Some Auto -> should_enable_color () - | Some Never -> false - | None -> should_enable_color ()); + color_enabled := should_enable_color ()); () end @@ -257,7 +236,7 @@ module Cli_arg_processor = struct let (Parser backend) = parsing_engine in (* This is the whole purpose of the Color module above *) - Color.setup None; + Color.setup (); (* Special case for tokens - bypass parsing entirely *) if target = "tokens" then diff --git a/compiler/syntax/src/res_ast_debugger.ml b/compiler/syntax/src/res_ast_debugger.ml index ff5b1a42c1c..2c49968c844 100644 --- a/compiler/syntax/src/res_ast_debugger.ml +++ b/compiler/syntax/src/res_ast_debugger.ml @@ -7,15 +7,9 @@ let print_engine = print_implementation = (fun ~width:_ ~filename:_ ~comments:_ structure -> Printast.implementation Format.std_formatter structure); - print_implementation_from_source = - (fun ~width:_ ~source:_ ~comments:_ structure -> - Printast.implementation Format.std_formatter structure); print_interface = (fun ~width:_ ~filename:_ ~comments:_ signature -> Printast.interface Format.std_formatter signature); - print_interface_from_source = - (fun ~width:_ ~source:_ ~comments:_ signature -> - Printast.interface Format.std_formatter signature); } module Sexp : sig @@ -968,15 +962,9 @@ module Sexp_ast = struct print_implementation = (fun ~width:_ ~filename:_ ~comments:_ parsetree -> parsetree |> structure |> Sexp.to_string |> print_string); - print_implementation_from_source = - (fun ~width:_ ~source:_ ~comments:_ parsetree -> - parsetree |> structure |> Sexp.to_string |> print_string); print_interface = (fun ~width:_ ~filename:_ ~comments:_ parsetree -> parsetree |> signature |> Sexp.to_string |> print_string); - print_interface_from_source = - (fun ~width:_ ~source:_ ~comments:_ parsetree -> - parsetree |> signature |> Sexp.to_string |> print_string); } end @@ -989,19 +977,9 @@ let comments_print_engine = let cmt_tbl = Comment_table.make () in Comment_table.walk_structure s cmt_tbl comments; Comment_table.log cmt_tbl); - Res_driver.print_implementation_from_source = - (fun ~width:_ ~source:_ ~comments s -> - let cmt_tbl = Comment_table.make () in - Comment_table.walk_structure s cmt_tbl comments; - Comment_table.log cmt_tbl); Res_driver.print_interface = (fun ~width:_ ~filename:_ ~comments s -> let cmt_tbl = Comment_table.make () in Comment_table.walk_signature s cmt_tbl comments; Comment_table.log cmt_tbl); - Res_driver.print_interface_from_source = - (fun ~width:_ ~source:_ ~comments s -> - let cmt_tbl = Comment_table.make () in - Comment_table.walk_signature s cmt_tbl comments; - Comment_table.log cmt_tbl); } diff --git a/compiler/syntax/src/res_comments_table.ml b/compiler/syntax/src/res_comments_table.ml index 9741d3ece62..6826d22a312 100644 --- a/compiler/syntax/src/res_comments_table.ml +++ b/compiler/syntax/src/res_comments_table.ml @@ -24,11 +24,6 @@ let copy tbl = let empty = make () -let rec list_last = function - | [] -> failwith "list_last: empty list" - | [x] -> x - | _ :: rest -> list_last rest - let print_location (k : Warnings.loc) = Doc.concat [ diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index 2d3eabd3944..448972b7010 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -391,13 +391,9 @@ let rec go_to_closing closing_token state = (* Madness *) let is_es6_arrow_expression ~in_ternary p = Parser.lookahead p (fun state -> - let _async = - match state.Parser.token with - | Lident "async" -> - Parser.next state; - true - | _ -> false - in + (match state.Parser.token with + | Lident "async" -> Parser.next state + | _ -> ()); match state.Parser.token with | Lident _ | Underscore -> ( Parser.next state; @@ -5920,8 +5916,7 @@ and parse_type_equation_or_constr_decl p = (* TODO: is this a good idea? *) (None, Asttypes.Public, Parsetree.Ptype_abstract) -and parse_spread_tail_classified ?current_type_name_path ?inline_types_context - ~start_pos ~spread_typ ~grammar p = +and parse_spread_tail_classified ~start_pos ~spread_typ ~grammar p = match p.token with | Rbrace -> (* `{...t}` no extra fields: treat as record without tail fields *) @@ -5933,8 +5928,7 @@ and parse_spread_tail_classified ?current_type_name_path ?inline_types_context let (fields : Parsetree.label_declaration list) = parse_comma_delimited_region ~grammar ~closing:Rbrace ~f: - (parse_field_declaration_region ?current_type_name_path - ?inline_types_context ~found_object_field) + (parse_field_declaration_region ~found_object_field) p in Parser.expect Rbrace p; diff --git a/compiler/syntax/src/res_driver.ml b/compiler/syntax/src/res_driver.ml index eddb55a1f27..20dd41956ed 100644 --- a/compiler/syntax/src/res_driver.ml +++ b/compiler/syntax/src/res_driver.ml @@ -37,24 +37,12 @@ type print_engine = { comments:Res_comment.t list -> Parsetree.structure -> unit; - print_implementation_from_source: - width:int -> - source:string -> - comments:Res_comment.t list -> - Parsetree.structure -> - unit; print_interface: width:int -> filename:string -> comments:Res_comment.t list -> Parsetree.signature -> unit; - print_interface_from_source: - width:int -> - source:string -> - comments:Res_comment.t list -> - Parsetree.signature -> - unit; } let setup ~filename ~for_printer () = @@ -185,19 +173,12 @@ let print_engine = (fun ~width ~filename:_ ~comments structure -> print_string (Res_printer.print_implementation ~width structure ~comments)); - print_implementation_from_source = - (fun ~width ~source:_ ~comments structure -> - print_string - (Res_printer.print_implementation ~width structure ~comments)); print_interface = (fun ~width ~filename:_ ~comments signature -> print_string (Res_printer.print_interface ~width signature ~comments)); - print_interface_from_source = - (fun ~width ~source:_ ~comments signature -> - print_string (Res_printer.print_interface ~width signature ~comments)); } -let parse_implementation ?(ignore_parse_errors = false) sourcefile = +let parse_implementation ~ignore_parse_errors sourcefile = Location.input_name := sourcefile; let parse_result = parsing_engine.parse_implementation ~for_printer:false ~filename:sourcefile @@ -208,7 +189,7 @@ let parse_implementation ?(ignore_parse_errors = false) sourcefile = parse_result.parsetree [@@raises exit] -let parse_interface ?(ignore_parse_errors = false) sourcefile = +let parse_interface ~ignore_parse_errors sourcefile = Location.input_name := sourcefile; let parse_result = parsing_engine.parse_interface ~for_printer:false ~filename:sourcefile diff --git a/compiler/syntax/src/res_driver.mli b/compiler/syntax/src/res_driver.mli index 4d6feb13de6..acd67f26c3e 100644 --- a/compiler/syntax/src/res_driver.mli +++ b/compiler/syntax/src/res_driver.mli @@ -49,24 +49,12 @@ type print_engine = { comments:Res_comment.t list -> Parsetree.structure -> unit; - print_implementation_from_source: - width:int -> - source:string -> - comments:Res_comment.t list -> - Parsetree.structure -> - unit; print_interface: width:int -> filename:string -> comments:Res_comment.t list -> Parsetree.signature -> unit; - print_interface_from_source: - width:int -> - source:string -> - comments:Res_comment.t list -> - Parsetree.signature -> - unit; } val parsing_engine : Res_diagnostics.t list parsing_engine @@ -75,9 +63,9 @@ val print_engine : print_engine (* ReScript implementation parsing compatible with ocaml pparse driver. Used by the compiler. *) val parse_implementation : - ?ignore_parse_errors:bool -> string -> Parsetree.structure + ignore_parse_errors:bool -> string -> Parsetree.structure [@@live] [@@raises Location.Error] (* ReScript interface parsing compatible with ocaml pparse driver. Used by the compiler *) -val parse_interface : ?ignore_parse_errors:bool -> string -> Parsetree.signature +val parse_interface : ignore_parse_errors:bool -> string -> Parsetree.signature [@@live] [@@raises Location.Error] diff --git a/compiler/syntax/src/res_driver_binary.ml b/compiler/syntax/src/res_driver_binary.ml index b6c9318d5cc..71eb12bd483 100644 --- a/compiler/syntax/src/res_driver_binary.ml +++ b/compiler/syntax/src/res_driver_binary.ml @@ -6,19 +6,9 @@ let print_engine = output_string stdout Config.ast_impl_magic_number; output_value stdout filename; output_value stdout structure); - print_implementation_from_source = - (fun ~width:_ ~source:_ ~comments:_ structure -> - output_string stdout Config.ast_impl_magic_number; - output_value stdout "source"; - output_value stdout structure); print_interface = (fun ~width:_ ~filename ~comments:_ signature -> output_string stdout Config.ast_intf_magic_number; output_value stdout filename; output_value stdout signature); - print_interface_from_source = - (fun ~width:_ ~source:_ ~comments:_ signature -> - output_string stdout Config.ast_intf_magic_number; - output_value stdout "source"; - output_value stdout signature); } diff --git a/compiler/syntax/src/res_driver_ml_printer.ml b/compiler/syntax/src/res_driver_ml_printer.ml index 232e328bf15..651ab058402 100644 --- a/compiler/syntax/src/res_driver_ml_printer.ml +++ b/compiler/syntax/src/res_driver_ml_printer.ml @@ -4,13 +4,7 @@ let print_engine = print_implementation = (fun ~width:_ ~filename:_ ~comments:_ structure -> Pprintast.structure Format.std_formatter structure); - print_implementation_from_source = - (fun ~width:_ ~source:_ ~comments:_ structure -> - Pprintast.structure Format.std_formatter structure); print_interface = (fun ~width:_ ~filename:_ ~comments:_ signature -> Pprintast.signature Format.std_formatter signature); - print_interface_from_source = - (fun ~width:_ ~source:_ ~comments:_ signature -> - Pprintast.signature Format.std_formatter signature); } diff --git a/compiler/syntax/src/res_io.ml b/compiler/syntax/src/res_io.ml index 1912705f2bf..1d55da8318f 100644 --- a/compiler/syntax/src/res_io.ml +++ b/compiler/syntax/src/res_io.ml @@ -11,4 +11,4 @@ let write_file ~filename ~contents:txt = let chan = open_out_bin filename in output_string chan txt; close_out chan -[@@raises Sys_error] [@@dead "+write_file"] +[@@raises Sys_error] diff --git a/compiler/syntax/src/res_io.mli b/compiler/syntax/src/res_io.mli index b0ec5ff356a..65e399e151f 100644 --- a/compiler/syntax/src/res_io.mli +++ b/compiler/syntax/src/res_io.mli @@ -5,4 +5,3 @@ val read_file : filename:string -> string (* writes "content" into file with name "filename" *) val write_file : filename:string -> contents:string -> unit -[@@dead "+write_file"] diff --git a/compiler/syntax/src/res_multi_printer.mli b/compiler/syntax/src/res_multi_printer.mli index bb661069006..bcfa6ce75b3 100644 --- a/compiler/syntax/src/res_multi_printer.mli +++ b/compiler/syntax/src/res_multi_printer.mli @@ -1,3 +1,3 @@ (* Interface to print source code to res. * Takes a filename called "input" and returns the corresponding formatted res syntax *) -val print : ?ignore_parse_errors:bool -> string -> string [@@dead "+print"] +val print : ?ignore_parse_errors:bool -> string -> string diff --git a/compiler/syntax/src/res_outcome_printer.ml b/compiler/syntax/src/res_outcome_printer.ml index f6fd5aec84c..6e68f556e13 100644 --- a/compiler/syntax/src/res_outcome_printer.ml +++ b/compiler/syntax/src/res_outcome_printer.ml @@ -14,34 +14,6 @@ module Printer = Res_printer * We don't support custom operators. *) let parenthesized_ident _name = true -(* TODO: better allocation strategy for the buffer *) -let escape_string_contents s = - let len = String.length s in - let b = Buffer.create len in - for i = 0 to len - 1 do - let c = (String.get [@doesNotRaise]) s i in - if c = '\008' then ( - Buffer.add_char b '\\'; - Buffer.add_char b 'b') - else if c = '\009' then ( - Buffer.add_char b '\\'; - Buffer.add_char b 't') - else if c = '\010' then ( - Buffer.add_char b '\\'; - Buffer.add_char b 'n') - else if c = '\013' then ( - Buffer.add_char b '\\'; - Buffer.add_char b 'r') - else if c = '\034' then ( - Buffer.add_char b '\\'; - Buffer.add_char b '"') - else if c = '\092' then ( - Buffer.add_char b '\\'; - Buffer.add_char b '\\') - else Buffer.add_char b c - done; - Buffer.contents b - (* let rec print_ident fmt ident = match ident with | Outcometree.Oide_ident s -> Format.pp_print_string fmt s | Oide_dot (id, s) -> @@ -66,20 +38,6 @@ let rec print_out_ident_doc ?(allow_uident = true) print_out_ident_doc call; Doc.lparen; print_out_ident_doc arg; Doc.rparen; ] -let print_out_attribute_doc (out_attribute : Outcometree.out_attribute) = - Doc.concat [Doc.text "@"; Doc.text out_attribute.oattr_name] - -let print_out_attributes_doc (attrs : Outcometree.out_attribute list) = - match attrs with - | [] -> Doc.nil - | attrs -> - Doc.concat - [ - Doc.group - (Doc.join ~sep:Doc.line (List.map print_out_attribute_doc attrs)); - Doc.line; - ] - let rec collect_arrow_args (out_type : Outcometree.out_type) args = match out_type with | Otyp_arrow (label, arg_type, return_type, arity) @@ -146,10 +104,6 @@ let rec print_out_type_doc (out_type : Outcometree.out_type) = Doc.concat [Doc.text ("'" ^ if ng then "_" else ""); Doc.text s] | Otyp_object (fields, rest) -> print_object_fields fields rest | Otyp_class _ -> Doc.nil - | Otyp_attribute (typ, attribute) -> - Doc.group - (Doc.concat - [print_out_attribute_doc attribute; Doc.line; print_out_type_doc typ]) (* example: Red | Blue | Green | CustomColour(float, float, float) *) | Otyp_sum constructors -> print_out_constructors_doc constructors (* example: {"name": string, "age": int} *) @@ -490,13 +444,11 @@ let print_type_parameter_doc (typ, (co, cn)) = let rec print_out_sig_item_doc ?(print_name_as_is = false) (out_sig_item : Outcometree.out_sig_item) = match out_sig_item with - | Osig_class _ | Osig_class_type _ -> Doc.nil | Osig_ellipsis -> Doc.dotdotdot | Osig_value value_decl -> Doc.group (Doc.concat [ - print_out_attributes_doc value_decl.oval_attributes; Doc.text (match value_decl.oval_prims with | [] -> "let " @@ -849,226 +801,6 @@ let print_out_signature fmt signature = Format.pp_print_string fmt (Doc.to_string ~width:80 (print_out_signature_doc signature)) -let valid_float_lexeme s = - let l = String.length s in - let rec loop i = - if i >= l then s ^ "." - else - match s.[i] [@doesNotRaise] with - | '0' .. '9' | '-' -> loop (i + 1) - | _ -> s - in - loop 0 - -let float_repres f = - match classify_float f with - | FP_nan -> "nan" - | FP_infinite -> if f < 0.0 then "neg_infinity" else "infinity" - | _ -> - let float_val = - let s1 = Printf.sprintf "%.12g" f in - if f = (float_of_string [@doesNotRaise]) s1 then s1 - else - let s2 = Printf.sprintf "%.15g" f in - if f = (float_of_string [@doesNotRaise]) s2 then s2 - else Printf.sprintf "%.18g" f - in - valid_float_lexeme float_val - -let rec print_out_value_doc (out_value : Outcometree.out_value) = - match out_value with - | Oval_array out_values -> - Doc.group - (Doc.concat - [ - Doc.lbracket; - Doc.indent - (Doc.concat - [ - Doc.soft_line; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map print_out_value_doc out_values); - ]); - Doc.trailing_comma; - Doc.soft_line; - Doc.rbracket; - ]) - | Oval_char c -> Doc.text ("'" ^ Char.escaped c ^ "'") - | Oval_constr (out_ident, out_values) -> - Doc.group - (Doc.concat - [ - print_out_ident_doc out_ident; - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.soft_line; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map print_out_value_doc out_values); - ]); - Doc.trailing_comma; - Doc.soft_line; - Doc.rparen; - ]) - | Oval_ellipsis -> Doc.text "..." - | Oval_int i -> Doc.text (Format.sprintf "%i" i) - | Oval_int32 i -> Doc.text (Format.sprintf "%lil" i) - | Oval_int64 i -> Doc.text (Format.sprintf "%LiL" i) - | Oval_nativeint i -> Doc.text (Format.sprintf "%nin" i) - | Oval_float f -> Doc.text (float_repres f) - | Oval_list out_values -> - Doc.group - (Doc.concat - [ - Doc.text "list["; - Doc.indent - (Doc.concat - [ - Doc.soft_line; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map print_out_value_doc out_values); - ]); - Doc.trailing_comma; - Doc.soft_line; - Doc.rbracket; - ]) - | Oval_printer fn -> - let fmt = Format.str_formatter in - fn fmt; - let str = Format.flush_str_formatter () in - Doc.text str - | Oval_record rows -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.soft_line; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun (out_ident, out_value) -> - Doc.group - (Doc.concat - [ - print_out_ident_doc out_ident; - Doc.text ": "; - print_out_value_doc out_value; - ])) - rows); - ]); - Doc.trailing_comma; - Doc.soft_line; - Doc.rparen; - ]) - | Oval_string (txt, _sizeToPrint, _kind) -> - Doc.text (escape_string_contents txt) - | Oval_stuff txt -> Doc.text txt - | Oval_tuple out_values -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.soft_line; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map print_out_value_doc out_values); - ]); - Doc.trailing_comma; - Doc.soft_line; - Doc.rparen; - ]) - (* Not supported by ReScript *) - | Oval_variant _ -> Doc.nil - -let print_out_exception_doc exc out_value = - match exc with - | Sys.Break -> Doc.text "Interrupted." - | Out_of_memory -> Doc.text "Out of memory during evaluation." - | Stack_overflow -> - Doc.text "Stack overflow during evaluation (looping recursion?)." - | _ -> - Doc.group - (Doc.indent - (Doc.concat - [Doc.text "Exception:"; Doc.line; print_out_value_doc out_value])) - -let print_out_phrase_signature signature = - let rec loop signature acc = - match signature with - | [] -> List.rev acc - | (Outcometree.Osig_typext (ext, Oext_first), None) :: signature -> - (* Gather together extension constructors *) - let rec gather_extensions acc items = - match items with - | (Outcometree.Osig_typext (ext, Oext_next), None) :: items -> - gather_extensions - ((ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr) - :: acc) - items - | _ -> (List.rev acc, items) - in - let exts, signature = - gather_extensions - [(ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr)] - signature - in - let te = - { - Outcometree.otyext_name = ext.oext_type_name; - otyext_params = ext.oext_type_params; - otyext_constructors = exts; - otyext_private = ext.oext_private; - } - in - let doc = print_out_type_extension_doc te in - loop signature (doc :: acc) - | (sig_item, opt_out_value) :: signature -> - let doc = - match opt_out_value with - | None -> print_out_sig_item_doc sig_item - | Some out_value -> - Doc.group - (Doc.concat - [ - print_out_sig_item_doc sig_item; - Doc.text " = "; - print_out_value_doc out_value; - ]) - in - loop signature (doc :: acc) - in - Doc.breakable_group ~force_break:true - (Doc.join ~sep:Doc.line (loop signature [])) - -let print_out_phrase_doc (out_phrase : Outcometree.out_phrase) = - match out_phrase with - | Ophr_eval (out_value, out_type) -> - Doc.group - (Doc.concat - [ - Doc.text "- : "; - print_out_type_doc out_type; - Doc.text " ="; - Doc.indent (Doc.concat [Doc.line; print_out_value_doc out_value]); - ]) - | Ophr_signature [] -> Doc.nil - | Ophr_signature signature -> print_out_phrase_signature signature - | Ophr_exception (exc, out_value) -> print_out_exception_doc exc out_value - -let print_out_phrase fmt out_phrase = - Format.pp_print_string fmt - (Doc.to_string ~width:80 (print_out_phrase_doc out_phrase)) - let print_out_module_type fmt out_module_type = Format.pp_print_string fmt (Doc.to_string ~width:80 (print_out_module_type_doc out_module_type)) @@ -1077,18 +809,10 @@ let print_out_type_extension fmt type_extension = Format.pp_print_string fmt (Doc.to_string ~width:80 (print_out_type_extension_doc type_extension)) -let print_out_value fmt out_value = - Format.pp_print_string fmt - (Doc.to_string ~width:80 (print_out_value_doc out_value)) - -(* Not supported in ReScript *) -(* Oprint.out_class_type *) let setup = lazy - (Oprint.out_value := print_out_value; - Oprint.out_type := print_out_type; + (Oprint.out_type := print_out_type; Oprint.out_module_type := print_out_module_type; Oprint.out_sig_item := print_out_sig_item; Oprint.out_signature := print_out_signature; - Oprint.out_type_extension := print_out_type_extension; - Oprint.out_phrase := print_out_phrase) + Oprint.out_type_extension := print_out_type_extension) diff --git a/compiler/syntax/src/res_parsetree_viewer.mli b/compiler/syntax/src/res_parsetree_viewer.mli index 8d4536717fe..0a7b334b538 100644 --- a/compiler/syntax/src/res_parsetree_viewer.mli +++ b/compiler/syntax/src/res_parsetree_viewer.mli @@ -17,7 +17,6 @@ val has_await_attribute : Parsetree.attributes -> bool val has_inline_record_definition_attribute : Parsetree.attributes -> bool val has_res_pat_variant_spread_attribute : Parsetree.attributes -> bool val has_dict_pattern_attribute : Parsetree.attributes -> bool -val has_dict_spread_attribute : Parsetree.attributes -> bool type dict_expr_part = | DictExprRows of Parsetree.expression @@ -71,7 +70,6 @@ val operator_precedence : string -> int val not_ghost_operator : string -> Location.t -> bool val is_unary_expression : Parsetree.expression -> bool -val is_binary_operator : string -> bool val is_binary_expression : Parsetree.expression -> bool val is_rhs_binary_operator : string -> bool val is_equality_operator : string -> bool diff --git a/compiler/syntax/src/res_scanner.ml b/compiler/syntax/src/res_scanner.ml index 82fbeb533bf..67be55fdc5d 100644 --- a/compiler/syntax/src/res_scanner.ml +++ b/compiler/syntax/src/res_scanner.ml @@ -148,7 +148,6 @@ let peek_char scanner target_char = in skip_whitespace_and_check scanner.offset -let peek_minus scanner = peek_char scanner '-' let peek_slash scanner = peek_char scanner '/' let make ~filename src = diff --git a/compiler/syntax/src/res_scanner.mli b/compiler/syntax/src/res_scanner.mli index cbb78fad4bd..df5273c5b39 100644 --- a/compiler/syntax/src/res_scanner.mli +++ b/compiler/syntax/src/res_scanner.mli @@ -34,8 +34,5 @@ val scan_template_literal_token : val scan_regex : t -> Lexing.position * Lexing.position * Res_token.t -(* Look ahead to see if the next non-whitespace character is a minus *) -val peek_minus : t -> bool - (* Look ahead to see if the next non-whitespace character is a slash *) val peek_slash : t -> bool diff --git a/compiler/syntax/src/res_token_debugger.ml b/compiler/syntax/src/res_token_debugger.ml index ff164ff4ae2..96e5a68ee6f 100644 --- a/compiler/syntax/src/res_token_debugger.ml +++ b/compiler/syntax/src/res_token_debugger.ml @@ -1,4 +1,4 @@ -type input = Filename of string | Source of string +type input = Filename of string let dump_tokens input = let src = @@ -13,13 +13,11 @@ let dump_tokens input = Printf.printf "Error reading file %s: %s\n" filename (Printexc.to_string e); exit 1) - | Source code -> code in let filename = match input with | Filename filename -> filename - | Source _ -> "" in let scanner = Res_scanner.make ~filename src in @@ -152,10 +150,6 @@ let token_print_engine = { Res_driver.print_implementation = (fun ~width:_ ~filename ~comments:_ _ -> dump_tokens (Filename filename)); - Res_driver.print_implementation_from_source = - (fun ~width:_ ~source ~comments:_ _ -> dump_tokens (Source source)); Res_driver.print_interface = (fun ~width:_ ~filename ~comments:_ _ -> dump_tokens (Filename filename)); - Res_driver.print_interface_from_source = - (fun ~width:_ ~source ~comments:_ _ -> dump_tokens (Source source)); } diff --git a/scripts/dce/README.md b/scripts/dce/README.md new file mode 100644 index 00000000000..3cb22e0ce6b --- /dev/null +++ b/scripts/dce/README.md @@ -0,0 +1,94 @@ +# Compiler dead-code analysis (reanalyze DCE) + +Tooling to run reanalyze's dead-code-elimination (DCE) over the **compiler's own +OCaml source**, to find removable dead code. This is the native-OCaml analog of +the `tests/analysis_tests/tests-reanalyze` suite (which analyzes ReScript code). + +## Quick start + +```bash +scripts/dce/run-dce.sh # writes _dce/report.txt +``` + +Requires the host OCaml switch (5.3) with `dune` available (`eval $(opam env)`). +The script fetches + builds standalone reanalyze from +`jono/cmt-sourcefile-fallback` by default (cached in +`~/.cache/rescript-dce/reanalyze-cmt-sourcefile-fallback`) and rebuilds the cache +when that branch advances. + +The runner excludes `tests/ounit_tests` from DCE by default. Unit tests should not +keep compiler implementation details live, and test-only helpers are intentionally +out of scope for the dead-code removal pass. Override `DCE_EXCLUDE_PATHS` only when +you explicitly want to experiment with a different exclusion set. + +## Why the vendored `rescript-tools reanalyze` does NOT work here + +The compiler's OCaml is compiled by the **host OCaml (5.3)** via dune, producing +`.cmt`/`.cmi` in the **5.3 format** (`Caml1999I035`). The vendored +`rescript-tools reanalyze` links the ReScript `ml` library, which only understands +the old **4.06-era** ReScript cmt format (used for `.res` → `.cmt`). Pointed at the +compiler's own cmts it fails immediately with `Fatal error: Cmi_format.Error`. + +So we use the **standalone** reanalyze (`rescript-lang/reanalyze`), built against +the host `compiler-libs.common`. OCaml 5.3 support started in +[reanalyze#203](https://github.com/rescript-lang/reanalyze/pull/203), with +follow-up source-file/dependency fixes on JonoPrest's +`jono/cmt-sourcefile-fallback` branch. The runner tracks that branch by default. + +## Status: actionable, still manually validated + +The tooling runs end-to-end and produces a full report over all dune-built cmts. +The `jono/cmt-sourcefile-fallback` build fixes the large cross-module +false-positive class seen with the earlier `ocaml-5-3` branch. Treat the report as +an actionable worklist, but still manually validate each warning with source +searches and `dune build @check` before committing removals. + +### 1. (Fixed) Entry-point roots — use `dune build @check` + +reanalyze DCE is a whole-program reachability analysis anchored at **roots** (entry +points = the executable mains). A plain `dune build` does native compilation and +emits only `.cmti` (no impl `.cmt`) for modules with an `.mli` — including the `bsc` +main — so reanalyze never sees the entry-point bodies and over-reports. The runner +now uses `dune build @check`, which typecheck-builds everything and emits the impl +`.cmt` for all modules. This fixed the `Bs_version`-class false positives. + +Residual root gap: the playground `jsoo` main is `enabled_if profile=browser` with +`(modes js wasm)` (no bytecode `.cmt`), and the dune comment says not to build it by +default (slow). So code used only by the playground can still show as dead. + +## Keeping the report actionable + +- declare entry points live with `-live-paths` / `-live-names`, +- `@live`/`@dead` source annotations (precedent: ~38 already exist in + `compiler/gentype` and `compiler/syntax`), plus `-suppress` for whole subtrees, +- handle the `jsoo` root gap (annotate live, or a check-only browser-profile build). + +## Lowest-noise categories to start from + +These depend on **call-site** analysis within the set, so they're far less +sensitive to the missing-roots problem and are the best first targets: + +- **Redundant Optional Argument** — optional arg *always supplied* at every call, + e.g. `transl_apply`'s `~inlined`/`~transformed_jsx` (`compiler/ml/translcore.ml`), + `Typ.poly`'s `~loc` (`compiler/ml/ast_helper`). Can be made mandatory. +- **Unused Argument** — optional arg *never used* in the body, e.g. + `type_open_`'s `~used_slot` (`compiler/ml/typemod.ml`). + +## Relationship to the manual "unreachable OCaml variant" survey + +Complementary, with a subtle boundary: + +- reanalyze **does** detect "variant case which is never constructed" (~278 found), + overlapping the manual survey — but with false positives when the only + construction site sits outside the analyzed cmt set. +- reanalyze **misses** variants that *are* constructed but only inside **unreachable + code**. Example: `Longident.Lapply` is "constructed" in `ctype.ml`'s `lid_of_path` + (a branch that never runs), so reanalyze sees it as live and does not flag it — + yet it is genuinely dead. That class still needs the manual reachability reasoning. + +## CI integration (proposed, not yet wired) + +Once the backlog is cleaned up, gate CI on **new** dead code: run `run-dce.sh`, +diff against the checked-in baseline, and fail on additions. Open question: how to +depend on the analyzer fix long-term (track the branch, pin a commit, or use an +upstream release once available). diff --git a/scripts/dce/live-findings.md b/scripts/dce/live-findings.md new file mode 100644 index 00000000000..4b92f4d2385 --- /dev/null +++ b/scripts/dce/live-findings.md @@ -0,0 +1,1051 @@ +# DCE live findings + +Working notes for warnings that look actionable in `_dce/report.txt`, but are +live after manual validation. + +## Live warnings + +### `Reanalyze.run_analysis ?file_stats` + +- Report: `Warning Unused Argument`, `analysis/reanalyze/src/reanalyze.ml`, + optional argument `file_stats` of `run_analysis`. +- Verdict: live; false positive. +- Validation: `analysis/reanalyze/src/reanalyze_server.ml` calls + `state.run_analysis ... ~file_stats ()` in the server request path, then reads + `file_stats.processed` and `file_stats.from_cache` for response stats. +- Implementation: `run_analysis` forwards `?file_stats` to + `process_cmt_files`; `process_cmt_files` mutates it from + `Reactive_analysis.process_files` stats when reactive mode is active. + +### `Ast_helper0` compatibility helper surface + +- Report: many `Warning Dead Value`, `Warning Dead Module`, and + `Warning Redundant Optional Argument` entries in `compiler/ml/ast_helper0.ml` + / `.mli`, plus frozen v0 constructors in `compiler/ml/parsetree0.ml`, + including helper submodules such as `Const`, `Typ`, `Pat`, `Exp`, `Mty`, + `Mod`, and `Te`, plus optional labels on `Te.constructor`, `Te.mk`, + `Type.field`, and `Type.constructor`. +- Verdict: live compatibility surface; do not remove as part of this DCE pass. +- Validation: `compiler/ml/ast_mapper_to0.ml` opens `Ast_helper0` and uses these + helpers while converting the current `Parsetree` to `Parsetree0`, supplying + locations, attributes, privacy flags, constructor arguments, and similar data + from the source tree. +- Context: `Ast_helper0` mirrors the helper shape for the frozen v0 parsetree. + The repository guidance says `parsetree0.ml` must not be modified and v0 PPX + compatibility must be preserved, so changing this helper API or pruning v0 + AST constructors for locally redundant labels is higher risk than the DCE + warning suggests. + +### `Ast_mapper` PPX compatibility API + +- Report: `Warning Dead Value` / `Warning Dead Module`, + `compiler/ml/ast_mapper.ml` / `.mli`, including `attribute_of_warning`, + `String_map`, `get_cookie`, `set_cookie`, `tool_name`, `apply`, + `run_main`, `register_function`, `register`, and convenience exports. +- Verdict: live compatibility surface; do not remove as part of this DCE pass. +- Validation: compiler code uses the core mapper through + `compiler/syntax/src/jsx_v4.ml`, `jsx_ppx.ml`, and `compiler/ml/subst.ml`. + `compiler/core/cmd_ppx_apply.ml` uses the ppx context add/drop helpers around + external mapper execution. The remaining API is the documented standalone + `-ppx` mapper surface in `ast_mapper.mli`, including registration and cookie + functions for mapper authors/drivers. +- Context: reanalyze sees repository-internal roots but not external compiler + library consumers. This module intentionally mirrors the OCaml PPX mapper API, + so pruning apparently unused public functions would risk breaking ppx tooling. + +### `Type_utils` type argument contexts + +- Report: `Warning Unused Argument`, `analysis/src/type_utils.ml`, optional + arguments on `instantiate_type2` and the local `extract_type` binding inside + `resolve_nested`. +- Verdict: live; false positive. +- Validation: `instantiate_type2` immediately matches `type_arg_context` and uses + its `type_args` and `type_params` to substitute type variables. `extract_type` + forwards `type_arg_context_from_type_manifest` into `maybe_set_type_arg_ctx`, + and recursive calls use `print_opening_debug:false` to avoid repeated verbose + logging. +- Context: reanalyze appears to lose this through optional forwarding/local + aliasing in the recursive type-extraction helpers. Removing these labels would + break generic type instantiation and manifest traversal. + +### `from_type` in unbound name errors + +- Report: `Warning Unused Argument`, `compiler/ml/typecore.ml` and + `compiler/ml/typetexp.ml`, optional argument `from_type` on label and + constructor unbound-name error helpers. +- Verdict: live for labels; intentionally shared/ignored for constructors. +- Validation: `compiler/ml/typecore.ml` calls `Label.disambiguate + ~from_type:ty_exp` for field access, and `compiler/ml/typetexp.ml` stores that + value in `Unbound_label`. The error printer uses it to emit the specific + option-unwrapping diagnostic when the attempted field access is on an + `option`. +- Context: constructors share the `Name_choice` functor interface but currently + ignore `from_type`. Splitting that interface for DCE would risk the shared + lookup/error plumbing for little practical cleanup. + +### `Env.lookup_* ?loc` + +- Report: `Warning Unused Argument`, `compiler/ml/env.ml` and + `compiler/ml/env.mli`, optional argument `loc` on the generic lookup helpers + and value/type/constructor/label/modtype wrappers. +- Verdict: live; false positive. +- Validation: `compiler/ml/typetexp.ml` passes `~loc` through `find_component` + into `Env.lookup_type`, `Env.lookup_constructor`, + `Env.lookup_all_constructors`, `Env.lookup_all_labels`, `Env.lookup_value`, + `Env.lookup_module`, and `Env.lookup_modtype`. For dotted paths, the generic + Env lookup helpers forward `?loc` into `lookup_module_descr`, which uses it + for deprecated-module warnings. +- Context: `compiler/ml/env.mli` documents that `?loc` reports deprecated-module + warnings. Removing the labels from the wrappers would drop source locations for + those diagnostics even though reanalyze does not see the cross-module flow. + +### `Env` external roots + +- Report: `Warning Dead Value` / `Warning Dead Type`, `compiler/ml/env.ml` and + `compiler/ml/env.mli`, for `reset_cache_toplevel` and the + `Persistent_signature.t` fields `filename` and `cmi`. +- Verdict: live; false positives. +- Validation: `compiler/jsoo/jsoo_playground_main.ml` calls + `Env.reset_cache_toplevel` from the playground reset path. + `compiler/core/bs_cmi_load.ml` returns + `Env.Persistent_signature.t option`, `compiler/core/bs_conditional_initial.ml` + installs that loader into `Env.Persistent_signature.load`, and + `compiler/ml/env.ml` reads both `filename` and `cmi` when acknowledging the + persistent signature. +- Context: the playground and core CMI loader are outside the roots reanalyze is + following for this report, so the exported reset hook and loader payload fields + look dead even though they are part of the live compiler setup. + +### Experimental feature set and reset hook + +- Report: `Warning Dead Module` / `Warning Dead Value`, + `compiler/ml/experimental_features.ml` and `.mli`, for `Feature_set`, + `Feature_set.compare`, and `reset`. +- Verdict: live; false positive. +- Validation: `compiler/bsc/rescript_compiler_main.ml` enables feature flags + through `Experimental_features.enable_from_string`, while + `compiler/frontend/bs_builtin_ppx.ml` and `compiler/ml/typecore.ml` query + `Experimental_features.is_enabled`. `Feature_set.add`, `mem`, and `empty` + back that state. `compiler/jsoo/jsoo_playground_main.ml` calls + `Experimental_features.reset` from the playground compiler reset path, next to + other global compiler-state resets. +- Context: the playground entry point and several frontend/type-checker call + sites are outside the roots followed by this DCE report. The `compare` + callback is consumed by `Set.Make`, and removing the reset hook would let + experimental feature flags leak between playground compilations. + +### `Location` diagnostic hooks + +- Report: `Warning Redundant Optional Argument`, `compiler/ml/location.ml` and + `compiler/ml/location.mli`, optional arguments `custom_intro` and `src` on + `report_error`; and `Warning Dead Value`, `compiler/ml/location.mli`, for + warning-printer hook exports such as `warning_printer`, + `formatter_for_warnings`, and `default_warning_printer`. +- Verdict: live; false positive. +- Validation: `compiler/syntax/src/res_diagnostics.ml` calls + `Location.report_error ~custom_intro ~src:(Some src)` when rendering syntax + diagnostics, and `compiler/jsoo/jsoo_playground_main.ml` uses the default + wrapper form. The local exception reporter also passes explicit `None` values. + The playground entry point installs a custom `formatter_for_warnings` and + `warning_printer`, and calls `default_warning_printer` from its custom hook. +- Context: these labels select syntax-error intro text and source rendering for + diagnostics. The warning hooks are public so the playground can intercept + compiler warnings. Reanalyze only counts the local wrapper call and misses the + jsoo cross-module diagnostic hooks. + +### Reactive combinator internals + +- Report: many `Warning Dead Value` entries in + `analysis/reactive/src/reactive.ml`, including `merge_entries`, + `count_changes`, `Registry.register`, nested `process` functions, and + combinator-local helpers such as `recompute_target`. +- Verdict: live; false positive. +- Validation: `analysis/reanalyze/src/reactive_liveness.ml`, + `reactive_solver.ml`, `reactive_merge.ml`, `reactive_decl_refs.ml`, + `reactive_type_deps.ml`, and related modules build the DCE pipeline with + `Reactive.source`, `Reactive.flat_map`, `Reactive.join`, `Reactive.union`, and + `Reactive.fixpoint`. Those public combinators call these local helpers when + sources emit and the scheduler propagates updates. +- Context: these warnings are cascading from the known cross-module liveness + blind spot: reanalyze does not mark the exported combinators live from their + users, so the implementation below them looks dead even though it runs in the + analyzer's reactive mode. + +### `Reactive_file_collection` live helpers + +- Report: `Warning Dead Value`, `analysis/reactive/src/reactive_file_collection.ml` + and `.mli`, for collection operations used by the reactive analyzer. +- Verdict: live; false positive. +- Validation: `analysis/reanalyze/src/reactive_analysis.ml` uses + `Reactive_file_collection.create`, `process_files_batch`, `mem`, `iter`, and + `to_collection`; `analysis/reanalyze/src/reanalyze.ml` uses + `process_files_batch` and `remove_batch` directly for churn tests. +- Context: the single-file/cache-management helpers were removed, but the + remaining collection operations are part of the live reactive analyzer path. + +### `Reactive_fixpoint` internals + +- Report: `Warning Dead Value`, `analysis/reactive/src/reactive_fixpoint.ml` + and `.mli`, including `analyze_edge_change`, `Metrics.update`, + `Invariants.*`, `has_live_predecessor`, and `apply`. +- Verdict: live; false positive. +- Validation: `analysis/reactive/src/reactive.ml` implements + `Reactive.fixpoint` by calling `Reactive_fixpoint.create`, `initialize`, + `apply`, `iter_current`, `get_current`, and `current_length`. The analyzer + liveness pipeline calls `Reactive.fixpoint` from + `analysis/reanalyze/src/reactive_liveness.ml`, so these private-module helpers + run when the reactive analyzer computes live declarations. +- Context: `reactive_fixpoint` is a private implementation module in the + `reactive` library. Reanalyze misses the cross-module root through + `Reactive.fixpoint`, so the implementation below `apply` looks dead even + though it is the incremental transitive-closure engine. + +### Reanalyze collection functor callbacks + +- Report: `Warning Dead Module` and `Warning Dead Value`, + `analysis/reanalyze/src/file_hash.ml`, `loc_set.ml`, `pos_hash.ml`, + `pos_set.ml`, and `Name.compare` in `name.ml` / `.mli`. +- Verdict: live; false positive. +- Validation: `Pos_hash` and `Pos_set` are used throughout the DCE liveness, + reference, declaration, annotation, and reactive pipelines. `Loc_set` is used + by exception analysis, `File_hash` is the file-keyed table helper, and + `module_path.ml` builds `Name_map = Map.Make (Name)`. +- Context: `hash`, `equal`, and `compare` are callbacks consumed by + `Hashtbl.Make`, `Set.Make`, or `Map.Make`. Reanalyze can miss those callback + edges and report the callback definitions as ordinary unused values. + +### Analysis collection functor callbacks + +- Report: `Warning Dead Module` and `Warning Dead Value`, + `analysis/src/shared_types.ml`, `Location_set.compare`. +- Verdict: live; false positive. +- Validation: `Shared_types.Location_set` stores file references in + `Shared_types.extra.file_references`; `analysis/src/process_extra.ml` adds + locations with `Location_set.add` / `singleton`, and + `analysis/src/references.ml` reads them with `Location_set.elements`. +- Context: the `compare` function is consumed by `Set.Make`, so it can look + unused as a plain value even though every set operation depends on it. + +### ML type-checker collection callbacks + +- Report: `Warning Dead Module` and `Warning Dead Value`, + `compiler/ml/ctype.ml`, `Type_pairs.equal` and `Type_pairs.hash`. +- Verdict: live; false positive. +- Validation: `Ctype.Type_pairs` is the hashtable used throughout type + equality, unification, subtyping, and generalization paths. `ctype.ml` calls + `Type_pairs.create`, `find`, `add`, `mem`, and `clear` in those algorithms. +- Context: `equal` and `hash` are callbacks consumed by `Hashtbl.Make`, so they + can look unreferenced as ordinary values even though every generated table + operation depends on them. + +### ML collection and variance callbacks + +- Report: `Warning Dead Module`, `Warning Dead Value`, and constructor warnings + in `compiler/ml/depend.ml`, `env.ml`, `experimental_features.ml`, + `matching.ml`, `parmatch.ml`, `path.ml` / `.mli`, `switch.ml`, + `typedecl.ml`, `typemod.ml`, and `types.ml` / `.mli`. +- Verdict: live; false positives. +- Validation: `Depend.String_set`, `Env.String_set`, `Typedecl.String_set`, + and `Typemod.String_set` are all local set helpers whose generated `empty`, + `add`, `mem`, `union`, `fold`, or `elements` functions are used in those + modules. `Types.Type_ops` feeds `Btype.Type_set`, `Type_map`, and + `Type_hash`; `Types.Ordered_string` feeds `Meths`, `Vars`, and `Concr`. + `Path.compare` is consumed by `Map.Make (Path)` / `Set.Make (Path)` in + `env.ml`, `mtype.ml`, `printtyp.ml`, and `subst.ml`, while `Path.heads` is + called by the `Typedtree_iter.Make_iterator` instance in `parmatch.ml`. + `Switch.Store.A_map` is the action-sharing map used by `Switch.Store`, and + `matching.ml` instantiates that functor as `Store_exp`. The same module + instantiates `Switch.Make (S_arg)` and calls the resulting `Switcher` + functions from pattern-matching compilation. `Parmatch.Constructor_tag_hashtbl` + is used by constructor-coverage checks, and the local `enter_expression` / + `leave_expression` callbacks are invoked by `Typedtree_iter.Make_iterator`. + `Types.Variance.May_weak` is set and queried by `typedecl.ml`, `typemod.ml`, + and `ctype.ml` while computing weak variance for type declarations. +- Context: these warnings are all callback, functor-instantiation, manifest + signature, or cross-module edges. Removing them would break dependency + analysis, environment consistency, variance checks, match compilation, or + exhaustiveness analysis. + +### Compiler-common cross-module hooks + +- Report: `Warning Dead Value` / `Warning Dead Module`, + `compiler/common/bs_loc.ml` and `.mli` (`t` fields), + `compiler/common/bs_version.ml` and `.mli` (`header`), + `compiler/common/ext_log.ml` and `.mli` (`dwarn`), and + `compiler/common/js_config.ml` and `.mli` (`js_stdout`). +- Verdict: live; false positive. +- Validation: `compiler/frontend/ast_external_process.ml` and `.mli` use + `Bs_loc.t`; `compiler/core/js_dump_program.ml` emits `Bs_version.header`; + `compiler/core/lam_compile_main.cppo.ml`, `lam_util.cppo.ml`, + `lam_stats_export.ml`, and `js_pass_debug.cppo.ml` call `Ext_log.dwarn`; + `compiler/core/lam_compile_main.cppo.ml` and `lam_compile_primitive.ml` read + `Js_config.js_stdout`. +- Context: these are cross-module and, for several callers, `.cppo.ml` paths. + They are live in the compiler pipeline even though the current DCE report + misses those edges. + +### Typed artifact readers and raw statement classification + +- Report: `Warning Dead Value` / `Warning Dead Type`, + `compiler/ml/classify_function.ml` / `.mli`, + `compiler/ml/cmi_format.ml` / `.mli`, `compiler/ml/cmt_format.mli`, + `compiler/ml/cmt_utils.ml`, and typedtree artifact fields such as + `open_description.open_loc`, `package_type.pack_type`, `package_type.pack_txt`, + `type_extension.tyext_txt`, and `extension_constructor.ext_name`. +- Verdict: live; false positives for compiler, GenType, and analysis tooling. +- Validation: `compiler/core/lam_convert.ml` calls + `Classify_function.classify_stmt` when lowering raw JavaScript statement + literals. `compiler/ml/cmt_format.cppo.ml` calls `Cmi_format.input_cmi`, + `Cmi_format.output_cmi`, and its own `read_magic_number` while reading and + writing `.cmi`, `.cmt`, and `.cmti` artifacts. `analysis/src/*`, + `analysis/reanalyze/src/*`, and `compiler/gentype/*` call + `Cmt_format.read_cmt`, inspect `Partial_interface` / `Packed` typed + artifacts, and traverse `Partial_class_expr` where present. The reported + typedtree fields are filled by `typemod.ml`, `typetexp.ml`, and + `typedecl.ml`, then carried in the typedtree payload serialized into `.cmt` + files. +- Context: the reported `cmt_infos` fields are serialized into typed artifact + files by `cmt_format.cppo.ml` and are part of the reader/writer schema even + when a specific field is not read back by current in-repo code. The + deprecation hook is installed from `cmt_format.cppo.ml` into + `Cmt_utils.record_deprecated_used` and invoked through + `compiler/ml/builtin_attributes.ml`. Unused public `Cmt_format` signature + exports for internal reader helpers, the hook installer, and the write-only + `deprecated_text` CMT payload field were removed. + +### Typedtree iterators + +- Report: `Warning Dead Value`, `compiler/ml/typedtree_iter.ml` / `.mli`, for + `Make_iterator` and traversal callbacks such as `iter_structure_item`, + `iter_signature_item_desc`, `iter_module_expr_desc`, `iter_class_expr_desc`, + and `iter_expression_desc`. +- Verdict: live; false positive. +- Validation: `compiler/jsoo/jsoo_playground_main.ml` instantiates + `Typedtree_iter.Make_iterator` with `Default_iterator_argument` and calls + `Iter.iter_structure_item` while building playground type hints. + `compiler/ml/parmatch.ml` also instantiates the functor to collect expression + identifiers for pattern-match analysis. +- Context: reanalyze does not root these callbacks through functor + instantiation and the jsoo playground entry point, so the generated iterator + methods look unused even though they run in live compiler tooling. + +### `Misc` live utility surface + +- Report: remaining `Warning Dead Value`, `Warning Dead Module`, and constructor + warnings in `compiler/ext/misc.ml` / `.mli`, including + `output_to_bin_file_directly`, `String_map`, `String_set`, and + `Color.setting`. +- Verdict: live; false positive for the remaining reported entries. +- Validation: `compiler/ml/cmt_format.cppo.ml` calls + `Misc.output_to_bin_file_directly`. `Misc.String_map` is used by the analysis + package metadata and completion paths; `Misc.String_set` is used through + `open Misc` in `compiler/ml/printtyp.ml`. `Color.Auto`, `Always`, and `Never` + are constructed by `compiler/ml/clflags.ml`, while `Color.setup` is used by + `compiler/ml/location.ml` and `analysis/reanalyze/src/log_.ml`. +- Context: the truly unused inherited helpers were removed. The survivors are + `.cppo.ml`, open-module, functor-callback, or cross-module edges that the DCE + report does not root correctly. + +### `Literals` shared constants + +- Report: remaining `Warning Dead Value` entries in + `compiler/ext/literals.ml`, including `js_type_*`, `param`, `partial_arg`, + `tmp`, `create`, `setter_suffix_len`, node path constants, and `pure`. +- Verdict: live; false positive for the remaining reported constants. +- Validation: `compiler/core/js_exp_make.ml` imports + `module L = Literals` and reads the `js_type_*` constants. + `Lam_eta_conversion` uses `param` and `partial_arg`, + `Ext_ident.create_tmp` uses `tmp`, `Js_exp_make` uses `create` and `pure`, + `Lam_convert` uses `setter_suffix_len`, and `Ext_path` uses `node_sep`, + `node_parent`, and `node_current`. +- Context: unused constants with no `Literals.*` or alias callers were removed. + The survivors are cross-module or alias-qualified uses that DCE reports as + unrooted. + +### `Primitive_modules` runtime module names + +- Report: `Warning Dead Value`, `compiler/ext/primitive_modules.ml`, for runtime + module-name constants such as `bool`, `int`, `float`, `bigint`, `string`, + `array`, `object_`, `hash`, and `exceptions`. +- Verdict: live; false positive for the reported constants. +- Validation: these names are used directly by lambda and JS lowering. Examples + include `lam_compile_primitive.ml` for primitive runtime calls, + `js_exp_make.ml` for checked integer/bigint operations and exception + creation, and `js_of_lam_option.ml` for option runtime helpers. Syntax and ML + frontend code also uses the same module-name table for dictionary, promise, + module, pervasives, and utility paths. +- Context: Reanalyze misses the cross-module roots even though these constants + determine generated runtime import names. + +### Frontend literal and UTF-8 helpers + +- Report: `Warning Dead Value`, `compiler/frontend/ast_literal.ml` / `.mli`, + `Lid.ignore_id`; and `compiler/frontend/ast_utf8_string.ml` / `.mli`, + `check_no_escapes_or_unicode` and `simple_comparison`. +- Verdict: live; false positives for the remaining reported entries. +- Validation: `compiler/frontend/ast_comb.ml` uses + `Ast_literal.Lid.ignore_id` to build calls to the compiler's ignore + primitive. `compiler/core/js_exp_make.ml` calls + `Ast_utf8_string.simple_comparison` from `str_equal` so string literal + equality can be folded only when there are no escape or unicode surprises; the + private `check_no_escapes_or_unicode` helper feeds that exported function. +- Context: stale `Ast_literal.Lid` exports, unused literal constructors, + orphaned frontend helpers, and the `Ast_utf8_string.pp_error` export were + removed. `Ast_utf8_string.transform_test` is retained as a unit-test support + hook and marked `[@@live]`. + +### Frontend FFI and lambda constants + +- Report: `Warning Dead Value`, `compiler/frontend/external_ffi_types.mli`, + `from_string`; and `compiler/frontend/lam_constant.ml` / `.mli`, + `string_of_pointer_info`, `eq_approx`, `lam_none`, and `is_allocating`. +- Verdict: live; false positives for the remaining reported entries. +- Validation: `compiler/core/lam_convert.ml` calls + `External_ffi_types.from_string` while lowering primitive externals. + `compiler/core/lam_compile_const.ml` calls + `Lam_constant.string_of_pointer_info` for generated integer comments, + `compiler/core/lam.ml` calls `Lam_constant.eq_approx` when comparing + constants, `compiler/core/lam_constant_convert.ml` uses `Lam_constant.lam_none` + for `Pt_shape_none`, and `compiler/core/lam_util.cppo.ml` calls + `Lam_constant.is_allocating` before preserving constant bindings. +- Context: the orphaned `Bs_syntaxerr.untagged_variant` type, the over-exported + `External_arg_spec.empty_label`, unused `Lam_constant.constructor_tag` fields, + and the unconstructed `Lam_constant.pointer_info.Some` case were removed. + What remains is cross-module compiler-core use that reanalyze does not root. + +### Untagged variant dynamic checks + +- Report: `Warning Dead Value` / `Warning Dead Value With Side Effects`, + `compiler/ml/ast_untagged_variants.ml`, for `Dynamic_checks.*` builders and + combinators such as `size`, `typeof`, literal check constructors, + `is_a_literal_case`, `is_int_tag`, and `add_runtime_type_check`. +- Verdict: live; false positives. +- Validation: `compiler/core/js_exp_make.ml` exposes `emit_check`, + `is_a_literal_case`, and `is_int_tag` by calling + `Ast_untagged_variants.Dynamic_checks`; `compiler/core/lam_compile.ml` uses + `Dynamic_checks.add_runtime_type_check` and the `( == )` builder while + compiling untagged variant comparisons and runtime checks. +- Context: unused standalone helpers `tag_can_be_undefined` and + `block_is_object` were removed. The remaining warnings are a cross-module + pipeline edge from ML variant analysis into JS lowering. + +### Untagged switch defaults and declarations + +- Report: `Warning Unused Argument`, `compiler/core/lam_compile.ml`, optional + arguments `default` and `declaration` on the local `switch` helper inside + `compile_untagged_cases`. +- Verdict: live; false positive. +- Validation: `compile_general_cases` calls its switch callback as + `switch ?default ?declaration switch_exp body`. The untagged-variant callback + partitions `instanceof` clauses away from `typeof` clauses, then forwards + `?default` and `?declaration` to `S.string_switch (E.typeof e)` from its + `typeof_switch` closure. The `default` body is also read directly when the + helper inserts null/array guards before the typeof switch. +- Context: reanalyze appears to lose the optional-label flow through the local + callback and nested closure. Removing these labels would drop default handling + or declaration threading for generated untagged-variant switch code. + +### GenType map/set helpers + +- Report: `Warning Dead Module` / `Warning Dead Value`, + `compiler/gentype/gen_ident.ml`, `module_name.ml` / `.mli`, and + `resolved_name.ml`, for `Int_map`, `Module_name.compare`, and + `Resolved_name.Name_set`. +- Verdict: live; false positives. +- Validation: `compiler/gentype/gen_ident.ml` uses `Int_map.empty`, `find`, and + `add` to assign stable generated names for anonymous type ids. + `Gentype_config.Module_name_map`, `module_resolver.ml`, and `emit_js.ml` build + maps with `Module_name` as the ordered key module, so `Module_name.compare` is + consumed by `Map.Make`. `Resolved_name.Name_set` is used by + `apply_equations_to_elements`, which is reached from + `compiler/gentype/translation.ml` through `Resolved_name.apply_equations`. +- Context: the unused `Paths.concat` alias and the stored-but-unread + `Gentype_config.t.bsb_project_root` field were removed. The remaining + warnings are callback/cross-module edges missed by DCE. + +### `Ext_util` table helpers + +- Report: `Warning Dead Value`, `compiler/ext/ext_util.ml` / `.mli`, for + `power_2_above`. +- Verdict: live; false positive. +- Validation: `Ext_util.power_2_above` sizes compiler hash tables in + `hash_gen.ml`, `hash_set_gen.ml`, `hash_set_ident_mask.ml`, and + `ordered_hash_map_gen.ml`. `string_of_int_as_char` is also live through + `lam_print.ml`, `js_dump.ml`, and `pprintast.ml`. +- Context: the truly unused `stats_to_string` debug helper was removed. The + remaining warning is a cross-module utility edge missed by DCE. + +### `Ext_buffer` production and test helpers + +- Report: `Warning Dead Value`, `compiler/ext/ext_buffer.ml` / `.mli`, for + `is_empty`, `not_equal`, and the `add_int_*` helpers. +- Verdict: live or intentionally retained. +- Validation: `Ext_buffer.is_empty` is used by `ext_modulename.ml` while + deriving JavaScript identifier names. `not_equal` and `add_int_1` through + `add_int_4` are unit-test support helpers exercised by the string/util OUnit + suites, so they are marked live rather than removing the unit-test surface. +- Context: unused `clear` and `digest` were removed. The remaining production + warning depends on the known `Ext_modulename` cross-module false positive. + +### `Ext_filename` test helpers + +- Report: `Warning Dead Value` / `Warning Dead Type`, + `compiler/ext/ext_filename.ml` / `.mli`, for `chop_all_extensions_maybe`, + `as_module`, and the `module_info` fields. +- Verdict: intentionally retained unit-test helper surface. +- Validation: these helpers are exercised by `ounit_string_tests.ml` and have + no production callers. They are marked live so unit-test-only validation code + remains available while DCE ignores test modules. +- Context: the fully unused `chop_extension_maybe` helper was removed. + +### `Ext_fmt` and `Ext_ident` compiler helpers + +- Report: `Warning Dead Module`, `Warning Dead Value`, and + `Warning Dead Value With Side Effects`, `compiler/ext/ext_fmt.ml` and + `compiler/ext/ext_ident.ml` / `.mli`, for formatting helpers, JavaScript + identifier flags, temporary identifiers, and identifier comparison helpers. +- Verdict: live; false positive for cross-module and `.cppo.ml` callers. +- Validation: `Ext_fmt.with_file_as_pp` is called from + `lam_compile_main.cppo.ml`, while `Ext_fmt.failwithf` is used by + `lam_dce.ml` and `ext_path.ml`. `Ext_ident.create_tmp`, `make_js_object`, + `make_unused`, and `is_js_or_global` are used throughout lambda and JS + lowering (`lam_compile*.ml`, `js_ast_util.ml`, `js_dump.ml`, and + `lam_dce.ml`). `Ext_ident.compare` and `equal` feed identity maps, hash sets, + and module identifier equality. +- Context: Reanalyze does not root these references through the cross-module + compiler pipeline. The unused `is_js_object`, `reset`, JS-module table, and + public `is_uppercase_exotic` export were removed. + +### `compiler/ext` cross-module helpers + +- Report: `Warning Dead Module`, `Warning Dead Type`, and + `Warning Dead Value` entries across `compiler/ext/config.ml`, + `ext_char.ml`, `ext_int.ml`, `ext_js_file_kind.ml`, `ext_modulename.ml`, + `ext_namespace.ml`, `ext_option.ml`, `ext_path.ml`, `ext_pervasives.ml`, + `ext_pp.ml`, `ext_scc.ml`, and `ext_sys.mli`. +- Verdict: live; false positive for production callers hidden behind + `.cppo.ml`, module aliases, or public type signatures. +- Validation: `Config.cmt_magic_number` is used by `cmt_format.cppo.ml`; + `Ext_char.is_lower_case`, `Ext_path.package_dir`, and + `Ext_pervasives.with_file_as_chan` are used by `lam_compile_main.cppo.ml`; + `Ext_int` feeds the integer map/hash/set functors and JS int32 lowering; + `Ext_js_file_kind.case` is stored in CMJ data and lambda compile env + signatures; `Ext_modulename.js_id_name_of_hint_name` is used by + `lam_compile_env.ml`; `Ext_namespace` is used by JS module-name lowering and + outcome printing; `Ext_option.map` / `exists` are used throughout lambda + passes; `Ext_path.node_rebase_file` is used by `js_name_of_module_id.cppo.ml`; + `Ext_pp.from_channel` and `brace_group` drive JS dumping; `Ext_scc.graph` is + used by `lam_scc.ml`; and `Ext_sys.is_windows_or_cygwin` is used by JS module + path generation. +- Context: several helper implementations are reported only because their + exported wrapper is itself reported as dead; the wrapper has a production + caller. Dead pretty-printer scope/debug helpers and extra `Ext_ref` protect + variants were removed. + +### `Ext_namespace` package-name helpers + +- Report: `Warning Dead Value`, `compiler/ext/ext_namespace.ml` / `.mli`, for + `is_valid_npm_package_name` and `namespace_of_package_name`. +- Verdict: intentionally retained unit-test-covered utility surface for now. +- Validation: grep finds only OUnit callers in + `tests/ounit_tests/ounit_string_tests.ml` and documentation references in + `ext_namespace_encode.mli`; there are no production callers in the current + compiler pipeline. +- Context: these helpers validate and encode npm package names for namespace + derivation. Since unit tests are excluded from DCE roots and this pass is + avoiding unit-test edits, they are documented rather than removed in this + batch. + +### `Ext_pervasives` unit-test number parsers + +- Report: `Warning Dead Value`, `compiler/ext/ext_pervasives.ml` / `.mli`, for + `nat_of_string_exn`, `parse_nat_of_string`, and their local helper. +- Verdict: intentionally retained unit-test-covered utility surface for now. +- Validation: the number parsers are exercised only by + `ounit_util_tests.ml`. Removing them breaks `dune build @check` while those + unit tests remain in the build, so they are documented rather than removed. +- Context: `with_file_as_chan` from the same module is production-live through + `.cppo.ml` callers. + +### `Ext_obj` and `Ext_scc` unit-test helpers + +- Report: `Warning Dead Module` / `Warning Dead Value`, + `compiler/ext/ext_obj.ml` / `.mli` and `compiler/ext/ext_scc.ml` / `.mli`, + for object dumping and SCC graph checking helpers. +- Verdict: intentionally retained unit-test helper surface where still used. +- Validation: `Ext_obj.dump` is the shared OUnit printer in several unit-test + modules, and `Ext_scc.graph_check` is used only by `ounit_scc_tests.ml`. + Both are marked live while unit tests are excluded from DCE roots. +- Context: unused `Ext_obj` debug helpers (`dump_endline`, `pp_any`, `bt`) were + removed. `Ext_scc.graph` remains production-live through `lam_scc.ml`. + +### `Ident` and SCC vector helpers + +- Report: `Warning Dead Value` / `Warning Dead Module`, + `compiler/ext/ident.ml` / `.mli`, `int_vec_util.ml` / `.mli`, and + `int_vec_vec.ml` / `.mli`. +- Verdict: live; false positive for the remaining reported identifiers. +- Validation: `Ident.is_predef_exn` is used by lambda conversion, + `Ident.print` is used by lambda and typed-tree printers, and + `Ident.compare` / `equal` are used by path comparison, type checking, maps, + and hash tables. `Int_vec_util.mem` and `Int_vec_vec` are used by + `lam_scc.ml` and `ext_scc.ml`. +- Context: the unused `Identifiable` helper module was removed. The remaining + warnings are cross-module edges missed by DCE. + +### Runtime package, warnings, and hash collections + +- Report: `Warning Dead Value` and `Warning Dead Module` entries in + `compiler/ext/runtime_package.ml` / `.mli`, `warnings.ml` / `.mli`, + `hash_gen.ml`, `hash_set_gen.ml`, `hash_set_ident_mask.ml` / `.mli`, and + `hash_set_poly.mli`. +- Verdict: live; false positive for the remaining production callers, with + some unit-test-only hash-set exports retained while unit tests are not being + edited. +- Validation: `Runtime_package.name` and `path` are used by compiler package + path resolution and JS package-info generation. `Warnings.reset_fatal` is used + by the playground entry point, and `Warnings.has_warnings` is used by + `lam_compile_main.cppo.ml`. `Hash_gen` / `Hash_set_gen` are wrapped by + `hash.cppo.ml` and `hash_set.cppo.ml`; `Hash_set_ident_mask` is used by + `lam_scc.ml`; `Hash_set_poly` is used by `used_attributes.ml` and covered by + unit tests for the extra collection operations. +- Context: unused `Warnings.Bad_module_name`, `mk_lazy`, unused interface + exports, and unused `Hash_set_poly` exports (`clear`, `reset`, `to_list`) + were removed. + +### `Ext_list` production helpers + +- Report: remaining `Warning Dead Value` entries in + `compiler/ext/ext_list.ml` / `.mli`, including `map_snd`, `append`, + `append_one`, `fold_right3`, `split_at`, `length_ge`, + `length_larger_than_n`, `stable_group`, `nth_opt`, `iter_snd`, + `exists_snd`, `fold_left2`, and `singleton_exn`. +- Verdict: live; false positive for the remaining reported helpers. +- Validation: the remaining helpers have production callers across the lambda + and JS pipelines. Examples include `Lam_convert` using `append_one`, + `length_ge`, `length_larger_than_n`, and `singleton_exn`; + `Lam_eta_conversion`, `Lam_compile`, and `Lam_pass_alpha_conversion` using + `split_at`; `Js_fun_env` using `filter_mapi`; `Js_pass_tailcall_inline` using + `fold_right3`; and many lambda/JS passes using `map_snd`, `iter_snd`, + `exists_snd`, `nth_opt`, and `fold_left2`. +- Context: helper functions with no production callers were removed, along with + unit tests that only exercised that dead helper surface. The remaining + warnings are ordinary cross-module `Ext_list.*` uses missed by DCE. + +### `Map_gen` and `Set_gen` collection cores + +- Report: `Warning Dead Module`, `Warning Dead Value`, and constructor warnings + across `compiler/ext/map_gen.ml`, `compiler/ext/map_gen.mli`, + `compiler/ext/set_gen.ml`, and `compiler/ext/set_gen.mli`, including the + `t.Empty`, `t.Leaf`, and `t.Node` constructor mirrors. +- Verdict: live; false positive. +- Validation: `compiler/ext/map.cppo.ml` defines concrete map modules by + wrapping `Map_gen.empty`, `is_empty`, `iter`, `fold`, `for_all`, `exists`, + `singleton`, `cardinal`, `bindings`, sorted-array helpers, `map`, `mapi`, + balancing helpers, `merge`, `join`, and tree constructors. Similarly, + `compiler/ext/set.cppo.ml` wraps `Set_gen.empty`, `iter`, `fold`, + `singleton`, `cardinal`, `elements`, `choose`, balancing and join/concat + helpers, and validation helpers. `map_ident.mli`, `map_int.mli`, + `map_string.mli`, `set_ident.mli`, `set_int.mli`, and `set_string.mli` + expose those generated concrete modules. +- Context: this is a `.cppo.ml` rooting issue. The report sees the generic tree + implementation as dead, but those functions are the shared implementation of + the compiler's generated map and set modules. Unused top-level map/set core + helpers and internal-only signature exports were removed where they were not + part of the generated concrete modules. + +### `Ext_array` production helpers + +- Report: remaining `Warning Dead Value` entries in + `compiler/ext/ext_array.ml` / `.mli`, currently `reverse_range`, + `of_list_map`, and `fold_left`. +- Verdict: live; false positive. +- Validation: `compiler/ext/vec.cppo.ml` calls `Ext_array.reverse_range`; + `compiler/core/lam_util.cppo.ml` and `lam_stats_export.ml` call + `Ext_array.of_list_map`; and `compiler/ext/map.cppo.ml` calls + `Ext_array.fold_left`. +- Context: helpers with no production callers were removed with their + unit-only tests. The remaining warnings are `.cppo.ml` and cross-module uses + missed by DCE. + +### Core JS analyzer and delimiters + +- Report: `Warning Dead Type`, `compiler/core/j.ml`, `delim.DBackQuotes`; and + many `Warning Dead Value` entries in `compiler/core/js_analyzer.ml` / `.mli`. +- Verdict: live; false positive. +- Validation: `DBackQuotes` is constructed by + `compiler/frontend/ast_utf8_string_interp.ml` for the processed `"bq"` + delimiter and printed by `compiler/core/js_dump.ml`. `Js_analyzer` helpers are + used from `js_pass_flatten.ml`, `js_shake.ml`, `js_exp_make.ml`, + `js_output.ml`, `js_pass_flatten_and_mark_dead.ml`, + `lam_compile_external_obj.ml`, `lam_compile_external_call.ml`, + `lam_compile_primitive.ml`, `lam_compile.ml`, and related JS passes. +- Context: these are cross-module compiler pipeline edges. The warning cluster + is consistent with the known DCE limitation where anything referenced only + across modules can appear dead. + +### Core JS utility and CMJ helpers + +- Report: `Warning Dead Module` / `Warning Dead Value`, + `compiler/core/js_arr.ml`, `js_ast_util.ml`, `js_block_runtime.ml`, + `js_call_info.ml`, and `js_cmj_format.ml` / `.mli`. +- Verdict: live; false positive for the remaining reported helpers. +- Validation: `Js_arr.ref_array` and `set_array` are used by + `compiler/core/lam_compile_external_call.ml`. `Js_ast_util.named_expression` + is used by `lam_compile_external_obj.ml` and `lam_compile.ml`. + `Js_block_runtime.check_additional_id` is used by `js_fold_basic.ml` and + `js_pass_scope.ml`; its reported local ids feed that exported helper. + `Js_call_info.dummy`, `ml_full_call`, and `na_full_call` are used by + `lam_compile.ml`, `js_exp_make.ml`, and `lam_compile_external_call.ml`. + `Js_cmj_format.single_na`, `make`, `to_file`, and `query_by_name` are used by + `lam_stats_export.ml`, `lam_compile_main.cppo.ml`, and + `lam_compile_env.ml`; the binary-search helpers are local dependencies of + `query_by_name`, and `for_sure_not_changed` is a local dependency of + `to_file`. +- Context: `Js_cmj_format.from_file_with_digest` and `from_string` had no + callers and were removed. The remaining entries are live through cross-module + compiler and `.cppo.ml` call sites. + +### Core JS dumping pipeline + +- Report: `Warning Dead Module` / `Warning Dead Value`, + `compiler/core/js_cmj_load.ml`, `js_dump.ml`, `js_dump_import_export.ml`, + `js_dump_lit.ml`, and `js_dump_program.ml` / `.mli`. +- Verdict: live; false positive for the remaining reported helpers. +- Validation: `compiler/core/lam_compile_env.ml` reads + `Js_cmj_load.load_unit`. `compiler/core/js_output.ml` calls + `Js_dump.string_of_block`, and `compiler/core/js_dump_program.ml` calls + `Js_dump.statements`. `compiler/core/js_dump_program.ml` calls + `Js_dump_import_export.exports`, `requires`, `imports`, and + `esmodule_export`; those helpers use the reported `Js_dump_lit` strings + through `module L = Js_dump_lit`. `Js_dump_program.dump_deps_program` is used + by `lam_compile_main.cppo.ml`, `dump_program` by `js_pass_debug.cppo.ml`, and + `pp_deps_program` by `compiler/jsoo/jsoo_playground_main.ml`. +- Context: unused `Js_dump_lit` strings and the unused + `Js_dump.string_of_expression` signature export were removed. The remaining + dumper warnings are cross-module compiler output paths, including `.cppo.ml` + and jsoo entry points that this DCE run misses. + +### `Js_exp_make` expression builders + +- Report: large `Warning Dead Value` cluster in + `compiler/core/js_exp_make.ml` / `.mli`. +- Verdict: live; false positive for the remaining reported builders and their + local helper chains. +- Validation: the module is imported as `module E = Js_exp_make` across core + lowering and JS passes, including `lam_compile.ml`, + `lam_compile_primitive.ml`, `lam_compile_external_call.ml`, + `lam_compile_external_obj.ml`, `js_stmt_make.ml`, `js_output.ml`, + `js_of_lam_array.ml`, `js_of_lam_block.ml`, `js_of_lam_option.ml`, + `js_of_lam_string.ml`, `js_of_lam_variant.ml`, `js_pass_flatten.ml`, + `js_pass_flatten_and_mark_dead.ml`, and `js_pass_external_shadow.ml`. Direct + `Js_exp_make.remove_pure_sub_exp` calls also exist in `lam_compile.ml`, and + tests use `Js_exp_make.var`. +- Context: `runtime_ref`, `assign_by_int`, and the public signature export for + `pure_runtime_call` had no callers and were removed. The remaining zero + direct-call entries, such as `bin`, `str_equal`, `push_negation`, and the + `simplify_*` helpers, are local dependencies of exported builders that are + used through `E.*`. `assign_by_exp` is called from + `compiler/core/js_of_lam_block.ml` through the usual `module E = Js_exp_make` + alias. The debug-printer ref is intentionally left because removing its + `Js_dump` hook unroots a large live dump-printer subgraph in the current DCE + report. + +### `Js_stmt_make` statement builders + +- Report: large `Warning Dead Value` cluster in + `compiler/core/js_stmt_make.ml` / `.mli`. +- Verdict: live; false positive. +- Validation: the module is imported as `module S = Js_stmt_make` across the JS + lowering and pass pipeline. Direct callers cover the reported statement + builders in `lam_compile.ml`, `lam_compile_external_obj.ml`, + `js_ast_util.ml`, `js_dump.ml`, `js_of_lam_variant.ml`, `js_output.ml`, + `js_pass_flatten.ml`, `js_pass_flatten_and_mark_dead.ml`, and + `js_pass_tailcall_inline.ml`. `debugger_block` is used for the `Pdebugger` + primitive in `lam_compile.ml`. +- Context: DCE misses the cross-module builder calls through `module S`, so it + reports exported constructors even though they are part of normal JS statement + generation. + +### `Lam` smart constructors + +- Report: `Warning Dead Value` cluster in `compiler/core/lam.ml` / `.mli`, + including `apply`, `eq_approx`, `switch`, `stringswitch`, `prim`, `if_`, + sequence/control-flow constructors, and local helper chains. +- Verdict: live; false positive for the remaining reported helpers. +- Validation: the reported `Lam.*` smart constructors are used throughout lambda + conversion and optimization passes, including `lam_convert.ml`, + `lam_pass_lets_dce.ml`, `lam_bounded_vars.ml`, + `lam_pass_eliminate_ref.ml`, `lam_pass_remove_alias.ml`, + `lam_pass_exits.ml`, `lam_pass_deep_flatten.ml`, `lam_subst.ml`, + `lam_eta_conversion.ml`, `lam_pass_alpha_conversion.ml`, `lam_analysis.ml`, + `lam_compile.ml`, and `lam_util.cppo.ml`. Local helpers are live through those + constructors: `is_eta_conversion_exn` through `apply`, `eq_option` and + `eq_approx_list` through `eq_approx`, `Lift.*` through `prim`, + `has_boolean_type`, `complete_range`, and `eval_const_as_bool` through `if_`, + and `result_wrap` through `handle_bs_non_obj_ffi`. +- Context: the duplicate `Lam.X` type alias module and the unused public + `inner_map` helper were removed. The remaining `Lam` warnings are exported + smart constructors used cross-module, which this DCE run does not root + correctly. + +### `Lambda.let_kind.Variable` + +- Report: `Warning Dead Type`, `compiler/ml/lambda.ml` and `.mli`, + `let_kind.Variable`. +- Verdict: live; false positive. +- Validation: `compiler/core/lam_compat.ml` aliases + `type let_kind = Lambda.let_kind = Strict | Alias | StrictOpt | Variable`. + The `Variable` constructor is then used through `Lam_compat.let_kind` by + lambda DCE, conversion, scope, printing, JS statement generation, and JS + operator metadata. +- Context: reanalyze reports the original constructor as unconstructed because + the live construction happens through the cross-module alias. Removing it from + `Lambda.let_kind` would break the shared let-kind model used by core lowering. + +### `Lam_id_kind` block metadata + +- Report: `Warning Dead Type` / `Warning Dead Value`, + `compiler/core/lam_id_kind.ml` and `.mli`, including `element.NA`, + `element.SimpleForm`, `t.ImmutableBlock`, and `print`. +- Verdict: live; false positive for the remaining metadata constructors. +- Validation: `compiler/core/lam_util.cppo.ml` constructs + `Lam_id_kind.ImmutableBlock` in `kind_of_lambda_block`, builds + `SimpleForm` / `NA` entries in `element_of_lambda`, and consumes the block + metadata in `field_flatten_get`. These helpers are called by + `lam_beta_reduce.ml`, `lam_pass_collect.ml`, `lam_pass_remove_alias.ml`, and + `lam_coercion.ml`. +- Context: the truly unused `Undefined`, `MutableBlock`, and `Exception` + constructors were removed. The remaining warnings are `.cppo.ml` and + cross-module lambda optimization edges that DCE does not root reliably. + +### Core lambda analysis and rewrite passes + +- Report: `Warning Dead Module` / `Warning Dead Value` clusters in + `compiler/core/lam_analysis.ml`, `lam_arity.ml`, `lam_arity_analysis.ml`, + `lam_beta_reduce.ml`, `lam_beta_reduce_util.ml`, `lam_bounded_vars.ml`, + `lam_check.ml`, `lam_closure.ml`, `lam_exit_count.ml`, + `lam_free_variables.ml`, `lam_group.ml`, and `lam_hit.ml` plus their `.mli` + files. +- Verdict: live; false positive for the remaining reported helpers. +- Validation: `Lam_analysis` is used by lambda DCE/count/remove-alias passes, + `lam_compile_main.cppo.ml`, `lam_compile.ml`, `lam_stats_export.ml`, + `lam_beta_reduce.ml`, `lam_dce.ml`, `lam_util.cppo.ml`, and + `lam_var_stats.ml`. `Lam_arity` and `Lam_arity_analysis` feed + `lam_pass_alpha_conversion.ml`, `lam_stats_export.ml`, `lam_coercion.ml`, + and `lam_pass_collect.ml`. `Lam_beta_reduce` is called from + `lam_pass_lets_dce.ml`, `lam_pass_count.ml`, `lam_pass_remove_alias.ml`, and + `lam_compile.ml`; it calls `Lam_beta_reduce_util.simple_beta_reduce` and + `Lam_bounded_vars.rewrite`. `Lam_check.check` is called by + `lam_compile_main.cppo.ml`. `Lam_closure` is used by + `lam_pass_remove_alias.ml`, `lam_stats_export.ml`, and `lam_compile.ml`. + `Lam_exit_count` is called by `lam_pass_exits.ml`; `Lam_free_variables` is + used by `lam_dce.ml` and `lam_compile.ml`; `Lam_group` is used by + `lam_pass_deep_flatten.ml`, `lam_coercion.ml`, `lam_dce.ml`, and + `lam_compile_main.cppo.ml`; and `Lam_hit` is used by + `lam_pass_eliminate_ref.ml`, `lam_scc.ml`, `lam_pass_remove_alias.ml`, + `lam_convert.ml`, `lam_pass_deep_flatten.ml`, and `lam_util.cppo.ml`. +- Context: unused `Lam_arity.equal`, `print`, and `print_arities_tbl` exports + were removed. The remaining entries are cross-module pass plumbing and local + helper chains under live pass functions. + +### `Lam_compat` aliases, comparisons, and field comments + +- Report: constructor warnings for `field_dbg_info` and `set_field_dbg_info` in + `compiler/core/lam_compat.ml` / `.mli`, plus comparison helpers and + `str_of_field_info`. +- Verdict: live; false positive for the remaining reported entries. +- Validation: `Lam_compat.field_dbg_info` and `set_field_dbg_info` are + manifest aliases of `Lambda` types. Their constructors are produced in the ML + lambda layer (`lambda.ml`, `translcore.ml`, `translmod.ml`, `matching.ml`) and + consumed by core lowering in `lam_convert.ml`, `lam_util.cppo.ml`, + `lam_arity_analysis.ml`, `lam_analysis.ml`, `lam_pass_remove_alias.ml`, + `lam_compile.ml`, `lam_print.ml`, `polyvar_pattern_match.ml`, and + `js_of_lam_block.ml`. `str_of_field_info` is used by `lam_print.ml` and by + `js_of_lam_block.ml` to preserve record-field comments in generated JS. + `cmp_int32` and `cmp_float` are called by `Lam.prim`; `eq_comparison` is + called by `lam_primitive.ml`. +- Context: unused `cmp_int` was removed. The remaining constructor warnings come + from constructors being built through the aliased `Lambda` type rather than + directly through `Lam_compat`. + +### `Lam_print` lambda printers + +- Report: `Warning Dead Value` entries in `compiler/core/lam_print.ml` / `.mli`, + including `lambda`, `serialize`, and `lambda_to_string`. +- Verdict: live false positives, except `primitive_to_string`, which had no + callers and was removed. +- Validation: `Lam_group.pp` calls `Lam_print.lambda`, + `lam_util.cppo.ml` calls `Lam_print.serialize`, and + `compiler/jsoo/jsoo_playground_main.ml` calls `Lam_print.lambda_to_string` + when rendering playground lambda output. The `primitive` printer is reached + from the live lambda printer. +- Context: these are debug/inspection printers reached through cross-module and + `.cppo.ml` paths that the DCE report does not root correctly. The playground + call site is not covered by `dune build @check`, so this warning must stay + documented rather than removed. The unused public `primitive` signature export + was removed; the implementation remains live through `lambda`. + +### Lambda-to-JS compilation pipeline + +- Report: `Warning Dead Module` / `Warning Dead Value` clusters in + `compiler/core/lam_compile.ml`, `lam_compile_const.ml`, and + `lam_compile_context.ml` plus their `.mli` files. +- Verdict: live; false positive. +- Validation: `lam_compile_main.cppo.ml` calls + `Lam_compile.compile_lambda` and `compile_recursive_lets`. The reported + top-level helpers in `lam_compile.ml` are local dependencies of the recursive + `compile` closure that produces those functions. `Lam_compile_const.translate` + and `translate_arg_cst` are used by `lam_compile.ml`, + `lam_compile_external_call.ml`, and `lam_compile_external_obj.ml`. + `Lam_compile_context` types and helpers are used by `lam_compile.ml`, + `lam_compile_main.cppo.ml`, `lam_compile_primitive.ml`, + `lam_compile_external_call.ml`, and `js_output.ml`. +- Context: DCE does not root the `.cppo.ml` entry point and therefore treats the + compiler backend and its local helper chains as dead. + +### Lambda compile environment and FFI lowering + +- Report: `Warning Dead Value` / `Warning Dead Module` clusters in + `compiler/core/lam_compile_env.ml`, `lam_compile_external_call.ml`, + `lam_compile_external_obj.ml`, `lam_compile_primitive.ml`, and + `lam_module_ident.ml` plus their `.mli` files. +- Verdict: live; false positive. +- Validation: `Lam_compile_env` is used by `lam_compile.ml`, + `lam_pass_remove_alias.ml`, `lam_arity_analysis.ml`, + `lam_stats_export.ml`, `js_implementation.ml`, `js_name_of_module_id.cppo.ml`, + and `lam_compile_main.cppo.ml`. `Lam_compile_external_call.translate_ffi` is + called by `lam_compile_primitive.ml`, and `ocaml_to_js_eff` is used by + `lam_compile_external_obj.ml`. `Lam_compile_external_obj.assemble_obj_args` + and `Lam_compile_primitive.translate` are called by `lam_compile.ml`. + `Lam_module_ident.t` is a manifest alias of `J.module_id`; `dynamic_import` + is filled by `Lam_module_ident.of_ml` and read by `js_dump_program.ml` when + emitting dynamic imports. `Lam_module_ident.Cmp` is passed to `Hash.Make` and + `Hash_set.Make`; the resulting tables and sets are used by + `lam_compile_env.ml` for module dependency caching and hard-dependency + collection. The reported helper functions in those modules are local + dependencies of those exported lowering entry points. +- Context: `lam_compile_external_call.arg_expression` is a manifest alias of + `Js_of_lam_variant.arg_expression`; constructor warnings there are false + positives for the same aliasing reason documented in the JS lowering section. + `Cmp.equal` and `Cmp.hash` are functor callbacks consumed by generated hash + modules, so they can look unused as standalone values. + +### Core JS lowering helpers + +- Report: `Warning Dead Module`, `Warning Dead Value`, and constructor warnings + in `compiler/core/js_fold_basic.ml`, `js_fun_env.ml`, + `js_name_of_module_id.mli`, `js_of_lam_array.ml`, + `js_of_lam_block.ml`, `js_of_lam_option.ml`, `js_of_lam_string.ml`, and + `js_of_lam_variant.ml` / `.mli`. +- Verdict: live; false positive for the remaining reported helpers. +- Validation: `lam_compile_main.cppo.ml` calls + `Js_fold_basic.calculate_hard_dependencies`. `Js_fun_env.make` is used while + building JS functions in `Js_exp_make`; `js_pass_scope.ml` and + `js_pass_tailcall_inline.ml` use `set_unbounded`, `mark_unused`, + `get_mutable_params`, and `no_tailcall`. `Js_name_of_module_id` is used by + `lam_compile_primitive.ml` and `js_dump_program.ml`. Array, block, option, + string, and variant lowering helpers are called from `lam_compile.ml`, + `lam_compile_const.ml`, `lam_compile_primitive.ml`, + `lam_compile_external_obj.ml`, and `lam_compile_external_call.ml`. + `Polyvar_pattern_match.Coll` is the hash table used by + `Polyvar_pattern_match.convert` while coalescing variant tag actions; its + generated operations are reached through the switcher hooks installed by + `compiler/core/bs_conditional_initial.ml`. +- Context: `Js_of_lam_option.option_unwrap_time` and `undef_to_opt` had no + callers and were removed. The `Js_of_lam_variant.arg_expression` constructor + warnings are false positives: `lam_compile_external_call.ml` re-exports the + same constructors with + `type arg_expression = Js_of_lam_variant.arg_expression = ...`, then + constructs and pattern matches `Splice0`, `Splice1`, and `Splice2`. + `Polyvar_pattern_match.Coll.equal` and `hash` are callbacks consumed by the + hash-table functor. + +### Core JS operators and output state + +- Report: constructor warnings in `compiler/core/js_op.ml` for + `property.Strict`, `Alias`, `StrictOpt`, and `Variable`; and + `Warning Dead Value` entries in `js_op_util.ml` / `.mli` and + `js_output.ml` / `.mli`. +- Verdict: live; false positive for the remaining reported entries. +- Validation: the property constructors are the shared + `Lam_compat.let_kind` constructors used by lambda DCE, conversion, scope, and + JS statement generation. `Js_op_util.update_used_stats` is used by + `js_pass_flatten_and_mark_dead.ml`, `js_pass_tailcall_inline.ml`, and + `js_pass_get_used.ml`; `same_vident` is used by `js_analyzer.ml` and + `Js_exp_make`; `of_lam_mutable_flag` is used by `lam_compile_primitive.ml`. + `Js_output` is central to `lam_compile.ml`, and `lam_compile_main.cppo.ml` + calls `Js_output.concat` and `output_as_block`. +- Context: unused operator model types/cases (`binop.Bnot`, `int_op`, `level`, + `access`, `recursive_info`, and `length_object.Bytes`) were removed, along + with the unused `Js_op_util.str_of_used_stats` and `Js_output.to_string` + debug exports. + +### Core JS package path helpers + +- Report: `Warning Dead Value` and record-field warnings in + `compiler/core/js_packages_info.ml` / `.mli`, plus + `Js_packages_state.get_packages_info`. +- Verdict: live; false positive for the remaining reported package helpers and + `package_found_info` fields. +- Validation: `compiler/core/js_name_of_module_id.cppo.ml` calls + `query_package_infos`, `runtime_package_path`, + `runtime_dir_of_module_system`, `same_package_by_name`, and + `is_runtime_package`, then reads `package_found_info.rel_path`, + `pkg_rel_path`, and `suffix`. `lam_compile_main.cppo.ml` uses + `Js_packages_info.iter`, `lam_compile_primitive.ml` uses + `Js_packages_info.map`, and `js_name_of_module_id.cppo.ml` reads + `Js_packages_state.get_packages_info`. +- Context: the unused package dump formatter and old `get_output_dir` helper + were removed. The remaining warnings are `.cppo.ml` call sites and record + fields read by package path generation. + +### Core JS pass pipeline and traversals + +- Report: `Warning Dead Module` / `Warning Dead Value` clusters in + `compiler/core/js_pass_debug.mli`, `js_pass_external_shadow.ml`, + `js_pass_flatten.ml`, `js_pass_flatten_and_mark_dead.ml`, + `js_pass_get_used.ml`, `js_pass_scope.ml`, `js_pass_tailcall_inline.ml`, and + the generated traversal helpers `js_record_fold.ml`, `js_record_iter.ml`, and + `js_record_map.ml`. +- Verdict: live; false positive. +- Validation: `compiler/core/lam_compile_main.cppo.ml` runs the JS pass + pipeline through `Js_pass_debug.dump`, `Js_pass_flatten.program`, + `Js_pass_external_shadow.program`, `Js_pass_tailcall_inline.tailcall_inline`, + `Js_pass_flatten_and_mark_dead.program`, and `Js_pass_scope.program`. + `js_pass_tailcall_inline.ml` calls `Js_pass_get_used.get_stats`. These passes + instantiate and call the `Js_record_*` traversal records, so the large helper + clusters under the traversal modules are live through the pass pipeline. +- Context: the DCE report misses `.cppo.ml` roots and therefore treats entire + passes and their generated traversal helper methods as dead. + +### `File_deps.File_hash` callbacks + +- Report: `Warning Dead Module` and `Warning Dead Value`, + `analysis/reanalyze/src/file_deps.ml`, `File_hash.hash` and `File_hash.equal`. +- Verdict: live; false positive. +- Validation: `File_deps.create_builder`, `add_file`, `add_dep`, + and `merge_into_builder` all use the `File_hash` table produced by + `Hashtbl.Make`. +- Context: `hash` and `equal` are callbacks consumed by the hashtable functor, + so they can look unreferenced as ordinary values even though table operations + depend on them. + +### `Arnold` ordered-set compare callbacks + +- Report: `Warning Dead Value`, `analysis/reanalyze/src/arnold.ml`, + `Function_args.compare_arg`, `Function_args.compare`, and + `Function_call.compare`; same pattern for `Path_map.compare` in + `analysis/reanalyze/src/dead_exception.ml` and `dead_type.ml`, and + `Exn.compare` in `analysis/reanalyze/src/exn.ml`. +- Verdict: live; false positive. +- Validation: `Function_call_set = Set.Make (Function_call)` uses + `Function_call.compare`, which delegates to `Function_args.compare`. The set is + used in the termination analyzer call stack (`Call_stack.to_set`, + `Function_call_set.mem`, `Function_call_set.union`, and + `Function_call_set.empty`). `dead_exception.ml` and `dead_type.ml` both build + `Path_map = Map.Make (...)`, then use `Path_map.add`, `find_opt`, and `iter` + for exception and type-label indexes. `exceptions.ml` and `issue.ml` build + `Set.Make (Exn)`, which requires `Exn.compare`. +- Context: compare functions supplied to functors can look unreferenced as plain + values even though the generated set module calls them. diff --git a/scripts/dce/run-dce.sh b/scripts/dce/run-dce.sh new file mode 100755 index 00000000000..bdcc160982e --- /dev/null +++ b/scripts/dce/run-dce.sh @@ -0,0 +1,77 @@ +#!/bin/bash +# Run reanalyze dead-code-elimination (DCE) over the compiler's OWN OCaml source. +# +# WHY A SEPARATE TOOL: the compiler's OCaml is built by the host OCaml (5.3) via +# dune, producing 5.3-format .cmt/.cmi. The vendored `rescript-tools reanalyze` +# links the ReScript `ml` library, which only understands the old (4.06-era) +# ReScript cmt format used for .res -> .cmt, so it CANNOT read the compiler's own +# cmts (fails with Cmi_format.Error). We therefore use the STANDALONE reanalyze +# built against the host compiler-libs. OCaml 5.3 support comes from +# rescript-lang/reanalyze#203 plus follow-up fixes from JonoPrest's +# `jono/cmt-sourcefile-fallback` branch, so we track that branch by default. +# +# Usage: scripts/dce/run-dce.sh [output-file] +# Output defaults to _dce/report.txt +set -euo pipefail + +REPO_ROOT="$(cd "$(dirname "$0")/../.." && pwd)" +cd "$REPO_ROOT" + +# Standalone reanalyze with OCaml 5.3 support and cmt source-file fixes. +REANALYZE_REPO="${REANALYZE_REPO:-https://github.com/JonoPrest/reanalyze.git}" +REANALYZE_REF="${REANALYZE_REF:-jono/cmt-sourcefile-fallback}" +REANALYZE_SRC="${REANALYZE_SRC:-$HOME/.cache/rescript-dce/reanalyze-cmt-sourcefile-fallback}" + +OUT="${1:-_dce/report.txt}" +mkdir -p "$(dirname "$OUT")" + +# Unit tests are intentionally excluded from DCE. They should not keep compiler +# implementation details live, and test-only helpers are noisy DCE targets. +EXCLUDE_PATHS="${DCE_EXCLUDE_PATHS:-$REPO_ROOT/tests/ounit_tests,tests/ounit_tests,./tests/ounit_tests,$REPO_ROOT/_build/default/tests/ounit_tests,_build/default/tests/ounit_tests}" + +# 1. Fetch + build the standalone reanalyze (cached). +if [ ! -d "$REANALYZE_SRC/.git" ]; then + echo "==> Fetching standalone reanalyze" + rm -rf "$REANALYZE_SRC" + git clone --quiet "$REANALYZE_REPO" "$REANALYZE_SRC" +else + echo "==> Updating standalone reanalyze" + git -C "$REANALYZE_SRC" fetch --quiet origin +fi + +if git -C "$REANALYZE_SRC" rev-parse --verify --quiet "refs/remotes/origin/$REANALYZE_REF" >/dev/null; then + git -C "$REANALYZE_SRC" checkout --quiet --detach "origin/$REANALYZE_REF" +else + git -C "$REANALYZE_SRC" checkout --quiet "$REANALYZE_REF" +fi + +BIN="$REANALYZE_SRC/_build/default/src/Reanalyze.exe" +STAMP="$REANALYZE_SRC/_build/.rescript-dce-reanalyze-sha" +REANALYZE_SHA="$(git -C "$REANALYZE_SRC" rev-parse HEAD)" +if [ ! -x "$BIN" ] || [ ! -f "$STAMP" ] || [ "$(cat "$STAMP")" != "$REANALYZE_SHA" ]; then + echo "==> Building reanalyze against $(ocaml -version)" + (cd "$REANALYZE_SRC" && dune build 2>&1 | tail -5) + mkdir -p "$(dirname "$STAMP")" + echo "$REANALYZE_SHA" > "$STAMP" +fi +echo "==> Using reanalyze $REANALYZE_SHA" + +# 2. Typecheck-build so dune emits fresh .cmt for EVERY module, including the +# executable mains (bsc, res_cli). A plain `dune build` does native compilation +# and emits only `.cmti` for modules that have an `.mli` (e.g. the bsc main), +# leaving reanalyze blind to the entry-point bodies and over-reporting dead code. +# `@check` is typecheck-only and emits the impl `.cmt` for all of them. +echo "==> dune build @check (producing .cmt files incl. entry points)" +dune build @check + +# 3. Run DCE over the dune build tree (compiler + tools + analysis + +# executables), excluding unit tests. All are host-OCaml 5.3 cmts; the +# ReScript runtime (4.06 cmts) lives outside _build/default so it is not +# picked up. +echo "==> Running DCE -> $OUT" +"$BIN" -exclude-paths "$EXCLUDE_PATHS" -dce-cmt _build/default > "$OUT" 2>&1 || true + +echo "==> Done. Summary:" +grep -oE "Warning [A-Za-z ]+" "$OUT" | sort | uniq -c | sort -rn || true +echo " never-constructed variants: $(grep -c 'never constructed' "$OUT" || echo 0)" +echo "Full report: $OUT" diff --git a/tests/ounit_tests/ounit_array_tests.ml b/tests/ounit_tests/ounit_array_tests.ml index 74274cd4f5b..fcd36a613e1 100644 --- a/tests/ounit_tests/ounit_array_tests.ml +++ b/tests/ounit_tests/ounit_array_tests.ml @@ -8,26 +8,6 @@ let printer_int_array xs = let suites = __FILE__ >::: [ - ( __LOC__ >:: fun _ -> - Ext_array.find_and_split [|"a"; "b"; "c"|] Ext_string.equal "--" - =~ No_split ); - ( __LOC__ >:: fun _ -> - Ext_array.find_and_split [|"a"; "b"; "c"; "--"|] Ext_string.equal - "--" - =~ Split ([|"a"; "b"; "c"|], [||]) ); - ( __LOC__ >:: fun _ -> - Ext_array.find_and_split - [|"--"; "a"; "b"; "c"; "--"|] - Ext_string.equal "--" - =~ Split ([||], [|"a"; "b"; "c"; "--"|]) ); - ( __LOC__ >:: fun _ -> - Ext_array.find_and_split - [|"u"; "g"; "--"; "a"; "b"; "c"; "--"|] - Ext_string.equal "--" - =~ Split ([|"u"; "g"|], [|"a"; "b"; "c"; "--"|]) ); - ( __LOC__ >:: fun _ -> - Ext_array.reverse [|1; 2|] =~ [|2; 1|]; - Ext_array.reverse [||] =~ [||] ); ( __LOC__ >:: fun _ -> let ( =~ ) = OUnit.assert_equal ~printer:printer_int_array in let k x y = Ext_array.of_list_map y x in @@ -38,22 +18,4 @@ let suites = k succ [1; 2; 3; 4; 5] =~ [|2; 3; 4; 5; 6|]; k succ [1; 2; 3; 4; 5; 6] =~ [|2; 3; 4; 5; 6; 7|]; k succ [1; 2; 3; 4; 5; 6; 7] =~ [|2; 3; 4; 5; 6; 7; 8|] ); - ( __LOC__ >:: fun _ -> - Ext_array.to_list_map_acc [|1; 2; 3; 4; 5; 6|] [1; 2; 3] (fun x -> - if x mod 2 = 0 then Some x else None) - =~ [2; 4; 6; 1; 2; 3] ); - ( __LOC__ >:: fun _ -> - Ext_array.to_list_map_acc [|1; 2; 3; 4; 5; 6|] [] (fun x -> - if x mod 2 = 0 then Some x else None) - =~ [2; 4; 6] ); - ( __LOC__ >:: fun _ -> - OUnit.assert_bool __LOC__ - (Ext_array.for_all2_no_exn [|1; 2; 3|] [|1; 2; 3|] ( = )) ); - ( __LOC__ >:: fun _ -> - OUnit.assert_bool __LOC__ (Ext_array.for_all2_no_exn [||] [||] ( = )); - OUnit.assert_bool __LOC__ - (not @@ Ext_array.for_all2_no_exn [||] [|1|] ( = )) ); - ( __LOC__ >:: fun _ -> - OUnit.assert_bool __LOC__ - (not (Ext_array.for_all2_no_exn [|1; 2; 3|] [|1; 2; 33|] ( = ))) ); ] diff --git a/tests/ounit_tests/ounit_list_test.ml b/tests/ounit_tests/ounit_list_test.ml index c08725ddab8..7860b51baf9 100644 --- a/tests/ounit_tests/ounit_list_test.ml +++ b/tests/ounit_tests/ounit_list_test.ml @@ -12,10 +12,6 @@ let suites = OUnit.assert_equal (Ext_list.flat_map [1; 2] (fun x -> [x; x])) [1; 1; 2; 2] ); - ( __LOC__ >:: fun _ -> - OUnit.assert_equal - (Ext_list.flat_map_append [1; 2] [3; 4] (fun x -> [x; x])) - [1; 1; 2; 2; 3; 4] ); ( __LOC__ >:: fun _ -> let ( =~ ) = OUnit.assert_equal ~printer:printer_int_list in Ext_list.flat_map [] (fun x -> [succ x]) =~ []; @@ -38,11 +34,6 @@ let suites = Ext_list.map_last [0; 0; 0; 0; 0] f =~ [0; 0; 0; 0; 1]; Ext_list.map_last [0; 0; 0; 0; 0; 0] f =~ [0; 0; 0; 0; 0; 1]; Ext_list.map_last [0; 0; 0; 0; 0; 0; 0] f =~ [0; 0; 0; 0; 0; 0; 1] ); - ( __LOC__ >:: fun _ -> - OUnit.assert_equal - (Ext_list.flat_map_append [1; 2] [false; false] (fun x -> - if x mod 2 = 0 then [true] else [])) - [true; false; false] ); ( __LOC__ >:: fun _ -> OUnit.assert_equal (Ext_list.map_append [0; 1; 2] ["1"; "2"; "3"] (fun x -> @@ -53,18 +44,6 @@ let suites = OUnit.assert_equal (a, b) ([1; 2; 3], [4; 5; 6]); OUnit.assert_equal (Ext_list.split_at [1] 1) ([1], []); OUnit.assert_equal (Ext_list.split_at [1; 2; 3] 2) ([1; 2], [3]) ); - ( __LOC__ >:: fun _ -> - let printer (a, b) = - Format.asprintf "([%a],%d)" - (Format.pp_print_list Format.pp_print_int) - a b - in - let ( =~ ) = OUnit.assert_equal ~printer in - Ext_list.split_at_last [1; 2; 3] =~ ([1; 2], 3); - Ext_list.split_at_last [1; 2; 3; 4; 5; 6; 7; 8] - =~ ([1; 2; 3; 4; 5; 6; 7], 8); - Ext_list.split_at_last [1; 2; 3; 4; 5; 6; 7] - =~ ([1; 2; 3; 4; 5; 6], 7) ); ( __LOC__ >:: fun _ -> OUnit.assert_equal (Ext_list.assoc_by_int [(2, "x"); (3, "y"); (1, "z")] 1 None) @@ -72,12 +51,6 @@ let suites = ( __LOC__ >:: fun _ -> Ounit_tests_util.assert_raise_any (fun _ -> Ext_list.assoc_by_int [(2, "x"); (3, "y"); (1, "z")] 11 None) ); - ( __LOC__ >:: fun _ -> - OUnit.assert_equal (Ext_list.length_compare [0; 0; 0] 3) `Eq; - OUnit.assert_equal (Ext_list.length_compare [0; 0; 0] 1) `Gt; - OUnit.assert_equal (Ext_list.length_compare [0; 0; 0] 4) `Lt; - OUnit.assert_equal (Ext_list.length_compare [] (-1)) `Gt; - OUnit.assert_equal (Ext_list.length_compare [] 0) `Eq ); ( __LOC__ >:: fun _ -> OUnit.assert_bool __LOC__ (Ext_list.length_larger_than_n [1; 2] [1] 1); @@ -89,14 +62,4 @@ let suites = OUnit.assert_bool __LOC__ (Ext_list.length_ge [1; 2; 3] 3); OUnit.assert_bool __LOC__ (Ext_list.length_ge [] 0); OUnit.assert_bool __LOC__ (not (Ext_list.length_ge [] 1)) ); - ( __LOC__ >:: fun _ -> - let ( =~ ) = OUnit.assert_equal in - - let f p x = Ext_list.exclude_with_val x p in - f (fun x -> x = 1) [1; 2; 3] =~ Some [2; 3]; - f (fun x -> x = 4) [1; 2; 3] =~ None; - f (fun x -> x = 2) [1; 2; 3; 2] =~ Some [1; 3]; - f (fun x -> x = 2) [1; 2; 2; 3; 2] =~ Some [1; 3]; - f (fun x -> x = 2) [2; 2; 2] =~ Some []; - f (fun x -> x = 3) [2; 2; 2] =~ None ); ]