dce lambda

cristianoc · cristianoc · commit edcd92107997 · 2025-02-22T19:21:27.000+01:00
diff --git a/compiler/core/js_of_lam_block.ml b/compiler/core/js_of_lam_block.ml
@@ -33,7 +33,7 @@ let make_block mutable_flag (tag_info : Lam_tag_info.t) tag args =
 
 let field (field_info : Lam_compat.field_dbg_info) e (i : int32) =
   match field_info with
-  | Fld_tuple | Fld_array ->
+  | Fld_tuple ->
     E.array_index_by_int ?comment:(Lam_compat.str_of_field_info field_info) e i
   | Fld_poly_var_content -> E.poly_var_value_access e
   | Fld_poly_var_tag -> E.poly_var_tag_access e
diff --git a/compiler/core/lam_analysis.ml b/compiler/core/lam_analysis.ml
@@ -97,8 +97,7 @@ let rec no_side_effects (lam : Lam.t) : bool =
     (* TODO *)
     | Praw_js_code _
     (* byte swap *)
-    | Parraysets | Parraysetu | Poffsetref _ | Praise | Plazyforce | Psetfield _
-      ->
+    | Parraysets | Parraysetu | Poffsetref _ | Praise | Psetfield _ ->
       false)
   | Llet (_, _, arg, body) -> no_side_effects arg && no_side_effects body
   | Lswitch (_, _) -> false
diff --git a/compiler/core/lam_compat.ml b/compiler/core/lam_compat.ml
@@ -73,11 +73,10 @@ type field_dbg_info = Lambda.field_dbg_info =
   | Fld_extension
   | Fld_variant
   | Fld_cons
-  | Fld_array
 
 let str_of_field_info (x : field_dbg_info) : string option =
   match x with
-  | Fld_array | Fld_extension | Fld_variant | Fld_cons | Fld_poly_var_tag
+  | Fld_extension | Fld_variant | Fld_cons | Fld_poly_var_tag
   | Fld_poly_var_content | Fld_tuple ->
     None
   | Fld_record {name; _}
diff --git a/compiler/core/lam_compat.mli b/compiler/core/lam_compat.mli
@@ -37,7 +37,6 @@ type field_dbg_info = Lambda.field_dbg_info =
   | Fld_extension
   | Fld_variant
   | Fld_cons
-  | Fld_array
 
 val str_of_field_info : field_dbg_info -> string option
 
diff --git a/compiler/core/lam_compile_primitive.ml b/compiler/core/lam_compile_primitive.ml
@@ -605,13 +605,3 @@ let translate output_prefix loc (cxt : Lam_compile_context.t)
     match args with
     | [e1] -> E.runtime_call Primitive_modules.hash "hash_final_mix" args
     | _ -> assert false)
-  | Plazyforce
-  (* FIXME: we don't inline lazy force or at least
-     let buckle handle it
-  *)
-  (* let parm = Ident.create "prim" in
-     Lfunction(Curried, [parm],
-               Matching.inline_lazy_force (Lvar parm) Location.none)
-     It is inlined, this should not appear here *)
-    ->
-    assert false
diff --git a/compiler/core/lam_constant_convert.ml b/compiler/core/lam_constant_convert.ml
@@ -63,7 +63,6 @@ let rec convert_constant (const : Lambda.structured_constant) : Lam_constant.t =
       if Ext_string.is_valid_hash_number name then
         Const_int {i = Ext_string.hash_number_as_i32_exn name; comment = None}
       else Const_pointer name)
