diff --git a/docs/haven.ebnf b/docs/haven.ebnf index 5851a54..ea2714a 100644 --- a/docs/haven.ebnf +++ b/docs/haven.ebnf @@ -7,6 +7,7 @@ top_decl ::= import | foreign_block | fn_decl | tydecl + | extend_decl | global_decl import ::= 'import' STRING ';' @@ -39,6 +40,12 @@ type_body ::= type | struct_decl | enum_decl +extend_decl ::= 'extend' IDENT 'with' '{' extend_item* '}' +extend_item ::= 'construct' block + | 'construct' '(' param_list? ')' block + | 'destruct' block +param_list ::= param (',' param)* + struct_decl ::= 'struct' '{' struct_field+ '}' struct_field ::= type IDENT ';' diff --git a/docs/language.md b/docs/language.md index 58f59f9..23b7e52 100644 --- a/docs/language.md +++ b/docs/language.md @@ -253,6 +253,34 @@ fn example() -> i32 { } ``` +`box` also supports type-directed construction: + +``` +type Buffer = struct { + i32 len; + i32 cap; +}; + +extend Buffer with { + construct(i32 cap) { + self->len = 0; + self->cap = cap; + } +} + +fn example() -> i32 { + let mut boxed = box Buffer(64); + let value = unbox boxed; + boxed = nil; + value.cap +} +``` + +`box T` allocates storage for `T`, recursively default-initializes its members, and then runs a zero-argument +constructor if `T` defines one. `box T(args...)` performs the same recursive default initialization, then calls +`construct` with the supplied arguments. This means member pointers are `nil` and inline subobjects are already in a +known state before `construct` runs. + Box types are written much like pointers, but using a caret (`^`) instead of an asterisk (`*`): @@ -319,6 +347,32 @@ declarations will also be automatically marked `pub` and `impure`, simplifying t Type declarations (`type X = ...`) may only appear at the file scope. +### Type Extensions + +Type extensions attach behavior to an existing type without changing its layout. + +``` +extend Buffer with { + construct(i32 cap) { + self->len = 0; + self->cap = cap; + } + + destruct { + self->len = 0; + } +} +``` + +In the current model, `extend` is behavioral only: + +- `construct(...) { ... }` defines an optional constructor hook. +- `destruct { ... }` defines an optional destructor hook. +- `self` is provided implicitly inside both hooks and is pointer-like, so fields are accessed with `self->field`. + +Constructors run automatically after recursive default-initialization. Destructors run automatically when the final +boxed reference is released. `extend` does not add fields or change ABI layout. + ### Variable Declarations #### File Scope diff --git a/docs/syntax.md b/docs/syntax.md index 2889560..40af872 100644 --- a/docs/syntax.md +++ b/docs/syntax.md @@ -28,6 +28,7 @@ top_decl ::= import | foreign_block | fn_decl | tydecl + | extend_decl | global_decl ``` @@ -47,6 +48,17 @@ referenced by: * top_decl +**extend_decl:** + +``` +extend_decl + ::= 'extend' IDENT 'with' '{' extend_item* '}' +``` + +referenced by: + +* top_decl + **cimport:** ![cimport](diagram/cimport.svg) @@ -259,6 +271,30 @@ referenced by: * tydecl +**extend_item:** + +``` +extend_item + ::= 'construct' block + | 'construct' '(' param_list? ')' block + | 'destruct' block +``` + +referenced by: + +* extend_decl + +**param_list:** + +``` +param_list + ::= param ( ',' param )* +``` + +referenced by: + +* extend_item + **struct_decl:** ![struct_decl](diagram/struct_decl.svg) diff --git a/examples/construct_box.hv b/examples/construct_box.hv new file mode 100644 index 0000000..36a6c6e --- /dev/null +++ b/examples/construct_box.hv @@ -0,0 +1,22 @@ +type Buffer = struct { + i32 len; + i32 cap; +}; + +extend Buffer with { + construct(i32 cap) { + self->len = 0; + self->cap = cap; + } + + destruct { + self->len = 0; + } +} + +pub impure fn main() -> i32 { + let mut boxed = box Buffer(64); + let value = unbox boxed; + boxed = nil; + value.cap +} diff --git a/src/bin/lsp/document_structure.ml b/src/bin/lsp/document_structure.ml index bf26ccd..a3adb3a 100644 --- a/src/bin/lsp/document_structure.ml +++ b/src/bin/lsp/document_structure.ml @@ -65,7 +65,7 @@ let folding_ranges (parsed : Cst.parsed_program) = let structural = Locate.nodes_matching (function - | Locate.Block _ | StructDecl _ | EnumDecl _ | Foreign _ -> true + | Locate.Block _ | StructDecl _ | EnumDecl _ | Foreign _ | TypeExtend _ -> true | _ -> false) parsed.program |> List.filter_map (fun node -> @@ -78,6 +78,8 @@ let folding_ranges (parsed : Cst.parsed_program) = folding_range ~kind:FoldingRangeKind.Region enum_decl.loc | Foreign foreign -> folding_range ~kind:FoldingRangeKind.Region foreign.loc + | TypeExtend ext -> + folding_range ~kind:FoldingRangeKind.Region ext.loc | _ -> None) in diff --git a/src/bin/lsp/document_symbols.ml b/src/bin/lsp/document_symbols.ml index be8a401..1c60198 100644 --- a/src/bin/lsp/document_symbols.ml +++ b/src/bin/lsp/document_symbols.ml @@ -59,6 +59,34 @@ let variant_symbol (variant : Cst.enum_variant) = ~selection_range:(Lsp_helpers.loc_to_range variant.value.name.loc) ?detail:(variant_detail variant) () +let extend_item_symbol (item : Cst.extend_item) = + match item.value with + | Cst.ExtendConstruct construct -> + make_symbol ~kind:SymbolKind.Constructor ~name:"construct" + ~range:(Lsp_helpers.loc_to_range item.loc) + ~selection_range:(Lsp_helpers.loc_to_range construct.loc) + ?detail: + (Some + (Printf.sprintf "(%s)" + (String.concat ", " + (List.map + (fun (param : Cst.param) -> type_text param.value.ty) + construct.value.params)))) + () + | Cst.ExtendDestruct block -> + make_symbol ~kind:SymbolKind.Method ~name:"destruct" + ~range:(Lsp_helpers.loc_to_range item.loc) + ~selection_range:(Lsp_helpers.loc_to_range block.loc) () + +let extend_symbol (ext : Cst.type_extend) = + make_symbol + ~kind:SymbolKind.Object + ~name:(Printf.sprintf "extend %s" ext.value.target.value) + ~range:(Lsp_helpers.loc_to_range ext.loc) + ~selection_range:(Lsp_helpers.loc_to_range ext.value.target.loc) + ~children:(List.map extend_item_symbol ext.value.items) + () + let function_symbol (fn : Cst.function_decl) = make_symbol ~kind:SymbolKind.Function ~name:fn.value.name.value ~range:(Lsp_helpers.loc_to_range fn.loc) @@ -102,6 +130,8 @@ let symbols_for_program (parsed : Cst.parsed_program) = [ variable_symbol var_decl ] | Cst.TDecl type_decl -> [ type_symbol type_decl ] + | Cst.Extend ext -> + [ extend_symbol ext ] | Cst.Foreign foreign -> List.map function_symbol foreign.value.decls | Cst.Import _ | Cst.CImport _ -> diff --git a/src/bin/lsp/inlay_hints.ml b/src/bin/lsp/inlay_hints.ml index 100619c..ded5cf2 100644 --- a/src/bin/lsp/inlay_hints.ml +++ b/src/bin/lsp/inlay_hints.ml @@ -46,6 +46,10 @@ let rec walk_expression typing type_env query_range acc (expr : Core.expression) acc | ToBool inner | SizeExpr inner | BoxExpr inner | Unbox inner | Ref inner | Load inner -> walk_expression typing type_env query_range acc inner + | BoxConstruct box -> + List.fold_left + (walk_expression typing type_env query_range) + acc box.value.args | Initializer init -> List.fold_left (walk_expression typing type_env query_range) diff --git a/src/bin/lsp/symbol_resolution.ml b/src/bin/lsp/symbol_resolution.ml index 722608a..ae915f2 100644 --- a/src/bin/lsp/symbol_resolution.ml +++ b/src/bin/lsp/symbol_resolution.ml @@ -476,6 +476,9 @@ and walk_expression state env (expr : Core.expression) = | Nil -> () | ToBool inner | SizeExpr inner | BoxExpr inner | Unbox inner | Ref inner | Load inner -> walk_expression state env inner + | BoxConstruct box -> + walk_type state box.value.ty; + List.iter (walk_expression state env) box.value.args | Initializer init -> List.iter (walk_expression state env) init.value.exprs | As cast -> @@ -774,6 +777,9 @@ let rec highlight_expression state env (expr : Core.expression) = | Nil -> () | ToBool inner | SizeExpr inner | BoxExpr inner | Unbox inner | Ref inner | Load inner -> highlight_expression state env inner + | BoxConstruct box -> + highlight_type state box.value.ty; + List.iter (highlight_expression state env) box.value.args | Initializer init -> List.iter (highlight_expression state env) init.value.exprs | As cast -> diff --git a/src/lib/ast/analysis_asserts.ml b/src/lib/ast/analysis_asserts.ml index e09b443..33aa414 100644 --- a/src/lib/ast/analysis_asserts.ml +++ b/src/lib/ast/analysis_asserts.ml @@ -125,6 +125,9 @@ module Assert = struct | Core.Match _ -> "match { ... }" | Core.BoxExpr inner -> "box " ^ render_expression ~ctx_prec:11 inner | Core.BoxType _ -> "box " + | Core.BoxConstruct box -> + Printf.sprintf "box (%s)" + (String.concat ", " (List.map render_expression box.value.args)) | Core.Unbox inner -> "unbox " ^ render_expression ~ctx_prec:11 inner | Core.Ref inner -> "ref " ^ render_expression ~ctx_prec:11 inner | Core.Load inner -> "load " ^ render_expression ~ctx_prec:11 inner @@ -197,6 +200,12 @@ module Assert = struct Printf.sprintf "%s := %s" (render_specialized_expression state write.value.target) (render_specialized_expression state write.value.value) + | Core.BoxConstruct box -> + Printf.sprintf "box (%s)" + (String.concat ", " + (List.map + (fun expr -> render_specialized_expression state expr) + box.value.args)) | (Core.Literal _ | Core.Identifier _ | Core.Block _ | Core.Initializer _ | Core.Match _ | Core.BoxType _ | Core.SizeType _ | Core.Nil) -> render_expression ~ctx_prec expr diff --git a/src/lib/ast/analysis_cfold.ml b/src/lib/ast/analysis_cfold.ml index 312a489..78564f0 100644 --- a/src/lib/ast/analysis_cfold.ml +++ b/src/lib/ast/analysis_cfold.ml @@ -250,6 +250,12 @@ module ConstantFold = struct }; } | Core.BoxExpr inner -> Core.BoxExpr (fold_expression inner) + | Core.BoxConstruct box -> + Core.BoxConstruct + { + box with + value = { box.value with args = List.map fold_expression box.value.args }; + } | Core.Unbox inner -> Core.Unbox (fold_expression inner) | Core.Ref inner -> Core.Ref (fold_expression inner) | Core.Load inner -> Core.Load (fold_expression inner) @@ -279,11 +285,14 @@ module ConstantFold = struct | Core.Assign write -> Core.Assign (fold_write write) | Core.Mutate write -> Core.Mutate (fold_write write) | Core.Literal literal -> Core.Literal (fold_literal literal) - | (Core.Identifier _ | Core.SizeType _ | Core.Nil | Core.BoxType _) as value -> value + | (Core.Identifier _ | Core.SizeType _ | Core.Nil | Core.BoxType _) as value -> + value in let expr = { expr with value } in match expr.value with - | Core.Literal _ | Core.Identifier _ | Core.Nil | Core.SizeType _ | Core.BoxType _ -> expr + | Core.Literal _ | Core.Identifier _ | Core.Nil | Core.SizeType _ | Core.BoxType _ + | Core.BoxConstruct _ -> + expr | Core.Block block when block.value.statements = [] -> ( match block.value.result with Some result -> result | None -> expr) | Core.ToBool inner -> ( diff --git a/src/lib/ast/analysis_cleanup.ml b/src/lib/ast/analysis_cleanup.ml index b0d50fb..1c031c3 100644 --- a/src/lib/ast/analysis_cleanup.ml +++ b/src/lib/ast/analysis_cleanup.ml @@ -90,6 +90,12 @@ module Cleanup = struct }; } | Core.BoxExpr inner -> Core.BoxExpr (clean_expression typed inner) + | Core.BoxConstruct box -> + Core.BoxConstruct + { + box with + value = { box.value with args = List.map (clean_expression typed) box.value.args }; + } | Core.Unbox inner -> Core.Unbox (clean_expression typed inner) | Core.Ref inner -> Core.Ref (clean_expression typed inner) | Core.Load inner -> Core.Load (clean_expression typed inner) @@ -123,7 +129,7 @@ module Cleanup = struct | Core.Assign write -> clean_write_like typed (fun write -> Core.Assign write) write | Core.Mutate write -> clean_write_like typed (fun write -> Core.Mutate write) write | (Core.Identifier _ | Core.Literal _ | Core.SizeType _ | Core.Nil | Core.BoxType _) as - value -> + value -> value in { expr with value = cleaned_value } diff --git a/src/lib/ast/analysis_ownership.ml b/src/lib/ast/analysis_ownership.ml index 24671c9..816f063 100644 --- a/src/lib/ast/analysis_ownership.ml +++ b/src/lib/ast/analysis_ownership.ml @@ -199,7 +199,7 @@ module Ownership = struct else match expr.value with | Core.Nil -> () - | Core.BoxExpr _ | Core.BoxType _ -> () + | Core.BoxExpr _ | Core.BoxType _ | Core.BoxConstruct _ -> () | Core.Call call -> emit_retains_for_expected_enum_call state reason expected call | Core.As cast -> emit_retains_for_transfer state reason expected cast.value.inner | Core.Block block -> @@ -264,6 +264,8 @@ module Ownership = struct let rec visit_expression state scopes (expr : Core.expression) = match expr.value with | Core.Identifier _ | Core.Nil | Core.SizeType _ | Core.BoxType _ -> () + | Core.BoxConstruct box -> + List.iter (visit_expression state scopes) box.value.args | Core.Literal literal -> ( match literal.value with | Core.Vector vec -> diff --git a/src/lib/ast/analysis_purity.ml b/src/lib/ast/analysis_purity.ml index 99479a5..4da5459 100644 --- a/src/lib/ast/analysis_purity.ml +++ b/src/lib/ast/analysis_purity.ml @@ -91,6 +91,8 @@ module Purity = struct let visit = visit_expression state current in match expr.value with | Core.Identifier _ | Core.Literal _ | Core.SizeType _ | Core.BoxType _ | Core.Nil -> () + | Core.BoxConstruct box -> + List.iter (visit env) box.value.args | Core.ToBool inner | Core.SizeExpr inner | Core.BoxExpr inner diff --git a/src/lib/ast/analysis_semantic.ml b/src/lib/ast/analysis_semantic.ml index 2c476f8..3d2e463 100644 --- a/src/lib/ast/analysis_semantic.ml +++ b/src/lib/ast/analysis_semantic.ml @@ -521,6 +521,8 @@ module Semantic = struct | _ -> ()) | Core.BoxExpr inner -> check_expression state env loop_depth inner + | Core.BoxConstruct box -> + List.iter (check_expression state env loop_depth) box.value.args | Core.Unbox inner -> check_expression state env loop_depth inner; (match expr_resolved_type state inner with @@ -751,14 +753,15 @@ module Semantic = struct if not (is_lvalue write.value.target) then add_diagnostic state Error expr.loc "assignment target must be assignable"; - Option.iter - (fun name -> - match lookup env name with - | Some binding when not binding.is_mutable -> - add_diagnostic state Error expr.loc - (Printf.sprintf "assignment to immutable binding %s" name) - | _ -> ()) - (root_identifier_name write.value.target); + if assignment_requires_mutable_root write.value.target then + Option.iter + (fun name -> + match lookup env name with + | Some binding when not binding.is_mutable -> + add_diagnostic state Error expr.loc + (Printf.sprintf "assignment to immutable binding %s" name) + | _ -> ()) + (root_identifier_name write.value.target); (match ( expr_annotation state write.value.target, expr_annotation state write.value.value ) diff --git a/src/lib/ast/analysis_specialize.ml b/src/lib/ast/analysis_specialize.ml index 2456aff..1f5653e 100644 --- a/src/lib/ast/analysis_specialize.ml +++ b/src/lib/ast/analysis_specialize.ml @@ -235,6 +235,20 @@ module Specialize = struct } | Core.BoxExpr inner -> { expr with value = Core.BoxExpr (rewrite_expression state annotations inner) } + | Core.BoxConstruct box -> + { + expr with + value = + Core.BoxConstruct + { + box with + value = + { + box.value with + args = List.map (rewrite_expression state annotations) box.value.args; + }; + }; + } | Core.Unbox inner -> { expr with value = Core.Unbox (rewrite_expression state annotations inner) } | Core.Ref inner -> diff --git a/src/lib/ast/analysis_types.ml b/src/lib/ast/analysis_types.ml index 0b40d68..e0c696c 100644 --- a/src/lib/ast/analysis_types.ml +++ b/src/lib/ast/analysis_types.ml @@ -4,6 +4,8 @@ open Haven_core module Core = Core_ast module String_map = Map.Make (String) +let dummy_loc = { Loc.start_pos = Lexing.dummy_pos; end_pos = Lexing.dummy_pos } + type type_class = | TypeClassUnknown | TypeClassNumeric @@ -58,9 +60,14 @@ type resolved_ty = type type_decl_info = | TypeAlias of Core.haven_type - | TypeStruct of Core.struct_decl - | TypeEnum of Core.enum_decl - | TypeForward + | TypeStruct of Core.struct_decl * type_lifecycle + | TypeEnum of Core.enum_decl * type_lifecycle + | TypeForward of type_lifecycle + +and type_lifecycle = { + construct : Core.function_decl option; + destruct : Core.function_decl option; +} type type_env = type_decl_info String_map.t @@ -407,6 +414,7 @@ let rec core_type_of_resolved_ty loc = function }; loc; }) + | ResolvedGenericParam name -> mk_type loc (Core.CustomType { name = mk_identifier loc name }) | ResolvedNamed (name, []) -> mk_type loc (Core.CustomType { name = mk_identifier loc name }) | ResolvedNamed (name, args) -> @@ -420,8 +428,27 @@ let rec core_type_of_resolved_ty loc = function }; loc; }) - | ResolvedGenericParam name -> - mk_type loc (Core.CustomType { name = mk_identifier loc name }) + +let rec string_of_resolved_ty = function + | ResolvedInt (_, bits) -> Printf.sprintf "i%d" bits + | ResolvedFloat -> "float" + | ResolvedString -> "str" + | ResolvedVoid -> "void" + | ResolvedVec vec -> Printf.sprintf "vec%d" vec.dimension + | ResolvedMatrix mat -> Printf.sprintf "mat%dx%d" mat.rows mat.columns + | ResolvedVecHole -> "vec?" + | ResolvedMatrixHole -> "mat?" + | ResolvedPointer inner -> string_of_resolved_ty inner ^ "*" + | ResolvedBox inner -> string_of_resolved_ty inner ^ "^" + | ResolvedCell inner -> "cell<" ^ string_of_resolved_ty inner ^ ">" + | ResolvedArray (inner, count) -> + Printf.sprintf "%s[%d]" (string_of_resolved_ty inner) count + | ResolvedFunction _ -> "fn" + | ResolvedGenericParam name -> name + | ResolvedNamed (name, []) -> name + | ResolvedNamed (name, args) -> + Printf.sprintf "%s<%s>" name + (String.concat ", " (List.map string_of_resolved_ty args)) let resolved_is_bool = function ResolvedInt (Unsigned, 1) -> true | _ -> false @@ -556,18 +583,39 @@ let type_env_of_program (program : Core.program) = (fun env (decl : Core.top_decl) -> match decl.value with | Core.TDecl type_decl -> ( + let lifecycle = + { construct = type_decl.value.construct; destruct = type_decl.value.destruct } + in match type_decl.value.data with | Core.TypeDeclAlias ty -> String_map.add type_decl.value.name.value (TypeAlias ty) env | Core.TypeDeclStruct struct_decl -> - String_map.add type_decl.value.name.value (TypeStruct struct_decl) env + String_map.add type_decl.value.name.value (TypeStruct (struct_decl, lifecycle)) env | Core.TypeDeclEnum enum_decl -> - String_map.add type_decl.value.name.value (TypeEnum enum_decl) env + String_map.add type_decl.value.name.value (TypeEnum (enum_decl, lifecycle)) env | Core.TypeDeclForward -> - String_map.add type_decl.value.name.value TypeForward env) + String_map.add type_decl.value.name.value (TypeForward lifecycle) env) | _ -> env) String_map.empty program.value.decls +let lookup_type_lifecycle type_env name = + match String_map.find_opt name type_env with + | Some (TypeStruct (_, lifecycle)) + | Some (TypeEnum (_, lifecycle)) + | Some (TypeForward lifecycle) -> + Some lifecycle + | Some (TypeAlias _) | None -> None + +let lifecycle_user_params (fn_decl : Core.function_decl) = + match fn_decl.value.params.value.params with + | _self :: params -> params + | [] -> [] + +let lifecycle_has_default_construct (lifecycle : type_lifecycle) = + match lifecycle.construct with + | Some fn_decl -> lifecycle_user_params fn_decl = [] + | None -> true + let resolve_array_count (lit : Core.literal) = match lit.value with Core.Integer count when count >= 0 -> Some count | _ -> None @@ -598,7 +646,7 @@ let rec resolve_named_type type_env active subst loc name args = match String_map.find_opt name type_env with | Some (TypeAlias ty) when args = [] -> resolve_core_type type_env (name :: active) subst loc ty - | Some (TypeStruct _) | Some (TypeEnum _) | Some TypeForward -> + | Some (TypeStruct _) | Some (TypeEnum _) | Some (TypeForward _) -> Some (ResolvedNamed (name, args)) | Some (TypeAlias _) -> None | None -> None) @@ -661,6 +709,41 @@ and resolve_core_type type_env active subst loc (ty : Core.haven_type) = resolve_named_type type_env active subst loc templ.value.outer.value args | None -> None) +let rec resolved_default_constructible type_env = function + | ResolvedInt _ + | ResolvedFloat + | ResolvedString + | ResolvedVoid + | ResolvedVec _ + | ResolvedMatrix _ + | ResolvedVecHole + | ResolvedMatrixHole + | ResolvedPointer _ + | ResolvedBox _ + | ResolvedCell _ + | ResolvedFunction _ -> + true + | ResolvedGenericParam _ -> false + | ResolvedArray (inner, _) -> resolved_default_constructible type_env inner + | ResolvedNamed (name, _) -> ( + match String_map.find_opt name type_env with + | Some (TypeAlias ty) -> ( + match resolve_core_type type_env [] [] dummy_loc ty with + | Some resolved -> resolved_default_constructible type_env resolved + | None -> false) + | Some (TypeStruct (decl, lifecycle)) -> + lifecycle_has_default_construct lifecycle + && + List.for_all + (fun (field : Core.struct_field) -> + match resolve_core_type type_env [] [] field.loc field.value.ty with + | Some resolved -> resolved_default_constructible type_env resolved + | None -> false) + decl.value.fields + | Some (TypeEnum (_, lifecycle)) | Some (TypeForward lifecycle) -> + lifecycle_has_default_construct lifecycle + | None -> false) + let wider_numeric_type loc (left : Core.haven_type) (right : Core.haven_type) = match (left.value, right.value) with | Core.FloatType, _ | _, Core.FloatType -> float_type loc @@ -679,7 +762,7 @@ let rec lookup_enum_decl type_env loc ty = match ty with | ResolvedNamed (name, args) -> ( match lookup_named_type type_env name with - | Some (TypeEnum decl) -> + | Some (TypeEnum (decl, _)) -> Option.map (fun subst -> (decl, subst)) (zip_lists (List.map (fun (id : Core.identifier) -> id.value) decl.value.generics) args) @@ -714,7 +797,7 @@ let rec lookup_struct_fields type_env loc ty = match ty with | ResolvedNamed (name, _args) -> ( match lookup_named_type type_env name with - | Some (TypeStruct decl) -> + | Some (TypeStruct (decl, _)) -> let resolve_field (field : Core.struct_field) = Option.map (fun ty -> (field.value.name.value, ty)) @@ -762,7 +845,7 @@ let rec resolved_contains_box_ownership type_env active loc ty = | Some alias_ty -> resolved_contains_box_ownership type_env (name :: active) loc alias_ty | None -> false) - | Some (TypeStruct decl) -> + | Some (TypeStruct (decl, _)) -> List.exists (fun (field : Core.struct_field) -> match resolve_core_type type_env [] [] field.loc field.value.ty with @@ -771,7 +854,7 @@ let rec resolved_contains_box_ownership type_env active loc ty = field_ty | None -> false) decl.value.fields - | Some (TypeEnum decl) -> ( + | Some (TypeEnum (decl, _)) -> ( match lookup_enum_decl type_env loc resolved with | Some (_, subst) -> List.exists @@ -786,7 +869,7 @@ let rec resolved_contains_box_ownership type_env active loc ty = variant.value.inner_tys) decl.value.variants | None -> false) - | Some TypeForward | None -> false) + | Some (TypeForward _) | None -> false) let resolved_deref_once = function | ResolvedPointer inner | ResolvedBox inner | ResolvedCell inner -> Some inner @@ -823,3 +906,15 @@ let is_lvalue (expr : Core.expression) = | _ -> false in loop expr + +let assignment_requires_mutable_root (expr : Core.expression) = + let rec loop (expr : Core.expression) = + match expr.value with + | Core.Identifier _ -> true + | Core.Field field -> + if field.value.arrow then false else loop field.value.target + | Core.Index index -> loop index.value.target + | Core.Unbox _ | Core.Load _ -> false + | _ -> true + in + loop expr diff --git a/src/lib/ast/analysis_typing.ml b/src/lib/ast/analysis_typing.ml index af3527b..5b2ca74 100644 --- a/src/lib/ast/analysis_typing.ml +++ b/src/lib/ast/analysis_typing.ml @@ -418,6 +418,52 @@ module Typing = struct (resolve_core_type state.type_env [] [] expr.loc ty); metavar = metavar_of_type core_ty; } + | Core.BoxConstruct box -> + let core_ty = box_type expr.loc box.value.ty in + let resolved_inner = resolve_core_type state.type_env [] [] expr.loc box.value.ty in + let infer_constructor_args resolved_inner = + let lifecycle_name = + match resolved_inner with + | ResolvedNamed (name, _) -> name + | _ -> string_of_resolved_ty resolved_inner + in + match lookup_type_lifecycle state.type_env lifecycle_name with + | Some { construct = Some fn_decl; _ } -> + let params = lifecycle_user_params fn_decl in + List.iteri + (fun index (arg : Core.expression) -> + let expected = + nth_or_none + (List.map + (fun (param : Core.param) -> + resolve_core_type state.type_env [] [] param.loc param.value.ty) + params) + index + in + ignore (infer_value_expression state env ~expected_type:expected arg)) + box.value.args; + if List.length params <> List.length box.value.args then + add_diagnostic state Error expr.loc + (Printf.sprintf + "constructor for %s expects %d argument(s), but %d were provided" + (string_of_resolved_ty resolved_inner) + (List.length params) (List.length box.value.args)) + | _ -> + List.iter + (fun (arg : Core.expression) -> + ignore (infer_value_expression state env arg)) + box.value.args; + if box.value.args <> [] then + add_diagnostic state Error expr.loc + (Printf.sprintf "type %s does not define a constructor" + (string_of_resolved_ty resolved_inner)) + in + Option.iter infer_constructor_args resolved_inner; + { + inferred_type = Some core_ty; + resolved_type = Option.map (fun ty -> ResolvedBox ty) resolved_inner; + metavar = metavar_of_type core_ty; + } | Core.Unbox inner -> ( let inner_ann = infer_expression state env inner in match inner_ann.resolved_type with diff --git a/src/lib/ast/analysis_verify.ml b/src/lib/ast/analysis_verify.ml index f360cd4..4b08b01 100644 --- a/src/lib/ast/analysis_verify.ml +++ b/src/lib/ast/analysis_verify.ml @@ -42,6 +42,15 @@ module Verify = struct (Printf.sprintf "%s still has an unresolved expression type after typing" context)) + let verify_default_constructible state loc context ty = + match resolve_core_type state.type_env [] [] loc ty with + | Some resolved when resolved_default_constructible state.type_env resolved -> () + | Some resolved -> + add_diagnostic state Error loc + (Printf.sprintf "%s requires a default-constructible type, but %s is not" + context (string_of_resolved_ty resolved)) + | None -> () + let verify_binding_annotation state (binding : Core.let_stmt) = match binding_annotation state binding with | Some { resolved_type = Some _; _ } -> () @@ -97,8 +106,14 @@ module Verify = struct | Core.As cast -> verify_declared_type state cast.loc "cast target" cast.value.target_type; verify_expression state cast.value.inner - | Core.SizeType ty | Core.BoxType ty -> + | Core.SizeType ty -> verify_declared_type state expr.loc "embedded type expression" ty + | Core.BoxType ty -> + verify_declared_type state expr.loc "embedded type expression" ty; + verify_default_constructible state expr.loc "box type construction" ty + | Core.BoxConstruct box -> + verify_declared_type state expr.loc "embedded type expression" box.value.ty; + List.iter (verify_expression state) box.value.args | Core.Match match_expr -> verify_expression state match_expr.value.expr; List.iter @@ -181,6 +196,10 @@ module Verify = struct verify_declared_type state binding.loc (Printf.sprintf "global %s" binding.value.name.value) binding.value.ty; + if binding.value.init_expr = None then + verify_default_constructible state binding.loc + (Printf.sprintf "global %s default initialization" binding.value.name.value) + binding.value.ty; Option.iter (verify_expression state) binding.value.init_expr | Core.TDecl decl -> verify_type_decl state decl | Core.Import _ | Core.CImport _ -> () diff --git a/src/lib/ast/convert.ml b/src/lib/ast/convert.ml index ace75e8..362dec6 100644 --- a/src/lib/ast/convert.ml +++ b/src/lib/ast/convert.ml @@ -1,7 +1,9 @@ +open Haven_core + module Cst = Haven_cst.Cst module Surface = Surface_ast module Core = Core_ast -open Haven_core +module String_set = Set.Make (String) type block_context = [ `Statement | `Value ] @@ -9,9 +11,12 @@ type lowered_block_item = | LoweredStatement of Surface.statement | LoweredExpression of Surface.expression -type lowering_state = { mutable next_fresh : int } +type lowering_state = { + mutable next_fresh : int; + mutable known_types : String_set.t; +} -let fresh_state () = { next_fresh = 0 } +let fresh_state () = { next_fresh = 0; known_types = String_set.empty } let fresh_name st prefix = st.next_fresh <- st.next_fresh + 1; @@ -45,6 +50,13 @@ let mk_core_vec loc value : Core.vec_literal = { value; loc } let mk_core_mat loc value : Core.mat_literal = { value; loc } let mk_core_enum loc value : Core.enum_literal = { value; loc } let mk_core_iteration_hint loc value : Core.iteration_hint = { value; loc } + +type surface_extension_hooks = { + construct : Surface.lifecycle_construct option; + destruct : Surface.block option; + loc : Loc.t; +} + let default_iter_type loc = mk_core_type loc (Core.NumericType { Haven_token.Token.signedness = Haven_token.Token.Signed; bits = 32 }) @@ -103,6 +115,7 @@ and cst_top_decl_to_surface (decl : Cst.top_decl) : Surface.top_decl = | Cst.Import i -> Surface.Import { value = i.value; loc = i.loc } | Cst.CImport i -> Surface.CImport { value = i.value; loc = i.loc } | Cst.Foreign f -> Surface.Foreign (cst_foreign_to_surface f) + | Cst.Extend e -> Surface.Extend (cst_type_extend_to_surface e) in mk_surface decl.loc value @@ -162,11 +175,50 @@ and cst_var_decl_to_surface (decl : Cst.var_decl) : Surface.var_decl = in mk_surface decl.loc value +and cst_type_extend_to_surface (ext : Cst.type_extend) : Surface.type_extend = + let hooks = + List.fold_left + (fun hooks (item : Cst.extend_item) -> + match item.value with + | Cst.ExtendConstruct construct -> + if Option.is_some hooks.construct then + failwith + (Printf.sprintf "duplicate construct block in extend %s" + ext.value.target.value); + { + hooks with + construct = + Some + (mk_surface construct.loc + { + Surface.params = + List.map cst_param_to_surface construct.value.params; + body = cst_block_to_surface construct.value.body; + }); + } + | Cst.ExtendDestruct block -> + if Option.is_some hooks.destruct then + failwith + (Printf.sprintf "duplicate destruct block in extend %s" + ext.value.target.value); + { hooks with destruct = Some (cst_block_to_surface block) }) + { construct = None; destruct = None; loc = ext.loc } + ext.value.items + in + mk_surface ext.loc + { + Surface.target = cst_identifier_to_surface ext.value.target; + construct = hooks.construct; + destruct = hooks.destruct; + } + and cst_type_decl_to_surface (decl : Cst.type_decl) : Surface.type_decl = let value = { Surface.name = cst_identifier_to_surface decl.value.name; data = cst_type_decl_data_to_surface decl.value.data; + construct = None; + destruct = None; } in mk_surface decl.loc value @@ -179,7 +231,10 @@ and cst_type_decl_data_to_surface = function and cst_struct_decl_to_surface (decl : Cst.struct_decl) : Surface.struct_decl = let value = - { Surface.fields = List.map cst_struct_field_to_surface decl.value.fields } + { + Surface.fields = List.map cst_struct_field_to_surface decl.value.fields; + lifecycle = None; + } in mk_surface decl.loc value @@ -721,8 +776,148 @@ let trip_count_of_range (range : Surface.iter_range) = let fresh_identifier st prefix loc = mk_core_ident loc (fresh_name st prefix) +let lifecycle_function_name (target : Surface.identifier) kind = + Printf.sprintf "__haven_%s_%s" kind target.value + +let mk_surface_pointer_type loc inner = + mk_surface_type loc (Surface.PointerType inner) + +let mk_surface_void_type loc = mk_surface_type loc Surface.VoidType + +let synthesize_surface_lifecycle_fn + (target : Surface.identifier) + kind loc + (user_params : Surface.param list) + body = + let self_ident = mk_surface_ident loc "self" in + let target_ty = + mk_surface_type loc (Surface.CustomType { name = mk_surface_ident target.loc target.value }) + in + let self_ty = mk_surface_pointer_type loc target_ty in + mk_surface loc + { + Surface.public = false; + impure = true; + name = mk_surface_ident loc (lifecycle_function_name target kind); + definition = Some body; + intrinsic = None; + params = + mk_surface loc + { + Surface.params = + (mk_surface loc { Surface.name = self_ident; ty = self_ty }) :: user_params; + vararg = false; + }; + return_type = Some (mk_surface_void_type loc); + vararg = false; + } + +let merge_surface_extension + (target : Surface.identifier) + (existing : surface_extension_hooks) + (ext : Surface.type_extend) = + let construct = + match (existing.construct, ext.value.construct) with + | Some _, Some _ -> + failwith + (Printf.sprintf "duplicate construct block for type %s" target.value) + | Some body, None | None, Some body -> Some body + | None, None -> None + in + let destruct = + match (existing.destruct, ext.value.destruct) with + | Some _, Some _ -> + failwith + (Printf.sprintf "duplicate destruct block for type %s" target.value) + | Some body, None | None, Some body -> Some body + | None, None -> None + in + { construct; destruct; loc = existing.loc } + let rec surface_program_to_core st (program : Surface.program) : Core.program = - let decls = List.map (surface_top_decl_to_core st) program.value.decls in + let extensions, decls_rev = + List.fold_left + (fun (extensions, decls_rev) (decl : Surface.top_decl) -> + match decl.value with + | Surface.Extend ext -> + let existing = + match List.assoc_opt ext.value.target.value extensions with + | Some hooks -> hooks + | None -> { construct = None; destruct = None; loc = ext.loc } + in + let hooks = merge_surface_extension ext.value.target existing ext in + ((ext.value.target.value, hooks) :: List.remove_assoc ext.value.target.value extensions, decls_rev) + | _ -> (extensions, decl :: decls_rev)) + ([], []) + program.value.decls + in + let seen_types = + List.filter_map + (fun (decl : Surface.top_decl) -> + match decl.value with + | Surface.TDecl ty -> Some ty.value.name.value + | _ -> None) + program.value.decls + in + st.known_types <- + List.fold_left (fun acc name -> String_set.add name acc) String_set.empty seen_types; + let decls = + List.rev decls_rev + |> List.concat_map (fun (decl : Surface.top_decl) -> + match decl.value with + | Surface.TDecl ty -> ( + let hooks = List.assoc_opt ty.value.name.value extensions in + (match (hooks, ty.value.data) with + | ( Some { construct; destruct; _ }, + Surface.TypeDeclStruct _ ) + when Option.is_some construct || Option.is_some destruct -> + () + | Some _, _ -> + failwith + (Printf.sprintf + "extend target %s must be a struct in the first-pass lifecycle model" + ty.value.name.value) + | None, _ -> ()); + let construct : Surface.function_decl option = + Option.bind hooks (fun hooks -> + Option.map + (fun (construct : Surface.lifecycle_construct) -> + synthesize_surface_lifecycle_fn ty.value.name "construct" ty.loc + construct.value.params construct.value.body) + hooks.construct) + in + let destruct : Surface.function_decl option = + Option.bind hooks (fun hooks -> + Option.map + (synthesize_surface_lifecycle_fn ty.value.name "destruct" ty.loc []) + hooks.destruct) + in + let ty = + { + ty with + value = { ty.value with construct; destruct }; + } + in + let core_ty = surface_top_decl_to_core st { decl with value = Surface.TDecl ty } in + let lifecycle_fns : Surface.function_decl option list = [ construct; destruct ] in + let extra_fdecls = + List.filter_map + (fun (hook : Surface.function_decl option) -> + Option.map + (fun (fn : Surface.function_decl) -> + mk_core fn.loc (Core.FDecl (surface_function_decl_to_core st fn))) + hook) + lifecycle_fns + in + core_ty :: extra_fdecls) + | Surface.Extend _ -> [] + | _ -> [ surface_top_decl_to_core st decl ]) + in + List.iter + (fun (name, _) -> + if not (List.mem name seen_types) then + failwith (Printf.sprintf "extend target %s does not match any declared type" name)) + extensions; mk_core program.loc { Core.decls = decls } and surface_top_decl_to_core st (decl : Surface.top_decl) : Core.top_decl = @@ -734,6 +929,8 @@ and surface_top_decl_to_core st (decl : Surface.top_decl) : Core.top_decl = | Surface.Import i -> Core.Import { value = i.value; loc = i.loc } | Surface.CImport i -> Core.CImport { value = i.value; loc = i.loc } | Surface.Foreign f -> Core.Foreign (surface_foreign_to_core st f) + | Surface.Extend _ -> + failwith "surface extend declarations must be merged before core lowering" in mk_core decl.loc value @@ -791,6 +988,8 @@ and surface_type_decl_to_core st (decl : Surface.type_decl) : Core.type_decl = { Core.name = surface_identifier_to_core decl.value.name; data = surface_type_decl_data_to_core st decl.value.data; + construct = Option.map (surface_function_decl_to_core st) decl.value.construct; + destruct = Option.map (surface_function_decl_to_core st) decl.value.destruct; } and surface_type_decl_data_to_core st = function @@ -801,7 +1000,18 @@ and surface_type_decl_data_to_core st = function and surface_struct_decl_to_core st (decl : Surface.struct_decl) : Core.struct_decl = mk_core decl.loc - { Core.fields = List.map (surface_struct_field_to_core st) decl.value.fields } + { + Core.fields = List.map (surface_struct_field_to_core st) decl.value.fields; + lifecycle = + Option.map + (fun (lifecycle : Surface.struct_lifecycle) -> + mk_core lifecycle.loc + { + Core.constructor = Option.map surface_identifier_to_core lifecycle.value.constructor; + destructor = Option.map surface_identifier_to_core lifecycle.value.destructor; + }) + decl.value.lifecycle; + } and surface_struct_field_to_core _st (field : Surface.struct_field) : Core.struct_field = @@ -1076,6 +1286,25 @@ and surface_expr_to_core st (expr : Surface.expression) : Core.expression = Core.expr = surface_expr_to_core st m.value.expr; arms = List.map (surface_match_arm_to_core st) m.value.arms; }) + | Surface.BoxExpr ({ value = Surface.Identifier id; _ } as inner) + when String_set.mem id.value st.known_types -> + Core.BoxType + (mk_core_type inner.loc + (Core.CustomType { name = surface_identifier_to_core id })) + | Surface.BoxExpr { value = Surface.Call call; loc } + when (match call.value.target.value with + | Surface.Identifier id -> String_set.mem id.value st.known_types + | _ -> false) -> + let ty = + match call.value.target.value with + | Surface.Identifier id -> + mk_core_type call.value.target.loc + (Core.CustomType { name = surface_identifier_to_core id }) + | _ -> assert false + in + Core.BoxConstruct + (mk_core loc + { Core.ty; args = List.map (surface_expr_to_core st) call.value.params }) | Surface.BoxExpr inner -> Core.BoxExpr (surface_expr_to_core st inner) | Surface.BoxType ty -> Core.BoxType (surface_type_to_core ty) | Surface.Unbox inner -> Core.Unbox (surface_expr_to_core st inner) diff --git a/src/lib/ast/core_ast.ml b/src/lib/ast/core_ast.ml index 54cb581..5f33289 100644 --- a/src/lib/ast/core_ast.ml +++ b/src/lib/ast/core_ast.ml @@ -92,7 +92,12 @@ and var_decl_desc = { } and var_decl = var_decl_desc node -and type_decl_desc = { name : identifier; data : type_decl_data } +and type_decl_desc = { + name : identifier; + data : type_decl_data; + construct : function_decl option; + destruct : function_decl option; +} and type_decl = type_decl_desc node and type_decl_data = @@ -101,7 +106,15 @@ and type_decl_data = | TypeDeclEnum of enum_decl | TypeDeclForward -and struct_decl_desc = { fields : struct_field list } +and struct_lifecycle_desc = { + constructor : identifier option; + destructor : identifier option; +} +and struct_lifecycle = struct_lifecycle_desc node +and struct_decl_desc = { + fields : struct_field list; + lifecycle : struct_lifecycle option; +} and enum_decl_desc = { generics : identifier list; variants : enum_variant list } and struct_field_desc = { name : identifier; ty : haven_type } and enum_variant_desc = { name : identifier; inner_tys : haven_type list } @@ -173,6 +186,7 @@ and expression_desc = | Match of match_expr | BoxExpr of expression | BoxType of haven_type + | BoxConstruct of box_construct | Unbox of expression | Ref of expression | Load of expression @@ -183,6 +197,8 @@ and expression_desc = | Mutate of write and expression = expression_desc node +and box_construct_desc = { ty : haven_type; args : expression list } +and box_construct = box_construct_desc node and call_desc = { target : expression; params : expression list } and call = call_desc node and index_desc = { target : expression; index : expression } diff --git a/src/lib/ast/imports.ml b/src/lib/ast/imports.ml index 6685517..b442bb3 100644 --- a/src/lib/ast/imports.ml +++ b/src/lib/ast/imports.ml @@ -94,7 +94,7 @@ and expand_top_decl state ~current_file (decl : Cst.top_decl) : Cst.top_decl lis expand_import state ~current_file import_path.value import_path.loc | Cst.CImport import_path -> expand_cimport state ~current_file import_path.value import_path.loc - | Cst.Foreign _ | Cst.FDecl _ | Cst.TDecl _ | Cst.VDecl _ -> + | Cst.Foreign _ | Cst.FDecl _ | Cst.TDecl _ | Cst.VDecl _ | Cst.Extend _ -> [ decl ] and expand_import state ~current_file import_path loc = diff --git a/src/lib/ast/llvm_ir.ml b/src/lib/ast/llvm_ir.ml index d2d7c1b..37ed54a 100644 --- a/src/lib/ast/llvm_ir.ml +++ b/src/lib/ast/llvm_ir.ml @@ -61,6 +61,8 @@ type preamble = { box_ref_ty : Llvm.lltype; box_unref : Llvm.llvalue; box_unref_ty : Llvm.lltype; + free : Llvm.llvalue; + free_ty : Llvm.lltype; } type global_init = { @@ -292,14 +294,14 @@ and llvm_named_type t ?loc (resolved : Analysis.resolved_ty) = match resolved with | Analysis.ResolvedNamed (name, _args) -> ( match Analysis.lookup_named_type t.type_env name with - | Some (Analysis.TypeStruct decl) -> llvm_struct_type t ?loc resolved decl - | Some (Analysis.TypeEnum decl) -> llvm_enum_type t ?loc resolved decl + | Some (Analysis.TypeStruct (decl, _)) -> llvm_struct_type t ?loc resolved decl + | Some (Analysis.TypeEnum (decl, _)) -> llvm_enum_type t ?loc resolved decl | Some Analysis.TypeAlias alias -> ( match Analysis.resolve_core_type t.type_env [] [] (with_default dummy_loc loc) alias with | Some alias_ty -> llvm_type_of_resolved t ?loc alias_ty | None -> fail ?loc "failed to resolve alias %s during LLVM lowering" name) - | Some Analysis.TypeForward | None -> + | Some (Analysis.TypeForward _) | None -> fail ?loc "unknown named type %s during LLVM lowering" name) | _ -> fail ?loc "expected named type during LLVM lowering" @@ -508,7 +510,19 @@ let create_preamble context llmodule = let box_unref, box_unref_ty = declare_runtime_function llmodule "__haven_box_unref" void_type [ ptr_type ] in - { new_empty_box; new_empty_box_ty; new_box; new_box_ty; box_ref; box_ref_ty; box_unref; box_unref_ty } + let free, free_ty = declare_runtime_function llmodule "free" void_type [ ptr_type ] in + { + new_empty_box; + new_empty_box_ty; + new_box; + new_box_ty; + box_ref; + box_ref_ty; + box_unref; + box_unref_ty; + free; + free_ty; + } let target_codegen_opt_level = function | O0 -> Llvm_target.CodeGenOptLevel.None @@ -779,10 +793,210 @@ let emit_box_ref t box = let preamble = require_preamble t "box retain/release" in ignore (Llvm.build_call preamble.box_ref_ty preamble.box_ref [| box |] "" t.builder) -let emit_box_unref t box = +let lookup_lifecycle t = function + | Analysis.ResolvedNamed (name, _) -> Analysis.lookup_type_lifecycle t.type_env name + | _ -> None + +let emit_lifecycle_call t _resolved (fn_decl : Core.function_decl) storage extra_args = + match lookup_function_symbol t fn_decl.value.name.value with + | Function_symbol { fn; fn_type; resolved_type = Analysis.ResolvedFunction (params, ret, _); named_params; _ } -> + if named_params <> 1 + List.length extra_args then + fail ~loc:fn_decl.loc + "lifecycle hook %s expected %d argument(s), but lowering produced %d" + fn_decl.value.name.value named_params (1 + List.length extra_args); + if not (Analysis.equal_resolved_type ret Analysis.ResolvedVoid) then + fail ~loc:fn_decl.loc "lifecycle hook %s must return void" fn_decl.value.name.value; + (match params with + | self_param :: extra_param_tys + when Analysis.resolved_is_pointerish self_param + && List.length extra_param_tys = List.length extra_args -> + ignore (Llvm.build_call fn_type fn (Array.of_list (storage :: extra_args)) "" t.builder) + | self_param :: _ + when not (Analysis.resolved_is_pointerish self_param) -> + fail ~loc:fn_decl.loc + "lifecycle hook %s self parameter must be pointer-like" + fn_decl.value.name.value + | _ -> + fail ~loc:fn_decl.loc "lifecycle hook %s must start with exactly one self parameter" + fn_decl.value.name.value) + | Function_symbol _ -> + fail ~loc:fn_decl.loc "lifecycle hook %s did not resolve to a callable function type" + fn_decl.value.name.value + | Variable_symbol _ -> + fail ~loc:fn_decl.loc "lifecycle hook %s unexpectedly resolved to a variable" + fn_decl.value.name.value + +let emit_default_constructor_call t resolved storage = + match lookup_lifecycle t resolved with + | Some { construct = Some fn_decl; _ } + when Analysis.lifecycle_user_params fn_decl = [] -> + emit_lifecycle_call t resolved fn_decl storage [] + | _ -> () + +let emit_constructor_call t resolved storage extra_args = + match lookup_lifecycle t resolved with + | Some { construct = Some fn_decl; _ } -> + emit_lifecycle_call t resolved fn_decl storage extra_args + | _ -> () + +let emit_destructor_call t resolved storage = + match lookup_lifecycle t resolved with + | Some { destruct = Some fn_decl; _ } -> emit_lifecycle_call t resolved fn_decl storage [] + | _ -> () + +let rec resolved_has_destructor_hook t = function + | (Analysis.ResolvedNamed (name, _) as resolved) -> ( + match Analysis.lookup_named_type t.type_env name with + | Some (Analysis.TypeStruct (decl, lifecycle)) -> + Option.is_some lifecycle.destruct + || List.exists + (fun (field : Core.struct_field) -> + match Analysis.resolve_core_type t.type_env [] [] field.loc field.value.ty with + | Some field_ty -> resolved_has_destructor_hook t field_ty + | None -> false) + decl.value.fields + | Some (Analysis.TypeEnum (decl, lifecycle)) -> ( + Option.is_some lifecycle.destruct + || + match Analysis.lookup_enum_decl t.type_env dummy_loc resolved with + | Some (_, subst) -> + List.exists + (fun (variant : Core.enum_variant) -> + List.exists + (fun inner_ty -> + match Analysis.resolve_core_type t.type_env [] subst variant.loc inner_ty with + | Some resolved_inner -> resolved_has_destructor_hook t resolved_inner + | None -> false) + variant.value.inner_tys) + decl.value.variants + | None -> false) + | Some (Analysis.TypeAlias alias) -> ( + match Analysis.resolve_core_type t.type_env [] [] dummy_loc alias with + | Some alias_ty -> resolved_has_destructor_hook t alias_ty + | None -> false) + | Some (Analysis.TypeForward lifecycle) -> Option.is_some lifecycle.destruct + | None -> false) + | Analysis.ResolvedArray (inner, _) -> resolved_has_destructor_hook t inner + | _ -> false + +let rec emit_default_initialize_storage ?(run_constructor = true) t resolved storage = + ignore (Llvm.build_store (Llvm.const_null (llvm_type_of_resolved t resolved)) storage t.builder); + match resolved with + | Analysis.ResolvedArray (inner, count) -> + for index = 0 to count - 1 do + let zero = Llvm.const_int (i32_type t) 0 in + let idx = Llvm.const_int (i32_type t) index in + let element_ptr = + Llvm.build_in_bounds_gep (llvm_type_of_resolved t resolved) storage + [| zero; idx |] "array.init.elem" t.builder + in + emit_default_initialize_storage t inner element_ptr + done + | Analysis.ResolvedNamed (name, _) -> ( + match Analysis.lookup_named_type t.type_env name with + | Some (Analysis.TypeStruct (decl, _)) -> + let struct_ty = llvm_type_of_resolved t resolved in + List.iteri + (fun index (field : Core.struct_field) -> + match Analysis.resolve_core_type t.type_env [] [] field.loc field.value.ty with + | Some field_ty -> + let field_ptr = + Llvm.build_struct_gep struct_ty storage index "field.init" t.builder + in + emit_default_initialize_storage t field_ty field_ptr + | None -> ()) + decl.value.fields; + if run_constructor then emit_default_constructor_call t resolved storage + | Some (Analysis.TypeEnum _) | Some (Analysis.TypeForward _) -> + if run_constructor then emit_default_constructor_call t resolved storage + | Some (Analysis.TypeAlias alias) -> ( + match Analysis.resolve_core_type t.type_env [] [] dummy_loc alias with + | Some alias_ty -> emit_default_initialize_storage ~run_constructor t alias_ty storage + | None -> ()) + | None -> ()) + | _ -> () + +and emit_recursive_destruct_on_storage t resolved storage = + match resolved with + | Analysis.ResolvedBox inner -> + let box = Llvm.build_load (ptr_type t) storage "box.handle" t.builder in + emit_box_unref t inner box + | Analysis.ResolvedArray (inner, count) -> + for index = count - 1 downto 0 do + let zero = Llvm.const_int (i32_type t) 0 in + let idx = Llvm.const_int (i32_type t) index in + let element_ptr = + Llvm.build_in_bounds_gep (llvm_type_of_resolved t resolved) storage + [| zero; idx |] "array.drop.elem" t.builder + in + emit_recursive_destruct_on_storage t inner element_ptr + done + | Analysis.ResolvedNamed (name, _) -> ( + match Analysis.lookup_named_type t.type_env name with + | Some (Analysis.TypeStruct (decl, _)) -> + emit_destructor_call t resolved storage; + let struct_ty = llvm_type_of_resolved t resolved in + List.iteri + (fun index (field : Core.struct_field) -> + match Analysis.resolve_core_type t.type_env [] [] field.loc field.value.ty with + | Some field_ty -> + let field_ptr = + Llvm.build_struct_gep struct_ty storage index "field.drop" t.builder + in + emit_recursive_destruct_on_storage t field_ty field_ptr + | None -> ()) + decl.value.fields + | Some (Analysis.TypeEnum (_, _)) -> + emit_destructor_call t resolved storage + | Some (Analysis.TypeAlias alias) -> ( + match Analysis.resolve_core_type t.type_env [] [] dummy_loc alias with + | Some alias_ty -> emit_recursive_destruct_on_storage t alias_ty storage + | None -> ()) + | Some (Analysis.TypeForward _) -> emit_destructor_call t resolved storage + | None -> ()) + | _ -> () + +and emit_box_unref t inner box = let preamble = require_preamble t "box retain/release" in - ignore - (Llvm.build_call preamble.box_unref_ty preamble.box_unref [| box |] "" t.builder) + if Analysis.resolved_contains_box_ownership t.type_env [] dummy_loc inner + || resolved_has_destructor_hook t inner + then ( + let fn = current_function t in + let done_block = Llvm.append_block t.context "box.release.done" fn.fn_value in + let release_block = Llvm.append_block t.context "box.release" fn.fn_value in + let keep_block = Llvm.append_block t.context "box.keep" fn.fn_value in + let box_is_null = Llvm.build_is_null box "box.isnull" t.builder in + ignore (Llvm.build_cond_br box_is_null done_block release_block t.builder); + Llvm.position_at_end release_block t.builder; + let rc_ptr = Llvm.build_pointercast box (ptr_type t) "box.rc" t.builder in + let rc = Llvm.build_load (i32_type t) rc_ptr "box.rc.value" t.builder in + let new_rc = Llvm.build_sub rc (Llvm.const_int (i32_type t) 1) "box.rc.dec" t.builder in + ignore (Llvm.build_store new_rc rc_ptr t.builder); + let rc_is_zero = + Llvm.build_icmp Llvm.Icmp.Eq new_rc (Llvm.const_int (i32_type t) 0) "box.rc.zero" + t.builder + in + ignore (Llvm.build_cond_br rc_is_zero keep_block done_block t.builder); + Llvm.position_at_end keep_block t.builder; + let box_raw = Llvm.build_pointercast box (ptr_type t) "box.raw" t.builder in + let payload_raw = + Llvm.build_in_bounds_gep (i8_type t) box_raw [| const_i32 t 16 |] "box.payload.raw" + t.builder + in + let payload_ptr = + Llvm.build_pointercast payload_raw + (ptr_type t) "box.payload" t.builder + in + emit_recursive_destruct_on_storage t inner payload_ptr; + let free_fn_ty = Llvm.function_type (void_type t) [| ptr_type t |] in + let free_fn = Llvm.declare_function "free" free_fn_ty t.llmodule in + Llvm.set_linkage Llvm.Linkage.External free_fn; + Llvm.set_function_call_conv Llvm.CallConv.c free_fn; + ignore (Llvm.build_call free_fn_ty free_fn [| box |] "" t.builder); + ignore (Llvm.build_br done_block t.builder); + Llvm.position_at_end done_block t.builder) + else + ignore (Llvm.build_call preamble.box_unref_ty preamble.box_unref [| box |] "" t.builder) let ensure_storage t resolved value = let slot = build_alloca t (llvm_type_of_resolved t resolved) "spill" in @@ -802,9 +1016,9 @@ let coerce_store_value t ?loc value source target = let rec emit_ownership_on_storage t kind resolved storage = match resolved with - | Analysis.ResolvedBox _ -> + | Analysis.ResolvedBox inner -> let box = Llvm.build_load (ptr_type t) storage "box.handle" t.builder in - if kind = Analysis.Retain then emit_box_ref t box else emit_box_unref t box + if kind = Analysis.Retain then emit_box_ref t box else emit_box_unref t inner box | Analysis.ResolvedArray (inner, count) -> for index = 0 to count - 1 do let zero = Llvm.const_int (i32_type t) 0 in @@ -835,7 +1049,7 @@ and emit_ownership_on_named t kind resolved storage = match resolved with | Analysis.ResolvedNamed (name, _args) -> ( match Analysis.lookup_named_type t.type_env name with - | Some (Analysis.TypeStruct decl) -> + | Some (Analysis.TypeStruct (decl, _)) -> let field_types = with_default [] (Analysis.lookup_struct_fields t.type_env decl.loc resolved) in @@ -847,13 +1061,13 @@ and emit_ownership_on_named t kind resolved storage = in emit_ownership_on_storage t kind field_ty field_ptr) field_types - | Some (Analysis.TypeEnum decl) -> + | Some (Analysis.TypeEnum (decl, _)) -> emit_ownership_on_enum t kind resolved decl storage | Some (Analysis.TypeAlias alias) -> ( match Analysis.resolve_core_type t.type_env [] [] dummy_loc alias with | Some alias_ty -> emit_ownership_on_storage t kind alias_ty storage | None -> ()) - | Some Analysis.TypeForward | None -> ()) + | Some (Analysis.TypeForward _) | None -> ()) | _ -> () and emit_ownership_on_enum t kind resolved decl storage = @@ -918,8 +1132,8 @@ and emit_ownership_on_enum t kind resolved decl storage = let emit_ownership_on_value t kind resolved value = match resolved with - | Analysis.ResolvedBox _ -> - if kind = Analysis.Retain then emit_box_ref t value else emit_box_unref t value + | Analysis.ResolvedBox inner -> + if kind = Analysis.Retain then emit_box_ref t value else emit_box_unref t inner value | _ -> let storage = ensure_storage t resolved value in emit_ownership_on_storage t kind resolved storage @@ -1729,8 +1943,8 @@ and emit_expr t (expr : Core.expression) = Llvm.const_null (llvm_type_of_resolved t (expr_resolved_type t expr)) | Core.Match match_expr -> emit_match t expr match_expr | Core.BoxExpr inner -> emit_box_expr t expr inner - | Core.BoxType _ -> - fail ~loc:expr.loc "box type expressions are not supported during LLVM lowering" + | Core.BoxType ty -> emit_box_type_expr t expr ty + | Core.BoxConstruct box -> emit_box_construct_expr t expr box | Core.Unbox inner -> emit_unbox t expr inner | Core.Ref inner -> emit_lvalue t inner | Core.Load inner -> @@ -1784,6 +1998,40 @@ and emit_box_expr t (expr : Core.expression) inner = |] "box.new" t.builder +and emit_box_type_expr t (expr : Core.expression) ty = + let inner_resolved = resolved_type_of_core_type t ty.loc ty in + let box_layout = emit_box_layout t inner_resolved in + let box_size = + Llvm_target.DataLayout.abi_size box_layout t.data_layout |> Int64.to_int + in + let preamble = require_preamble t ~loc:expr.loc "box allocation" in + let box_handle = + Llvm.build_call preamble.new_empty_box_ty preamble.new_empty_box + [| Llvm.const_int (i32_type t) box_size |] + "box.new.empty" t.builder + in + let value_ptr = emit_box_value_ptr t (Analysis.ResolvedBox inner_resolved) box_handle in + emit_default_initialize_storage t inner_resolved value_ptr; + box_handle + +and emit_box_construct_expr t (expr : Core.expression) (box : Core.box_construct) = + let inner_resolved = resolved_type_of_core_type t box.value.ty.loc box.value.ty in + let box_layout = emit_box_layout t inner_resolved in + let box_size = + Llvm_target.DataLayout.abi_size box_layout t.data_layout |> Int64.to_int + in + let preamble = require_preamble t ~loc:expr.loc "box allocation" in + let box_handle = + Llvm.build_call preamble.new_empty_box_ty preamble.new_empty_box + [| Llvm.const_int (i32_type t) box_size |] + "box.new.empty" t.builder + in + let value_ptr = emit_box_value_ptr t (Analysis.ResolvedBox inner_resolved) box_handle in + emit_default_initialize_storage ~run_constructor:false t inner_resolved value_ptr; + let arg_values = List.map (emit_expr t) box.value.args in + emit_constructor_call t inner_resolved value_ptr arg_values; + box_handle + and emit_unbox t (expr : Core.expression) inner = let inner_value = emit_expr t inner in let inner_ty = expr_resolved_type t inner in @@ -2078,7 +2326,9 @@ let lower_global_initializer t (decl : Core.var_decl) = match lookup_global_symbol t decl.value.name.value with | Variable_symbol { storage; resolved_type; _ } -> ( match decl.value.init_expr with - | None -> () + | None -> + Llvm.set_initializer (zero_constant t resolved_type) storage; + t.global_inits_rev <- { decl; storage } :: t.global_inits_rev | Some init -> ( match constant_of_expr t init with | Some constant -> @@ -2137,15 +2387,16 @@ let emit_global_ctor t = Llvm.position_at_end entry t.builder; List.iter (fun { decl; storage } -> + let resolved = resolved_type_of_core_type t decl.loc decl.value.ty in match decl.value.init_expr with + | None -> + emit_default_initialize_storage t resolved storage | Some init -> let value = emit_expr t init in - let resolved = resolved_type_of_core_type t decl.loc decl.value.ty in ignore (Llvm.build_store (emit_cast t value (expr_resolved_type t init) resolved) - storage t.builder) - | None -> ()) + storage t.builder)) inits; ignore (Llvm.build_br fn_state.return_block t.builder); Llvm.position_at_end fn_state.return_block t.builder; diff --git a/src/lib/ast/pretty.ml b/src/lib/ast/pretty.ml index 7013456..9575a20 100644 --- a/src/lib/ast/pretty.ml +++ b/src/lib/ast/pretty.ml @@ -270,12 +270,29 @@ let pp_surface_type_decl_data fmt = function decl.value.variants | TypeDeclForward -> fprintf fmt "Forward" +let pp_surface_lifecycle_fn fmt = function + | Some (fn : Surface.function_decl) -> pp_surface_identifier fmt fn.value.name + | None -> fprintf fmt "None" + +let pp_surface_lifecycle_construct fmt (construct : Surface.lifecycle_construct) = + fprintf fmt "Construct(params=[%a], body=%a)" + (pp_print_list ~pp_sep pp_surface_param) + construct.value.params pp_surface_block construct.value.body + +let pp_surface_type_extend fmt (ext : Surface.type_extend) = + fprintf fmt "Extend(%a, construct=%a, destruct=%a)" pp_surface_identifier + ext.value.target + (pp_print_option pp_surface_lifecycle_construct) ext.value.construct + (pp_print_option pp_surface_block) ext.value.destruct + let pp_surface_decl fmt (decl : Surface.top_decl) = match decl.value with | Surface.FDecl fn -> fprintf fmt "FDecl(%a)" pp_surface_function fn | TDecl ty -> - fprintf fmt "TypeDecl(%a, %a)" pp_surface_identifier ty.value.name - pp_surface_type_decl_data ty.value.data + fprintf fmt "TypeDecl(%a, %a, construct=%a, destruct=%a)" pp_surface_identifier + ty.value.name pp_surface_type_decl_data ty.value.data pp_surface_lifecycle_fn + ty.value.construct pp_surface_lifecycle_fn ty.value.destruct + | Extend ext -> pp_surface_type_extend fmt ext | VDecl v -> pp_surface_var_decl fmt v | Import i -> fprintf fmt "Import(%s)" i.value | CImport i -> fprintf fmt "CImport(%s)" i.value @@ -377,6 +394,10 @@ and pp_core_expression fmt (expr : Core.expression) = m.value.arms | BoxExpr inner -> fprintf fmt "BoxExpr(%a)" pp_core_expression inner | BoxType ty -> fprintf fmt "BoxType(%a)" pp_core_type ty + | BoxConstruct box -> + fprintf fmt "BoxConstruct(%a, %a)" pp_core_type box.value.ty + (pp_print_list ~pp_sep pp_core_expression) + box.value.args | Unbox inner -> fprintf fmt "Unbox(%a)" pp_core_expression inner | Ref inner -> fprintf fmt "Ref(%a)" pp_core_expression inner | Load inner -> fprintf fmt "Load(%a)" pp_core_expression inner @@ -505,12 +526,17 @@ let pp_core_type_decl_data fmt = function decl.value.variants | TypeDeclForward -> fprintf fmt "Forward" +let pp_core_lifecycle_fn fmt = function + | Some (fn : Core.function_decl) -> pp_core_identifier fmt fn.value.name + | None -> fprintf fmt "None" + let pp_core_decl fmt (decl : Core.top_decl) = match decl.value with | Core.FDecl fn -> fprintf fmt "FDecl(%a)" pp_core_function fn | TDecl ty -> - fprintf fmt "TypeDecl(%a, %a)" pp_core_identifier ty.value.name - pp_core_type_decl_data ty.value.data + fprintf fmt "TypeDecl(%a, %a, construct=%a, destruct=%a)" pp_core_identifier + ty.value.name pp_core_type_decl_data ty.value.data pp_core_lifecycle_fn + ty.value.construct pp_core_lifecycle_fn ty.value.destruct | VDecl v -> pp_core_var_decl fmt v | Import i -> fprintf fmt "Import(%s)" i.value | CImport i -> fprintf fmt "CImport(%s)" i.value diff --git a/src/lib/ast/surface_ast.ml b/src/lib/ast/surface_ast.ml index 7a70631..a549736 100644 --- a/src/lib/ast/surface_ast.ml +++ b/src/lib/ast/surface_ast.ml @@ -69,6 +69,7 @@ and top_decl_desc = | Import of string node | CImport of string node | Foreign of foreign + | Extend of type_extend and top_decl = top_decl_desc node @@ -94,16 +95,39 @@ and var_decl_desc = { } and var_decl = var_decl_desc node -and type_decl_desc = { name : identifier; data : type_decl_data } +and type_decl_desc = { + name : identifier; + data : type_decl_data; + construct : function_decl option; + destruct : function_decl option; +} and type_decl = type_decl_desc node +and lifecycle_construct_desc = { params : param list; body : block } +and lifecycle_construct = lifecycle_construct_desc node + +and type_extend_desc = { + target : identifier; + construct : lifecycle_construct option; + destruct : block option; +} +and type_extend = type_extend_desc node + and type_decl_data = | TypeDeclAlias of haven_type | TypeDeclStruct of struct_decl | TypeDeclEnum of enum_decl | TypeDeclForward -and struct_decl_desc = { fields : struct_field list } +and struct_lifecycle_desc = { + constructor : identifier option; + destructor : identifier option; +} +and struct_lifecycle = struct_lifecycle_desc node +and struct_decl_desc = { + fields : struct_field list; + lifecycle : struct_lifecycle option; +} and enum_decl_desc = { generics : identifier list; variants : enum_variant list } and struct_field_desc = { name : identifier; ty : haven_type } and enum_variant_desc = { name : identifier; inner_tys : haven_type list } diff --git a/src/lib/cst/cst.ml b/src/lib/cst/cst.ml index 8947085..3ea3d92 100644 --- a/src/lib/cst/cst.ml +++ b/src/lib/cst/cst.ml @@ -124,6 +124,7 @@ and top_decl_desc = | Import of string node | CImport of string node | Foreign of foreign + | Extend of type_extend and top_decl = top_decl_desc node @@ -152,6 +153,18 @@ and var_decl = var_decl_desc node and type_decl_desc = { name : identifier; data : type_decl_data } and type_decl = type_decl_desc node +and type_extend_desc = { target : identifier; items : extend_item list } +and type_extend = type_extend_desc node + +and lifecycle_construct_desc = { params : param list; body : block } +and lifecycle_construct = lifecycle_construct_desc node + +and extend_item_desc = + | ExtendConstruct of lifecycle_construct + | ExtendDestruct of block + +and extend_item = extend_item_desc node + and type_decl_data = | TypeDeclAlias of haven_type | TypeDeclStruct of struct_decl diff --git a/src/lib/cst/emit.ml b/src/lib/cst/emit.ml index a43b9c8..58b4e46 100644 --- a/src/lib/cst/emit.ml +++ b/src/lib/cst/emit.ml @@ -602,6 +602,31 @@ let emit_type_decl fmt (ty : type_decl) = | TypeDeclEnum e -> fprintf fmt "type %a = %a;" emit_identifier ty.name emit_enum_decl e +let emit_extend_item ~comments fmt (item : extend_item) = + emit_comments ~comments ~indent:1 ~loc:item.loc ~kind:`Leading fmt; + (match item.value with + | ExtendConstruct construct -> + if construct.value.params = [] then + fprintf fmt "%sconstruct %a" (spaces 1) (emit_block ~indent:1 ~comments) + construct.value.body + else + fprintf fmt "%sconstruct(%a) %a" (spaces 1) + (pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ", ") emit_param) + construct.value.params (emit_block ~indent:1 ~comments) construct.value.body + | ExtendDestruct block -> + fprintf fmt "%sdestruct %a" (spaces 1) (emit_block ~indent:1 ~comments) block); + emit_comments ~comments ~indent:1 ~loc:item.loc ~kind:`Trailing ~separate:true fmt + +let emit_type_extend ~comments fmt (ext : type_extend) = + let ext = unwrap ext in + fprintf fmt "extend %a with {\n" emit_identifier ext.target; + List.iteri + (fun idx item -> + emit_extend_item ~comments fmt item; + if idx < List.length ext.items - 1 then fprintf fmt "\n") + ext.items; + fprintf fmt "\n}" + let emit_foreign ~comments fmt (f : foreign) = let f = unwrap f in fprintf fmt "foreign %a {\n" emit_string_lit f.lib; @@ -624,6 +649,7 @@ let emit_decl ~comments fmt decl = (match decl.value with | FDecl d -> emit_fdecl ~comments fmt d | TDecl t -> emit_type_decl fmt t + | Extend e -> emit_type_extend ~comments fmt e | VDecl v -> emit_var_decl ~comments fmt v | Import i -> fprintf fmt "import %a;" emit_string_lit i | CImport i -> fprintf fmt "cimport %a;" emit_string_lit i diff --git a/src/lib/cst/locate.ml b/src/lib/cst/locate.ml index 67253fe..916c9b4 100644 --- a/src/lib/cst/locate.ml +++ b/src/lib/cst/locate.ml @@ -7,6 +7,8 @@ type any_node = | FunctionDecl of function_decl | VarDecl of var_decl | TypeDecl of type_decl + | TypeExtend of type_extend + | ExtendItem of extend_item | StructDecl of struct_decl | EnumDecl of enum_decl | StructField of struct_field @@ -51,6 +53,8 @@ let location_of = function | FunctionDecl f -> f.loc | VarDecl v -> v.loc | TypeDecl t -> t.loc + | TypeExtend e -> e.loc + | ExtendItem i -> i.loc | StructDecl s -> s.loc | EnumDecl e -> e.loc | StructField f -> f.loc @@ -319,6 +323,17 @@ and walk_top_decl predicate acc decl = | FDecl f -> walk_function_decl predicate acc f | VDecl v -> walk_var_decl predicate acc v | TDecl t -> walk_type_decl predicate acc t + | Extend e -> + let acc = add_if predicate (TypeExtend e) acc in + List.fold_left + (fun acc (item : extend_item) -> + let acc = add_if predicate (ExtendItem item) acc in + match item.value with + | ExtendConstruct construct -> + walk_block predicate acc construct.value.body + | ExtendDestruct block -> + walk_block predicate acc block) + acc e.value.items | Import _ | CImport _ -> acc | Foreign f -> let acc = add_if predicate (Foreign f) acc in diff --git a/src/lib/cst/pretty.ml b/src/lib/cst/pretty.ml index afef00f..987ac97 100644 --- a/src/lib/cst/pretty.ml +++ b/src/lib/cst/pretty.ml @@ -307,10 +307,27 @@ let pp_type_decl fmt (ty : type_decl) = fprintf fmt "@[TypeDecl(@,%a,@ %a@,)@]" pp_identifier ty.name pp_type_decl_data ty.data +let pp_lifecycle_construct fmt (decl : lifecycle_construct) = + fprintf fmt "Construct(params=[%a], body=%a)" + (pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ",@ ") pp_param) + decl.value.params pp_block decl.value.body + +let pp_extend_item fmt (item : extend_item) = + match item.value with + | ExtendConstruct construct -> pp_lifecycle_construct fmt construct + | ExtendDestruct block -> fprintf fmt "Destruct(%a)" pp_block block + +let pp_type_extend fmt (ext : type_extend) = + let ext = unwrap ext in + fprintf fmt "@[Extend(@,%a,@ items=[%a]@,)@]" pp_identifier ext.target + (pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ",@ ") pp_extend_item) + ext.items + let pp_decl fmt decl = match decl.value with | FDecl d -> fprintf fmt "@[FDecl(@,%a@,)@]" pp_fdecl d | TDecl t -> pp_type_decl fmt t + | Extend e -> pp_type_extend fmt e | VDecl v -> pp_var_decl fmt v | Import i -> fprintf fmt "Import(%s)" i.value | CImport i -> fprintf fmt "CImport(%s)" i.value diff --git a/src/lib/parser/grammar.mly b/src/lib/parser/grammar.mly index e2bc7db..e4d3267 100644 --- a/src/lib/parser/grammar.mly +++ b/src/lib/parser/grammar.mly @@ -34,7 +34,7 @@ %token PUB FN MUT IF ELSE LET WHILE UNTIL BREAK CONTINUE MATCH AS ITER %token LOAD RET STRUCT TYPE NIL DEFER IMPURE ENUM IMPORT CIMPORT SIZE %token BOX UNBOX INTRINSIC FOREIGN DATA STATE VEC MAT FUNCTION -%token VAFUNCTION CELL REF +%token VAFUNCTION CELL REF EXTEND WITH CONSTRUCT DESTRUCT (* Operator precedence table *) %left LOGIC_OR @@ -66,6 +66,7 @@ top_decl: | i=cimport_decl { mk_loc $startpos $endpos (CImport i) } | f=foreign_decl { mk_loc $startpos $endpos (Foreign f) } | t=type_decl { mk_loc $startpos $endpos (TDecl t) } + | e=extend_decl { mk_loc $startpos $endpos (Extend e) } | v=global_decl { mk_loc $startpos $endpos (VDecl v) } ; @@ -119,6 +120,21 @@ type_decl: | TYPE i=identifier EQUAL t=type_defn SEMICOLON { mk_loc $startpos $endpos { name = i; data = t } } | TYPE i=identifier SEMICOLON { mk_loc $startpos $endpos { name = i; data = TypeDeclForward } } ; +extend_decl: + EXTEND i=identifier WITH LBRACE items=list(extend_item) RBRACE + { mk_loc $startpos $endpos { target = i; items } } + ; +extend_item: + | CONSTRUCT b=block { + let construct : lifecycle_construct_desc = { params = []; body = b } in + mk_loc $startpos $endpos (ExtendConstruct (mk_loc $startpos $endpos construct)) + } + | CONSTRUCT LPAREN ps=separated_list(COMMA, param) RPAREN b=block { + let construct : lifecycle_construct_desc = { params = ps; body = b } in + mk_loc $startpos $endpos (ExtendConstruct (mk_loc $startpos $endpos construct)) + } + | DESTRUCT b=block { mk_loc $startpos $endpos (ExtendDestruct b) } + ; type_defn: | t=haven_type { TypeDeclAlias t } | s=struct_decl { TypeDeclStruct s } diff --git a/src/lib/parser/parser.ml b/src/lib/parser/parser.ml index d3d543f..597975a 100644 --- a/src/lib/parser/parser.ml +++ b/src/lib/parser/parser.ml @@ -53,6 +53,10 @@ let keywords = ("Cell", Grammar.CELL); ("load", Grammar.LOAD); ("ref", Grammar.REF); + ("extend", Grammar.EXTEND); + ("with", Grammar.WITH); + ("construct", Grammar.CONSTRUCT); + ("destruct", Grammar.DESTRUCT); ]) let keyword_or_ident s = diff --git a/src/test/test_llvm_ir.ml b/src/test/test_llvm_ir.ml index 13c780d..ddd9343 100644 --- a/src/test/test_llvm_ir.ml +++ b/src/test/test_llvm_ir.ml @@ -10,6 +10,102 @@ let emit_ir source = assert_no_diagnostics "llvm ir ownership" pipeline.ownership.diagnostics; Haven.Ast.Llvm_ir.emit_ir_string pipeline +let next_loc = + let counter = ref 0 in + fun () -> + let start_cnum = !counter * 2 in + incr counter; + let start_pos : Lexing.position = + { + pos_fname = "manual-test.hv"; + pos_lnum = 1; + pos_bol = 0; + pos_cnum = start_cnum; + } + in + let end_pos = { start_pos with pos_cnum = start_cnum + 1 } in + { Haven_core.Loc.start_pos; end_pos } + +let node value = { Core.value; loc = next_loc () } +let ident value = node value +let ty_i32 = node (Core.NumericType { Haven_token.Token.signedness = Signed; bits = 32 }) +let ty_i8 = node (Core.NumericType { Haven_token.Token.signedness = Signed; bits = 8 }) +let ty_i8_ptr = node (Core.PointerType ty_i8) +let ty_void = node Core.VoidType +let ty_buffer = node (Core.CustomType { name = ident "Buffer" }) +let ty_buffer_cell = node (Core.CellType ty_buffer) +let int_lit value = node (Core.Literal (node (Core.Integer value))) +let nil_expr = node Core.Nil +let box_buffer_expr = node (Core.BoxType ty_buffer) + +let field_expr target ~arrow name = + node + (Core.Field + (node + { + Core.target = target; + arrow; + field = ident name; + })) + +let assign_stmt target value = + node + (Core.Expression + (node + (Core.Assign + (node + { + Core.target = target; + value; + })))) + +let let_stmt ~mut name init_expr = + node + (Core.Let + (node + { + Core.mut = mut; + ty = None; + name = ident name; + init_expr; + })) + +let block ?result statements = node { Core.statements = statements; result } + +let fn_decl ?(public = false) ?(impure = false) ?(definition = None) ?(params = []) + ?(return_type = Some ty_void) name = + node + { + Core.public = public; + impure; + name = ident name; + definition; + intrinsic = None; + params = node { Core.params = params; vararg = false }; + return_type; + vararg = false; + } + +let param ty name = node { Core.name = ident name; ty } +let struct_field ty name = node ({ Core.name = ident name; ty } : Core.struct_field_desc) + +let emit_core_ir program = + let pipeline = Analysis.Pipeline.run_core { Core.program = program } in + let fail_if_diagnostics label diagnostics = + if diagnostics <> [] then + let messages = + String.concat " | " + (List.map (fun (diag : Analysis.diagnostic) -> diag.message) diagnostics) + in + failwith (label ^ ": " ^ messages) + in + fail_if_diagnostics "core llvm ir typing" pipeline.typing.diagnostics; + fail_if_diagnostics "core llvm ir verify" pipeline.verify.diagnostics; + fail_if_diagnostics "core llvm ir semantic" pipeline.semantic.diagnostics; + fail_if_diagnostics "core llvm ir purity" pipeline.purity.diagnostics; + fail_if_diagnostics "core llvm ir ownership" pipeline.ownership.diagnostics; + Haven.Ast.Llvm_ir.emit_ir_string pipeline + let run () = let main_ir = emit_ir "pub fn main() -> i32 { 7 }" in assert_true "main IR should define main" @@ -163,4 +259,111 @@ pub fn main() -> u32 { assert_true "successful compile asserts should not reach LLVM" (not (string_contains compile_assert_ir "compile-time assert")); assert_true "compile assert specializations should still lower normally" - (string_contains compile_assert_ir "@mat_width_eq__spec__mat2x2__mat2x2") + (string_contains compile_assert_ir "@mat_width_eq__spec__mat2x2__mat2x2"); + + let surface_lifecycle_ir = + emit_ir + {| +type Buffer = struct { + i8* ptr; + i32 len; +}; + +extend Buffer with { + construct(i32 len) { + self->len = len; + } + + destruct { + self->len = 0; + } +} +pub impure fn main() -> i32 { + let mut boxed = box Buffer(7); + boxed = nil; + 0 +} +|} + in + assert_true "surface lifecycle lowering should emit the synthesized constructor" + (string_contains surface_lifecycle_ir "define internal void @__haven_construct_Buffer"); + assert_true "surface lifecycle lowering should emit the synthesized destructor" + (string_contains surface_lifecycle_ir "define internal void @__haven_destruct_Buffer"); + assert_true "surface lifecycle lowering should call the synthesized constructor" + (string_contains surface_lifecycle_ir "call void @__haven_construct_Buffer"); + assert_true "surface lifecycle lowering should call the synthesized destructor" + (string_contains surface_lifecycle_ir "call void @__haven_destruct_Buffer"); + + let ctor_decl = + fn_decl "buffer_construct" + ~params:[ param ty_buffer_cell "self" ] + ~definition:(Some (block [])) + in + let dtor_decl = + fn_decl "buffer_destruct" + ~params:[ param ty_buffer_cell "self" ] + ~definition:(Some (block [])) + in + let buffer_type = + node + (Core.TDecl + (node + { + Core.name = ident "Buffer"; + data = + Core.TypeDeclStruct + (node + { + Core.fields = + [ + struct_field ty_i8_ptr "data"; + struct_field ty_i32 "len"; + ]; + lifecycle = None; + }); + construct = Some ctor_decl; + destruct = Some dtor_decl; + })) + in + let global_buffer_decl = + node + { + Core.name = ident "GLOBAL_BUFFER"; + public = false; + is_mutable = false; + ty = ty_buffer; + init_expr = None; + } + in + let main_decl = + fn_decl "main" ~public:true ~impure:true ~return_type:(Some ty_i32) + ~definition: + (Some + (block ~result:(int_lit 0) + [ + let_stmt ~mut:true "boxed" box_buffer_expr; + assign_stmt (node (Core.Identifier (ident "boxed"))) nil_expr; + ])) + in + let lifecycle_ir = + emit_core_ir + (node + { + Core.decls = + [ + buffer_type; + node (Core.VDecl global_buffer_decl); + node (Core.FDecl ctor_decl); + node (Core.FDecl dtor_decl); + node (Core.FDecl main_decl); + ]; + }) + in + assert_true "global default initialization should emit a synthesized ctor" + (string_contains lifecycle_ir "@__haven_global_init"); + assert_true "global default initialization should call the type constructor" + (string_contains lifecycle_ir "call void @buffer_construct"); + assert_true "box type construction should call the type constructor" + (string_contains lifecycle_ir "call void @buffer_construct"); + assert_true "final box release should call the type destructor" + (string_contains lifecycle_ir "call void @buffer_destruct") diff --git a/src/test/test_parser.ml b/src/test/test_parser.ml index bcc06b2..1d9f40b 100644 --- a/src/test/test_parser.ml +++ b/src/test/test_parser.ml @@ -31,6 +31,24 @@ let run () = assert_parse_ok "initializer without trailing comma" "type Thing = struct { i32 value; }; pub fn main() -> i32 { let Thing thing = { 1 }; thing.value }"; + assert_parse_ok "extend lifecycle block" + {| +type Buffer = struct { + i8* ptr; + i32 len; +}; + +extend Buffer with { + construct(i32 len) { + self->len = len; + } + + destruct { + self->len = 0; + } +} +|}; + assert_parse_error_contains "initializer trailing comma" "parse error" "type Thing = struct { i32 value; }; pub fn main() -> i32 { let Thing thing = { 1, }; thing.value }";