process import, misc improvements

bin/sailor.ml

@@ -15,6 +15,7 @@ module ProcessPass = ProcessPass.Process.Pass
 module Hir = IrHir.Hir.Pass
 module Thir = IrThir.Thir.Pass
 module Mir = IrMir.Mir.Pass
+module MirChecks = Misc.Cfg_analysis.Pass
 module Imports = Misc.Imports.Pass
 module MCall = Misc.MethodCall.Pass
 module Mono = Mono.Monomorphization.Pass
@@ -36,6 +37,7 @@ let apply_passes (sail_module : Hir.in_body SailModule.t) (comp_mode : Cli.comp_
     @> Imports.transform 
     @> MCall.transform 
     @> Mir.transform
+    @> MirChecks.transform
     @> active_if dump_ir mir_debug
     @> Mono.transform
     @> finish 
@@ -71,8 +73,8 @@ let add_opt_passes (pm : [`Module] Llvm.PassManager.t) : unit  =
 let link ?(is_lib = false) (llm:Llvm.llmodule) (module_name : string) (basepath:string) (imports: string list) (libs : string list) (target, machine) clang_args : int =
   let f = Filename.(concat basepath module_name ^ Const.object_file_ext) in
   let triple = T.TargetMachine.triple machine in
-  let objfiles = String.concat " " (f::imports) in 
-  let libs = List.map (fun l -> "-l " ^ l) libs |> String.concat " "  in 
+  let objfiles = List.fold_left (Fmt.str "%s '%s'") "" (f::imports)   in 
+  let libs = List.fold_left (Fmt.str "%s -l '%s'") " " libs in 
   if T.Target.has_asm_backend target then
     begin
       Logs.info (fun m -> m "emitting object file...");

src/codegen/codegen_.ml

@@ -166,19 +166,19 @@ let cfgToIR (proto:L.llvalue) (decls,cfg: mir_function) (llvm:llvm_args) (env :S
           L.position_at_end llvm_bb llvm.b;
           L.build_br (BlockMap.find f.next llvm_bbs) llvm.b |> ignore;
           llvm_bbs
-        | Some (SwitchInt (e,cases,default)) -> 
-            let sw_val = eval_r env llvm e in
+        | Some (SwitchInt si) -> 
+            let sw_val = eval_r env llvm si.choice in
             let sw_val = L.build_intcast sw_val (L.i32_type llvm.c) "" llvm.b (* for condition, expression val will be bool *)
-            and llvm_bbs = aux default llvm_bbs env in
+            and llvm_bbs = aux si.default llvm_bbs env in
             L.position_at_end llvm_bb llvm.b;
-            let sw = L.build_switch sw_val (BlockMap.find default llvm_bbs) (List.length cases) llvm.b in
+            let sw = L.build_switch sw_val (BlockMap.find si.default llvm_bbs) (List.length si.paths) llvm.b in
             List.fold_left (
               fun bm (n,lbl) -> 
                 let n = L.const_int (L.i32_type llvm.c) n 
                 and bm = aux lbl bm env 
                 in L.add_case sw n (BlockMap.find lbl bm);
                 bm
-            ) llvm_bbs cases
+            ) llvm_bbs si.paths
 
         | None -> failwith "no terminator : mir is broken" (* can't happen *)
         | Some Break -> failwith "no break should be there"

src/common/monadic/monadState.ml

@@ -40,15 +40,15 @@ module M = T(MonadIdentity)
 
 
 
-module CounterTransformer  = functor (M:Monad) -> struct
-  include T(M)(struct type t = int end)
+module CounterTransformer  = functor (M:Monad)(C : sig type t val succ : t -> t val init : t end) -> struct
+  include T(M)(struct type t = C.t end)
 
-  let tick : unit t = fun n -> set (succ n) n
-  let get : int t = get
-  let fresh : int t = bind get (fun n -> bind tick (fun () ->  pure n))
+  let tick : unit t = fun n -> set (C.succ n) n
+  let get : C.t t = get
+  let fresh : C.t t = bind get (fun n -> bind tick (fun () ->  pure n))
 
 
-  let run (f : 'a t) = M.bind (f 0) (fun (r,_) -> M.pure r) (* generalize to all monads ?  *)
+  let run (f : 'a t) = M.bind (f C.init) (fun (r,_) -> M.pure r) (* generalize to all monads ?  *)
 end
 
 module Counter = CounterTransformer(MonadIdentity)

src/common/typesCommon.ml

@@ -144,11 +144,12 @@ type 'a process_defn =
 }
 
 type 'e proc_init = {
-    id : string;
-    proc : string;
-    params : 'e list;
-    read : l_str list;
-    write : l_str list;
+  mloc : l_str  option;
+  id : string;
+  proc : string;
+  params : 'e list;
+  read : l_str list;
+  write : l_str list;
 }
 
 type method_sig = 
@@ -170,9 +171,9 @@ type 'a method_defn =
 
 
 type ty_defn = {
-      name: string;
-      ty: sailtype option; (* None means abstract type *)
-      loc : loc;
+  name: string;
+  ty: sailtype option; (* None means abstract type *)
+  loc : loc;
 }
 
 type enum_proto = 

src/parsing/parser.mly

@@ -139,8 +139,12 @@ let process_body :=
     }
 
 let proc_init := 
-    | id = UID ; ":" ; "=" ; proc = UID ; params =  midrule(p = process_params(separated_list(",", expression)); {Option.value p ~default:[]}) ; (read,write) = shared_vars(located(ID)) ; { {id;proc;params;read;write} }
-    | id = UID ; params = midrule(p = process_params(separated_list(",", expression)); {Option.value p ~default:[]}) ; (read,write) = shared_vars(located(ID)) ; { {id;proc=id;params;read;write} }
+    | id = UID ; ":" ; "=" ; mloc = ioption(module_loc); proc = UID 
+        ; params =  midrule(p = process_params(separated_list(",", expression)); {Option.value p ~default:[]}) 
+        ; (read,write) = shared_vars(located(ID)) ; { {mloc;id;proc;params;read;write} }
+    | mloc = ioption(module_loc) ; id = UID 
+        ; params = midrule(p = process_params(separated_list(",", expression)); {Option.value p ~default:[]}) 
+        ; (read,write) = shared_vars(located(ID)) ; { {mloc;id;proc=id;params;read;write} }
 
 let loop := 
     located(

src/passes/ir/sailHir/hirMonad.ml

@@ -9,7 +9,7 @@ module Make(MonoidSeq : Monad.Monoid) = struct
   module HIREnv = SailModule.SailEnv(V)
 
   module E = Error.Logger
-  module EC = MonadState.CounterTransformer(E)
+  module EC = MonadState.CounterTransformer(E)(struct type t = int let succ = Int.succ let init = 0 end)
   module ECS =  struct 
     include MonadState.T(EC)(HIREnv)
     let fresh = EC.fresh |> lift

src/passes/ir/sailHir/hirUtils.ml

@@ -121,4 +121,64 @@ let check_non_cyclic_struct (name:string) (l,proto) env : unit E.t =
       | _ -> return ()
     ) s.fields
   in
-  aux name l proto []
+  aux name l proto []
+
+  let rename_var_exp (f: string -> string) (e: _ AstHir.expression) = 
+    let open AstHir in 
+    let rec aux (e : _ expression) = 
+      let buildExp = buildExp e.info in 
+      match e.exp with 
+      | Variable id -> buildExp @@ Variable (f id)
+      | Deref e -> let e = aux e in buildExp @@ Deref e
+      | StructRead (mod_loc,e, id) -> let e = aux e in buildExp @@ StructRead(mod_loc,e,id)
+      | ArrayRead (e1, e2) ->
+        let e1 = aux e1 in 
+        let e2 = aux e2 in 
+        buildExp @@ ArrayRead (e1,e2)
+      | Literal _ as l -> buildExp l
+      | UnOp (op, e) -> let e = aux e in buildExp @@ UnOp (op,e)
+      | BinOp(op,e1,e2)->
+        let e1 = aux e1 in 
+        let e2 = aux e2 in
+        buildExp @@ BinOp(op,e1,e2)
+      | Ref (b, e) ->
+        let e = aux e in buildExp @@ Ref(b,e)
+      | ArrayStatic el -> let el = List.map aux el in buildExp @@ ArrayStatic el
+      | StructAlloc (origin,id, m) -> let m = List.map (fun (n,e) -> n,aux e) m in buildExp @@ StructAlloc (origin,id,m)
+      | EnumAlloc (id, el) -> let el = List.map aux el in buildExp @@ EnumAlloc (id,el)
+      | MethodCall (mod_loc, id, el) -> let el  = List.map aux el in buildExp @@ MethodCall (mod_loc,id,el)
+      in aux e
+
+  let rename_var_stmt (f:string -> string) s = 
+    let open AstHir in 
+    let rec aux (s : _ statement) = 
+      let buildStmt = buildStmt s.info in
+      match s.stmt with
+      | DeclVar (mut, id, opt_t,opt_exp) -> 
+        let e = MonadOption.M.fmap  (rename_var_exp f) opt_exp in
+        buildStmt @@ DeclVar (mut,f id,opt_t,e)
+      | Assign(e1, e2) -> 
+        let e1 = rename_var_exp f e1
+        and e2 = rename_var_exp f e2 in 
+        buildStmt @@ Assign(e1, e2)
+      | Seq(c1, c2) -> 
+        let c1 = aux c1 in
+        let c2 = aux c2 in
+        buildStmt  @@ Seq(c1, c2)
+      | If(cond_exp, then_s, else_s) -> 
+        let cond_exp = rename_var_exp f cond_exp in
+        let then_s = aux then_s in
+        let else_s  = MonadOption.M.fmap aux else_s in
+        buildStmt (If(cond_exp, then_s, else_s))
+      | Loop c -> let c = aux c in buildStmt (Loop c)
+      | Break -> buildStmt Break
+      | Case(e, _cases) -> let e = rename_var_exp f e in buildStmt (Case (e, []))
+      | Invoke (var, mod_loc, id, el) -> 
+        let el = List.map (rename_var_exp f) el in 
+        let var = MonadOption.M.fmap f var in
+        buildStmt @@ Invoke(var,mod_loc, id,el)
+      | Return e -> let e =  MonadOption.M.fmap (rename_var_exp f) e in buildStmt @@ Return e
+      | Block c -> let c = aux c in buildStmt (Block c)
+      | Skip -> buildStmt Skip
+      in
+      aux s

src/passes/ir/sailHir/pp_hir.ml

@@ -28,10 +28,16 @@ let rec ppPrintExpression (pf : Format.formatter) (e : expression) : unit =
     | EnumAlloc (id,el) ->  
       fprintf pf "[%s(%a)]" (snd id)
         (pp_print_list ~pp_sep:pp_comma ppPrintExpression) el
-    | MethodCall _ -> ()
+    | MethodCall ((_,id),mod_loc,el) -> 
+      fprintf pf "%a%s(%a)" 
+      (pp_print_option  (fun fmt (_,ml) -> fprintf fmt "%s::" ml)) mod_loc
+      id 
+      (pp_print_list ~pp_sep:pp_comma ppPrintExpression) el
 
 let rec ppPrintStatement (pf : Format.formatter) (s : statement) : unit = match s.stmt with
-| DeclVar (_mut, id, _opt_t,_opt_exp) -> fprintf pf "\nvar %s;" id 
+| DeclVar (_mut, id, opt_t,opt_exp) -> fprintf pf "\nvar %s%a%a;" id 
+      (pp_print_option (fun fmt -> fprintf fmt " : %a" pp_type)) opt_t
+      (pp_print_option (fun fmt -> fprintf fmt " = %a" ppPrintExpression)) opt_exp
 | Assign(e1, e2) -> fprintf pf "\n%a = %a;" ppPrintExpression e1 ppPrintExpression e2
 | Seq(c1, c2) -> fprintf pf "%a%a" ppPrintStatement c1 ppPrintStatement c2
 | If(cond_exp, then_s,else_s) -> fprintf pf "\nif (%a) {\n%a\n}\n%a" 
@@ -41,8 +47,12 @@ let rec ppPrintStatement (pf : Format.formatter) (s : statement) : unit = match
 | Loop c -> fprintf pf "\nloop {%a\n}" ppPrintStatement c
 | Break -> fprintf pf "break;"
 | Case(_e, _cases) -> ()
-| Invoke (var, _mod_loc, (_,id), el) -> fprintf pf "\n%a%s(%a);" (pp_print_option  pp_print_string) var id (pp_print_list ~pp_sep:pp_comma ppPrintExpression) el
-| Return _e -> fprintf pf "\nreturn ?;"
+| Invoke (var, mod_loc, (_,id), el) -> fprintf pf "\n%a%a%s(%a);" 
+    (pp_print_option  (fun fmt v -> fprintf fmt "%s = " v)) var 
+    (pp_print_option  (fun fmt (_,ml) -> fprintf fmt "%s::" ml)) mod_loc
+    id 
+    (pp_print_list ~pp_sep:pp_comma ppPrintExpression) el
+| Return e -> fprintf pf "\nreturn %a;" (pp_print_option  ppPrintExpression) e
 | Block c -> fprintf pf "\n{\n@[ %a @]\n}" ppPrintStatement c
 | Skip -> ()
 
@@ -55,7 +65,7 @@ let ppPrintMethodSig (pf : Format.formatter) (s : TypesCommon.method_sig) : unit
 
 let ppPrintMethod (pf : Format.formatter) (m: statement TypesCommon.method_defn) : unit = 
   match m.m_body with
-  | Right s ->  fprintf pf  "fn %a{\n@{<hov 2> @ %a@]}\n"  ppPrintMethodSig m.m_proto ppPrintStatement s
+  | Right s ->  fprintf pf  "fn %a{\n@[<hov 2>%a@]\n}\n"  ppPrintMethodSig m.m_proto ppPrintStatement s
   | Left _ -> fprintf pf "extern fn %a\n" ppPrintMethodSig m.m_proto
 
 

src/passes/ir/sailMir/astMir.ml

@@ -2,8 +2,37 @@ open Common
 open TypesCommon
 open IrThir
 
+(*
+type unOp = Not | Neg
+type binOp = Add | Sub | Mul | Div
+
+type constant = literal (* nothing else for now *)
+
+type ('info,'import) lvalue = 
+  | UserBinding of string 
+  | TempBinding of string
+  | FunArg of string
+  | FunRet of string
+  | Projection of {import : 'import ; strct : ('info,'import) lvalue ; field : l_str}
+  | Deref of ('info,'import) lvalue
+  | ArrayIndex of {array : ('info,'import) lvalue; index : ('info,'import) lvalue}
+
+
+type ('info,'import) rvalue = 
+  | Use of ('info,'import) lvalue
+  | BinOp of {left : ('info,'import) lvalue ; right : ('info,'import) lvalue; op : binOp}
+  | UnOp of unOp * ('info,'import) lvalue
+  | Box
+  | Constant of constant
+  | Aggregate of ('info, 'import) lvalue dict
+
+type drop_kind = Shallow | Deep 
+type statement = Assign of lvalue * rvalue | Drop of drop_kind * lvalue
+
+*)
+
 type expression = Thir.expression
-type statement = Thir.statement
+type statement = Thir.statement 
 
 type declaration = {location : loc; mut : bool; id : string; varType : sailtype}
 type assignment = {location : loc; target : expression; expression : expression}
@@ -15,7 +44,7 @@ type terminator =
 | Goto of label
 | Invoke of {id : string; origin:l_str; target: string option; params : expression list; next:label}
 | Return of expression option
-| SwitchInt of expression * (int * label) list * label
+| SwitchInt of {choice : expression ; paths : (int * label) list ; default : label}
 | Break 
 
 
@@ -30,8 +59,9 @@ end
 
 module VE = Common.Env.VariableEnv(V)
 
-type basicBlock = {
-  env : VE.t;
+type ('f,'b) basicBlock = {
+  forward_info : 'f;
+  backward_info : 'b;
   assignments : assignment list;
   predecessors : LabelSet.t;
   terminator : terminator option;
@@ -47,7 +77,7 @@ module BlockMap = Map.Make(Int)
 type cfg = {
   input : label;
   output : label;
-  blocks : basicBlock BlockMap.t
+  blocks : (VE.t,unit) basicBlock BlockMap.t
 }
 
-type mir_function = declaration list * cfg
+type mir_function = declaration list * cfg