Port oxcaml/oxcaml#493

Author: stedolan

asmcomp/cmm.ml

@@ -167,6 +167,7 @@ and operation =
   | Cprobe of { name: string; handler_code_sym: string; }
   | Cprobe_is_enabled of { name: string }
   | Copaque
+  | Cbeginregion | Cendregion
 
 type expression =
     Cconst_int of int * Debuginfo.t

asmcomp/cmm.mli

@@ -165,6 +165,7 @@ and operation =
   | Cprobe of { name: string; handler_code_sym: string; }
   | Cprobe_is_enabled of { name: string }
   | Copaque (* Sys.opaque_identity *)
+  | Cbeginregion | Cendregion
 
 (** Every basic block should have a corresponding [Debuginfo.t] for its
     beginning. *)

asmcomp/cmm_helpers.ml

@@ -762,7 +762,6 @@ let unboxed_float_array_ref arr ofs dbg =
 let float_array_ref arr ofs dbg =
   box_float dbg Alloc_heap (unboxed_float_array_ref arr ofs dbg)
 
-(* TODO support mutation of local arrays *)
 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)
@@ -773,6 +772,10 @@ let float_array_set arr ofs newval dbg =
   Cop(Cstore (Double, Lambda.Assignment),
     [array_indexing log2_size_float arr ofs dbg; newval], dbg)
 
+let addr_array_set_local arr ofs newval dbg =
+  Cop(Cextcall("caml_modify_local", typ_void, [], false),
+      [arr; untag_int ofs dbg; newval], dbg)
+
 (* String length *)
 
 (* Length of string block *)
@@ -844,14 +847,14 @@ let make_alloc_generic ~mode set_fn dbg tag wordsize args =
          fill_fields 1 args)
   end
 
-let make_alloc ?(mode=Lambda.Alloc_heap) dbg tag args =
+let make_alloc ~mode dbg tag args =
   let addr_array_init arr ofs newval dbg =
     Cop(Cextcall("caml_initialize", typ_void, [], false),
         [array_indexing log2_size_addr arr ofs dbg; newval], dbg)
   in
   make_alloc_generic ~mode addr_array_init dbg tag (List.length args) args
 
-let make_float_alloc ?(mode=Lambda.Alloc_heap) dbg tag args =
+let make_float_alloc ~mode dbg tag args =
   make_alloc_generic ~mode float_array_set dbg tag
                      (List.length args * size_float / size_addr) args
 
@@ -2489,9 +2492,7 @@ let setfield_computed ptr init arg1 arg2 arg3 dbg =
   | Caml_modify ->
       return_unit dbg (addr_array_set arg1 arg2 arg3 dbg)
   | Caml_modify_local ->
-      (* TODO: support this, if there are any uses.
-         (Currently, setfield_computed is only used by classes) *)
-      Misc.fatal_error "setfield_computed: local"
+      return_unit dbg (addr_array_set_local arg1 arg2 arg3 dbg)
   | Simple ->
       return_unit dbg (int_array_set arg1 arg2 arg3 dbg)
 

asmcomp/cmm_helpers.mli

@@ -247,6 +247,8 @@ val unboxed_float_array_ref :
 val float_array_ref : expression -> expression -> Debuginfo.t -> expression
 val addr_array_set :
   expression -> expression -> expression -> Debuginfo.t -> expression
+val addr_array_set_local :
+  expression -> expression -> expression -> Debuginfo.t -> expression
 val int_array_set :
   expression -> expression -> expression -> Debuginfo.t -> expression
 val float_array_set :
@@ -287,11 +289,11 @@ val call_cached_method :
 
 (** Allocate a block of regular values with the given tag *)
 val make_alloc :
-  ?mode:Lambda.alloc_mode -> Debuginfo.t -> int -> expression list -> expression
+  mode:Lambda.alloc_mode -> Debuginfo.t -> int -> expression list -> expression
 
 (** Allocate a block of unboxed floats with the given tag *)
 val make_float_alloc :
-  ?mode:Lambda.alloc_mode -> Debuginfo.t -> int -> expression list -> expression
+  mode:Lambda.alloc_mode -> Debuginfo.t -> int -> expression list -> expression
 
 (** Bounds checking *)
 

asmcomp/printcmm.ml

@@ -161,6 +161,8 @@ let operation d = function
     Printf.sprintf "probe[%s %s]" name handler_code_sym
   | Cprobe_is_enabled {name} -> Printf.sprintf "probe_is_enabled[%s]" name
   | Copaque -> "opaque"
+  | Cbeginregion -> "beginregion"
+  | Cendregion -> "endregion"
 
 let rec expr ppf = function
   | Cconst_int (n, _dbg) -> fprintf ppf "%i" n

asmcomp/selectgen.ml

@@ -109,6 +109,11 @@ let oper_result_type = function
   | Cprobe _ -> typ_void
   | Cprobe_is_enabled _ -> typ_int
   | Copaque -> typ_val
+  | Cbeginregion ->
+    (* This must not be typ_val; the begin-region operation returns a
+       naked pointer into the local allocation stack. *)
+    typ_int
+  | Cendregion -> typ_void
 
 (* Infer the size in bytes of the result of an expression whose evaluation
    may be deferred (cf. [emit_parts]). *)
@@ -349,6 +354,7 @@ method is_simple_expr = function
       | Capply _ | Cextcall _ | Calloc _ | Cstore _
       | Craise _ | Ccheckbound
       | Cprobe _ | Cprobe_is_enabled _ | Copaque -> false
+      | Cbeginregion | Cendregion -> false (* avoid reordering *)
         (* The remaining operations are simple if their args are *)
       | Cload _ | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi | Cand | Cor
       | Cxor | Clsl | Clsr | Casr | Ccmpi _ | Caddv | Cadda | Ccmpa _ | Cnegf
@@ -391,6 +397,7 @@ method effects_of exp =
       | Calloc Alloc_heap -> EC.none
       | Calloc Alloc_local -> EC.coeffect_only Coeffect.Arbitrary
       | Cstore _ -> EC.effect_only Effect.Arbitrary
+      | Cbeginregion | Cendregion -> EC.arbitrary
       | Craise _ | Ccheckbound -> EC.effect_only Effect.Raise
       | Cload (_, Asttypes.Immutable) -> EC.none
       | Cload (_, Asttypes.Mutable) -> EC.coeffect_only Coeffect.Read_mutable
@@ -519,6 +526,8 @@ method select_operation op args _dbg =
   | (Cprobe { name; handler_code_sym; }, _) ->
     Iprobe { name; handler_code_sym; }, args
   | (Cprobe_is_enabled {name}, _) -> Iprobe_is_enabled {name}, []
+  | (Cbeginregion, _) -> Ibeginregion, []
+  | (Cendregion, _) -> Iendregion, args
   | _ -> Misc.fatal_error "Selection.select_oper"
 
 method private select_arith_comm op = function