Squashed 'ocaml/' changes from fe8a98b..ce88833

ce88833 Merge flambda-backend changes
b7506bb Revert "Cherry-pick of ocaml/ocaml 1eeb0e7fe595f5f9e1ea1edbdf785ff3b49feeeb (#12)"
183f688 Add config option to enable/disable stack allocation (#22)
ee7c849 If both the type and mode of an ident are wrong, complain about the type. (#19)
44bade0 Allow submoding during module inclusion checks (#21)
de3bec9 Add subtyping between arrows of related modes (#20)
93d8615 Enable the local keywords even when the local extension is off (#18)
81dd85e Documentation for local allocations
b05519f Fix a GC bug in local stack scanning (#17)
9f879de Fix __FUNCTION__ (#15)
a78975e Optimise "include struct ... end" in more cases (ocaml/ocaml#11134)
b819c66 Cherry-pick of ocaml/ocaml 1eeb0e7fe595f5f9e1ea1edbdf785ff3b49feeeb (#12)
bb363d4 Optimise the allocation of optional arguments (#11)

git-subtree-dir: ocaml
git-subtree-split: ce88833

Author: lpw25

Makefile.config.in

@@ -246,6 +246,7 @@ AWK=@AWK@
 STDLIB_MANPAGES=@stdlib_manpages@
 NAKED_POINTERS=@naked_pointers@
 INTEL_JCC_BUG_CFLAGS=@intel_jcc_bug_cflags@
+STACK_ALLOCATION=@stack_allocation@
 
 ### Native command to build ocamlrun.exe
 

asmcomp/afl_instrument.ml

@@ -46,12 +46,12 @@ let rec with_afl_logging b dbg =
       Clet(VP.create cur_pos, op Cxor [op (Cload (Word_int, Asttypes.Mutable))
         [afl_prev_loc dbg]; Cconst_int (cur_location, dbg)],
       Csequence(
-        op (Cstore(Byte_unsigned, Assignment))
+        op (Cstore(Byte_unsigned, Assignment alloc_heap))
           [op Cadda [Cvar afl_area; Cvar cur_pos];
             op Cadda [op (Cload (Byte_unsigned, Asttypes.Mutable))
                         [op Cadda [Cvar afl_area; Cvar cur_pos]];
                       Cconst_int (1, dbg)]],
-        op (Cstore(Word_int, Assignment))
+        op (Cstore(Word_int, Assignment alloc_heap))
           [afl_prev_loc dbg; Cconst_int (cur_location lsr 1, dbg)]))) in
   Csequence(instrumentation, instrument b)
 

asmcomp/cmm_helpers.ml

@@ -606,7 +606,8 @@ let unbox_float dbg =
 (* Complex *)
 
 let box_complex dbg c_re c_im =
-  Cop(Calloc Alloc_heap, [alloc_floatarray_header 2 dbg; c_re; c_im], dbg)
+  Cop(Calloc Lambda.alloc_heap,
+      [alloc_floatarray_header 2 dbg; c_re; c_im], dbg)
 
 let complex_re c dbg = Cop(Cload (Double, Immutable), [c], dbg)
 let complex_im c dbg = Cop(Cload (Double, Immutable),
@@ -760,16 +761,16 @@ let unboxed_float_array_ref arr ofs dbg =
   Cop(Cload (Double, Mutable),
     [array_indexing log2_size_float arr ofs dbg], dbg)
 let float_array_ref arr ofs dbg =
-  box_float dbg Alloc_heap (unboxed_float_array_ref arr ofs dbg)
+  box_float dbg Lambda.alloc_heap (unboxed_float_array_ref arr ofs dbg)
 
 let addr_array_set arr ofs newval dbg =
   Cop(Cextcall("caml_modify", typ_void, [], false),
       [array_indexing log2_size_addr arr ofs dbg; newval], dbg)
 let int_array_set arr ofs newval dbg =
-  Cop(Cstore (Word_int, Lambda.Assignment),
+  Cop(Cstore (Word_int, Lambda.Assignment Lambda.alloc_heap),
     [array_indexing log2_size_addr arr ofs dbg; newval], dbg)
 let float_array_set arr ofs newval dbg =
-  Cop(Cstore (Double, Lambda.Assignment),
+  Cop(Cstore (Double, Lambda.Assignment Lambda.alloc_heap),
     [array_indexing log2_size_float arr ofs dbg; newval], dbg)
 
 let addr_array_set_local arr ofs newval dbg =
@@ -828,7 +829,7 @@ let call_cached_method obj tag cache pos args (apos,mode) dbg =
 (* Allocation *)
 
 let make_alloc_generic ~mode set_fn dbg tag wordsize args =
-  if mode = Lambda.Alloc_local || wordsize <= Config.max_young_wosize then
+  if Lambda.is_local_mode mode || wordsize <= Config.max_young_wosize then
     let hdr =
       match mode with
       | Lambda.Alloc_local -> local_block_header tag wordsize
@@ -1003,13 +1004,14 @@ let bigarray_set unsafe elt_kind layout b args newval dbg =
         bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg)
           (fun addr ->
           Csequence(
-            Cop(Cstore (kind, Assignment), [addr; complex_re newv dbg], dbg),
-            Cop(Cstore (kind, Assignment),
+            Cop(Cstore (kind, Assignment Lambda.alloc_heap),
+                [addr; complex_re newv dbg], dbg),
+            Cop(Cstore (kind, Assignment Lambda.alloc_heap),
                 [Cop(Cadda, [addr; Cconst_int (sz, dbg)], dbg);
                  complex_im newv dbg],
                 dbg))))
     | _ ->
-        Cop(Cstore (bigarray_word_kind elt_kind, Assignment),
+        Cop(Cstore (bigarray_word_kind elt_kind, Assignment Lambda.alloc_heap),
             [bigarray_indexing unsafe elt_kind layout b args dbg; newval],
             dbg))
 
@@ -1162,7 +1164,7 @@ let unaligned_load_16 ptr idx dbg =
 let unaligned_set_16 ptr idx newval dbg =
   if Arch.allow_unaligned_access
   then
-    Cop(Cstore (Sixteen_unsigned, Assignment),
+    Cop(Cstore (Sixteen_unsigned, Assignment Lambda.alloc_heap),
       [add_int ptr idx dbg; newval], dbg)
   else
     let cconst_int i = Cconst_int (i, dbg) in
@@ -1173,8 +1175,8 @@ let unaligned_set_16 ptr idx newval dbg =
     let v2 = Cop(Cand, [newval; cconst_int 0xFF], dbg) in
     let b1, b2 = if Arch.big_endian then v1, v2 else v2, v1 in
     Csequence(
-        Cop(Cstore (Byte_unsigned, Assignment), [add_int ptr idx dbg; b1], dbg),
-        Cop(Cstore (Byte_unsigned, Assignment),
+        Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap), [add_int ptr idx dbg; b1], dbg),
+        Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap),
             [add_int (add_int ptr idx dbg) (cconst_int 1) dbg; b2], dbg))
 
 let unaligned_load_32 ptr idx dbg =
@@ -1205,7 +1207,7 @@ let unaligned_load_32 ptr idx dbg =
 let unaligned_set_32 ptr idx newval dbg =
   if Arch.allow_unaligned_access
   then
-    Cop(Cstore (Thirtytwo_unsigned, Assignment), [add_int ptr idx dbg; newval],
+    Cop(Cstore (Thirtytwo_unsigned, Assignment Lambda.alloc_heap), [add_int ptr idx dbg; newval],
       dbg)
   else
     let cconst_int i = Cconst_int (i, dbg) in
@@ -1225,16 +1227,16 @@ let unaligned_set_32 ptr idx newval dbg =
       else v4, v3, v2, v1 in
     Csequence(
         Csequence(
-            Cop(Cstore (Byte_unsigned, Assignment),
+            Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap),
                 [add_int ptr idx dbg; b1], dbg),
-            Cop(Cstore (Byte_unsigned, Assignment),
+            Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap),
                 [add_int (add_int ptr idx dbg) (cconst_int 1) dbg; b2],
                 dbg)),
         Csequence(
-            Cop(Cstore (Byte_unsigned, Assignment),
+            Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap),
                 [add_int (add_int ptr idx dbg) (cconst_int 2) dbg; b3],
                 dbg),
-            Cop(Cstore (Byte_unsigned, Assignment),
+            Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap),
                 [add_int (add_int ptr idx dbg) (cconst_int 3) dbg; b4],
                 dbg)))
 
@@ -1280,7 +1282,7 @@ let unaligned_load_64 ptr idx dbg =
 let unaligned_set_64 ptr idx newval dbg =
   assert(size_int = 8);
   if Arch.allow_unaligned_access
-  then Cop(Cstore (Word_int, Assignment), [add_int ptr idx dbg; newval], dbg)
+  then Cop(Cstore (Word_int, Assignment Lambda.alloc_heap), [add_int ptr idx dbg; newval], dbg)
   else
     let cconst_int i = Cconst_int (i, dbg) in
     let v1 =
@@ -1319,32 +1321,32 @@ let unaligned_set_64 ptr idx newval dbg =
     Csequence(
         Csequence(
             Csequence(
-                Cop(Cstore (Byte_unsigned, Assignment),
+                Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap),
                     [add_int ptr idx dbg; b1],
                     dbg),
-                Cop(Cstore (Byte_unsigned, Assignment),
+                Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap),
                     [add_int (add_int ptr idx dbg) (cconst_int 1) dbg; b2],
                     dbg)),
             Csequence(
-                Cop(Cstore (Byte_unsigned, Assignment),
+                Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap),
                     [add_int (add_int ptr idx dbg) (cconst_int 2) dbg; b3],
                     dbg),
-                Cop(Cstore (Byte_unsigned, Assignment),
+                Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap),
                     [add_int (add_int ptr idx dbg) (cconst_int 3) dbg; b4],
                     dbg))),
         Csequence(
             Csequence(
-                Cop(Cstore (Byte_unsigned, Assignment),
+                Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap),
                     [add_int (add_int ptr idx dbg) (cconst_int 4) dbg; b5],
                     dbg),
-                Cop(Cstore (Byte_unsigned, Assignment),
+                Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap),
                     [add_int (add_int ptr idx dbg) (cconst_int 5) dbg; b6],
                     dbg)),
             Csequence(
-                Cop(Cstore (Byte_unsigned, Assignment),
+                Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap),
                     [add_int (add_int ptr idx dbg) (cconst_int 6) dbg; b7],
                     dbg),
-                Cop(Cstore (Byte_unsigned, Assignment),
+                Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap),
                     [add_int (add_int ptr idx dbg) (cconst_int 7) dbg; b8],
                     dbg))))
 
