update to LLVM 15 & OCaml 5.1.0

.github/workflows/build.yml

@@ -16,10 +16,10 @@ jobs:
       - uses: actions/checkout@v3
 
 
-      - name: setup llvm 14 repo 
+      - name: setup llvm 15 repo 
         run: |
-          echo "deb http://apt.llvm.org/focal/ llvm-toolchain-focal-14 main" | sudo tee -a /etc/apt/sources.list
-          echo "deb-src http://apt.llvm.org/focal/ llvm-toolchain-focal-14 main"  | sudo tee -a /etc/apt/sources.list
+          echo "deb http://apt.llvm.org/focal/ llvm-toolchain-focal-15 main" | sudo tee -a /etc/apt/sources.list
+          echo "deb-src http://apt.llvm.org/focal/ llvm-toolchain-focal-15 main"  | sudo tee -a /etc/apt/sources.list
           wget -O - https://apt.llvm.org/llvm-snapshot.gpg.key|sudo apt-key add -
           sudo apt update
 
@@ -29,19 +29,18 @@ jobs:
         # uses: ocaml/setup-ocaml@6d924c1a7769aa5cdd74bdd901f6e24eb05024b1
         uses: ocaml/setup-ocaml@v2
         with:
-          ocaml-compiler: 4.14.X
+          ocaml-compiler: 5.0.X
 
 
       - run: opam install . --deps-only
 
       - run: opam exec -- dune build
 
-      - name: Archive saili and sailor
+      - name: Archive sailor
         uses: actions/upload-artifact@v3
         with:
-          name: saili and sailor for ${{ steps.system-info.outputs.release }}
+          name: sailor for ${{ steps.system-info.outputs.release }}
           path: |
-            _build/install/default/bin/saili
             _build/install/default/bin/sailor
           if-no-files-found: error
 

bin/dune

@@ -8,6 +8,9 @@
     fmt
     fmt.tty
     fmt.cli
+    ctypes.foreign
     logs.cli
     )
-  (public_name sailor))
+  (public_name sailor)
+  (modes byte exe)
+)

dune-project

@@ -1,8 +1,9 @@
-(lang dune 3.2)
+(lang dune 3.7)
 (name "sail-pl")
 (version 0.1)
 (using menhir 2.0)
 (generate_opam_files true)
+(map_workspace_root false)
 
 (license GPL) 
 (authors "Frederic Dabrowski")
@@ -15,13 +16,13 @@
   (synopsis "SAIL: Safe Interactive Language")
   (description "SAIL means Safe Interactive Language.")
   (depends 
-    (ocaml (>= 4.13.1))
+    (ocaml (>= 5.1.0))
     (cmdliner (>= 1.1.1))
     (fmt  (>= 0.9.0))
     (menhir (>= 2.0))
     (logs (>= 0.7))
     (mtime (>= 1.3.0))
     (ctypes-foreign (>= 0.18.0))
-    (llvm (>= 13.0.0))
+    (llvm (= 15.0.0))
     zarith
     ))

sail-pl.opam

@@ -9,15 +9,15 @@ license: "GPL"
 homepage: "https://sail-pl.github.io"
 bug-reports: "https://sail-pl.github.io"
 depends: [
-  "dune" {>= "3.2"}
-  "ocaml" {>= "4.13.1"}
+  "dune" {>= "3.7"}
+  "ocaml" {>= "5.1.0"}
   "cmdliner" {>= "1.1.1"}
   "fmt" {>= "0.9.0"}
   "menhir" {>= "2.0"}
   "logs" {>= "0.7"}
   "mtime" {>= "1.3.0"}
   "ctypes-foreign" {>= "0.18.0"}
-  "llvm" {>= "13.0.0"}
+  "llvm" {= "15.0.0"}
   "zarith"
   "odoc" {with-doc}
 ]

src/codegen/codegenEnv.ml

@@ -1,30 +1,30 @@
-open Llvm
 open Common
 open TypesCommon
 open Env
 open Mono
 open IrMir
 module E = Logging.Logger
+module L = Llvm
 
 open Monad.UseMonad(E)
 open MakeOrderedFunctions(ImportCmp)
 
 module Declarations = struct
   include SailModule.Declarations
   type process_decl = unit
