introduce annotation #[stable_call_conv]

compiler/src/arch_full.ml

@@ -44,6 +44,7 @@ module type Core_arch = sig
   val is_ct_asm_extra : extra_op -> bool
   val is_doit_asm_extra : extra_op -> bool
 
+  val internal_call_conv : (reg, regx, xreg, rflag, cond) internal_calling_convention
 end
 
 module type Arch = sig
@@ -81,6 +82,8 @@ module type Arch = sig
   val arch_info : (reg, regx, xreg, rflag, cond, asm_op, extra_op) Pretyping.arch_info
 
   val is_ct_sopn : ?doit:bool -> extended_op -> bool
+
+  val internal_call_conv : (var, var, var, var, cond) internal_calling_convention
 end
 
 module Arch_from_Core_arch (A : Core_arch) :
@@ -214,4 +217,10 @@ module Arch_from_Core_arch (A : Core_arch) :
    | BaseOp (_, o) -> (if doit then is_doit_asm_op else is_ct_asm_op) o
    | ExtOp o -> (if doit then is_doit_asm_extra else is_ct_asm_extra) o
 
+  let internal_call_conv =
+    { icall_reg   = List.map var_of_reg  internal_call_conv.icall_reg
+    ; icall_regx  = List.map var_of_regx internal_call_conv.icall_regx
+    ; icall_xreg  = List.map var_of_xreg internal_call_conv.icall_xreg
+    ; icall_rflag = List.map var_of_flag internal_call_conv.icall_rflag
+    }
 end

compiler/src/arch_full.mli

@@ -46,6 +46,7 @@ module type Core_arch = sig
   val is_ct_asm_extra : extra_op -> bool
   val is_doit_asm_extra : extra_op -> bool
 
+  val internal_call_conv : (reg, regx, xreg, rflag, cond) internal_calling_convention
 end
 
 module type Arch = sig
@@ -83,6 +84,8 @@ module type Arch = sig
   val arch_info : (reg, regx, xreg, rflag, cond, asm_op, extra_op) Pretyping.arch_info
 
   val is_ct_sopn : ?doit:bool -> extended_op -> bool
+
+  val internal_call_conv : (var, var, var, var, cond) internal_calling_convention
 end
 
 module Arch_from_Core_arch (A : Core_arch) : Arch

compiler/src/arm_arch_full.ml

@@ -123,4 +123,6 @@ module Arm (Lowering_params : Arm_input) : Arch_full.Core_arch
   let pp_asm = Pp_arm_m4.print_prog
 
   let callstyle = Arch_full.ByReg { call = Some LR; return = false }
+
+  let internal_call_conv = Arm_decl.arm_internal_call_conv
 end

compiler/src/main_compiler.ml

@@ -125,7 +125,6 @@ let main () =
     let env, pprog, _ast =
       try Compile.parse_file Arch.arch_info ~idirs:!Glob_options.idirs infile
       with
-      | Annot.AnnotationError (loc, code) -> hierror ~loc:(Lone loc) ~kind:"annotation error" "%t" code
       | Pretyping.TyError (loc, code) -> hierror ~loc:(Lone loc) ~kind:"typing error" "%a" Pretyping.pp_tyerror code
       | Syntax.ParseError (loc, msg) ->
           let msg =
@@ -264,8 +263,11 @@ let main () =
           if !debug then Format.eprintf "assembly listing written@."
       end else if List.mem Compiler.Assembly !print_list then
           Format.printf "%a%!" Arch.pp_asm asm
+    | exception Annot.AnnotationError (loc, code) -> hierror ~loc:(Lone loc) ~kind:"annotation error" "%t" code
     end
   with
+
+
   | Utils.HiError e ->
     Format.eprintf "%a@." pp_hierror e;
     exit 1

compiler/src/regalloc.ml

@@ -743,6 +743,44 @@ module Regalloc (Arch : Arch_full.Arch)
           in
           cnf
 
