From b024d91920eb9c37fbaba5645291c65268ec57dc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?T=C3=A9rence=20Clastres?= Date: Wed, 6 Sep 2023 01:13:53 +0200 Subject: [PATCH] update to LLVM 15 & OCaml 5.1.0 --- .github/workflows/build.yml | 13 ++++---- bin/dune | 5 ++- dune-project | 7 +++-- sail-pl.opam | 6 ++-- src/codegen/codegenEnv.ml | 59 ++++++++++++++++++----------------- src/codegen/codegenUtils.ml | 4 +-- src/codegen/codegen_.ml | 35 +++++++++++++-------- src/passes/process/process.ml | 2 +- 8 files changed, 72 insertions(+), 59 deletions(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index c2bc86c..8ee9058 100644 --- a/.github/workflows/build.yml +++ b/.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 diff --git a/bin/dune b/bin/dune index 4826ea5..bd40c2b 100755 --- a/bin/dune +++ b/bin/dune @@ -8,6 +8,9 @@ fmt fmt.tty fmt.cli + ctypes.foreign logs.cli ) - (public_name sailor)) + (public_name sailor) + (modes byte exe) +) diff --git a/dune-project b/dune-project index f4fc6cd..f44944d 100644 --- a/dune-project +++ b/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 )) diff --git a/sail-pl.opam b/sail-pl.opam index 5f0db52..ebfbf8a 100644 --- a/sail-pl.opam +++ b/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} ] diff --git a/src/codegen/codegenEnv.ml b/src/codegen/codegenEnv.ml index f1dc565..bda04d0 100644 --- a/src/codegen/codegenEnv.ml +++ b/src/codegen/codegenEnv.ml @@ -1,10 +1,10 @@ -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) @@ -12,8 +12,8 @@ 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 @@ -21,10 +21,10 @@ 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,18 +34,18 @@ 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;_} -> @@ -53,13 +53,13 @@ let getLLVMBasicType f ty llc llm : lltype E.t = 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 diff --git a/src/codegen/codegenUtils.ml b/src/codegen/codegenUtils.ml index 8cf2fe4..507df51 100644 --- a/src/codegen/codegenUtils.ml +++ b/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 \ No newline at end of file diff --git a/src/codegen/codegen_.ml b/src/codegen/codegen_.ml index 93285e3..51aa99a 100644 --- a/src/codegen/codegen_.ml +++ b/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; diff --git a/src/passes/process/process.ml b/src/passes/process/process.ml index 609ecaa..e5cc6ba 100644 --- a/src/passes/process/process.ml +++ 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