-  type method_decl = {defn : MirAst.mir_function method_defn ; llval :  llvalue ; extern : bool}
-  type struct_decl = {defn : struct_proto; ty : lltype}
+  type method_decl = {defn : MirAst.mir_function method_defn ; llval :  L.llvalue ; llty : L.lltype; extern : bool}
+  type struct_decl = {defn : struct_proto; ty : L.lltype}
   type enum_decl = unit
 end
 
 module DeclEnv = DeclarationsEnv (Declarations)
 
 module SailEnv = VariableDeclEnv (Declarations)(
   struct 
-    type t = bool * llvalue
+    type t = bool * L.llvalue
     let string_of_var _ = ""
 
-    let param_to_var (p:param) = p.mut,global_context () |> i1_type |> const_null (*fixme : make specialized var env for passes to not have this ugly thing *)
+    let param_to_var (p:param) = L.(p.mut,global_context () |> i1_type |> const_null) (*fixme : make specialized var env for passes to not have this ugly thing *)
 
   end
 ) 
@@ -34,32 +34,32 @@ open Declarations
 type in_body = Monomorphization.Pass.out_body
 
 
-let getLLVMBasicType f ty llc llm  : lltype E.t = 
+let getLLVMBasicType f ty llc llm  : L.lltype E.t = 
   let rec aux ty = 
     match ty.value with
-    | Bool -> i1_type llc |> return
-    | Int n -> integer_type llc n |> return
-    | Float -> double_type llc |> return
-    | Char -> i8_type llc |> return
-    | String -> i8_type llc |> pointer_type |> return
-    | ArrayType (t,s) -> let+ t = aux t in array_type t s
-    | Box t | RefType (t,_) -> aux t <&> pointer_type
+    | Bool -> L.i1_type llc |> return
+    | Int n -> L.integer_type llc n |> return
+    | Float -> L.double_type llc |> return
+    | Char -> L.i8_type llc |> return
+    | String -> L.pointer_type2 llc |> return
+    | ArrayType (t,s) -> let+ t = aux t in L.array_type t s
+    | Box _ | RefType _ -> L.pointer_type2 llc |> return
     | GenericType _ -> E.throw Logging.(make_msg ty.loc "no generic type in codegen")
-    | CompoundType {name; _} when name.value = "_value" -> i64_type llc |> return (* for extern functions *)
+    | CompoundType {name; _} when name.value = "_value" -> L.i64_type llc |> return (* for extern functions *)
     | CompoundType {origin=None;_} 
     | CompoundType {decl_ty=None;_} -> E.throw Logging.(make_msg  ty.loc  "compound type with no origin or decl_ty")
     | CompoundType  {origin=Some mname; name; decl_ty=Some d;_} -> 
       f (mname.value,name.value,d) llc llm aux
   in aux ty
 
 
-  let handle_compound_type_codegen env (mname,name,d) llc _llm (aux : sailtype -> lltype E.t) : lltype E.t = 
+  let handle_compound_type_codegen env (mname,name,d) llc _llm (aux : sailtype -> L.lltype E.t) : L.lltype E.t = 
     match DeclEnv.find_decl name (Specific (mname,Filter [d])) env with 
     | Some (T tdef) -> 
       begin
         match tdef with
         | {ty=Some t;_} -> aux t 
-        | {ty=None;_} -> i64_type llc |> return
+        | {ty=None;_} -> L.i64_type llc |> return
       end
     | Some (E _enum) -> failwith "todo enum"
     | Some (S {ty;_}) -> return ty
@@ -69,23 +69,23 @@ let getLLVMBasicType f ty llc llm  : lltype E.t =
 
   let getLLVMType = fun e -> getLLVMBasicType (handle_compound_type_codegen e)
 
-  let handle_compound_type env (mname,name,d) llc llm (aux : sailtype -> lltype E.t) : lltype E.t = 
+  let handle_compound_type env (mname,name,d) llc llm (aux : sailtype -> L.lltype E.t) : L.lltype E.t = 
     match SailModule.DeclEnv.find_decl name (Specific (mname,Filter [d])) env with 
     | Some (T tdef) -> 
       begin
         match tdef with
         | {ty=Some t;_} -> aux t 
-        | {ty=None;_} -> i64_type llc |> return
+        | {ty=None;_} -> L.i64_type llc |> return
       end
     | Some (E _enum) -> failwith "todo enum"
     | Some (S (_,defn)) ->
       let _,f_types = List.split defn.fields in
       let* elts = ListM.map (fun ty -> aux (fst ty.value)) f_types <&> Array.of_list in
       begin