-  | Const_float_array s -> assert false
   | Const_immstring s -> Const_string {s; unicode = false}
   | Const_block (t, xs) -> (
     let tag = Lambda.tag_of_tag_info t in
diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml
@@ -229,7 +229,6 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t =
   | Pfield (id, info) -> prim ~primitive:(Pfield (id, info)) ~args loc
   | Psetfield (id, info) -> prim ~primitive:(Psetfield (id, info)) ~args loc
   | Pduprecord -> prim ~primitive:Pduprecord ~args loc
-  | Plazyforce -> prim ~primitive:Plazyforce ~args loc
   | Praise _ -> prim ~primitive:Praise ~args loc
   | Pobjcomp x -> prim ~primitive:(Pobjcomp x) ~args loc
   | Pobjorder -> prim ~primitive:Pobjorder ~args loc
@@ -248,8 +247,8 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t =
   | Paddint -> prim ~primitive:Paddint ~args loc
   | Psubint -> prim ~primitive:Psubint ~args loc
   | Pmulint -> prim ~primitive:Pmulint ~args loc
-  | Pdivint _is_safe (*FIXME*) -> prim ~primitive:Pdivint ~args loc
-  | Pmodint _is_safe (*FIXME*) -> prim ~primitive:Pmodint ~args loc
+  | Pdivint -> prim ~primitive:Pdivint ~args loc
+  | Pmodint -> prim ~primitive:Pmodint ~args loc
   | Pandint -> prim ~primitive:Pandint ~args loc
   | Porint -> prim ~primitive:Porint ~args loc
   | Pxorint -> prim ~primitive:Pxorint ~args loc
@@ -334,11 +333,6 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t =
   | Pjs_fn_make arity -> prim ~primitive:(Pjs_fn_make arity) ~args loc
   | Pjs_fn_make_unit -> prim ~primitive:Pjs_fn_make_unit ~args loc
   | Pjs_fn_method -> prim ~primitive:Pjs_fn_method ~args loc
-  | Pjs_unsafe_downgrade ->
-    let primitive : Lam_primitive.t =
-      Pjs_unsafe_downgrade {name = Ext_string.empty; setter = false}
-    in
-    prim ~primitive ~args loc
 
 (* Does not exist since we compile array in js backend unlike native backend *)
 
diff --git a/compiler/core/lam_primitive.ml b/compiler/core/lam_primitive.ml
@@ -40,8 +40,6 @@ type t =
   | Psetfield of int * Lam_compat.set_field_dbg_info
   (* could have field info at least for record *)
   | Pduprecord
-  (* Force lazy values *)
-  | Plazyforce
   (* External call *)
   | Pjs_call of {
       prim_name: string;
@@ -222,10 +220,10 @@ let eq_primitive_approx (lhs : t) (rhs : t) =
   | Pjs_apply | Pjs_runtime_apply | Pval_from_option | Pval_from_option_not_nest
   | Pundefined_to_opt | Pnull_to_opt | Pnull_undefined_to_opt | Pis_null
   | Pis_not_none | Psome | Psome_not_nest | Pis_undefined | Pis_null_undefined
-  | Pimport | Ptypeof | Pfn_arity | Plazyforce | Pis_poly_var_block | Pdebugger
-  | Pinit_mod | Pupdate_mod | Pduprecord | Pmakearray | Parraylength
-  | Parrayrefu | Parraysetu | Parrayrefs | Parraysets | Pjs_fn_make_unit
-  | Pjs_fn_method | Phash | Phash_mixstring | Phash_mixint | Phash_finalmix ->
+  | 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 | Phash_mixstring | Phash_mixint | Phash_finalmix ->
     rhs = lhs
   | Pcreate_extension a -> (
     match rhs with
diff --git a/compiler/core/lam_primitive.mli b/compiler/core/lam_primitive.mli
@@ -36,7 +36,6 @@ type t =
   | Pfield of int * Lambda.field_dbg_info
   | Psetfield of int * Lambda.set_field_dbg_info
   | Pduprecord
-  | Plazyforce
   | Pjs_call of {
       (* Location.t *  [loc] is passed down *)
       prim_name: string;
diff --git a/compiler/core/lam_print.ml b/compiler/core/lam_print.ml
@@ -82,7 +82,6 @@ let primitive ppf (prim : Lam_primitive.t) =
     let instr = "setfield " in
     fprintf ppf "%s%i" instr n
   | Pduprecord -> fprintf ppf "duprecord"
-  | Plazyforce -> fprintf ppf "force"
   | Pjs_call {prim_name} -> fprintf ppf "%s[js]" prim_name
   | Pjs_object_create _ -> fprintf ppf "[js.obj]"
   | Praise -> fprintf ppf "raise"
diff --git a/compiler/ml/env.ml b/compiler/ml/env.ml
@@ -57,7 +57,6 @@ let prefixed_sg = Hashtbl.create 113
 type error =
   | Illegal_renaming of string * string * string
   | Inconsistent_import of string * string * string
-  | Need_recursive_types of string * string
   | Missing_module of Location.t * Path.t * Path.t
   | Illegal_value_name of Location.t * string
 
@@ -147,8 +146,6 @@ type summary =
   | Env_extension of summary * Ident.t * extension_constructor
   | Env_module of summary * Ident.t * module_declaration
   | Env_modtype of summary * Ident.t * modtype_declaration
-  | Env_class of unit
-  | Env_cltype of unit
   | Env_open of summary * Path.t
   | Env_functor_arg of summary * Ident.t
   | Env_constraints of summary * type_declaration PathMap.t
@@ -732,8 +729,6 @@ let check_pers_struct name =
           " %a@ contains the compiled interface for @ %s when %s was expected"
           Location.print_filename filename ps_name name
       | Inconsistent_import _ -> assert false
-      | Need_recursive_types (name, _) ->
-        Format.sprintf "%s uses recursive types" name
       | Missing_module _ -> assert false
       | Illegal_value_name _ -> assert false
     in
@@ -2129,10 +2124,6 @@ let report_error ppf = function
       "@[<hov>The files %a@ and %a@ make inconsistent assumptions@ over \
        interface %s@]"
       Location.print_filename source1 Location.print_filename source2 name
-  | Need_recursive_types (import, export) ->
-    fprintf ppf
-      "@[<hov>Unit %s imports from %s, which uses recursive types.@ %s@]" export
-      import "The compilation flag -rectypes is required"
   | Missing_module (_, path1, path2) ->
     fprintf ppf "@[@[<hov>";
     if Path.same path1 path2 then
diff --git a/compiler/ml/env.mli b/compiler/ml/env.mli
@@ -27,8 +27,6 @@ type summary =
   | Env_extension of summary * Ident.t * extension_constructor
   | Env_module of summary * Ident.t * module_declaration
   | Env_modtype of summary * Ident.t * modtype_declaration
-  | Env_class of unit
-  | Env_cltype of unit
   | Env_open of summary * Path.t
   | Env_functor_arg of summary * Ident.t
   | Env_constraints of summary * type_declaration PathMap.t
@@ -239,7 +237,6 @@ val env_of_only_summary : (summary -> Subst.t -> t) -> t -> t
 type error =
   | Illegal_renaming of string * string * string
   | Inconsistent_import of string * string * string
-  | Need_recursive_types of string * string
   | Missing_module of Location.t * Path.t * Path.t
   | Illegal_value_name of Location.t * string
 
diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml
@@ -5,7 +5,6 @@ type type_clash_statement = FunctionCall
 type type_clash_context =
   | SetRecordField
   | ArrayValue
-  | FunctionReturn
   | MaybeUnwrapOption
   | IfCondition
   | IfReturn
@@ -53,8 +52,6 @@ let error_expected_type_text ppf type_clash_context =
     fprintf ppf
       "But it's being used with the @{<info>%s@} operator, which works on:"
       operator
-  | Some FunctionReturn ->
-    fprintf ppf "But this function is expecting you to return:"
   | Some StringConcat -> fprintf ppf "But string concatenation is expecting:"
   | _ -> fprintf ppf "But it's expected to have type:"
 
diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml
@@ -125,7 +125,6 @@ type field_dbg_info =
   | Fld_extension
   | Fld_variant
   | Fld_cons
-  | Fld_array
 
 let fld_record (lbl : label) =
   Fld_record
@@ -164,8 +163,6 @@ let fld_record_extension_set (lbl : label) =
 
 type immediate_or_pointer = Immediate | Pointer
 
-type is_safe = Safe | Unsafe
-
 type primitive =
   | Pidentity
   | Pignore
@@ -183,8 +180,6 @@ type primitive =
   | Pfield of int * field_dbg_info
   | Psetfield of int * set_field_dbg_info
   | Pduprecord
-  (* Force lazy values *)
-  | Plazyforce
   (* External call *)
   | Pccall of Primitive.description
   (* Exceptions *)
@@ -209,8 +204,8 @@ type primitive =
   | Paddint
   | Psubint
   | Pmulint
-  | Pdivint of is_safe
-  | Pmodint of is_safe
+  | Pdivint
+  | Pmodint
   | Pandint
   | Porint
   | Pxorint
@@ -310,13 +305,12 @@ type primitive =
   | Pjs_fn_make of int
   | Pjs_fn_make_unit
   | Pjs_fn_method
-  | Pjs_unsafe_downgrade
 
 and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge
 
 and value_kind = Pgenval
 
-and raise_kind = Raise_regular | Raise_reraise | Raise_notrace
+and raise_kind = Raise_regular | Raise_reraise
 
 type pointer_info =
   | Pt_constructor of {
@@ -334,7 +328,6 @@ type structured_constant =
   | Const_base of Asttypes.constant
   | Const_pointer of int * pointer_info
   | Const_block of tag_info * structured_constant list
-  | Const_float_array of string list
   | Const_immstring of string
   | Const_false
   | Const_true
@@ -507,16 +500,6 @@ let name_lambda strict arg fn =
     let id = Ident.create "let" in
     Llet (strict, Pgenval, id, arg, fn id)
 
-let name_lambda_list args fn =
-  let rec name_list names = function
-    | [] -> fn (List.rev names)
-    | (Lvar _ as arg) :: rem -> name_list (arg :: names) rem
-    | arg :: rem ->
-      let id = Ident.create "let" in
-      Llet (Strict, Pgenval, id, arg, name_list (Lvar id :: names) rem)
-  in
-  name_list [] args
-
 let iter_opt f = function
   | None -> ()
   | Some e -> f e
@@ -650,16 +633,6 @@ let transl_value_path ?(loc = Location.none) env path =
 
 let transl_extension_path = transl_value_path
 
-(* compatibility alias, deprecated in the .mli *)
-(* Compile a sequence of expressions *)
-
-let rec make_sequence fn = function
-  | [] -> lambda_unit
-  | [x] -> fn x
-  | x :: rem ->
-    let lam = fn x in
-    Lsequence (lam, make_sequence fn rem)
-
 (* Apply a substitution to a lambda-term.
    Assumes that the bound variables of the lambda-term do not
    belong to the domain of the substitution.
@@ -713,83 +686,16 @@ let subst_lambda s lam =
   in
   subst lam
 
-let rec map f lam =
-  let lam =
-    match lam with
-    | Lvar _ -> lam
-    | Lconst _ -> lam
-    | Lapply {ap_func; ap_args; ap_loc; ap_inlined} ->
-      Lapply
-        {
-          ap_func = map f ap_func;
-          ap_args = List.map (map f) ap_args;
-          ap_loc;
-          ap_inlined;
-        }
-    | Lfunction {params; body; attr; loc} ->
-      Lfunction {params; body = map f body; attr; loc}
-    | Llet (str, k, v, e1, e2) -> Llet (str, k, v, map f e1, map f e2)
-    | Lletrec (idel, e2) ->
-      Lletrec (List.map (fun (v, e) -> (v, map f e)) idel, map f e2)
-    | Lprim (p, el, loc) -> Lprim (p, List.map (map f) el, loc)
-    | Lswitch (e, sw, loc) ->
-      Lswitch
-        ( map f e,
-          {
-            sw_numconsts = sw.sw_numconsts;
-            sw_consts = List.map (fun (n, e) -> (n, map f e)) sw.sw_consts;
-            sw_numblocks = sw.sw_numblocks;
-            sw_blocks = List.map (fun (n, e) -> (n, map f e)) sw.sw_blocks;
-            sw_failaction = Misc.may_map (map f) sw.sw_failaction;
-            sw_names = sw.sw_names;
-          },
-          loc )
-    | Lstringswitch (e, sw, default, loc) ->
-      Lstringswitch
-        ( map f e,
-          List.map (fun (s, e) -> (s, map f e)) sw,
-          Misc.may_map (map f) default,
-          loc )
-    | Lstaticraise (i, args) -> Lstaticraise (i, List.map (map f) args)
-    | Lstaticcatch (body, id, handler) ->
-      Lstaticcatch (map f body, id, map f handler)
-    | Ltrywith (e1, v, e2) -> Ltrywith (map f e1, v, map f e2)
-    | Lifthenelse (e1, e2, e3) -> Lifthenelse (map f e1, map f e2, map f e3)
-    | Lsequence (e1, e2) -> Lsequence (map f e1, map f e2)
-    | Lwhile (e1, e2) -> Lwhile (map f e1, map f e2)
-    | Lfor (v, e1, e2, dir, e3) -> Lfor (v, map f e1, map f e2, dir, map f e3)
-    | Lassign (v, e) -> Lassign (v, map f e)
-    | Lsend (k, o, loc) -> Lsend (k, map f o, loc)
-  in
-  f lam
-
 (* To let-bind expressions to variables *)
 
 let bind str var exp body =
   match exp with
   | Lvar var' when Ident.same var var' -> body
   | _ -> Llet (str, Pgenval, var, exp, body)
 
-and commute_comparison = function
-  | Ceq -> Ceq
-  | Cneq -> Cneq
-  | Clt -> Cgt
-  | Cle -> Cge
-  | Cgt -> Clt
-  | Cge -> Cle
-
-and negate_comparison = function
-  | Ceq -> Cneq
-  | Cneq -> Ceq
-  | Clt -> Cge
-  | Cle -> Cgt
-  | Cgt -> Cle
-  | Cge -> Clt
-
 let raise_kind = function
   | Raise_regular -> "raise"
   | Raise_reraise -> "reraise"
-  | Raise_notrace -> "raise_notrace"
 
 let lam_of_loc kind loc =
   let loc_start = loc.Location.loc_start in
@@ -821,5 +727,3 @@ let lam_of_loc kind loc =
     in
     Lconst (Const_immstring loc)
   | Loc_LINE -> Lconst (Const_base (Const_int lnum))
-
-let reset () = raise_count := 0
diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli
diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml
diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml
diff --git a/compiler/ml/unified_ops.ml b/compiler/ml/unified_ops.ml