+
+let stable_call_conv = "stable_call_conv"
+
+let is_stable_call_conv f =
+  Annotations.has_symbol stable_call_conv f.f_annot.f_user_annot
+
+type internal_max_use_reg =
+  { max_reg  : int;
+    max_regx : int;
+    max_xreg : int;
+    max_flag : int; }
+
+let default_max_use_reg =
+  let icc = Arch.internal_call_conv in
+  { max_reg  = List.length icc.icall_reg
+  ; max_regx = List.length icc.icall_regx
+  ; max_xreg = List.length icc.icall_xreg
+  ; max_flag = List.length icc.icall_rflag }
+
+let process_call_conv f =
+  Annot.ensure_uniq1 stable_call_conv
+    (Annot.on_attribute
+      ~on_empty:(fun _ _ _ -> default_max_use_reg)
+      ~on_struct:(fun loc _ s ->
+        let get n name = Annot.ensure_uniq1 name (Annot.int (Some (Z.of_int n))) s |> Option.default Z.zero |> Z.to_int in
+        let d = default_max_use_reg in
+        let max = { max_reg  = get d.max_reg "reg"
+                  ; max_regx = get d.max_regx "regx"
+                  ; max_xreg = get d.max_xreg "xreg"
+                  ; max_flag = get d.max_flag "flag" } in
+        if d.max_reg  < max.max_reg then Annot.error ~loc "reg = %i is too large, it should be at most %i" max.max_reg d.max_reg;
+        if d.max_regx < max.max_regx then Annot.error ~loc "regx = %i is too large, it should be at most %i" max.max_regx d.max_regx;
+        if d.max_xreg < max.max_xreg then Annot.error ~loc "xreg = %i is too large, it should be at most %i" max.max_xreg d.max_xreg;
+        if d.max_flag < max.max_flag then Annot.error ~loc "flag = %i is too large, it should be at most %i" max.max_flag d.max_flag;
+        max)
+      (fun loc _nid -> Annot.error ~loc "no attribute or = {reg = <int>; regx = <int>; xreg = <int>; flag = <int> } expected after %s" stable_call_conv))
+  f.f_annot.f_user_annot
+
 let allocate_forced_registers return_addresses nv (vars: int Hv.t) tr (cnf: conflicts)
     (f: ('info, 'asm) func) (a: A.allocation) : conflicts =
   let split ~ctxt ~num =