-      match type_by_name llm ("struct." ^ name) with 
+      match L.type_by_name llm ("struct." ^ name) with 
         | Some ty -> return ty 
-        | None -> (let ty = named_struct_type llc ("struct." ^ name) in
-          struct_set_body ty elts false; return ty)
+        | None -> (let ty = L.named_struct_type llc ("struct." ^ name) in
+        L.struct_set_body ty elts false; return 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
@@ -96,12 +96,13 @@ let getLLVMBasicType f ty llc llm  : lltype E.t =
 let llvm_proto_of_method_sig (m:method_sig) env llc llm = 
   let* llvm_rt = match m.rtype with
   | Some t -> getLLVMType env t llc llm
-  | None -> void_type llc |> return
+  | None -> L.void_type llc |> return
   in
   let+ args_type = ListM.map (fun ({ty;_}: param) -> getLLVMType env ty llc llm) m.params <&> Array.of_list in
-  let method_t = if m.variadic then var_arg_function_type else function_type in
+  let method_t = if m.variadic then L.var_arg_function_type else L.function_type in
   let name = if not (m.extern || m.name = "main") then Fmt.str "_%s_%s" (DeclEnv.get_name env) m.name else m.name in 
-  declare_function name (method_t llvm_rt args_type ) llm
+  let ty = method_t llvm_rt args_type in 
+  ty,L.declare_function name ty llm
 
 let collect_monos (sm: in_body SailModule.t) = 
   let open SailModule.DeclEnv in
@@ -145,14 +146,14 @@ let get_declarations (sm: in_body SailModule.t) llc llm : DeclEnv.t E.t =
         else
           false,m.m_proto
         in
-      let* llproto = llvm_proto_of_method_sig proto env llc llm 
+      let* llty,llproto = llvm_proto_of_method_sig proto env llc llm 
       in        
       let m_body = 
         if is_import then 
           Either.left (m.m_proto.name,[])  (* decls body from imports are opaque *)
         else m.m_body 
       in
-      DeclEnv.add_decl m.m_proto.name {extern; defn = {m with m_body}; llval=llproto} Method d
+      DeclEnv.add_decl m.m_proto.name {extern; defn = {m with m_body}; llval=llproto; llty} Method d
     ) env methods
   in
 
@@ -168,10 +169,10 @@ let get_declarations (sm: in_body SailModule.t) llc llm : DeclEnv.t E.t =
     SEnv.fold (fun acc (name,(_,defn)) -> 
       let _,f_types = List.split defn.fields in
       let* elts = ListM.map (fun ty-> _getLLVMType sm.declEnv (fst ty.value) llc llm) f_types <&> Array.of_list in
-      let ty = match type_by_name llm ("struct." ^ name) with 
+      let ty = match L.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
+        | None -> let ty = L.named_struct_type llc ("struct." ^ name) in
+          L.struct_set_body ty elts false; ty
     in
       DeclEnv.add_decl name {defn;ty} Struct acc
     ) write_env structs

src/codegen/codegenUtils.ml

@@ -18,7 +18,7 @@ let getLLVMLiteral (l:literal) (llvm:llvm_args) : llvalue =
   | LInt i -> const_int_of_string (integer_type llvm.c i.size) (Z.to_string i.l) 10
   | LFloat f -> const_float (double_type llvm.c) f
   | LChar c -> const_int (i8_type llvm.c) (Char.code c)
-  | LString s -> build_global_stringptr  s ".str" llvm.b
+  | LString s -> let s = build_global_stringptr  s ".str" llvm.b in build_pointercast s (pointer_type2 llvm.c) "" llvm.b
 
 let ty_of_alias(ty:sailtype) env : sailtype  =
   match ty.value with
