Remove various FIXMEs (#46)

  - runtime: Already_scanned optimisation is not supported
  - runtime: Backwards local pointers are not possible
  - lambda: make function with no cases fatal
  - typing, lambda: remove various already-fixed FIXMEs
  - lambda: remove / convert to TODO some primitives FIXMEs
  - typing, lambda: remove local lazy support
  - selectgen: allow region fusion across try

Author: stedolan

asmcomp/cmm_helpers.ml

@@ -760,7 +760,7 @@ 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)
 
-(* FIXME local arrays *)
+(* 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)
@@ -1396,8 +1396,8 @@ let int64_native_prim name arity ~alloc =
     ~native_repr_args:(make_args arity)
     ~native_repr_res:u64
 
-(* FIXME: On 32-bit, these will do heap allocations
-   even when local allocs are possible *)
+(* TODO: On 32-bit, these will do heap allocations even in situations
+   where local allocs are allowed *)
 let simplif_primitive_32bits :
   Clambda_primitives.primitive -> Clambda_primitives.primitive = function
     Pbintofint (Pint64,_) -> Pccall (default_prim "caml_int64_of_int")
@@ -2439,11 +2439,12 @@ type ternary_primitive =
 
 let setfield_computed ptr init arg1 arg2 arg3 dbg =
   match assignment_kind ptr init with
-  (* FIXME local *)
   | Caml_modify ->
       return_unit dbg (addr_array_set arg1 arg2 arg3 dbg)
   | Caml_modify_local ->
-      return_unit dbg (addr_array_set arg1 arg2 arg3 dbg)
+      (* TODO: support this, if there are any uses.
+         (Currently, setfield_computed is only used by classes) *)
+      Misc.fatal_error "setfield_computed: local"
   | Simple ->
       return_unit dbg (int_array_set arg1 arg2 arg3 dbg)
 

asmcomp/cmmgen.ml

@@ -501,7 +501,7 @@ let rec transl env e =
             bigarray_get unsafe elt_kind layout
               (transl env arg1) (List.map (transl env) argl) dbg in
           begin match elt_kind with
-          (* FIXME allow local allocs *)
+          (* TODO: local alloaction of bigarray elements *)
             Pbigarray_float32 | Pbigarray_float64 -> box_float dbg Alloc_heap elt
           | Pbigarray_complex32 | Pbigarray_complex64 -> elt
           | Pbigarray_int32 -> box_int dbg Pint32 Alloc_heap elt
@@ -790,11 +790,10 @@ and transl_ccall env prim args dbg =
   let typ_res, wrap_result =
     match prim.prim_native_repr_res with
     | _, Same_as_ocaml_repr -> (typ_val, fun x -> x)
-    (* FIXME allow Alloc_local *)
+    (* TODO: Allow Alloc_local on suitably typed C stubs *)
     | _, Unboxed_float -> (typ_float, box_float dbg Alloc_heap)
     | _, Unboxed_integer Pint64 when size_int = 4 ->
         ([|Int; Int|], box_int dbg Pint64 Alloc_heap)
-    (* FIXME: Allow Alloc_local on suitably typed C stubs? *)
     | _, Unboxed_integer bi -> (typ_int, box_int dbg bi Alloc_heap)
     | _, Untagged_int -> (typ_int, (fun i -> tag_int i dbg))
   in

asmcomp/selectgen.ml

@@ -849,8 +849,7 @@ method emit_expr (env:environment) exp =
           None
       end
   | Ctrywith(e1, v, e2, _dbg) ->
-      (* FIXME: region/trywith interaction? match with exception? *)
-      let (r1, s1) = self#emit_sequence env' e1 in
+      let (r1, s1) = self#emit_sequence env e1 in
       let rv = self#regs_for typ_val in
       let (r2, s2) = self#emit_sequence (env_add v rv env) e2 in
       let r = join env r1 s1 r2 s2 in
@@ -1173,7 +1172,6 @@ method emit_tail (env:environment) exp =
       self#insert env (Icatch(rec_flag, List.map aux handlers, s_body))
         [||] [||]
   | Ctrywith(e1, v, e2, _dbg) ->