@@ -752,37 +790,44 @@ let allocate_forced_registers return_addresses nv (vars: int Hv.t) tr (cnf: conf
        hierror_reg ~loc:(Lone f.f_loc) ~funname:f.f_name.fn_name "too many %s according to the ABI (only %d available on this architecture)"
          ctxt num
   in
-  let alloc_from_list loc ~ctxt rs xs q vs : unit =
+  let alloc_from_list ~ctxt get regs regxs xregs flags loc vs : unit =
     let f x = Hv.find vars x in
-    let num_rs = List.length rs in
-    let num_xs = List.length xs in
-    List.fold_left (fun (rs, xs) p ->
-        let p = q p in
+    let num_regs  = List.length regs in
+    let num_regxs = List.length regxs in
+    let num_xregs = List.length xregs in
+    let num_flags = List.length flags in
+    List.fold_left (fun (regs, regxs, xregs, flags) p ->
+        let p = get p in
         match f p with
         | i ->
-          let d, rs, xs =
+          let d, regs, regxs, xregs, flags =
             match kind_of_type Arch.reg_size p.v_kind p.v_ty with
-            | Word -> let d, rs = split ~ctxt ~num:num_rs rs in d, rs, xs
+            | Word -> let d, regs = split ~ctxt ~num:num_regs regs in d, regs, regxs, xregs, flags
             | Vector ->
                 let ctxt = "large " ^ ctxt in
-                let d, xs = split ~ctxt ~num:num_xs xs in d, rs, xs
+                let d, xregs = split ~ctxt ~num:num_xregs xregs in d, regs, regxs, xregs, flags
             | Extra ->
-               hierror_reg ~loc:(Lmore loc) "unexpected extra register %a" pp_var p
+                let ctxt = "extra " ^ ctxt in
+                let d, regxs = split ~ctxt ~num:num_regxs regxs in d, regs, regxs, xregs, flags
             | Flag ->
-               hierror_reg ~loc:(Lmore loc) "unexpected flag register %a" pp_var p
+                let ctxt = "flag " ^ ctxt in
+                let d, flags = split ~ctxt ~num:num_flags flags in d, regs, regxs, xregs, flags
             | Unknown ty ->
               hierror_reg ~loc:(Lmore loc) "unknown type %a for forced register %a"
                 PrintCommon.pp_ty ty (Printer.pp_var ~debug:true) p
           in
           allocate_one nv vars loc cnf p i d a;
-          (rs, xs)
-        | exception Not_found -> (rs, xs))
-      (rs, xs)
+          (regs, regxs, xregs, flags)
+        | exception Not_found -> (regs, regxs, xregs, flags))
+      (regs, regxs, xregs, flags)
       vs
-    |> (ignore : var list * var list -> unit)
+    |> (ignore : var list * var list * var list * var list -> unit)
   in
-  let alloc_args loc get = alloc_from_list loc ~ctxt:"parameters" Arch.argument_vars Arch.xmm_argument_vars get in
-  let alloc_ret loc get = alloc_from_list loc ~ctxt:"return values" Arch.ret_vars Arch.xmm_ret_vars get in
+
+  let alloc_args_gen get = alloc_from_list ~ctxt:"parameters" get in
+  let alloc_ret_gen get =  alloc_from_list ~ctxt:"return values" get in
+  let alloc_args get = alloc_args_gen get Arch.argument_vars [] Arch.xmm_argument_vars [] in
+  let alloc_ret get  = alloc_ret_gen get Arch.ret_vars [] Arch.xmm_ret_vars [] in
   let rec alloc_instr_r loc c =
     function
     | Cfor (_, _, s)
@@ -791,8 +836,8 @@ let allocate_forced_registers return_addresses nv (vars: int Hv.t) tr (cnf: conf
     | Csyscall(lvs, _, es) ->
        let get_a = function Pvar { gv ; gs = Slocal } -> L.unloc gv | _ -> assert false in
        let get_r = function Lvar gv -> L.unloc gv | _ -> assert false in
-       alloc_args loc get_a es;
-       alloc_ret loc get_r lvs;
+       alloc_args get_a loc es;
+       alloc_ret  get_r loc lvs;
        c
 
     | Cwhile (_, s1, _, _, s2)
@@ -816,8 +861,14 @@ let allocate_forced_registers return_addresses nv (vars: int Hv.t) tr (cnf: conf
     List.fold_left (fun c instr -> alloc_instr c instr) c s
   in
   let loc = L.i_loc0 f.f_loc in
-  if FInfo.is_export f.f_cc then alloc_args loc identity f.f_args;
-  if FInfo.is_export f.f_cc then alloc_ret loc L.unloc f.f_ret;
+  if FInfo.is_export f.f_cc then
+    (alloc_args identity loc f.f_args; alloc_ret L.unloc loc f.f_ret)
+  else
+    if is_stable_call_conv f then
+    (let icc = Arch.internal_call_conv in
+     alloc_args_gen identity icc.icall_reg icc.icall_regx icc.icall_xreg icc.icall_rflag loc f.f_args;
+     alloc_ret_gen L.unloc icc.icall_reg icc.icall_regx icc.icall_xreg icc.icall_rflag loc f.f_ret);
+
   let cnf = alloc_stmt f.f_body cnf in
   (match Arch.callstyle with
   | Arch_full.ByReg { call = Some r; return } ->
@@ -1201,32 +1252,51 @@ let global_allocation return_addresses (funcs: ('info, 'asm) func list) :
     - generate a fresh variable to hold the return address (if needed)
     - split live ranges (caveat: do not forget to remove φ-nodes at the end)
     - compute liveness information
-    - compute variables that are killed by a call to a function (including return addresses and extra registers)
-
+    - compute variables that are killed by a call to a function,
+      including return addresses and extra registers.
+      If the `stable_call_conv` is used then all
+      registers allowed to be used are also considered as killed.
+    - compute also the set of variables used by the function, including
+      the ones in the called functions
     Initial 'info are preserved in the result.
    *)
   let liveness_table : (Sv.t * Sv.t, 'asm) func Hf.t = Hf.create 17 in
   let killed_map : Sv.t Hf.t = Hf.create 17 in
   let killed fn = Hf.find killed_map fn in
+  let fn_vars_map : Sv.t Hf.t = Hf.create 17 in
+  let fn_vars fn = Hf.find fn_vars_map fn in
   let preprocess f =
     let f = f |> fill_in_missing_names |> Ssa.split_live_ranges false in
     Hf.add liveness_table f.f_name (Liveness.live_fd true f);
     let ra = Hf.find return_addresses f.f_name in
-    let written =
-      let written, cg = written_vars_fc f in
-      let written =
-        match f.f_cc with
-        | (Export | Internal) -> written
-        | Subroutine ->
-          Sv.union (vars_retaddr ra) written
-      in
-      let killed_by_calls =
-        Mf.fold (fun fn _locs acc -> Sv.union (killed fn) acc)
-          cg Sv.empty in
-      let killed_by_syscalls = if has_syscall f.f_body then Arch.syscall_kill else Sv.empty in
-      Sv.union (Sv.union written killed_by_calls) killed_by_syscalls
+    let written, cg = written_vars_fc f in
+    let ra =
+      match f.f_cc with
+      | (Export | Internal) -> Sv.empty
+      | Subroutine -> vars_retaddr ra
     in
+    (* If stable_call_conv is used then all allowed registers are considered as written *)
+    let written_call_conv =
+      match process_call_conv f with
+      | None -> Sv.empty
+      | Some mu ->
+        let icc = Arch.internal_call_conv in
+        [List.take mu.max_reg icc.icall_reg; List.take mu.max_regx icc.icall_regx;
+         List.take mu.max_xreg icc.icall_xreg; List.take mu.max_flag icc.icall_rflag]
+        |> List.flatten |> Sv.of_list in
+    let all_vars = Sv.union ra (vars_fc f) in
+    let all_vars =
+      Mf.fold (fun fn _locs acc -> Sv.union (fn_vars fn) acc)
+        cg all_vars in
+    let written = Sv.union ra (Sv.union written_call_conv written) in
+    let killed_by_calls =
+      Mf.fold (fun fn _locs acc -> Sv.union (killed fn) acc)
+        cg Sv.empty in
+    let killed_by_syscalls = if has_syscall f.f_body then Arch.syscall_kill else Sv.empty in
+    let written = Sv.union (Sv.union written killed_by_calls) killed_by_syscalls in
+
     Hf.add killed_map f.f_name written;
+    Hf.add fn_vars_map f.f_name all_vars;
     f
   in
   let funcs : (unit, 'asm) func list = funcs |> List.rev |> List.rev_map preprocess in
@@ -1286,6 +1356,26 @@ let global_allocation return_addresses (funcs: ('info, 'asm) func list) :
       liveness_table
       conflicts
   in
+  let conflicts =
+    (* If stable_call_conv is used then all variables used in f
+       are in conflict with the registers that are declared to be not modified by the
+       specified calling convention *)
+    let doit conflicts f =
+      match process_call_conv f with
+      | None -> conflicts
+      | Some mu ->
+        let icc = Arch.internal_call_conv in
+        let exclude =
+          List.flatten [List.drop mu.max_reg icc.icall_reg;
+                        List.drop mu.max_regx icc.icall_regx;
+                        List.drop mu.max_xreg icc.icall_xreg;
+                        List.drop mu.max_flag icc.icall_rflag ] in
+        let fv = fn_vars f.f_name in
+        List.fold_left (fun c x ->
+          Sv.fold (fun y c -> conflicts_add_one Arch.pointer_data Arch.reg_size Arch.asmOp vars tr Lnone x y c) fv c)
+          conflicts exclude in
+     List.fold_left doit conflicts funcs
+    in
 
   (* In-register return address conflicts with function arguments *)
   let conflicts =

compiler/src/riscv_arch_full.ml

@@ -59,4 +59,6 @@ module Riscv (Lowering_params : Riscv_input) : Arch_full.Core_arch
   let pp_asm = Pp_riscv.print_prog
 
   let callstyle = Arch_full.ByReg { call = Some RA; return = true }
+
+  let internal_call_conv = Riscv_decl.riscv_internal_call_conv
 end

compiler/src/x86_arch_full.ml

@@ -238,4 +238,5 @@ module X86 (Lowering_params : X86_input) :
 
   include Lowering_params
 
+  let internal_call_conv = X86_decl.x86_internal_call_conv
 end

compiler/tests/negative.expected

@@ -909,8 +909,8 @@ register allocation: too many return values according to the ABI (only 2 availab
 fail/register_allocation/x86-64/unknown_type_register.jazz:
 
 "fail/register_allocation/x86-64/unknown_type_register.jazz", line 1 (0-28):
-compilation error:
-register allocation: unexpected flag register a
+compilation error in function f:
+register allocation: too many flag parameters according to the ABI (only 0 available on this architecture)
 
 fail/register_allocation/x86-64/var_unallocated.jazz:
 

compiler/tests/success/x86-64/stable_call_conv.jazz

@@ -0,0 +1,43 @@
+#[stable_call_conv = {reg = 5, flag = 5}]
+fn f(reg u64 x1, reg u64 x2) -> reg u64 {
+   reg u64 x3 = x1;
+   x3 += x2;
+   reg u64 x4 = x2;
+   x4 += x3;
+
+   reg u64 x5 = x4;
+   x5 += x3;
+   x5 += x4;
+   x5 += x3;
+   x5 += x2;
+   x5 += x1;
+   x5 = x5;
+   return x5;
+}
+
+#[stable_call_conv = {reg = 5, flag}]
+fn g1(reg u64 x1, reg u64 x2) -> reg u64 {
+   #spill(x2);
+   x1 = f(x1, x2);
+   #unspill(x2);
+   x1 += x2;
+   return x1;
+}
+
+#[stable_call_conv = {reg = 6, flag}]
+fn g2(reg u64 x1, reg u64 x2) -> reg u64 {
+   reg u64 x3 = x2;
+   x1 = f(x1, x2);
+   x1 += x3;
+   return x1;
+}
+
+export fn h (reg u64 x, reg u64 y, reg u64 w) -> reg u64 {
+   reg u64 z;
+   #spill(y);
+   z = g1(x, y);
+   #unspill(y);
+   z = g2(z, y);
+   z += w;
+   return z;
+}

docs/source/index.md

@@ -9,13 +9,15 @@
 
 language/syntax/index
 language/semantics/index
+language/harmony/index
 :::
 
 :::{toctree}
 :caption: Compiler
 
 compiler/passes/index
 compiler/advanced/index
+
 :::
 
 :::{toctree}

docs/source/language/harmony/index.md

@@ -0,0 +1,7 @@
+# Living in harmony with the Jasmin compiler
+
+:::{toctree}
+:maxdepth: 2
+
+regalloc.md
+:::