@@ -93,7 +93,7 @@ let toLLVMArgs (args: param list ) (env:DeclEnv.t) (llvm:llvm_args) : (bool * sa
 
 
 let get_memcpy_intrinsic llvm = 
-  let args_type = [|i8_type llvm.c |> pointer_type; i8_type llvm.c |> pointer_type ; i64_type llvm.c; i1_type llvm.c|] in
+  let args_type = [|pointer_type2 llvm.c;  pointer_type2 llvm.c; i64_type llvm.c; i1_type llvm.c|] in
 
   let f = declare_function "llvm.memcpy.p0i8.p0i8.i64" (function_type (void_type llvm.c) args_type ) llvm.m in
   f

src/codegen/codegen_.ml

@@ -13,29 +13,36 @@ let rec eval_l (venv,tenv as env:SailEnv.t* Env.TypeEnv.t) (llvm:llvm_args) (exp
   | Variable x -> 
     let+ _,v = match (SailEnv.get_var x venv) with 
       | Some (_,n) -> return n 
-      | None -> E.throw Logging.(make_msg dummy_pos @@ Fmt.str "var '%s' not found" x)
+      | None -> E.throw Logging.(make_msg exp.tag.loc @@ Fmt.str "var '%s' not found" x)
     in v
 
   | Deref x -> eval_r env llvm x
 
   | ArrayRead a -> 
     let* array_val = eval_l env llvm a.array in
+    let* llty = 
+      Env.TypeEnv.get_from_id (mk_locatable a.array.tag.loc  a.array.tag.ty) tenv >>= fun t -> 
+        getLLVMType (snd venv) t llvm.c llvm.m in 
     let+ index = eval_r env llvm a.idx in
-    let llvm_array = L.build_in_bounds_gep array_val [|L.(const_int (i64_type llvm.c) 0 ); index|] "" llvm.b in 
+    let llvm_array = L.build_in_bounds_gep2 llty array_val [|L.(const_int (i64_type llvm.c) 0 ); index|] "" llvm.b in 
     llvm_array
 
   | StructRead2 s -> 
     let* st = eval_l env llvm s.value.strct in
+    let* llty = 
+      Env.TypeEnv.get_from_id (mk_locatable s.value.strct.tag.loc  s.value.strct.tag.ty) tenv >>= fun t -> 
+        getLLVMType (snd venv) t llvm.c llvm.m in 
+
     let* st_type_name = Env.TypeEnv.get_from_id (mk_locatable s.value.strct.tag.loc s.value.strct.tag.ty) tenv >>= function  
       | {value=CompoundType c;_} -> return c.name.value
-      | _ -> E.throw Logging.(make_msg dummy_pos "problem with structure type") 
+      | _ -> E.throw Logging.(make_msg exp.tag.loc "problem with structure type") 
     in 
     let+ decl = (SailEnv.get_decl st_type_name (Specific (s.import.value,Struct)) venv 
                 |> E.throw_if_none Logging.(make_msg exp.tag.loc @@ Fmt.str "compiler error : no decl '%s' found" st_type_name)) in
 
     let fields = decl.defn.fields in
     let {value=_,idx;_} = List.assoc s.value.field.value fields in 
-    L.build_struct_gep st idx "" llvm.b
+    L.build_struct_gep2 llty st idx "" llvm.b
 
   | StructAlloc2 s -> 
     let _,fieldlist = s.value.fields |> List.split in
@@ -47,7 +54,7 @@ let rec eval_l (venv,tenv as env:SailEnv.t* Env.TypeEnv.t) (llvm:llvm_args) (exp
     let struct_v = L.build_alloca strct_ty "" llvm.b in 
     let+ () = ListM.iteri ( fun i f ->
       let+ v = eval_r env llvm f.value in
-      let v_f = L.build_struct_gep struct_v i "" llvm.b in
+      let v_f = L.build_struct_gep2 (L.pointer_type2 llvm.c) struct_v i "" llvm.b in
       L.build_store v v_f llvm.b |> ignore
       ) fieldlist in
     struct_v
@@ -58,8 +65,9 @@ let rec eval_l (venv,tenv as env:SailEnv.t* Env.TypeEnv.t) (llvm:llvm_args) (exp
 
 and eval_r (venv,tenv as env:SailEnv.t* Env.TypeEnv.t) (llvm:llvm_args) (exp:MirAst.expression) : L.llvalue E.t = 
   let* ty = Env.TypeEnv.get_from_id (mk_locatable exp.tag.loc exp.tag.ty) tenv in
+  let* llty = getLLVMType (snd venv) ty llvm.c llvm.m in 
   match exp.node with
-  | Variable _ | StructRead2 _ | ArrayRead _ | StructAlloc2 _ ->  let+ v = eval_l env llvm exp in L.build_load v "" llvm.b
+  | Variable _ | StructRead2 _ | ArrayRead _ | StructAlloc2 _ ->  let+ v = eval_l env llvm exp in L.build_load2 llty v "" llvm.b
 
   | Literal l -> return @@ getLLVMLiteral l llvm
 
@@ -71,7 +79,7 @@ and eval_r (venv,tenv as env:SailEnv.t* Env.TypeEnv.t) (llvm:llvm_args) (exp:Mir
       in binary bop.op (ty_of_alias ty (snd venv)) l1 l2 llvm.b  
   | Ref (_,e) -> eval_l env llvm e
 
-  | Deref e -> let+ v = eval_l env llvm e in L.build_load v "" llvm.b
+  | Deref e -> let+ v = eval_l env llvm e in L.build_load2 llty v "" llvm.b
 
   | ArrayStatic elements -> 
     begin
@@ -84,7 +92,7 @@ and eval_r (venv,tenv as env:SailEnv.t* Env.TypeEnv.t) (llvm:llvm_args) (exp:Mir
     L.set_linkage L.Linkage.Private array;
     L.set_unnamed_addr true array;
     L.set_global_constant true array;
-    L.build_load array "" llvm.b
+    L.build_load2 llty array "" llvm.b
     end
 
   | EnumAlloc _ -> E.throw Logging.(make_msg exp.tag.loc "enum allocation unimplemented") 
@@ -96,14 +104,15 @@ and construct_call (name:string) (mname:l_str) (args:MirAst.expression list) (ve
   (* let mname = mangle_method_name name origin.mname args_type in  *)
   let mangled_name = "_" ^ mname.value ^ "_" ^ name in 
   Logs.debug (fun m -> m "constructing call to %s" name);
-  let* llval,ext = match SailEnv.get_decl mangled_name (Specific (mname.value,Method)) venv with 
+
+  let* llval,ext,llty = match SailEnv.get_decl mangled_name (Specific (mname.value,Method)) venv with 
     | None ->   
       begin
       match SailEnv.get_decl name (Specific (mname.value,Method)) venv with 
-      | Some {llval;extern;_} -> return (llval,extern)
+      | Some d -> return (d.llval,d.extern,d.llty)
       | None -> E.throw Logging.(make_msg mname.loc @@ Printf.sprintf "implementation of %s not found" mangled_name ) 
       end
-    | Some {llval;extern;_} -> return (llval,extern)
+    | Some d -> return (d.llval,d.extern,d.llty)
   in
 
   let+ args = 
@@ -122,7 +131,7 @@ and construct_call (name:string) (mname:l_str) (args:MirAst.expression list) (ve
     else 
       return llargs 
   in
-  L.build_call llval (Array.of_list args) "" llvm.b
+  L.build_call2 llty llval (Array.of_list args) "" llvm.b
 
 open MirAst
 
@@ -218,7 +227,7 @@ let methodToIR (llc:L.llcontext) (llm:L.llmodule) (decl:Declarations.method_decl
     Logs.info (fun m -> m "codegen of %s" name);
     let builder = L.builder llc in
     let llvm = {b=builder; c=llc ; m = llm; layout=Llvm_target.DataLayout.of_string (L.data_layout llm)} in
-    let* () = E.throw_if Logging.(make_msg dummy_pos @@ "redefinition of function " ^  name) (L.block_begin decl.llval <> At_end decl.llval) in
+    let* () = E.throw_if Logging.(make_msg decl.defn.m_proto.pos @@ "redefinition of function " ^  name) (L.block_begin decl.llval <> At_end decl.llval) in
     let bb = L.append_block llvm.c "" decl.llval in
     L.position_at_end bb llvm.b;
 

src/passes/process/process.ml

@@ -88,7 +88,7 @@ module Pass = Pass.Make(struct
         let* m = M.throw_if_none Logging.(make_msg dummy_pos "need main process") 
                                   (List.find_opt (fun p -> p.p_name = Constants.main_process) procs) 
         in 
-        let (pi: _ proc_init) = {mloc=None; read = []; write = [] ; params = [] ; id = Constants.main_process ; proc = Constants.main_process} in
+        let (pi: _ proc_init) = {mloc=Some (mk_locatable dummy_pos Constants.sail_module_self); read = []; write = [] ; params = [] ; id = Constants.main_process ; proc = Constants.main_process} in
         let* body = compute_tree FieldSet.empty (dummy_pos,pi) in 
         let+ () = M.write_loop body in m
       ) |> M.run sm.declEnv >>| finalize