@@ -1824,7 +1826,7 @@ let cache_public_method meths tag cache dbg =
     VP.create tagged,
       Cop(Caddi, [lsl_const (Cvar li) log2_size_addr dbg;
         cconst_int(1 - 3 * size_addr)], dbg),
-    Csequence(Cop (Cstore (Word_int, Assignment), [cache; Cvar tagged], dbg),
+    Csequence(Cop (Cstore (Word_int, Assignment Lambda.alloc_heap), [cache; Cvar tagged], dbg),
               Cvar tagged)))))
 
 let has_local_allocs e =
@@ -1896,9 +1898,12 @@ let apply_function_body (arity, (mode : Lambda.alloc_mode)) =
   (* In the slowpath, a region is necessary in case
      the initial applications do local allocations *)
   let region =
-    match mode with
-    | Alloc_heap -> Some (V.create_local "region")
-    | Alloc_local -> None
+    if not Config.stack_allocation then None
+    else begin
+      match mode with
+      | Alloc_heap -> Some (V.create_local "region")
+      | Alloc_local -> None
+    end
   in
   let rec app_fun clos n =
     if n = arity-1 then begin
@@ -2130,8 +2135,9 @@ let rec intermediate_curry_functions ~nlocal ~arity num =
     let name2 = if num = 0 then name1 else name1 ^ "_" ^ Int.to_string num in
     let arg = V.create_local "arg" and clos = V.create_local "clos" in
     let fun_dbg = placeholder_fun_dbg ~human_name:name2 in
