wip

[skip ci]

bin/sailor.ml

@@ -16,30 +16,30 @@ module Thir = IrThir.Thir.Pass
 module Mir = IrMir.Mir.Pass
 module Imports = IrMisc.Imports.Pass
 module MCall = IrMisc.MethodCall.Pass
-module MProc = IrMisc.MainProcess.Pass
 module Mono = IrMisc.Monomorphization.Pass
 module SetupLoop = IrMisc.SetupLoop.Pass
+module MProc = IrMisc.SetupMain.Pass
 
 
 (* error handling *)
 open Monad.UseMonad(E)
 
-let moduleToIR (m:Mir.out_body SailModule.t) (dump_decl:bool) (verify_ir:bool) : L.llmodule E.t =
-  let module Env = C.CodegenEnv in 
-  let llc = L.create_context () in
-  let llm = L.create_module llc m.md.name in
-  let* decls = Env.get_declarations m llc llm in
 
-  if dump_decl then failwith "not done yet";
-
-  let env = C.CodegenEnv.SailEnv.empty decls in
-
-  Env.DeclEnv.iter_decls (fun name m -> let func = C.Codegen_.methodToIR llc llm m env name in if verify_ir then Llvm_analysis.assert_valid_function func) (Self Method) decls >>= fun () ->
-  if verify_ir then 
-    match Llvm_analysis.verify_module llm with 
-    | None -> return llm 
-    | Some reason -> E.throw @@ Error.make dummy_pos (Fmt.str "LLVM : %s" reason)
-  else return llm
+let apply_passes (sail_module : SailParser.AstParser.statement SailModule.methods_processes SailModule.t) (comp_mode : Cli.comp_mode) : Mir.out_body SailModule.t E.t =
+  let open Pass.Progression in 
+  let active_if cond p = if cond then p else Fun.id in 
+  let passes = Fun.id
+    @> Hir.transform 
+    @> active_if (comp_mode = Loop) SetupLoop.transform
+    @> Thir.transform 
+    @> MCall.transform 
+    @> Mir.transform 
+    @> Imports.transform 
+    (* @> Mono.transform  *)
+    @> active_if (comp_mode <> Library) MProc.transform 
+    @> finish 
+  in run passes (return sail_module)
+
 
 
 let set_target (llm : Llvm.llmodule) (triple:string) : Llvm_target.Target.t * Llvm_target.TargetMachine.t =
@@ -135,42 +135,28 @@ let find_file_opt ?(maxdepth = 4) ?(paths = [Filename.current_dir_name]) (f:stri
     | None ->  aux dir 0
     ) None paths
 
+let unmarshal_mir file = In_channel.with_open_bin file @@ fun c -> (Marshal.from_channel c : Mir.out_body SailModule.t)
+let marshal_mir file m = Out_channel.with_open_bin file @@ fun c -> Marshal.to_channel c m []
 
 let sailor (files: string list) (intermediate:bool) (jit:bool) (noopt:bool) (dump_decl:bool) () (force_comp:bool list) (paths:string list) (comp_mode : Cli.comp_mode)  (clang_args: string) (verify_ir:bool) (target_triple:string) = 
-  Llvm.enable_pretty_stacktrace ();
-  Llvm.install_fatal_error_handler (fun err -> print_string @@ Fmt.str "LLVM ERROR : '%s'\n" err);
-
-  let apply_passes sail_module (comp_mode : Cli.comp_mode) : Mir.out_body SailModule.t E.t =
-    return sail_module 
-    |> Hir.transform 
-    |> (if comp_mode = Loop then SetupLoop.transform else Fun.id)
-    |> Thir.transform 
-    |> MCall.transform
-    |> Mir.transform 
-    |> Imports.transform
-    |> (if comp_mode <> Library then MProc.transform else Fun.id)
-    |> Mono.transform
-  in
-
-  let compile sail_module basepath (comp_mode : Cli.comp_mode) : Mir.out_body SailModule.t E.t =
+  let compile sail_module basepath (comp_mode : Cli.comp_mode) : unit E.t =
     let* m = apply_passes sail_module comp_mode in
     (* Out_channel.with_open_text Filename.(concat basepath m.md.name ^ ".mir.debug") (fun f -> Format.fprintf (Format.formatter_of_out_channel f) "%a" Pp_mir.ppPrintModule m); *)
 
