Remove Lev_module_definition from lambda (#135)

Author: ncik-roberts

bytecomp/bytegen.ml

@@ -1014,8 +1014,6 @@ let rec comp_expr env exp sz cont =
             let cont1 = add_event ev cont in
             comp_expr env lam sz cont1
           end
-      | Lev_module_definition _ ->
-          comp_expr env lam sz cont
       end
   | Lifused (_, exp) ->
       comp_expr env exp sz cont

lambda/lambda.ml

@@ -533,7 +533,6 @@ and lambda_event_kind =
   | Lev_after of Types.type_expr
   | Lev_function
   | Lev_pseudo
-  | Lev_module_definition of Ident.t
 
 type program =
   { compilation_unit : Compilation_unit.t;

lambda/lambda.mli

@@ -447,7 +447,6 @@ and lambda_event_kind =
   | Lev_after of Types.type_expr
   | Lev_function
   | Lev_pseudo
-  | Lev_module_definition of Ident.t
 
 type program =
   { compilation_unit : Compilation_unit.t;

lambda/printlambda.ml

@@ -786,8 +786,6 @@ let rec lam ppf = function
        | Lev_after _  -> "after"
        | Lev_function -> "funct-body"
        | Lev_pseudo -> "pseudo"
-       | Lev_module_definition ident ->
-         Format.asprintf "module-defn(%a)" Ident.print ident
       in
       (* -dno-locations also hides the placement of debug events;
          this is good for the readability of the resulting output (usually

lambda/translcore.ml

@@ -715,16 +715,10 @@ and transl_exp0 ~in_new_scope ~scopes e =
       let lam = !transl_module ~scopes Tcoerce_none None modl in
       Lsequence(Lprim(Pignore, [lam], of_location ~scopes loc.loc),
                 transl_exp ~scopes body)
-  | Texp_letmodule(Some id, loc, Mp_present, modl, body) ->
+  | Texp_letmodule(Some id, _loc, Mp_present, modl, body) ->
       let defining_expr =
         let mod_scopes = enter_module_definition ~scopes id in
-        let lam = !transl_module ~scopes:mod_scopes Tcoerce_none None modl in
-        Levent (lam, {
-          lev_loc = of_location ~scopes loc.loc;
-          lev_kind = Lev_module_definition id;
-          lev_repr = None;
-          lev_env = Env.empty;
-        })
+        !transl_module ~scopes:mod_scopes Tcoerce_none None modl
       in
       Llet(Strict, Lambda.layout_module, id, defining_expr, transl_exp ~scopes body)
   | Texp_letmodule(_, _, Mp_absent, _, body) ->

lambda/translmod.ml

@@ -457,15 +457,15 @@ let compile_recmodule ~scopes compile_rhs bindings cont =
   eval_rec_bindings
     (reorder_rec_bindings
        (List.map
-          (fun {mb_id=id; mb_name; mb_expr=modl; mb_loc=loc; _} ->
+          (fun {mb_id=id; mb_name; mb_expr=modl; _} ->
              let id_or_ignore_loc, shape =
                match id with
                | None ->
                  let loc = of_location ~scopes mb_name.loc in
                  Ignore_loc loc, Result.Error Unnamed
                | Some id -> Id id, init_shape id modl
              in
-             (id_or_ignore_loc, modl.mod_loc, shape, compile_rhs id modl loc))
+             (id_or_ignore_loc, modl.mod_loc, shape, compile_rhs id modl))
           bindings))
     cont
 
@@ -720,14 +720,6 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function
                                of_location ~scopes mb.mb_name.loc), body),
               size
           | Some id ->
-              let module_body =
-                Levent (module_body, {
-                  lev_loc = of_location ~scopes mb.mb_loc;
-                  lev_kind = Lev_module_definition id;
-                  lev_repr = None;
-                  lev_env = Env.empty;
-                })
-              in
               Llet(pure_module mb.mb_expr, Lambda.layout_module, id, module_body, body), size
           end
       | Tstr_module ({mb_presence=Mp_absent}) ->
@@ -741,21 +733,13 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function
             transl_structure ~scopes loc ext_fields cc rootpath final_env rem
           in
           let lam =
-            compile_recmodule ~scopes (fun id modl loc ->
+            compile_recmodule ~scopes (fun id modl ->
               match id with
               | None -> transl_module ~scopes Tcoerce_none None modl
               | Some id ->
-                  let module_body =
-                    transl_module
-                      ~scopes:(enter_module_definition ~scopes id)
-                      Tcoerce_none (field_path rootpath id) modl
-                  in
-                  Levent (module_body, {
-                    lev_loc = of_location ~scopes loc;
-                    lev_kind = Lev_module_definition id;
-                    lev_repr = None;
-                    lev_env = Env.empty;
-                  })
+                  transl_module
+                    ~scopes:(enter_module_definition ~scopes id)
+                    Tcoerce_none (field_path rootpath id) modl
             ) bindings body
           in
           lam, size
@@ -1238,7 +1222,7 @@ let transl_store_structure ~scopes glob map prims aliases str =
         | Tstr_recmodule bindings ->
             let ids = List.filter_map (fun mb -> mb.mb_id) bindings in
             compile_recmodule ~scopes
-              (fun id modl _loc ->
+              (fun id modl ->
                  Lambda.subst no_env_update subst
                    (match id with
                     | None ->
@@ -1638,7 +1622,7 @@ let transl_toplevel_item ~scopes item =
   | Tstr_recmodule bindings ->
       let idents = List.filter_map (fun mb -> mb.mb_id) bindings in
       compile_recmodule ~scopes
-        (fun id modl _loc ->
+        (fun id modl ->
            match id with
            | None ->
              transl_module ~scopes Tcoerce_none None modl

testsuite/tests/basic-modules/anonymous.ocamlc.reference

@@ -14,12 +14,10 @@
         (ignore
           (let (x =[(consts ()) (non_consts ([0: [int], [int]]))] [0: 4 2])
             (makeblock 0 x)))
-        (apply (field 1 (global CamlinternalMod!)) [0: [0]] A
-          (module-defn(A) Anonymous anonymous.ml(23):567-608 A))
+        (apply (field 1 (global CamlinternalMod!)) [0: [0]] A A)
         (apply (field 1 (global CamlinternalMod!)) [0: [0]] B
-          (module-defn(B) Anonymous anonymous.ml(33):703-773
-            (let (x =[(consts ()) (non_consts ([0: *, *]))] [0: "foo" "bar"])
-              (makeblock 0))))
+          (let (x =[(consts ()) (non_consts ([0: *, *]))] [0: "foo" "bar"])
+            (makeblock 0)))
         (let
           (f = (function {nlocal = 0} param : int 0) s = (makemutable 0 ""))
           (seq

testsuite/tests/basic-modules/anonymous.ocamlopt.flambda.reference

@@ -13,12 +13,10 @@
       (ignore
         (let (x =[(consts ()) (non_consts ([0: [int], [int]]))] [0: 4 2])
           (makeblock 0 x)))
-      (apply (field 1 (global CamlinternalMod!)) [0: [0]] A
-        (module-defn(A) Anonymous anonymous.ml(23):567-608 A))
+      (apply (field 1 (global CamlinternalMod!)) [0: [0]] A A)
       (apply (field 1 (global CamlinternalMod!)) [0: [0]] B
-        (module-defn(B) Anonymous anonymous.ml(33):703-773
-          (let (x =[(consts ()) (non_consts ([0: *, *]))] [0: "foo" "bar"])
-            (makeblock 0))))
+        (let (x =[(consts ()) (non_consts ([0: *, *]))] [0: "foo" "bar"])
+          (makeblock 0)))
       (let (f = (function {nlocal = 0} param : int 0) s = (makemutable 0 ""))
         (seq
           (ignore

testsuite/tests/functors/functors.compilers.reference

@@ -1,66 +1,53 @@
 (setglobal Functors!
   (let
     (O =
-       (module-defn(O) Functors functors.ml(12):184-279
-         (function {nlocal = 0} X is_a_functor always_inline never_loop
-           (let
-             (cow =
-                (function {nlocal = 0} x[int] : int (apply (field 0 X) x))
-              sheep =
-                (function {nlocal = 0} x[int] : int (+ 1 (apply cow x))))
-             (makeblock 0 cow sheep))))
+       (function {nlocal = 0} X is_a_functor always_inline never_loop
+         (let
+           (cow = (function {nlocal = 0} x[int] : int (apply (field 0 X) x))
+            sheep = (function {nlocal = 0} x[int] : int (+ 1 (apply cow x))))
+           (makeblock 0 cow sheep)))
      F =
-       (module-defn(F) Functors functors.ml(17):281-392
-         (function {nlocal = 0} X Y is_a_functor always_inline never_loop
-           (let
-             (cow =
-                (function {nlocal = 0} x[int] : int
-                  (apply (field 0 Y) (apply (field 0 X) x)))
-              sheep =
-                (function {nlocal = 0} x[int] : int (+ 1 (apply cow x))))
-             (makeblock 0 cow sheep))))
+       (function {nlocal = 0} X Y is_a_functor always_inline never_loop
+         (let
+           (cow =
+              (function {nlocal = 0} x[int] : int
+                (apply (field 0 Y) (apply (field 0 X) x)))
+            sheep = (function {nlocal = 0} x[int] : int (+ 1 (apply cow x))))
+           (makeblock 0 cow sheep)))
      F1 =
-       (module-defn(F1) Functors functors.ml(31):516-632
-         (function {nlocal = 0} X Y is_a_functor always_inline never_loop
-           (let
-             (cow =
-                (function {nlocal = 0} x[int] : int
-                  (apply (field 0 Y) (apply (field 0 X) x)))
-              sheep =
-                (function {nlocal = 0} x[int] : int (+ 1 (apply cow x))))
-             (makeblock 0 sheep))))
+       (function {nlocal = 0} X Y is_a_functor always_inline never_loop
+         (let
+           (cow =
+              (function {nlocal = 0} x[int] : int
+                (apply (field 0 Y) (apply (field 0 X) x)))
+            sheep = (function {nlocal = 0} x[int] : int (+ 1 (apply cow x))))
+           (makeblock 0 sheep)))
      F2 =
-       (module-defn(F2) Functors functors.ml(36):634-784
-         (function {nlocal = 0} X Y is_a_functor always_inline never_loop
-           (let
-             (X =a (makeblock 0 (field 1 X))
-              Y =a (makeblock 0 (field 1 Y))
-              cow =
-                (function {nlocal = 0} x[int] : int
-                  (apply (field 0 Y) (apply (field 0 X) x)))
-              sheep =
-                (function {nlocal = 0} x[int] : int (+ 1 (apply cow x))))
-             (makeblock 0 sheep))))
-     M =
-       (module-defn(M) Functors functors.ml(41):786-970
+       (function {nlocal = 0} X Y is_a_functor always_inline never_loop
          (let
-           (F =
-              (module-defn(F) Functors.M functors.ml(44):849-966
-                (function {nlocal = 0} X Y is_a_functor always_inline
-                  never_loop
-                  (let
-                    (cow =
-                       (function {nlocal = 0} x[int] : int
-                         (apply (field 0 Y) (apply (field 0 X) x)))
-                     sheep =
-                       (function {nlocal = 0} x[int] : int
-                         (+ 1 (apply cow x))))
-                    (makeblock 0 cow sheep)))))
-           (makeblock 0
-             (function {nlocal = 0} funarg funarg is_a_functor stub
-               (let
-                 (let =
-                    (apply F (makeblock 0 (field 1 funarg))
-                      (makeblock 0 (field 1 funarg))))
-                 (makeblock 0 (field 1 let))))))))
+           (X =a (makeblock 0 (field 1 X))
+            Y =a (makeblock 0 (field 1 Y))
+            cow =
+              (function {nlocal = 0} x[int] : int
+                (apply (field 0 Y) (apply (field 0 X) x)))
+            sheep = (function {nlocal = 0} x[int] : int (+ 1 (apply cow x))))
+           (makeblock 0 sheep)))
+     M =
+       (let
+         (F =
+            (function {nlocal = 0} X Y is_a_functor always_inline never_loop
+              (let
+                (cow =
+                   (function {nlocal = 0} x[int] : int
+                     (apply (field 0 Y) (apply (field 0 X) x)))
+                 sheep =
+                   (function {nlocal = 0} x[int] : int (+ 1 (apply cow x))))
+                (makeblock 0 cow sheep))))
+         (makeblock 0
+           (function {nlocal = 0} funarg funarg is_a_functor stub
+             (let
+               (let =
+                  (apply F (makeblock 0 (field 1 funarg))
+                    (makeblock 0 (field 1 funarg))))
+               (makeblock 0 (field 1 let)))))))
     (makeblock 0 O F F1 F2 M)))