Static check for noalloc and friends

Makefile

@@ -373,6 +373,7 @@ fmt:
 	  $$(find backend/debug \
 	    \( -name "*.ml" -or -name "*.mli" \))
 	ocamlformat -i backend/cmm_helpers.ml{,i}
+	ocamlformat -i backend/checkmach.ml{,i}
 	ocamlformat -i tools/merge_archives.ml
 	ocamlformat -i \
 	  $$(find backend/debug/dwarf \
@@ -387,6 +388,7 @@ check-fmt:
            [ "$$(git status --porcelain backend/asm_targets)" != "" ] || \
            [ "$$(git status --porcelain backend/debug)" != "" ] || \
            [ "$$(git status --porcelain backend/cmm_helpers.ml{,i})" != "" ] || \
+           [ "$$(git status --porcelain backend/checkmach.ml{,i})" != "" ] || \
            [ "$$(git status --porcelain tools/merge_archives.ml)" != "" ]; then \
 	  echo; \
 	  echo "Tree must be clean before running 'make check-fmt'"; \
@@ -400,6 +402,7 @@ check-fmt:
            [ "$$(git diff backend/asm_targets)" != "" ] || \
            [ "$$(git diff backend/debug)" != "" ] || \
            [ "$$(git diff backend/cmm_helpers.ml{,i})" != "" ] || \
+           [ "$$(git diff backend/checkmach.ml{,i})" != "" ] || \
            [ "$$(git diff tools/merge_archives.ml)" != "" ]; then \
 	  echo; \
 	  echo "The following code was not formatted correctly:"; \

backend/.ocamlformat-enable

@@ -2,6 +2,8 @@ cmm_helpers.ml
 cmm_helpers.mli
 internal_assembler/*.ml
 internal_assembler/*.mli
+checkmach.ml
+checkmach.mli
 cfg/**/*.ml
 cfg/**/*.mli
 asm_targets/**/*.ml

backend/asmgen.ml

@@ -88,6 +88,7 @@ let (pass_to_cfg : Cfg_format.cfg_unit_info Compiler_pass_map.t) =
   |> Compiler_pass_map.add Compiler_pass.Selection (new_cfg_unit_info ())
 
 let reset () =
+  Checkmach.reset_unit_info ();
   start_from_emit := false;
   Compiler_pass_map.iter (fun pass (cfg_unit_info : Cfg_format.cfg_unit_info) ->
     if should_save_ir_after pass then begin
@@ -360,6 +361,7 @@ let compile_fundecl ?dwarf ~ppf_dump fd_cmm =
   ++ Profile.record ~accumulate:true "deadcode" Deadcode.fundecl
   ++ Compiler_hooks.execute_and_pipe Compiler_hooks.Mach_live
   ++ pass_dump_if ppf_dump dump_live "Liveness analysis"
+  ++ Checkmach.fundecl ppf_dump
   ++ (fun (fd : Mach.fundecl) ->
     let force_linscan = should_use_linscan fd in
       match force_linscan, register_allocator with
@@ -436,7 +438,8 @@ let compile_genfuns ?dwarf ~ppf_dump f =
        (Cmm_helpers.Generic_fns_tbl.of_fns
           (Compilenv.current_unit_infos ()).ui_generic_fns))
 
-let compile_unit ~output_prefix ~asm_filename ~keep_asm ~obj_filename ~may_reduce_heap gen =
+let compile_unit ~output_prefix ~asm_filename ~keep_asm ~obj_filename ~may_reduce_heap
+        ~ppf_dump gen =
   reset ();
   let create_asm = should_emit () &&
                    (keep_asm || not !Emitaux.binary_backend_available) in
@@ -448,6 +451,7 @@ let compile_unit ~output_prefix ~asm_filename ~keep_asm ~obj_filename ~may_reduc
        Misc.try_finally
          (fun () ->
             gen ();
+            Checkmach.record_unit_info ppf_dump;
             write_ir output_prefix)
          ~always:(fun () ->
              if create_asm then close_out !Emitaux.output_channel)
@@ -600,7 +604,7 @@ let asm_filename output_prefix =
 
 let compile_implementation unix ?toplevel ~backend ~filename ~prefixname
       ~middle_end ~ppf_dump (program : Lambda.program) =
-  compile_unit ~output_prefix:prefixname
+  compile_unit ~ppf_dump ~output_prefix:prefixname
     ~asm_filename:(asm_filename prefixname) ~keep_asm:!keep_asm_file
     ~obj_filename:(prefixname ^ ext_obj)
     ~may_reduce_heap:(Option.is_none toplevel)
@@ -615,7 +619,7 @@ let compile_implementation unix ?toplevel ~backend ~filename ~prefixname
 let compile_implementation_flambda2 unix ?toplevel ?(keep_symbol_tables=true)
     ~filename ~prefixname ~size:module_block_size_in_words ~module_ident
     ~module_initializer ~flambda2 ~ppf_dump ~required_globals () =
-  compile_unit ~output_prefix:prefixname
+  compile_unit ~ppf_dump ~output_prefix:prefixname
     ~asm_filename:(asm_filename prefixname) ~keep_asm:!keep_asm_file
     ~obj_filename:(prefixname ^ ext_obj)
     ~may_reduce_heap:(Option.is_none toplevel)

backend/asmgen.mli

@@ -62,8 +62,12 @@ val compile_implementation_flambda2
   -> unit
   -> unit
 
-val compile_implementation_linear :
-    (module Compiler_owee.Unix_intf.S) -> string -> progname:string -> unit
+val compile_implementation_linear
+  : (module Compiler_owee.Unix_intf.S)
+  -> string
+  -> progname:string
+  -> ppf_dump:Format.formatter
+  -> unit
 
 val compile_phrase
   : ?dwarf:Dwarf_ocaml.Dwarf.t
@@ -85,6 +89,7 @@ val compile_unit
    -> keep_asm:bool
    -> obj_filename:string
    -> may_reduce_heap:bool
+   -> ppf_dump:Format.formatter
    -> (unit -> unit)
    -> unit
 

backend/asmlink.ml

@@ -388,6 +388,7 @@ let link_shared ~ppf_dump objfiles output_name =
       ~asm_filename:startup ~keep_asm:!Clflags.keep_startup_file
       ~obj_filename:startup_obj
       ~may_reduce_heap:true
+      ~ppf_dump
       (fun () ->
          make_shared_startup_file ~ppf_dump genfns units_tolink
       );
@@ -459,6 +460,7 @@ let link unix ~ppf_dump objfiles output_name =
       ~asm_filename:startup ~keep_asm:!Clflags.keep_startup_file
       ~obj_filename:startup_obj
       ~may_reduce_heap:true
+      ~ppf_dump
       (fun () -> make_startup_file unix ~ppf_dump ~named_startup_file
         ~filename:startup genfns units_tolink);
     Emitaux.reduce_heap_size ~reset:(fun () -> reset ());

backend/asmpackager.ml

@@ -282,6 +282,8 @@ let build_package_cmx members cmxfile =
     else
       Clambda (get_approx ui)
   in
+  let ui_checks = Compilenv.Checks.create () in
+  List.iter (fun info -> Compilenv.Checks.merge info.ui_checks ~into:ui_checks) units;
   Export_info_for_pack.clear_import_state ();
   let pkg_infos =
     { ui_name = ui.ui_name;
@@ -304,6 +306,7 @@ let build_package_cmx members cmxfile =
       ui_force_link =
           List.exists (fun info -> info.ui_force_link) units;
       ui_export_info;
+      ui_checks;
     } in
   Compilenv.write_unit_info pkg_infos cmxfile
 

backend/cfg/cfg_intf.ml

@@ -41,6 +41,7 @@ module S = struct
   type external_call_operation =
     { func_symbol : string;
       alloc : bool;
+      effects : Cmm.effects;
       ty_res : Cmm.machtype;
       ty_args : Cmm.exttype list
     }

backend/cfg/cfg_regalloc_utils.ml

@@ -75,10 +75,11 @@ let destroyed_at_basic : Cfg.basic -> Reg.t array =
              { ident; which_parameter; provenance; is_assignment }))
   | Call c -> (
     match c with
-    | P (External { func_symbol; alloc; ty_res; ty_args }) ->
+    | P (External { func_symbol; alloc; ty_res; ty_args; effects }) ->
       let func = func_symbol in
       let returns = true in
-      at_oper (Iop (Iextcall { func; ty_res; ty_args; alloc; returns }))
+      at_oper
+        (Iop (Iextcall { func; ty_res; ty_args; alloc; returns; effects }))
     | P (Alloc { bytes; dbginfo; mode }) ->
       at_oper (Iop (Ialloc { bytes; dbginfo; mode }))
     | P (Checkbound { immediate }) -> (
@@ -120,10 +121,11 @@ let destroyed_at_terminator : Cfg.terminator -> Reg.t array =
     | Func (Direct { func_symbol }) ->
       let func = func_symbol in
       at_oper (Mach.Iop (Itailcall_imm { func })))
-  | Call_no_return { func_symbol; alloc; ty_res; ty_args } ->
+  | Call_no_return { func_symbol; alloc; ty_res; ty_args; effects } ->
     let func = func_symbol in
     let returns = false in
-    at_oper (Mach.Iop (Iextcall { func; ty_res; ty_args; alloc; returns }))
+    at_oper
+      (Mach.Iop (Iextcall { func; ty_res; ty_args; alloc; returns; effects }))
 
 let[@inline] int_max (left : int) (right : int) = Stdlib.max left right
 

backend/cfg/cfg_to_linear.ml

@@ -45,9 +45,10 @@ let from_basic (basic : Cfg.basic) : L.instruction_desc =
   | Poptrap -> Lpoptrap
   | Call (F Indirect) -> Lop Icall_ind
   | Call (F (Direct { func_symbol })) -> Lop (Icall_imm { func = func_symbol })
-  | Call (P (External { func_symbol; alloc; ty_args; ty_res })) ->
+  | Call (P (External { func_symbol; alloc; effects; ty_args; ty_res })) ->
     Lop
-      (Iextcall { func = func_symbol; alloc; ty_args; ty_res; returns = true })
+      (Iextcall
+         { func = func_symbol; alloc; effects; ty_args; ty_res; returns = true })
   | Call (P (Checkbound { immediate = None })) -> Lop (Iintop Icheckbound)
   | Call (P (Checkbound { immediate = Some i })) ->
     Lop (Iintop_imm (Icheckbound, i))
@@ -174,11 +175,16 @@ let linearize_terminator cfg (terminator : Cfg.terminator Cfg.instruction)
       [L.Lop (Itailcall_imm { func = func_symbol })], None
     | Tailcall (Self { destination }) ->
       [L.Lop (Itailcall_imm { func = Cfg.fun_name cfg })], Some destination
-    | Call_no_return { func_symbol; alloc; ty_args; ty_res } ->
+    | Call_no_return { func_symbol; alloc; effects; ty_args; ty_res } ->
       ( [ L.Lop
             (Iextcall
-               { func = func_symbol; alloc; ty_args; ty_res; returns = false })
-        ],
+               { func = func_symbol;
+                 alloc;
+                 effects;
+                 ty_args;
+                 ty_res;
+                 returns = false
+               }) ],
         None )
     | Switch labels -> [L.Lswitch labels], None
     | Never -> Misc.fatal_error "Cannot linearize terminator: Never"