-    let+ llm = moduleToIR m dump_decl verify_ir in
+    let+ llm = C.Codegen_.moduleToIR m dump_decl verify_ir in
 
     (* only generate mir file if codegen succeeds *)
-    Out_channel.with_open_bin Filename.(concat basepath m.md.name ^ Const.mir_file_ext) (fun f -> Marshal.to_channel f m []);
+    marshal_mir Filename.(concat basepath m.md.name ^ Const.mir_file_ext) m;
 
     let tm = set_target llm target_triple in
 
     if not noopt && comp_mode <> Library then 
-      begin
-        let open L.PassManager in
-        let pm = create () in add_opt_passes pm;
-        let res = run_module llm pm in
-        Logs.debug (fun m -> m "pass manager executed, module modified : %b" res);
-        dispose pm
-      end
+        L.PassManager.(
+          let pm = create () in add_opt_passes pm;
+          let res = run_module llm pm in
+          Logs.debug (fun m -> m "pass manager executed, module modified : %b" res);
+          dispose pm
+        )
     ;
 
     if intermediate then L.print_module Filename.(concat basepath m.md.name ^ Const.llvm_ir_ext) llm;
@@ -181,36 +167,37 @@ let sailor (files: string list) (intermediate:bool) (jit:bool) (noopt:bool) (dum
         let imports = object_files @ List.map (fun i -> i.dir ^ i.mname ^ Const.object_file_ext) @@ ImportSet.elements m.imports in
         let ret = link llm sail_module.md.name basepath imports libs tm ~is_lib:(comp_mode = Library) clang_args in
         if ret <> 0 then
-          (Fmt.str "clang couldn't execute properly (error %i)" ret |> failwith)
+          Fmt.(str_like stderr "clang couldn't execute properly (error %i)" ret) |> failwith
       end
     ;
 
-    if jit && comp_mode <> Library then execute llm else L.dispose_module llm;
-    m
+    if jit && comp_mode <> Library then execute llm else L.dispose_module llm
   in
 
-  let rec process_file f (treated: string list) (compiling: (string*loc) list) comp_mode : (string list * 'a SailModule.t) E.t = 
+  let rec process_file f (treated: string list) (compiling: (string*loc) list) comp_mode : string list E.t = 
     let mname = Filename.(basename f |> remove_extension) in 
     let basepath = Filename.(dirname f) in 
 
     if List.mem mname treated then
-     (Logs.debug (fun m -> m "skipping module '%s'" mname); 
-      return (treated,SailModule.emptyModule))
+    begin 
+      Logs.debug (fun m -> m "skipping module '%s'" mname); 
+      return treated
+    end
     else
       let treated = mname::treated in 
       let add_imports_decls (curr_env: SailModule.DeclEnv.t ) (imports : ImportSet.t) = 
         ImportSet.fold (fun i -> 
           let file = i.dir ^ i.mname ^ Const.mir_file_ext in 
           Logs.debug (fun m -> m "reading module '%s' from mir file %s" i.mname file); 
-          let slmd : Mir.out_body SailModule.t = In_channel.with_open_bin file  Marshal.from_channel in
+          let slmd = unmarshal_mir file in
           (* Logs.debug (fun m -> m "decls of import %s : \n %s" i.mname (SailModule.DeclEnv.string_of_env slmd.declEnv)); *)
           SailModule.DeclEnv.add_import_decls (i, slmd.declEnv)
         )
         imports curr_env 
     in
 
       let* slmd = P.parse_program f in 
-      let process_imports_and_compile () : (string list * 'a SailModule.t) E.t =
+      let process_imports_and_compile () : string list E.t =
         let open MakeOrderedFunctions(ImportCmp) in 
         Logs.info (fun m -> m "======= processing module '%s' =======" slmd.md.name );
         Logs.debug (fun m -> m "module hash : %s" (Digest.to_hex slmd.md.hash));
@@ -236,18 +223,13 @@ let sailor (files: string list) (intermediate:bool) (jit:bool) (noopt:bool) (dum
             let import = fun m -> {i with dir=Filename.(dirname m ^ dir_sep); proc_order=(List.length compiling)} in 
 
             match find_file_opt source ~paths:(Filename.current_dir_name::paths),find_file_opt mir_name with
-            | Some s,Some m 
-              when In_channel.with_open_bin m 
-              (fun f -> 
-                let mir : 'a SailModule.t = Marshal.from_channel f in 
-                Digest.(equal mir.md.hash @@ file s) && 
-                List.length force_comp < 2 &&
-                mir.md.version = Const.sailor_version
-              )
-              -> (* mir up-to-date with source -> use mir *)
+            | Some s,Some m when let mir = unmarshal_mir m in 
+                                    Digest.(equal mir.md.hash @@ file s) && 
+                                    List.length force_comp < 2 && 
+                                    mir.md.version = Const.sailor_version -> (* mir up-to-date with source -> use mir *)
               return (treated,import m)
             | None, Some m -> (* mir but no source -> use mir *)
-              let mir :'a SailModule.t = In_channel.with_open_bin m Marshal.from_channel in
+              let mir = unmarshal_mir m in
               E.throw_if 
               (Error.make dummy_pos @@ Printf.sprintf "module %s was compiled with sailor %s, current is %s" mir.md.name mir.md.version Const.sailor_version)
               (mir.md.version <> Const.sailor_version) 
@@ -256,38 +238,38 @@ let sailor (files: string list) (intermediate:bool) (jit:bool) (noopt:bool) (dum
               E.throw @@ Error.make i.loc "import not found"
             | Some s, _ -> (* source but no mir or mir not up-to-date -> compile *)
               begin
-              let+ treated',_mir = process_file s treated ((slmd.md.name,i.loc)::compiling) Cli.Library
+              let+ treated = process_file s treated ((slmd.md.name,i.loc)::compiling) Cli.Library
               in 
-              treated',import s
+              treated,import s
               end 
           ) treated slmd.imports 
         in 
         let declEnv = add_imports_decls slmd.declEnv imports in
-        let+ sm = compile {slmd with imports ; declEnv} basepath comp_mode in
+        let+ _sm = compile {slmd with imports ; declEnv} basepath comp_mode in
         Logs.info (fun m -> m "======= done processing module '%s' =======\n" slmd.md.name);
-        treated,sm
+        treated
       in
 
       let mir_file = Filename.(dirname f ^ dir_sep ^ slmd.md.name ^ Const.mir_file_ext) in
       (* if mir file exists, check hash, if same hash, no need to compile *)
       if Sys.file_exists mir_file && (List.length force_comp = 0) then
-        let mir : 'a SailModule.t = In_channel.with_open_bin mir_file Marshal.from_channel in
+        let mir = unmarshal_mir mir_file in
         let* () = E.throw_if (Error.make dummy_pos @@ Printf.sprintf "module %s was compiled with sailor %s, current is %s" mir.md.name mir.md.version Const.sailor_version)
                   (mir.md.version <> Const.sailor_version) 
         in
         if not @@ Digest.equal mir.md.hash slmd.md.hash then
-          process_imports_and_compile () 
+          process_imports_and_compile ()
         else 
           begin
             Logs.app (fun m -> m "'%s' is up-to-date, use '-f' to force compilation" slmd.md.name);
-            return (treated,mir)
+            return treated
           end
       else
-        process_imports_and_compile ()
-  in 
+        process_imports_and_compile () 
+      in 
 
   try
-    match ListM.fold_left (fun t f -> let+ t,_ = process_file f t [] comp_mode in f::t) [] files with
+    match ListM.fold_left (fun t f -> let+ t = process_file f t [] comp_mode in f::t) [] files with
     | Ok treated,_ -> Logs.debug (fun m -> m "files processed : %s " @@ String.concat " " treated) ; `Ok ()
     | Error e,errs -> 
       Error.print_errors (e::errs);
@@ -299,12 +281,11 @@ let sailor (files: string list) (intermediate:bool) (jit:bool) (noopt:bool) (dum
           Logs.warn (fun m -> m "backtrace recording is not turned on, only the exception name will be printed. To print the backtrace, run with 'OCAMLRUNPARAM=b'");
           Printexc.to_string e)
         else Printexc.get_backtrace () in 
-     `Error (false,msg)
+    `Error (false,msg)
 
 
 let () = 
-  Llvm_all_backends.initialize (); (* init here to show targets from the cli *)
-  Cmdliner.Cmd.eval (Cli.cmd sailor) |> exit
-
-
-
+  Llvm_all_backends.initialize ();
+  L.enable_pretty_stacktrace ();
+  L.install_fatal_error_handler (fun err -> Logs.err (fun m -> m "LLVM ERROR : '%s'\n" err));
+  Cmdliner.Cmd.eval (Cli.cmd sailor) |> exit

src/codegen/codegenEnv.ml

@@ -10,7 +10,7 @@ open MakeOrderedFunctions(ImportCmp)
 module Declarations = struct
   include SailModule.Declarations
   type process_decl = unit
-  type method_decl = {defn : IrMir.Mir.Pass.out_body method_defn ; llval :  llvalue ; extern : bool}
+  type method_decl = {defn : IrMir.AstMir.mir_function method_defn ; llval :  llvalue ; extern : bool}
   type struct_decl = {defn : struct_proto; ty : lltype}
   type enum_decl = unit
 end
@@ -30,7 +30,6 @@ module SailEnv = VariableDeclEnv (Declarations)(
 open Declarations
 
 
-
 let getLLVMBasicType f t llc llm  : lltype = 
   let rec aux = function
   | Bool -> i1_type llc
@@ -80,7 +79,7 @@ let getLLVMBasicType f t llc llm  : lltype =
       match type_by_name llm ("struct." ^ name) with 
         | Some ty -> ty 
         | None -> (let ty = named_struct_type llc ("struct." ^ name) in
-             struct_set_body ty elts false; ty)
+          struct_set_body ty elts false; ty)
       end
     | Some _ -> failwith "something is broken"
     | None -> failwith @@ Fmt.str "getLLVMType : %s '%s' not found in module '%s'" (string_of_decl d) name mname
@@ -97,21 +96,32 @@ let llvm_proto_of_method_sig (m:method_sig) env llc llm =
   let method_t = if m.variadic then var_arg_function_type else function_type in
   declare_function m.name (method_t llvm_rt args_type ) llm
 
+let collect_monos (sm: 'a SailModule.methods_processes SailModule.t) = 
+  let open SailModule.DeclEnv in
+  let decls = get_own_decls sm.declEnv in
+  let m = List.filter (fun m -> m.m_proto.generics = []) sm.body.methods in
+  let s = StructSeq.(decls |> get_decls Struct |> to_seq |> Seq.filter (fun (_,(_,(s:struct_proto))) -> s.generics = []) |> of_seq) in
+  let e = EnumSeq.(decls |> get_decls Enum |> to_seq |> Seq.filter (fun (_,(_,(e:enum_proto))) -> e.generics = [] ) |> of_seq)  in
+  let t = get_decls Type decls
+  in m,s,e,t
 
 let get_declarations (sm: IrMir.Mir.Pass.out_body SailModule.t) llc llm : DeclEnv.t E.t = 
   let open Monad.MonadSyntax(E) in
   let open Monad.MonadOperator(E) in
+  let open SailModule.DeclEnv in
+
+  let methods,structs,enums,types = collect_monos sm in  
+
 
   Logs.debug (fun m -> m 
   "codegen of %i method(s), %i struct(s), %i type(s) and %i enum(s)"
-   (List.length sm.methods)
-    SailModule.DeclEnv.(get_own_decls sm.declEnv |> get_decls Struct |> container_length)
-    SailModule.DeclEnv.(get_own_decls sm.declEnv |> get_decls Type |> container_length)
-    SailModule.DeclEnv.(get_own_decls sm.declEnv |> get_decls Enum |> container_length)
+  (List.length methods)
+  (container_length structs)
+  (container_length types)
+  (container_length enums)
   );
 
   let valueify_method_sig (m:method_sig) : method_sig =
-    let open Monad.MonadOperator(MonadOption.M) in
     let value = fun pos -> CompoundType{origin=None;name=(pos,"_value");generic_instances=[];decl_ty=None} in
     let rtype = m.rtype in (* keep the current type *)
     let params = List.map (fun (p:param) -> {p with ty=(value p.loc)}) m.params in
@@ -120,8 +130,8 @@ let get_declarations (sm: IrMir.Mir.Pass.out_body SailModule.t) llc llm : DeclEn
 
   (* because the imports are at the mir stage, we also have to do some codegen for them *)
 
-  let load_methods methods is_import env = 
-    ListM.fold_left ( fun d m -> 
+  let load_methods (methods: IrMir.AstMir.mir_function method_defn list) is_import env = 
+    ListM.fold_left ( fun d (m:IrMir.AstMir.mir_function method_defn) -> 
       let extern,proto = 
         if (Either.is_left m.m_body) then (* extern method, all parameters must be of type value *)
           true,valueify_method_sig m.m_proto
@@ -142,13 +152,12 @@ let get_declarations (sm: IrMir.Mir.Pass.out_body SailModule.t) llc llm : DeclEn
   let module SEnv = MakeFromSequencable(SailModule.DeclEnv.StructSeq) in 
   let module TEnv = MakeFromSequencable(SailModule.DeclEnv.TypeSeq) in
 
-  let load_types (sm: 'a SailModule.t) env = 
+  let load_types types env = 
     TEnv.fold (fun acc (id,d) -> DeclEnv.add_decl id d Type acc) 
-    env 
-    SailModule.DeclEnv.(get_own_decls sm.declEnv |> get_decls Type)  
+    env types
   in
 
-  let load_structs (sm: 'a SailModule.t) write_env =  
+  let load_structs structs write_env =  
     SEnv.fold (fun acc (name,(_,defn)) -> 
       let _,f_types = List.split defn.fields in
       let elts = List.map (fun (_,t,_) -> _getLLVMType sm.declEnv t llc llm) f_types |> Array.of_list in
@@ -158,9 +167,7 @@ let get_declarations (sm: IrMir.Mir.Pass.out_body SailModule.t) llc llm : DeclEn
                   struct_set_body ty elts false; ty
     in
       DeclEnv.add_decl name {defn;ty} Struct acc
-    ) 
-    write_env
-    SailModule.DeclEnv.(get_own_decls sm.declEnv |> get_decls Struct)
+    ) write_env structs
   in 
   let sorted_imports = (sm.imports |> ImportSet.elements |> List.sort (fun i1 i2 -> Int.compare i1.proc_order i2.proc_order)) in 
 
@@ -169,15 +176,15 @@ let get_declarations (sm: IrMir.Mir.Pass.out_body SailModule.t) llc llm : DeclEn
   let* decls = 
     ListM.fold_left (fun (e:DeclEnv.t) (i:import)  -> 
       Logs.debug (fun m -> m "processing import %s" i.mname);
-      let (sm: 'a SailModule.t) = 
-        In_channel.with_open_bin (i.dir ^ i.mname ^ Constants.mir_file_ext) Marshal.from_channel
+      let sm = In_channel.with_open_bin (i.dir ^ i.mname ^ Constants.mir_file_ext) @@ fun c -> (Marshal.from_channel c : IrMir.Mir.Pass.out_body SailModule.t)
       in
       (* putting import methods,types,structs and enums into mir env *)
       let empty_env = DeclEnv.(empty |> set_name i.mname |> replace_imports_with e) in
-      let+ import_env = load_types sm empty_env >>= load_structs sm >>= load_methods sm.methods true in
+      let methods,structs,_enums,types = collect_monos sm in  
+      let+ import_env = load_types types empty_env >>= load_structs structs >>= load_methods methods true in
       (* Logs.debug (fun m -> m "import %s env : %s"  i.mname @@ DeclEnv.string_of_env import_env); *)
       DeclEnv.add_import_decls (i,import_env) e 
     ) DeclEnv.(empty |> set_name sm.md.name) sorted_imports
   in  
   (* convert own decls, only after loading imports *)
-  load_types sm decls >>= load_structs sm >>= load_methods sm.methods false
+  load_types types decls >>= load_structs structs >>= load_methods methods false

src/codegen/codegenUtils.ml

@@ -11,8 +11,7 @@ let mangle_method_name (name:string) (mname:string) (args: sailtype list ) : str
   (* Logs.debug (fun m -> m "renamed %s to %s" name res); *)
   res
 
-
-let getLLVMLiteral (l:literal)  (llvm:llvm_args) : llvalue =
+let getLLVMLiteral (l:literal) (llvm:llvm_args) : llvalue =
   match l with
   | LBool b -> const_int (i1_type llvm.c) (Bool.to_int b)
   | LInt i -> const_int_of_string (integer_type llvm.c i.size) (Z.to_string i.l) 10