Change compilation order of toplevel definitions. (#1649)

Control compilation order better.

This change applies to the compilation phase from typed tree to lambda code,
on the path used by the bytecode compiler.

    - Change transl_let (in translcore.ml) so that the body of a let
      construct and the bindindgs  can be evaluated in one order
      or the other.

    -  Enforce top to bottom order for (bytecode) compilation of toplevel
      definitions (in translmod.ml).

As a result, warnings from different toplevel definitions emitted
during this compilation phase should should appear by increasing location.
Furthermore, this was already the compilation order of toplevel definition
by the native code compiler. Thus, console output of both compiler now are closer
one to the other than before.

Also notice that the flambda compilers behave like the non-flambda bytecode compiler
as regards the compilation order of toplevel definitions.

Changes

@@ -128,6 +128,10 @@ Working version
 - GPR#1618: add the -dno-unique-ids and -dunique-ids compiler flags
   (Sébastien Hinderer, review by Leo White and Damien Doligez)
 
+- GPR#1649 change compilation order of toplevel definitions, so that some warnings
+  emitted by the bytecode compiler appear more in-order than before.
+  (Luc Maranget, advice and review by Damien Doligez)
+
 ### Code generation and optimizations:
 
 - GPR#1370: Fix code duplication in Cmmgen

bytecomp/translcore.ml

@@ -1209,12 +1209,18 @@ and transl_function loc untuplify_fn repr partial param cases =
        Matching.for_function loc repr (Lvar param)
          (transl_cases cases) partial)
 
-and transl_let rec_flag pat_expr_list body =
+(*
+  Notice: transl_let consumes (ie compiles) its pat_expr_list argument,
+  and returns a function that will take the body of the lambda-let construct.
+  This complication allows choosing any compilation order for the
+  bindings and body of let constructs.
+*)
+and transl_let rec_flag pat_expr_list =
   match rec_flag with
     Nonrecursive ->
       let rec transl = function
         [] ->
-          body
+          fun body -> body
       | {vb_pat=pat; vb_expr=expr; vb_attributes=attr; vb_loc} :: rem ->
           let lam = transl_exp expr in
           let lam =
@@ -1223,7 +1229,8 @@ and transl_let rec_flag pat_expr_list body =
           let lam =
             Translattribute.add_specialise_attribute lam vb_loc attr
           in
-          Matching.for_let pat.pat_loc lam pat (transl rem)
+          let mk_body = transl rem in
+          fun body -> Matching.for_let pat.pat_loc lam pat (mk_body body)
       in transl pat_expr_list
   | Recursive ->
       let idlist =
@@ -1244,7 +1251,8 @@ and transl_let rec_flag pat_expr_list body =
             vb_attributes
         in
         (id, lam) in