-     (* FIXME regions *)
       let (opt_r1, s1) = self#emit_sequence env e1 in
       let rv = self#regs_for typ_val in
       let s2 = self#emit_tail_sequence (env_add v rv env) e2 in

lambda/matching.ml

@@ -1973,7 +1973,7 @@ let get_expr_args_record ~scopes head (arg, _mut) rem =
             Lprim (Pfield lbl.lbl_pos, [ arg ], loc)
         | Record_unboxed _ -> arg
         | Record_float ->
-           (* FIXME: could be Alloc_local sometimes *)
+           (* TODO: could optimise to Alloc_local sometimes *)
            Lprim (Pfloatfield (lbl.lbl_pos, Alloc_heap), [ arg ], loc)
         | Record_extension _ -> Lprim (Pfield (lbl.lbl_pos + 1), [ arg ], loc)
       in

lambda/simplif.ml

@@ -761,7 +761,7 @@ let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body
         (wrapper_body, (inner_id, inner_fun))
   in
   try
-    (* FIXME: this optimisation is disabled in the presence of local returns *)
+    (* TODO: enable this optimisation even in the presence of local returns *)
     begin match kind with
     | Curried {nlocal} when nlocal > 0 -> raise Exit
     | _ -> ()

lambda/translattribute.ml

@@ -101,7 +101,7 @@ let get_bool_from_exp exp =
       | _ -> Result.Error ())
 
 let parse_id_payload txt loc ~default ~empty cases payload =
-  let(*FIXME[@local]*) warn () =
+  let[@local] warn () =
     let ( %> ) f g x = g (f x) in
     let msg =
       cases

lambda/translclass.ml

@@ -730,7 +730,6 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag =
   in
   let new_ids_meths = ref [] in
   let no_env_update _ _ env = env in
-  (* FIXME *)
   let msubst arr = function
       Lfunction {kind = Curried _ as kind;
                  params = (self, Pgenval) :: args; body} ->

lambda/translcore.ml

@@ -601,6 +601,7 @@ and transl_exp0 ~in_new_scope ~scopes e =
       (* when e needs no computation (constants, identifiers, ...), we
          optimize the translation just as Lazy.lazy_from_val would
          do *)
+      assert (transl_value_mode e.exp_mode = Alloc_heap);
       begin match Typeopt.classify_lazy_argument e with
       | `Constant_or_function ->
         (* A constant expr (of type <> float if [Config.flat_float_array] is
@@ -611,7 +612,7 @@ and transl_exp0 ~in_new_scope ~scopes e =
              block will never be shortcutted since it points to a float
              and Config.flat_float_array is true. *)
          Lprim(Pmakeblock(Obj.forward_tag, Immutable, None,
-                          transl_value_mode e.exp_mode),
+                          Alloc_heap),
                 [transl_exp ~scopes e], of_location ~scopes e.exp_loc)
       | `Identifier `Forward_value ->
          (* CR-someday mshinwell: Consider adding a new primitive
@@ -622,25 +623,24 @@ and transl_exp0 ~in_new_scope ~scopes e =
             value may subsequently turn into an immediate... *)
          Lprim (Popaque,
                 [Lprim(Pmakeblock(Obj.forward_tag, Immutable, None,
-                                  transl_value_mode e.exp_mode),
+                                  Alloc_heap),
                        [transl_exp ~scopes e],
                        of_location ~scopes e.exp_loc)],
                 of_location ~scopes e.exp_loc)
       | `Identifier `Other ->
          transl_exp ~scopes e
       | `Other ->
          (* other cases compile to a lazy block holding a function *)