backend/cfg/cfgize.ml

@@ -149,8 +149,10 @@ let basic_or_terminator_of_operation :
          (if String.equal (State.get_fun_name state) func
          then Self { destination = State.get_tailrec_label state }
          else Func (Direct { func_symbol = func })))
-  | Iextcall { func; ty_res; ty_args; alloc; returns } ->
-    let external_call = { Cfg.func_symbol = func; alloc; ty_res; ty_args } in
+  | Iextcall { func; ty_res; ty_args; alloc; effects; returns } ->
+    let external_call =
+      { Cfg.func_symbol = func; alloc; effects; ty_res; ty_args }
+    in
     if returns
     then Basic (Call (P (External external_call)))
     else Terminator (Call_no_return external_call)

backend/cfg/linear_to_cfg.ml

@@ -373,8 +373,8 @@ let to_basic (mop : Mach.operation) : C.basic =
   match mop with
   | Icall_ind -> Call (F Indirect)
   | Icall_imm { func } -> Call (F (Direct { func_symbol = func }))
-  | Iextcall { func; alloc; ty_args; ty_res; returns = true } ->
-    Call (P (External { func_symbol = func; alloc; ty_args; ty_res }))
+  | Iextcall { func; alloc; effects; ty_args; ty_res; returns = true } ->
+    Call (P (External { func_symbol = func; alloc; effects; ty_args; ty_res }))
   | Iintop Icheckbound -> Call (P (Checkbound { immediate = None }))
   | Iintop
       (( Iadd | Isub | Imul | Imulh _ | Idiv | Imod | Iand | Ior | Ixor | Ilsl
@@ -584,9 +584,9 @@ let rec create_blocks (t : t) (i : L.instruction) (block : C.basic_block)
       in
       add_terminator t block i desc ~stack_offset ~traps;
       create_blocks t i.next block ~stack_offset ~traps
-    | Iextcall { func; alloc; ty_args; ty_res; returns = false } ->
+    | Iextcall { func; alloc; effects; ty_args; ty_res; returns = false } ->
       let desc =
-        C.Call_no_return { func_symbol = func; alloc; ty_args; ty_res }
+        C.Call_no_return { func_symbol = func; alloc; effects; ty_args; ty_res }
       in
       add_terminator t block i desc ~stack_offset ~traps;
       create_blocks t i.next block ~stack_offset ~traps