Merge flambda-backend changes

Author: riaqn

Makefile.common-jst

@@ -51,13 +51,15 @@ endef
 .DEFAULT_GOAL := compiler
 .PHONY: boot-compiler boot-runtest runtime-stdlib compiler runtest
 
+boot_targets = \
+  $(boot_ocamlc) \
+  $(boot_ocamlopt) \
+  $(boot_ocamlmklib) \
+  $(boot_ocamldep) \
+  $(boot_ocamlobjinfo)
+
 boot-compiler: _build/_bootinstall
-	$(dune) build $(ws_boot) $(coverage_dune_flags) \
-	  $(boot_ocamlc) \
-	  $(boot_ocamlopt) \
-	  $(boot_ocamlmklib) \
-	  $(boot_ocamldep) \
-          $(boot_ocamlobjinfo)
+	$(dune) build $(ws_boot) $(coverage_dune_flags) $(boot_targets)
 
 boot-runtest: boot-compiler
 	$(dune) runtest $(ws_boot) $(coverage_dune_flags) --force
@@ -139,6 +141,13 @@ _install: compiler
 	$(cpl) -R _build/install/runtime_stdlib/lib/ocaml_runtime_stdlib/* _install/lib/ocaml/
 	rm -f _install/lib/ocaml/{META,dune-package,Makefile.config,dynlink.cmxa}
 	$(cpl) -R _build/install/main/lib/ocaml/* _install/lib/ocaml/
+	if [ "x$(legacy_layout)" == "xyes" ] ; \
+	then \
+          for libdir in unix str dynlink bigarray ; do \
+	    mv _install/lib/ocaml/$${libdir}/* _install/lib/ocaml/ ; \
+            rmdir _install/lib/ocaml/$${libdir} ; \
+          done \
+	fi
 	rm -f _install/lib/ocaml/{META,dune-package}
 	rm -f _install/lib/ocaml/compiler-libs/*.cmo
 	$(cpl) {_build/install/main,_install}/lib/ocaml/compiler-libs/topstart.cmo
@@ -202,11 +211,12 @@ install_for_test: _install
 	 done; \
 	 ln -s . lex; ln -s . yacc; \
 	 ln -s _install/lib/ocaml/compiler-libs compilerlibs; \
-	 mkdir -p otherlibs/{unix,dynlink/native,str}; \
+	 mkdir -p otherlibs/{unix,dynlink/native,str,bigarray}; \
 	 ln -s ../stdlib/threads otherlibs/systhreads; \
-	 $(cpl) stdlib/{lib,}unix* otherlibs/unix; \
-	 $(cpl) stdlib/dynlink* otherlibs/dynlink; \
-	 $(cpl) stdlib/{lib,}str* otherlibs/str; \
+         $(cpl) stdlib/unix/{lib,}unix* otherlibs/unix; \
+         $(cpl) stdlib/dynlink/dynlink* otherlibs/dynlink; \
+         $(cpl) stdlib/str/{lib,}str* otherlibs/str; \
+         ${cpl} stdlib/bigarray/bigarray* otherlibs/bigarray; \
 	 ln -s ../_build/main/$(ocamldir)/toplevel/byte/.ocamltoplevel.objs/byte toplevel; \
 	)
 
@@ -218,6 +228,7 @@ install_for_test: _install
 	cp $(main_build)/$(ocamldir)/.ocamlcommon.objs/byte/*.cmo _runtest/utils
 	rm -f _runtest/utils/{topdirs,opttopdirs}.cmi
 	cp _install/lib/ocaml/*.{cmi,cma,a,cmxa} _runtest/utils
+	cp _install/lib/ocaml/{unix,str,dynlink,bigarray}/*.{cmi,cma,a,cmxa} _runtest/utils
 	cp $(main_build)/$(ocamldir)/.ocamlcommon.objs/native/config.o _runtest/utils
 	# Needed for tests/warnings
 	cp $(ocamldir)/utils/warnings.ml _runtest/utils
@@ -302,4 +313,4 @@ promote-one: install_for_test
 # This target is like a polling version of upstream "make ocamlopt"
 .PHONY: hacking
 hacking: _build/_bootinstall
-	$(dune) build $(ws_boot) -w $(boot_ocamlopt)
+	$(dune) build $(ws_boot) -w $(boot_targets)

Makefile.menhir

@@ -111,6 +111,9 @@ import-menhirLib:
 	@ cp \
            $(addprefix `$(MENHIR) --suggest-menhirLib`/menhirLib.,ml mli) \
            boot/menhir
+# Partial applications of the form Obj.magic f x in menhirLib cause an issue with locals,
+# so rewrite these to Obj.magic (f x)
+	@ sed -i 's/\b\(in\|then\|with\|else\)\b/@@@\1/g; s/Obj.magic \([a-z0-9_]\+\( [a-z0-9_]\+\)\+\)/Obj.magic (\1)/g;  s/@@@//g' boot/menhir/menhirLib.ml
 
 
 ## demote-menhir

asmcomp/afl_instrument.ml

@@ -56,19 +56,19 @@ let rec with_afl_logging b dbg =
 
 and instrument = function
   (* these cases add logging, as they may be targets of conditional branches *)
-  | Cifthenelse (cond, t_dbg, t, f_dbg, f, dbg) ->
+  | Cifthenelse (cond, t_dbg, t, f_dbg, f, dbg, kind) ->
      Cifthenelse (instrument cond, t_dbg, with_afl_logging t t_dbg,
-       f_dbg, with_afl_logging f f_dbg, dbg)
-  | Ctrywith (e, ex, handler, dbg) ->
-     Ctrywith (instrument e, ex, with_afl_logging handler dbg, dbg)
-  | Cswitch (e, cases, handlers, dbg) ->
+       f_dbg, with_afl_logging f f_dbg, dbg, kind)
+  | Ctrywith (e, ex, handler, dbg, value_kind) ->
+     Ctrywith (instrument e, ex, with_afl_logging handler dbg, dbg, value_kind)
+  | Cswitch (e, cases, handlers, dbg, value_kind) ->
      let handlers =
        Array.map (fun (handler, handler_dbg) ->
            let handler = with_afl_logging handler handler_dbg in
            handler, handler_dbg)
          handlers
      in
-     Cswitch (instrument e, cases, handlers, dbg)
+     Cswitch (instrument e, cases, handlers, dbg, value_kind)
 
   (* these cases add no logging, but instrument subexpressions *)
   | Clet (v, e, body) -> Clet (v, instrument e, instrument body)
@@ -80,12 +80,12 @@ and instrument = function
   | Ctuple es -> Ctuple (List.map instrument es)
   | Cop (op, es, dbg) -> Cop (op, List.map instrument es, dbg)
   | Csequence (e1, e2) -> Csequence (instrument e1, instrument e2)
-  | Ccatch (isrec, cases, body) ->
+  | Ccatch (isrec, cases, body, kind) ->
      let cases =
        List.map (fun (nfail, ids, e, dbg) -> nfail, ids, instrument e, dbg)
          cases
      in
-     Ccatch (isrec, cases, instrument body)
+     Ccatch (isrec, cases, instrument body, kind)
   | Cexit (ex, args) -> Cexit (ex, List.map instrument args)
   | Cregion e -> Cregion (instrument e)
   | Ctail e -> Ctail (instrument e)

asmcomp/asmlink.ml

@@ -273,7 +273,9 @@ let make_startup_file ~ppf_dump units_list ~crc_interfaces =
     List.flatten (List.map (fun (info,_,_) -> info.ui_defines) units_list) in
   compile_phrase (Cmm_helpers.entry_point name_list);
   let units = List.map (fun (info,_,_) -> info) units_list in
-  List.iter compile_phrase (Cmm_helpers.generic_functions false units);
+  List.iter compile_phrase
+    (Cmm_helpers.emit_preallocated_blocks []
+      (Cmm_helpers.generic_functions false units));
   Array.iteri
     (fun i name -> compile_phrase (Cmm_helpers.predef_exception i name))
     Runtimedef.builtin_exceptions;
@@ -309,7 +311,8 @@ let make_shared_startup_file ~ppf_dump units =
   Compilenv.reset shared_startup_comp_unit;
   Emit.begin_assembly ();
   List.iter compile_phrase
-    (Cmm_helpers.generic_functions true (List.map fst units));
+    (Cmm_helpers.emit_preallocated_blocks []
+      (Cmm_helpers.generic_functions true (List.map fst units)));
   compile_phrase (Cmm_helpers.plugin_header units);
   compile_phrase
     (Cmm_helpers.global_table (List.map (fun (ui,_) -> ui.ui_unit) units));

asmcomp/asmpackager.ml

@@ -111,36 +111,26 @@ let make_package_object ~ppf_dump members targetobj targetname coercion
     let compilation_unit = CU.create for_pack_prefix modname in
     let prefixname = Filename.remove_extension objtemp in
     let required_globals = CU.Set.empty in
-    let program, middle_end =
-      if Config.flambda then
-        let main_module_block_size, code =
-          Translmod.transl_package_flambda components coercion
-        in
-        let code = Simplif.simplify_lambda code in
-        let program =
-          { Lambda.
-            code;
-            main_module_block_size;
-            compilation_unit;
-            required_globals;
-          }
-        in
-        program, Flambda_middle_end.lambda_to_clambda
-      else
-        let main_module_block_size, code =
-          Translmod.transl_store_package components
-            compilation_unit coercion
-        in
-        let code = Simplif.simplify_lambda code in
-        let program =
-          { Lambda.
-            code;
-            main_module_block_size;
-            compilation_unit;
-            required_globals;
-          }
-        in
-        program, Closure_middle_end.lambda_to_clambda
+    let transl_style : Translmod.compilation_unit_style =
+      if Config.flambda || Config.flambda2 then Plain_block
+      else Set_individual_fields
+    in
+    let main_module_block_size, code =
+      Translmod.transl_package components compilation_unit coercion
+        ~style:transl_style
+    in
+    let code = Simplif.simplify_lambda code in
+    let program =
+      { Lambda.
+        code;
+        main_module_block_size;
+        compilation_unit;
+        required_globals;
+      }
+    in
+    let middle_end =
+      if Config.flambda then Flambda_middle_end.lambda_to_clambda
+      else Closure_middle_end.lambda_to_clambda
     in
     Asmgen.compile_implementation ~backend
       ~prefixname

asmcomp/cmm.ml

@@ -13,7 +13,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-type machtype_component =
+type machtype_component = Cmx_format.machtype_component =
   | Val
   | Addr
   | Int
@@ -173,6 +173,12 @@ and operation =
   | Copaque
   | Cbeginregion | Cendregion
 
+type value_kind =
+  | Vval of Lambda.value_kind (* Valid OCaml values *)
+  | Vint (* Untagged integers and off-heap pointers *)
+  | Vaddr (* Derived pointers *)
+  | Vfloat (* Unboxed floating-point numbers *)
+
 type expression =
     Cconst_int of int * Debuginfo.t
   | Cconst_natint of nativeint * Debuginfo.t
@@ -189,17 +195,17 @@ type expression =
   | Cop of operation * expression list * Debuginfo.t
   | Csequence of expression * expression
   | Cifthenelse of expression * Debuginfo.t * expression
-      * Debuginfo.t * expression * Debuginfo.t
+      * Debuginfo.t * expression * Debuginfo.t * value_kind
   | Cswitch of expression * int array * (expression * Debuginfo.t) array
-      * Debuginfo.t
+      * Debuginfo.t * value_kind
   | Ccatch of
       rec_flag
         * (int * (Backend_var.With_provenance.t * machtype) list
           * expression * Debuginfo.t) list
-        * expression
+        * expression * value_kind
   | Cexit of int * expression list
   | Ctrywith of expression * Backend_var.With_provenance.t * expression
-      * Debuginfo.t
+      * Debuginfo.t * value_kind
   | Cregion of expression
   | Ctail of expression
 
@@ -234,8 +240,8 @@ type phrase =
     Cfunction of fundecl
   | Cdata of data_item list
 
-let ccatch (i, ids, e1, e2, dbg) =
-  Ccatch(Nonrecursive, [i, ids, e2, dbg], e1)
+let ccatch (i, ids, e1, e2, dbg, kind) =
+  Ccatch(Nonrecursive, [i, ids, e2, dbg], e1, kind)
 
 let reset () =
   label_counter := init_label
@@ -244,21 +250,21 @@ let iter_shallow_tail f = function
   | Clet(_, _, body) | Cphantom_let (_, _, body) | Clet_mut(_, _, _, body) ->
       f body;
       true
-  | Cifthenelse(_cond, _ifso_dbg, ifso, _ifnot_dbg, ifnot, _dbg) ->
+  | Cifthenelse(_cond, _ifso_dbg, ifso, _ifnot_dbg, ifnot, _dbg, _value_kind) ->
       f ifso;
       f ifnot;
       true
   | Csequence(_e1, e2) ->
       f e2;
       true
-  | Cswitch(_e, _tbl, el, _dbg') ->
+  | Cswitch(_e, _tbl, el, _dbg', _value_kind) ->
       Array.iter (fun (e, _dbg) -> f e) el;
       true
-  | Ccatch(_rec_flag, handlers, body) ->
+  | Ccatch(_rec_flag, handlers, body, _value_kind) ->
       List.iter (fun (_, _, h, _dbg) -> f h) handlers;
       f body;
       true
-  | Ctrywith(e1, _id, e2, _dbg) ->
+  | Ctrywith(e1, _id, e2, _dbg, _value_kind) ->
       f e1;
       f e2;
       true
@@ -280,30 +286,34 @@ let iter_shallow_tail f = function
   | Cop _ ->
       false
 
-let map_shallow_tail f = function
+let map_shallow_tail ?kind f = function
   | Clet(id, exp, body) ->
       Clet(id, exp, f body)
   | Clet_mut(id, kind, exp, body) ->
       Clet_mut(id, kind, exp, f body)
   | Cphantom_let(id, exp, body) ->
       Cphantom_let (id, exp, f body)
-  | Cifthenelse(cond, ifso_dbg, ifso, ifnot_dbg, ifnot, dbg) ->
+  | Cifthenelse(cond, ifso_dbg, ifso, ifnot_dbg, ifnot, dbg, kind_before) ->
       Cifthenelse
         (
           cond,
           ifso_dbg, f ifso,
           ifnot_dbg, f ifnot,
-          dbg
+          dbg,
+          Option.value kind ~default:kind_before
         )
   | Csequence(e1, e2) ->
       Csequence(e1, f e2)
-  | Cswitch(e, tbl, el, dbg') ->
-      Cswitch(e, tbl, Array.map (fun (e, dbg) -> f e, dbg) el, dbg')
-  | Ccatch(rec_flag, handlers, body) ->
+  | Cswitch(e, tbl, el, dbg', kind_before) ->
+      Cswitch(e, tbl, Array.map (fun (e, dbg) -> f e, dbg) el, dbg',
+              Option.value kind ~default:kind_before)
+  | Ccatch(rec_flag, handlers, body, kind_before) ->
       let map_h (n, ids, handler, dbg) = (n, ids, f handler, dbg) in
-      Ccatch(rec_flag, List.map map_h handlers, f body)
-  | Ctrywith(e1, id, e2, dbg) ->
-      Ctrywith(f e1, id, f e2, dbg)
+      Ccatch(rec_flag, List.map map_h handlers, f body,
+             Option.value kind ~default:kind_before)
+  | Ctrywith(e1, id, e2, dbg, kind_before) ->
+      Ctrywith(f e1, id, f e2, dbg,
+              Option.value kind ~default:kind_before)
   | Cregion e ->
       Cregion(f e)
   | Ctail e ->
@@ -319,7 +329,7 @@ let map_shallow_tail f = function
   | Ctuple _
   | Cop _ as cmm -> cmm
 
-let map_tail f =
+let map_tail ?kind f =
   let rec loop = function
     | Cconst_int _
     | Cconst_natint _
@@ -330,7 +340,7 @@ let map_tail f =
     | Ctuple _
     | Cop _ as c ->
         f c
-    | cmm -> map_shallow_tail loop cmm
+    | cmm -> map_shallow_tail ?kind loop cmm
   in
   loop
 
@@ -349,16 +359,16 @@ let iter_shallow f = function
       List.iter f el
   | Csequence (e1, e2) ->
       f e1; f e2
-  | Cifthenelse(cond, _ifso_dbg, ifso, _ifnot_dbg, ifnot, _dbg) ->
+  | Cifthenelse(cond, _ifso_dbg, ifso, _ifnot_dbg, ifnot, _dbg, _value_kind) ->
       f cond; f ifso; f ifnot
-  | Cswitch (_e, _ia, ea, _dbg) ->
+  | Cswitch (_e, _ia, ea, _dbg, _value_kind) ->
       Array.iter (fun (e, _) -> f e) ea
-  | Ccatch (_rf, hl, body) ->
+  | Ccatch (_rf, hl, body, _value_kind) ->
       let iter_h (_n, _ids, handler, _dbg) = f handler in
       List.iter iter_h hl; f body
   | Cexit (_n, el) ->
       List.iter f el
-  | Ctrywith (e1, _id, e2, _dbg) ->
+  | Ctrywith (e1, _id, e2, _dbg, _value_kind) ->
       f e1; f e2
   | Cregion e ->
       f e
@@ -386,17 +396,17 @@ let map_shallow f = function
       Cop (op, List.map f el, dbg)
   | Csequence (e1, e2) ->
       Csequence (f e1, f e2)
-  | Cifthenelse(cond, ifso_dbg, ifso, ifnot_dbg, ifnot, dbg) ->
-      Cifthenelse(f cond, ifso_dbg, f ifso, ifnot_dbg, f ifnot, dbg)
-  | Cswitch (e, ia, ea, dbg) ->
-      Cswitch (e, ia, Array.map (fun (e, dbg) -> f e, dbg) ea, dbg)
-  | Ccatch (rf, hl, body) ->
+  | Cifthenelse(cond, ifso_dbg, ifso, ifnot_dbg, ifnot, dbg, kind) ->
+      Cifthenelse(f cond, ifso_dbg, f ifso, ifnot_dbg, f ifnot, dbg, kind)
+  | Cswitch (e, ia, ea, dbg, kind) ->
+      Cswitch (e, ia, Array.map (fun (e, dbg) -> f e, dbg) ea, dbg, kind)
+  | Ccatch (rf, hl, body, kind) ->
       let map_h (n, ids, handler, dbg) = (n, ids, f handler, dbg) in
-      Ccatch (rf, List.map map_h hl, f body)
+      Ccatch (rf, List.map map_h hl, f body, kind)
   | Cexit (n, el) ->
       Cexit (n, List.map f el)
-  | Ctrywith (e1, id, e2, dbg) ->
-      Ctrywith (f e1, id, f e2, dbg)
+  | Ctrywith (e1, id, e2, dbg, value_kind) ->
+      Ctrywith (f e1, id, f e2, dbg, value_kind)
   | Cregion e ->
       Cregion (f e)
   | Ctail e ->