-         let mode = transl_value_mode e.exp_mode in (* FIXME test *)
          let fn = Lfunction {kind = Curried {nlocal=0};
                              params= [Ident.create_local "param", Pgenval];
                              return = Pgenval;
                              attr = default_function_attribute;
                              loc = of_location ~scopes e.exp_loc;
-                             mode;
+                             mode = Alloc_heap;
                              ret_mode = Alloc_heap;
                              body = transl_exp ~scopes e} in
           Lprim(Pmakeblock(Config.lazy_tag, Mutable, None,
-                           mode), [fn],
+                           Alloc_heap), [fn],
                 of_location ~scopes e.exp_loc)
       end
   | Texp_object (cs, meths) ->
@@ -940,8 +940,7 @@ and transl_function0
     let arg_mode, ret_mode, kind =
       match cases with
       | [] ->
-        (* With Camlp4, a pattern matching might be empty *)
-        Alloc_heap, Alloc_heap, Pgenval (* FIXME can this happen? *)
+        Misc.fatal_error "transl_function0: no cases"
       | {c_lhs=pat;c_rhs} :: other_cases ->
         (* All the patterns might not share the same types. We must take the
            union of the patterns types *)
@@ -1283,12 +1282,12 @@ and transl_letop ~scopes loc env let_ ands param case partial =
       event_function ~scopes case.c_rhs
         (function repr ->
            transl_curried_function ~scopes case.c_rhs.exp_loc return_kind
-             repr ~mode:Alloc_heap (*FIXME*) partial param [case])
+             repr ~mode:Alloc_heap partial param [case])
     in
     let attr = default_function_attribute in
     let loc = of_location ~scopes case.c_rhs.exp_loc in
     Lfunction{kind; params; return; body; attr; loc;
-              mode=Alloc_heap(*FIXME*); ret_mode (* FIXME *)}
+              mode=Alloc_heap; ret_mode}
   in
   Lapply{
     ap_loc = of_location ~scopes loc;

runtime/caml/stack.h

@@ -44,7 +44,7 @@
 #else
 #error "TARGET_power: wrong MODEL"
 #endif
-/* FIXME: Already_scanned optimisation not supported on this branch
+/* Already_scanned optimisation not supported on this branch
 #define Already_scanned(sp, retaddr) ((retaddr) & 1)
 #define Mask_already_scanned(retaddr) ((retaddr) & ~1)
 #define Mark_scanned(sp, retaddr) Saved_return_address(sp) = (retaddr) | 1

runtime/roots_nat.c

@@ -481,10 +481,10 @@ static void do_local_allocations(caml_local_arenas* loc,
           /* forwards pointer, common case */
           CAMLassert(ix <= arena_ix);
         } else {
-          /* FIXME: backwards pointer.
-             This should reset sp and iterate to a fixpoint */
+          /* If backwards pointers are ever supported (e.g. local recursive
+             values), then this should reset sp and iterate to a fixpoint */
           CAMLassert(ix >= arena_ix);
-          caml_fatal_error("FIXME: backwards local pointer");
+          caml_fatal_error("backwards local pointer");
         }
       }
     }

testsuite/tests/typing-local/local.ml