-      Lletrec(List.map2 transl_case pat_expr_list idlist, body)
+      let lam_bds = List.map2 transl_case pat_expr_list idlist in
+      fun body -> Lletrec(lam_bds, body)
 
 and transl_setinstvar loc self var expr =
   Lprim(Psetfield_computed (maybe_pointer expr, Assignment),

bytecomp/translmod.ml

@@ -456,6 +456,9 @@ and transl_module cc rootpath mexp =
 and transl_struct loc fields cc rootpath str =
   transl_structure loc fields cc rootpath str.str_final_env str.str_items
 
+(* The function  transl_structure is called by  the bytecode compiler.
+   Some effort is made to compile in top to bottom order, in order to display
+   warning by increasing locations. *)
 and transl_structure loc fields cc rootpath final_env = function
     [] ->
       let body, size =
@@ -512,11 +515,14 @@ and transl_structure loc fields cc rootpath final_env = function
           in
           Lsequence(transl_exp expr, body), size
       | Tstr_value(rec_flag, pat_expr_list) ->
+          (* Translate bindings first *)
+          let mk_lam_let =  transl_let rec_flag pat_expr_list in
           let ext_fields = rev_let_bound_idents pat_expr_list @ fields in
+          (* Then, translate remainder of struct *)
           let body, size =
             transl_structure loc ext_fields cc rootpath final_env rem
           in
-          transl_let rec_flag pat_expr_list body, size
+          mk_lam_let body, size
       | Tstr_primitive descr ->
           record_primitive descr.val_val;
           transl_structure loc fields cc rootpath final_env rem
@@ -540,9 +546,7 @@ and transl_structure loc fields cc rootpath final_env = function
           size
       | Tstr_module mb ->
           let id = mb.mb_id in
-          let body, size =
-            transl_structure loc (id :: fields) cc rootpath final_env rem
-          in
+          (* Translate module first *)
           let module_body =
             transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr
           in
@@ -550,6 +554,10 @@ and transl_structure loc fields cc rootpath final_env = function
             Translattribute.add_inline_attribute module_body mb.mb_loc
                                                  mb.mb_attributes
           in
+          (* Translate remainder second *)
+          let body, size =
+            transl_structure loc (id :: fields) cc rootpath final_env rem
+          in
           let module_body =
             Levent (module_body, {
               lev_loc = mb.mb_loc;

testsuite/tests/warnings/w47_inline.reference

@@ -1,15 +1,15 @@
-File "w47_inline.ml", line 13, characters 15-22:
-Warning 47: illegal payload for attribute 'inlined'.
-It must be either empty, 'always' or 'never'
-File "w47_inline.ml", line 8, characters 23-29:
-Warning 47: illegal payload for attribute 'inline'.
-It must be either empty, 'always' or 'never'
-File "w47_inline.ml", line 7, characters 23-29:
+File "w47_inline.ml", line 5, characters 23-29:
 Warning 47: illegal payload for attribute 'inline'.
 It must be either empty, 'always' or 'never'
 File "w47_inline.ml", line 6, characters 23-29:
 Warning 47: illegal payload for attribute 'inline'.
 It must be either empty, 'always' or 'never'
-File "w47_inline.ml", line 5, characters 23-29:
+File "w47_inline.ml", line 7, characters 23-29:
 Warning 47: illegal payload for attribute 'inline'.
 It must be either empty, 'always' or 'never'
+File "w47_inline.ml", line 8, characters 23-29:
+Warning 47: illegal payload for attribute 'inline'.
+It must be either empty, 'always' or 'never'
+File "w47_inline.ml", line 13, characters 15-22:
+Warning 47: illegal payload for attribute 'inlined'.
+It must be either empty, 'always' or 'never'

testsuite/tests/warnings/w53.reference

@@ -1,26 +1,26 @@
 File "w53.ml", line 2, characters 4-5:
 Warning 32: unused value h.
-File "w53.ml", line 31, characters 17-29:
+File "w53.ml", line 2, characters 14-20:
+Warning 53: the "inline" attribute cannot appear in this context
+File "w53.ml", line 3, characters 14-26:
 Warning 53: the "ocaml.inline" attribute cannot appear in this context
-File "w53.ml", line 30, characters 16-22:
-Warning 53: the "inline" attribute cannot appear in this context
-File "w53.ml", line 24, characters 0-39:
-Warning 53: the "inline" attribute cannot appear in this context
-File "w53.ml", line 23, characters 0-32:
-Warning 53: the "inline" attribute cannot appear in this context
-File "w53.ml", line 15, characters 16-24:
-Warning 53: the "tailcall" attribute cannot appear in this context
-File "w53.ml", line 12, characters 14-28:
-Warning 53: the "ocaml.tailcall" attribute cannot appear in this context
-File "w53.ml", line 11, characters 14-22:
-Warning 53: the "tailcall" attribute cannot appear in this context
-File "w53.ml", line 9, characters 16-23:
+File "w53.ml", line 5, characters 14-21:
 Warning 53: the "inlined" attribute cannot appear in this context
 File "w53.ml", line 6, characters 14-27:
 Warning 53: the "ocaml.inlined" attribute cannot appear in this context
-File "w53.ml", line 5, characters 14-21:
+File "w53.ml", line 9, characters 16-23:
 Warning 53: the "inlined" attribute cannot appear in this context
-File "w53.ml", line 3, characters 14-26:
-Warning 53: the "ocaml.inline" attribute cannot appear in this context
-File "w53.ml", line 2, characters 14-20:
+File "w53.ml", line 11, characters 14-22:
+Warning 53: the "tailcall" attribute cannot appear in this context
+File "w53.ml", line 12, characters 14-28:
+Warning 53: the "ocaml.tailcall" attribute cannot appear in this context
+File "w53.ml", line 15, characters 16-24:
+Warning 53: the "tailcall" attribute cannot appear in this context
+File "w53.ml", line 23, characters 0-32:
 Warning 53: the "inline" attribute cannot appear in this context
+File "w53.ml", line 24, characters 0-39:
+Warning 53: the "inline" attribute cannot appear in this context
+File "w53.ml", line 30, characters 16-22:
+Warning 53: the "inline" attribute cannot appear in this context
+File "w53.ml", line 31, characters 17-29:
+Warning 53: the "ocaml.inline" attribute cannot appear in this context

testsuite/tests/warnings/w54.reference

@@ -1,8 +1,8 @@
-File "w54.ml", line 9, characters 0-43:
-Warning 54: the "inline" attribute is used more than once on this expression
-File "w54.ml", line 5, characters 26-39:
-Warning 54: the "ocaml.inlined" attribute is used more than once on this expression
-File "w54.ml", line 3, characters 51-63:
-Warning 54: the "ocaml.inline" attribute is used more than once on this expression
 File "w54.ml", line 2, characters 33-39:
 Warning 54: the "inline" attribute is used more than once on this expression
+File "w54.ml", line 3, characters 51-63:
+Warning 54: the "ocaml.inline" attribute is used more than once on this expression
+File "w54.ml", line 5, characters 26-39:
+Warning 54: the "ocaml.inlined" attribute is used more than once on this expression
+File "w54.ml", line 9, characters 0-43:
+Warning 54: the "inline" attribute is used more than once on this expression