From 4999c381ed0cd2ee2d363be98b9acd85584c3197 Mon Sep 17 00:00:00 2001 From: Tobias Mock Date: Fri, 20 Oct 2023 17:56:40 +0200 Subject: [PATCH] Handle struct types more generally by using `is_struct` instead of hardcoding for (some) struct types. Also get rid off `const_param` bool, we don't need it anymore. Instead, handling of const globals and constexpr things is unified. Constexpr mutable globals are still missing though --- lib/codegen/codegen.ml | 27 ++++++++------------------- lib/codegen/helpers.ml | 18 ++++++++++-------- lib/codegen/llvm_types.ml | 9 +-------- 3 files changed, 19 insertions(+), 35 deletions(-) diff --git a/lib/codegen/codegen.ml b/lib/codegen/codegen.ml index eeced335..1e03a654 100644 --- a/lib/codegen/codegen.ml +++ b/lib/codegen/codegen.ml @@ -34,7 +34,7 @@ end = struct let start_index, alloca = match ret_t with - | (Trecord _ | Tvariant _ | Tfun _) as t -> ( + | t when is_struct t -> ( match pkind_of_typ false t with | Boxed -> (* Whenever the return type is boxed, we add the prealloc to the environment *) @@ -63,7 +63,8 @@ end = struct (* If we want to return a struct, we copy the struct to its ptr (1st parameter) and return void *) match ret.typ with - | (Trecord _ | Tvariant _ | Tfun _) as t -> ( + | Tpoly _ -> () + | t when is_struct t -> ( match pkind_of_typ false t with | Boxed -> (* Since we only have POD records, we can safely memcpy here *) @@ -77,9 +78,7 @@ end = struct in let finalize = Some fun_finalize in - let param = - { vars = tvars; alloca; finalize; rec_block; const_pass = false } - in + let param = { vars = tvars; alloca; finalize; rec_block } in let ret = gen_expr param abs.body in (match recursive with @@ -493,7 +492,7 @@ end = struct let value, lltyp = match ret_t with - | (Trecord _ | Tvariant _ | Tfun _) as t -> ( + | t when is_struct t -> ( let lltyp = get_lltype_def ret_t in match pkind_of_typ false t with | Boxed -> @@ -526,7 +525,7 @@ end = struct let start_index, ret = match func.typ with - | Tfun (_, (Trecord _ as r), _) | Tfun (_, (Tvariant _ as r), _) -> ( + | Tfun (_, r, _) when is_struct r -> ( match pkind_of_typ false r with | Boxed -> (1, r) | Unboxed size -> (0, type_unboxed size)) @@ -559,10 +558,7 @@ end = struct List.iter store_arg margs; let lltyp = - (* TODO record *) - match ret with - | Trecord _ | Tvariant _ -> get_lltype_def ret_t - | t -> get_lltype_param false t + if is_struct ret then get_lltype_def ret_t else get_lltype_param false ret in let value = Llvm.build_br rec_block.rec_ builder in @@ -879,13 +875,6 @@ end = struct ignore (Llvm.build_store value record builder); (record, Const_ptr)) else (value, Const) - (* | Const -> *) - (* let values = *) - (* List.map (fun (_, expr) -> (gen_expr param expr).value) labels *) - (* |> Array.of_list *) - (* in *) - (* let ret = Llvm.const_named_struct lltyp values in *) - (* (ret, Const) *) in let v = { value; typ; lltyp; kind } in @@ -1133,7 +1122,7 @@ and Auto : Autogen_intf.S = Autogen.Make (T) (H) (Ar) let fill_constants constants = let f (name, tree, toplvl) = - let init = Core.gen_expr { no_param with const_pass = true } tree in + let init = Core.gen_expr no_param tree in (* We only add records to the global table, because they are expected as ptrs. For ints or floats, we just return the immediate value *) let init = diff --git a/lib/codegen/helpers.ml b/lib/codegen/helpers.ml index 9a402eb7..911d7301 100644 --- a/lib/codegen/helpers.ml +++ b/lib/codegen/helpers.ml @@ -109,10 +109,12 @@ struct let bb = Llvm.build_bitcast let default_kind = function + | t when is_struct t -> Ptr | Tint | Tbool | Tfloat | Tu8 | Ti32 | Tf32 | Tunit | Traw_ptr _ | Tarray _ -> Imm - | Trecord _ | Tvariant _ | Tfun _ | Tpoly _ | Tfixed_array _ -> Ptr + | Trecord _ | Tvariant _ | Tfun _ | Tpoly _ | Tfixed_array _ -> + failwith "unreachable" let bring_default value = if is_struct value.typ then value.value @@ -304,7 +306,7 @@ struct let set_struct_field value ptr = match value.typ with - | Trecord _ | Tvariant _ | Tfun _ -> + | t when is_struct t -> if value.value <> ptr then let size = sizeof_typ value.typ |> llval_of_size in memcpy ~dst:ptr ~src:value ~size @@ -547,7 +549,7 @@ struct if mut then tailrec_store ~src ~dst else store_or_copy ~src ~dst in match src.typ with - | Trecord _ | Tvariant _ | Tfun _ -> + | t when is_struct t -> let typ = get_lltype_def src.typ |> m in let dst = Llvm.build_alloca typ "" builder in store dst; @@ -665,16 +667,16 @@ struct let fun_return name ret = match ret.typ with - | (Trecord _ | Tvariant _ | Tfun _) as t -> ( + | Tpoly id when String.equal id "tail" -> + (* This magic id is used to mark a tailrecursive call *) + Llvm.build_ret_void builder + | Tpoly _ -> failwith "Internal Error: Generic return" + | t when is_struct t -> ( match pkind_of_typ false t with | Boxed -> (* Default record case *) Llvm.build_ret_void builder | Unboxed kind -> let unboxed, _ = unbox_record ~kind ~ret:true ret in Llvm.build_ret unboxed builder) - | Tpoly id when String.equal id "tail" -> - (* This magic id is used to mark a tailrecursive call *) - Llvm.build_ret_void builder - | Tpoly _ -> failwith "Internal Error: Generic return" | Tunit -> if String.equal name "main" then Llvm.(build_ret (const_int int_t 0)) builder diff --git a/lib/codegen/llvm_types.ml b/lib/codegen/llvm_types.ml index 5b0e8aa8..eac4f818 100644 --- a/lib/codegen/llvm_types.ml +++ b/lib/codegen/llvm_types.ml @@ -18,17 +18,10 @@ type param = { alloca : Llvm.llvalue option; finalize : (llvar -> unit) option; rec_block : rec_block option; - const_pass : bool; } let no_param = - { - vars = Vars.empty; - alloca = None; - finalize = None; - rec_block = None; - const_pass = false; - } + { vars = Vars.empty; alloca = None; finalize = None; rec_block = None } let context = Llvm.global_context () let the_module = Llvm.create_module context "context"