@@ -787,32 +787,13 @@ Error: This value escapes its region
 (* Don't escape through a lazy value *)
 
 let foo (local_ x) =
-  lazy (print_string !x)
-[%%expect{|
-Line 2, characters 22-23:
-2 |   lazy (print_string !x)
-                          ^
-Error: The value x is local, so cannot be used inside a closure that might escape
-|}]
-
-let foo (local_ x) =
-  let l = lazy (print_string !x) in
-  l
-[%%expect{|
-Line 3, characters 2-3:
-3 |   l
-      ^
-Error: This local value escapes its region
-  Hint: Cannot return local value without an explicit "local_" annotation
-|}]
-
-
-let foo (local_ x) =
-  let l = lazy (print_string !x) in
-  let lazy () = l in
+  let _ = lazy (print_string !x) in
   ()
 [%%expect{|
-val foo : local_ string ref -> unit = <fun>
+Line 2, characters 30-31:
+2 |   let _ = lazy (print_string !x) in
+                                  ^
+Error: The value x is local, so cannot be used inside a closure that might escape
 |}]
 
 (* Don't escape through a functor *)
@@ -1718,7 +1699,7 @@ Error: Wrong arity for builtin primitive "%int32_add"
 |}]
 
 (*
-FIXME: perhaps allow this, but requires caml_compare changes (Is_in_value_area)
+TODO: perhaps allow this, but requires caml_compare changes (Is_in_value_area)
 let compare (local_ x) (local_ y) =
   [x = y; x <> y; x < y; x > y; x <= y; x >= y; compare x y = 0; x == y; x != y]
 [%%expect{|
@@ -1737,8 +1718,3 @@ let promote (local_ x) = +x
 [%%expect{|
 val promote : local_ int -> int = <fun>
 |}]
-
-(* In debug mode, Gc.minor () checks for minor heap->local pointers *)
-let () = Gc.minor ()
-[%%expect{|
-|}]

typing/ctype.mli

@@ -274,6 +274,7 @@ val unify_gadt:
 val unify_var: Env.t -> type_expr -> type_expr -> unit
         (* Same as [unify], but allow free univars when first type
            is a variable. *)
+val unify_alloc_mode: alloc_mode -> alloc_mode -> unit
 val filter_arrow: Env.t -> type_expr -> arg_label ->
                   alloc_mode * type_expr * alloc_mode * type_expr
         (* A special case of unification (with l:'a -> 'b). *)

typing/env.ml

@@ -285,7 +285,6 @@ module IdTbl =
       }
 
     let add_lock mode next =
-      (* FIXME optimisation: shared lock on shared ctx should be no-op *)
       { current = Ident.empty; layer = Lock {mode; next} }
 
     let map f next =

typing/typecore.ml

@@ -3586,7 +3586,7 @@ and type_expect_
           None -> None
         | Some sexp ->
             if !Clflags.principal then begin_def ();
-            (* FIXME: mode can be more relaxed than this if fields are nonlocal *)
+            (* TODO: mode can be more relaxed than this if fields are nonlocal *)
             let exp = type_exp ~recarg env (mode_subcomponent expected_mode) sexp in
             if !Clflags.principal then begin
               end_def ();
@@ -4011,9 +4011,11 @@ and type_expect_
                     filter_self_method env met Private meths privty
                   in
                   let method_type = newvar () in
-                  let (_marg_FIXME, obj_ty, _mres_FIXME, res_ty) =
+                  let (marg, obj_ty, mres, res_ty) =
                     filter_arrow env method_type Nolabel
                   in
+                  unify_alloc_mode marg Alloc_mode.global;
+                  unify_alloc_mode mres Alloc_mode.global;
                   unify env obj_ty desc.val_type;
                   unify env res_ty (instance typ);
                   let method_desc =
@@ -4256,14 +4258,11 @@ and type_expect_
         exp_env = env;
       }
   | Pexp_lazy e ->
-      register_allocation expected_mode;
-      let closure_mode = Value_mode.regional_to_global expected_mode.mode in
       let ty = newgenvar () in
       let to_unify = Predef.type_lazy_t ty in
       with_explanation (fun () ->
         unify_exp_types loc env to_unify (generic_instance ty_expected));
-      let env = Env.add_lock closure_mode env in
-      let env = Env.add_region_lock env in
+      let env = Env.add_lock Value_mode.global env in
       let arg = type_expect env mode_global e (mk_expected ty) in
       re {
         exp_desc = Texp_lazy arg;
@@ -4421,7 +4420,6 @@ and type_expect_
         exp_env = env;
       }
   | Pexp_letop{ let_ = slet; ands = sands; body = sbody } ->
-      (* FIXME: Allow local mode binding operators *)
       let rec loop spat_acc ty_acc sands =
         match sands with
         | [] -> spat_acc, ty_acc
@@ -5888,7 +5886,6 @@ and type_let
   let l =
     List.map2
       (fun ((_,p), (e, _)) pvb ->
-        (* FIXME: maybe we want modes in the vb? *)
         {vb_pat=p; vb_expr=e; vb_attributes=pvb.pvb_attributes;
          vb_loc=pvb.pvb_loc;
         })