-    let mode : Lambda.alloc_mode =
-      if num >= arity - nlocal then Alloc_local else Alloc_heap in
+    let mode =
+      if num >= arity - nlocal then Lambda.alloc_local else Lambda.alloc_heap
+    in
     let curried n : Clambda.arity = (Curried {nlocal=min nlocal n}, n) in
     Cfunction
      {fun_name = name2;
@@ -2214,7 +2220,7 @@ module ApplyFnSet =
 module AritySet =
   Set.Make (struct type t = Clambda.arity let compare = compare end)
 
-let default_apply = ApplyFnSet.of_list [2,Alloc_heap; 3,Alloc_heap]
+let default_apply = ApplyFnSet.of_list [2,Lambda.alloc_heap; 3,Lambda.alloc_heap]
   (* These apply funs are always present in the main program because
      the run-time system needs them (cf. runtime/<arch>.S) . *)
 
@@ -2260,7 +2266,7 @@ let negint arg dbg =
 let offsetref n arg dbg =
   return_unit dbg
     (bind "ref" arg (fun arg ->
-         Cop(Cstore (Word_int, Assignment),
+         Cop(Cstore (Word_int, Assignment Lambda.alloc_heap),
              [arg;
               add_const (Cop(Cload (Word_int, Mutable), [arg], dbg))
                 (n lsl 1) dbg],
@@ -2318,11 +2324,13 @@ let assignment_kind
     (ptr: Lambda.immediate_or_pointer)
     (init: Lambda.initialization_or_assignment) =
   match init, ptr with
-  | Assignment, Pointer -> Caml_modify
-  | Local_assignment, Pointer -> Caml_modify_local
+  | Assignment Alloc_heap, Pointer -> Caml_modify
+  | Assignment Alloc_local, Pointer ->
+    assert Config.stack_allocation;
+    Caml_modify_local
   | Heap_initialization, _ ->
      Misc.fatal_error "Cmm_helpers: Lambda.Heap_initialization unsupported"
-  | (Assignment | Local_assignment), Immediate
+  | (Assignment _), Immediate
   | Root_initialization, (Immediate | Pointer) -> Simple
 
 let setfield n ptr init arg1 arg2 dbg =
@@ -2505,7 +2513,7 @@ let arrayref_safe kind arg1 arg2 dbg =
                   (get_header_without_profinfo arr dbg) dbg; idx],
               int_array_ref arr idx dbg)))
       | Pfloatarray ->
-          box_float dbg Alloc_heap (
+          box_float dbg Lambda.alloc_heap (
             bind "index" arg2 (fun idx ->
             bind "arr" arg1 (fun arr ->
               Csequence(
@@ -2528,7 +2536,7 @@ let setfield_computed ptr init arg1 arg2 arg3 dbg =
       return_unit dbg (int_array_set arg1 arg2 arg3 dbg)
 
 let bytesset_unsafe arg1 arg2 arg3 dbg =
-      return_unit dbg (Cop(Cstore (Byte_unsigned, Assignment),
+      return_unit dbg (Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap),
                       [add_int arg1 (untag_int arg2 dbg) dbg;
                        ignore_high_bit_int (untag_int arg3 dbg)], dbg))
 
@@ -2539,7 +2547,7 @@ let bytesset_safe arg1 arg2 arg3 dbg =
        bind "str" arg1 (fun str ->
         Csequence(
           make_checkbound dbg [string_length str dbg; idx],
-          Cop(Cstore (Byte_unsigned, Assignment),
+          Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap),
               [add_int str idx dbg;
                ignore_high_bit_int newval],
               dbg))))))
@@ -2716,7 +2724,7 @@ let entry_point namelist =
   let cconst_int i = Cconst_int (i, dbg ()) in
   let cconst_symbol sym = Cconst_symbol (sym, dbg ()) in
   let incr_global_inited () =
-    Cop(Cstore (Word_int, Assignment),
+    Cop(Cstore (Word_int, Assignment Lambda.alloc_heap),
         [cconst_symbol "caml_globals_inited";
          Cop(Caddi, [Cop(Cload (Word_int, Mutable),
                        [cconst_symbol "caml_globals_inited"], dbg ());

asmcomp/cmmgen.ml

@@ -341,13 +341,13 @@ let is_unboxed_number_cmm ~strict cmm =
     | Cconst_symbol (s, _) ->
         begin match Cmmgen_state.structured_constant_of_sym s with
         | Some (Uconst_float _) ->
-            notify (Boxed (Boxed_float (Alloc_heap, Debuginfo.none), true))
+            notify (Boxed (Boxed_float (alloc_heap, Debuginfo.none), true))
         | Some (Uconst_nativeint _) ->
-            notify (Boxed (Boxed_integer (Pnativeint, Alloc_heap, Debuginfo.none), true))
+            notify (Boxed (Boxed_integer (Pnativeint, alloc_heap, Debuginfo.none), true))
         | Some (Uconst_int32 _) ->
-            notify (Boxed (Boxed_integer (Pint32, Alloc_heap, Debuginfo.none), true))
+            notify (Boxed (Boxed_integer (Pint32, alloc_heap, Debuginfo.none), true))
         | Some (Uconst_int64 _) ->
-            notify (Boxed (Boxed_integer (Pint64, Alloc_heap, Debuginfo.none), true))
+            notify (Boxed (Boxed_integer (Pint64, alloc_heap, Debuginfo.none), true))
         | _ ->
             notify No_unboxing
         end
@@ -494,7 +494,7 @@ let rec transl env e =
              state of [Translcore], we will in fact only get here with
              [Pfloatarray]s. *)
           assert (kind = kind');
-          transl_make_array dbg env kind Alloc_heap args
+          transl_make_array dbg env kind alloc_heap args
       | (Pduparray _, [arg]) ->
           let prim_obj_dup =
             Primitive.simple ~name:"caml_obj_dup" ~arity:1 ~alloc:true
@@ -510,11 +510,11 @@ let rec transl env e =
               (transl env arg1) (List.map (transl env) argl) dbg in
           begin match elt_kind with
           (* TODO: local allocation of bigarray elements *)
-            Pbigarray_float32 | Pbigarray_float64 -> box_float dbg Alloc_heap elt
+            Pbigarray_float32 | Pbigarray_float64 -> box_float dbg alloc_heap elt
           | Pbigarray_complex32 | Pbigarray_complex64 -> elt
-          | Pbigarray_int32 -> box_int dbg Pint32 Alloc_heap elt
-          | Pbigarray_int64 -> box_int dbg Pint64 Alloc_heap elt
-          | Pbigarray_native_int -> box_int dbg Pnativeint Alloc_heap elt
+          | Pbigarray_int32 -> box_int dbg Pint32 alloc_heap elt
+          | Pbigarray_int64 -> box_int dbg Pint64 alloc_heap elt
+          | Pbigarray_native_int -> box_int dbg Pnativeint alloc_heap elt
           | Pbigarray_caml_int -> tag_int elt dbg
           | Pbigarray_sint8 | Pbigarray_uint8
           | Pbigarray_sint16 | Pbigarray_uint16 -> tag_int elt dbg
@@ -760,7 +760,9 @@ and transl_make_array dbg env kind mode args =
       let prim =
         match (mode : Lambda.alloc_mode) with
         | Alloc_heap -> "caml_make_array"
-        | Alloc_local -> "caml_make_array_local"
+        | Alloc_local ->
+          assert Config.stack_allocation;
+          "caml_make_array_local"
       in
       Cop(Cextcall(prim, typ_val, [], true),
           [make_alloc ~mode dbg 0 (List.map (transl env) args)], dbg)
@@ -804,10 +806,10 @@ and transl_ccall env prim args dbg =
     match prim.prim_native_repr_res with
     | _, Same_as_ocaml_repr -> (typ_val, fun x -> x)
     (* TODO: Allow Alloc_local on suitably typed C stubs *)
-    | _, Unboxed_float -> (typ_float, box_float dbg Alloc_heap)
+    | _, Unboxed_float -> (typ_float, box_float dbg alloc_heap)
     | _, Unboxed_integer Pint64 when size_int = 4 ->
-        ([|Int; Int|], box_int dbg Pint64 Alloc_heap)
-    | _, Unboxed_integer bi -> (typ_int, box_int dbg bi Alloc_heap)
+        ([|Int; Int|], box_int dbg Pint64 alloc_heap)
+    | _, Unboxed_integer bi -> (typ_int, box_int dbg bi alloc_heap)
     | _, Untagged_int -> (typ_int, (fun i -> tag_int i dbg))
   in
   let typ_args, args = transl_args prim.prim_native_repr_args args in
@@ -1169,9 +1171,9 @@ and transl_let env str kind id exp transl_body =
        of allocation mode it may be possible to mark some Alloc_local *)
     match str, kind with
     | Mutable, Pfloatval ->
-        Boxed (Boxed_float (Alloc_heap, dbg), false)
+        Boxed (Boxed_float (alloc_heap, dbg), false)
     | Mutable, Pboxedintval bi ->
-        Boxed (Boxed_integer (bi, Alloc_heap, dbg), false)
+        Boxed (Boxed_integer (bi, alloc_heap, dbg), false)
     | _, (Pfloatval | Pboxedintval _) ->
         (* It would be safe to always unbox in this case, but
            we do it only if this indeed allows us to get rid of

asmcomp/comballoc.ml

@@ -37,7 +37,7 @@ let rec combine i allocstate =
       | Pending_alloc {reg; dbginfos; totalsz; mode = prev_mode}
           when (mode = prev_mode) &&
               ((totalsz + sz <= (Config.max_young_wosize + 1) * Arch.size_addr)
-               || mode = Lambda.Alloc_local) ->
+               || Lambda.is_local_mode mode) ->
           let (next, state) =
            combine i.next
              (Pending_alloc { reg = i.res.(0);

asmcomp/printcmm.ml

@@ -126,8 +126,8 @@ let operation d = function
       match init with
       | Lambda.Heap_initialization -> "(heap-init)"
       | Lambda.Root_initialization -> "(root-init)"
-      | Lambda.Assignment -> ""
-      | Local_assignment -> "(local)"
+      | Lambda.Assignment Alloc_heap -> ""
+      | Lambda.Assignment Alloc_local -> "(local)"
     in
     Printf.sprintf "store %s%s" (chunk c) init
   | Caddi -> "+"