6043 lines
293 KiB
OCaml
6043 lines
293 KiB
OCaml
(** The checker: AST → typed IR.
|
||
|
||
Two passes, because top-level names in a package are order-independent
|
||
(plan.org, Modules): the first collects every type, signature and global,
|
||
the second checks bodies against them. Mutually recursive functions need no
|
||
forward declaration, and a struct may be used above where it is declared.
|
||
|
||
Checking is *bidirectional*. An expression is checked against an expected
|
||
type when there is one and inferred when there is not, which is what makes
|
||
[None], a bare [0] and a struct literal work without any inference engine:
|
||
the expected type flows in from the function's return type, the parameter
|
||
it is being passed to, or the field it is being stored in.
|
||
|
||
The rule from the two misparse bugs applies here too: *anything not yet
|
||
implemented is rejected by name*, never approximated. Milestone 2 is
|
||
calc-me.flan and nothing more (plan.org, Build sequence), so [Vec], [Map],
|
||
[Result]/[try], user data types, closures, [dotimes], [defer], generics and
|
||
cross-package imports are all errors with a message that says which
|
||
milestone they belong to. *)
|
||
|
||
let fail = Loc.fail
|
||
|
||
(* [List.map]'s evaluation order is unspecified, and checking allocates frame
|
||
slots as a side effect. Left-to-right is required, not a preference: a later
|
||
let binding sees an earlier one, and slot numbering must be reproducible. *)
|
||
let rec map_lr f = function
|
||
| [] -> []
|
||
| x :: rest -> let y = f x in y :: map_lr f rest
|
||
|
||
let rec map2_lr f xs ys =
|
||
match xs, ys with
|
||
| [], [] -> []
|
||
| x :: xs, y :: ys -> let z = f x y in z :: map2_lr f xs ys
|
||
| _ -> invalid_arg "map2_lr"
|
||
|
||
(* ── Environments ──────────────────────────────────────────────────── *)
|
||
|
||
type binding = {
|
||
slot : int;
|
||
bty : Types.t;
|
||
assignable : bool; (* locals are places; parameters are not — spec-memory *)
|
||
}
|
||
|
||
type env = {
|
||
structs : (string, Tast.structure) Hashtbl.t;
|
||
datas : (string, Tast.data) Hashtbl.t;
|
||
(* The untagged unions, by name, and they are [Tast.structure] values on
|
||
purpose: a union's members *are* a field list, and every one of them is at
|
||
offset zero. Giving them a record of their own would have meant a second
|
||
shape for [field_index] and for every walk over a member list, to say
|
||
nothing new — which table the name is in is already what says whether the
|
||
offsets are cumulative or all zero, exactly as it is for a data type. *)
|
||
unions : (string, Tast.structure) Hashtbl.t;
|
||
(* Every data type case, twice over: once under its full spelling ["U.C"], which
|
||
is how a value of it is written, and once under the bare ["C"], which is
|
||
how a [match] arm names it and how a mistake spells a constructor. The
|
||
full spelling is a key rather than something split out of a dotted name at
|
||
the use site, because a data type's own name can contain a slash (an imported
|
||
[rl/U]) and may one day contain a dot; string surgery would own an edge
|
||
this does not have to.
|
||
|
||
The bare entry is deliberately last-writer-wins and is *only* used to say
|
||
"C is a case of U, write (U.C ...)". Two data types may share a case name —
|
||
construction is qualified and a pattern resolves against the scrutinee, so
|
||
both are unambiguous — and refusing that would be a restriction with no
|
||
mechanism behind it. *)
|
||
cases : (string, string * Tast.variant) Hashtbl.t;
|
||
aliases : (string, Ast.texpr) Hashtbl.t;
|
||
consts : (string, int64) Hashtbl.t; (* compile-time array lengths *)
|
||
locs : (string, Loc.t) Hashtbl.t; (* where each type was declared *)
|
||
(* Enum name -> its members, in declaration order. A keyword at a call site
|
||
resolves against this and nothing else. *)
|
||
enums : (string, (string * int64) list) Hashtbl.t;
|
||
(* Flan name -> the C symbol it is really called by. A foreign function is an
|
||
ordinary entry in [fns] as well; this only records how to name it. *)
|
||
externs : (string, string) Hashtbl.t;
|
||
fns : (string, Types.t list * Types.t) Hashtbl.t;
|
||
globals : (string, Types.t * bool) Hashtbl.t; (* type, is a constant *)
|
||
(* Functions the checker made up: a handler-bind clause is lifted into one,
|
||
because a handler is called from wherever the signal was and cannot be a
|
||
branch in the function that established it. *)
|
||
mutable lifted : Tast.fn list;
|
||
|
||
(* ── Generics by monomorphisation (spike, milestone 5) ────────────────
|
||
A generic [defn] is *not* in [fns]: its signature mentions type variables
|
||
and nothing can be called at it. It lives here, as the AST it was written
|
||
as, and every call site turns it into an ordinary function with concrete
|
||
types. Odin's model exactly — [find_or_generate_polymorphic_procedure]
|
||
keeps the source [Entity] and hangs generated ones off it. *)
|
||
generics : (string, Ast.fn) Hashtbl.t;
|
||
(* Its signature as *written*: parameter and return types with [Types.Var]
|
||
in them. This is the pattern a call site matches its argument types
|
||
against to bind the variables. *)
|
||
gsigs : (string, string list * Types.t list * Types.t) Hashtbl.t;
|
||
(* The instantiation cache. Odin's [gen_procs] list, keyed the way Odin keys
|
||
it: a linear scan comparing whole concrete signatures with
|
||
[are_types_identical] — here [Types.equal] pairwise. Same types twice
|
||
means one copy. *)
|
||
insts : (string, (Types.t list * Types.t * string) list ref) Hashtbl.t;
|
||
(* The copies themselves, in the order they were generated. They are
|
||
ordinary [Tast.fn]s from here down; nothing in a backend knows they were
|
||
ever generic. *)
|
||
mutable instances : Tast.fn list;
|
||
(* The type variables in scope while a generic signature is being resolved.
|
||
Empty everywhere else, which is what keeps the lowercase rejection at
|
||
[resolve_name] the default. *)
|
||
mutable tyvars : string list;
|
||
(* What each of them is bound to while one instantiation's body is checked.
|
||
[resolve_name] consults it before anything else, so the body resolves
|
||
[t] to [i32] and every node under it is concrete. *)
|
||
mutable subst : (string * Types.t) list;
|
||
(* The [where] predicates in scope: what the abstract pass may assume about
|
||
the variables, and what each instantiation checks its concrete types
|
||
answer yes to. Empty everywhere a generic signature or body is not being
|
||
resolved, which is what keeps every refusal below the default. *)
|
||
mutable tvpreds : Ast.pred list;
|
||
(* The chain of instantiations currently being generated, innermost last:
|
||
the generic's name and the concrete parameter types each copy was asked
|
||
for. It is the refusal for a generic that instantiates itself without
|
||
end — [(defn grow [x $t] () (grow [x x]))] asks for a copy at [[2 t]],
|
||
which asks for one at [[2 [2 t]]], forever — and without it the checker
|
||
does not fail, it *hangs*, which through [Session.eval] is [C-c C-c]
|
||
hanging with the dev daemon wedged behind it.
|
||
|
||
The test is structural rather than a depth count. A depth count names a
|
||
number the programmer did not write and cannot act on; this names the
|
||
chain. Odin has no cap of its own to copy, so there was nothing to
|
||
borrow. *)
|
||
mutable chain : (string * Types.t list * Loc.t) list;
|
||
}
|
||
|
||
let new_env () = {
|
||
structs = Hashtbl.create 16;
|
||
datas = Hashtbl.create 16;
|
||
unions = Hashtbl.create 16;
|
||
cases = Hashtbl.create 32;
|
||
aliases = Hashtbl.create 16;
|
||
consts = Hashtbl.create 16;
|
||
locs = Hashtbl.create 16;
|
||
enums = Hashtbl.create 8;
|
||
externs = Hashtbl.create 32;
|
||
fns = Hashtbl.create 32;
|
||
globals = Hashtbl.create 16;
|
||
lifted = [];
|
||
generics = Hashtbl.create 8;
|
||
gsigs = Hashtbl.create 8;
|
||
insts = Hashtbl.create 8;
|
||
instances = [];
|
||
tyvars = [];
|
||
subst = [];
|
||
tvpreds = [];
|
||
chain = [];
|
||
}
|
||
|
||
(* Where a named type was declared, and what it has, as a note.
|
||
|
||
This is the second half of the two-place messages: a refusal that says
|
||
[Cursor has no field pos] is true, and the reader's next move is always to
|
||
go and look at Cursor. Attaching the declaration's location and its actual
|
||
field names means the answer arrives with the question, and [next-error]
|
||
will take you there because a note prints as an entry of its own. Empty when
|
||
the name is not one this environment placed, so it degrades to the message
|
||
alone rather than to a wrong pointer. *)
|
||
let declared_note env name =
|
||
match Hashtbl.find_opt env.locs name with
|
||
| None -> []
|
||
| Some at ->
|
||
let names =
|
||
match Hashtbl.find_opt env.structs name with
|
||
| Some s -> List.map (fun (f : Tast.field) -> f.Tast.fname) s.Tast.fields
|
||
| None ->
|
||
(match Hashtbl.find_opt env.datas name with
|
||
| Some u -> List.map (fun (c : Tast.variant) -> c.Tast.vname) u.Tast.cases
|
||
| None ->
|
||
match Hashtbl.find_opt env.unions name with
|
||
| Some u -> List.map (fun (f : Tast.field) -> f.Tast.fname) u.Tast.fields
|
||
| None -> [])
|
||
in
|
||
let what =
|
||
if names = [] then name ^ " is declared here"
|
||
else name ^ " is declared here, with " ^ String.concat ", " names
|
||
in
|
||
[ Loc.note at what ]
|
||
|
||
(* What a [break] or a [continue] may be talking about, innermost first.
|
||
|
||
[Lloop] is a loop it is lexically inside, carrying its label if it was given
|
||
one. [Lbarrier] is something a jump may not cross, named so the refusal can
|
||
say which — and the barriers are the whole of the answer to the question
|
||
[return]'s [in_frames] rule could not answer.
|
||
|
||
[return] is refused inside a [handler-bind] or a [restart-case] blanketly,
|
||
because a return *always* crosses the frames established there and leaves
|
||
them on the stack pointing into a frame that has gone. A break crosses only
|
||
sometimes: a loop written wholly inside a [restart-case] body has a
|
||
perfectly good local break, and refusing it would be refusing the common
|
||
case for the uncommon one. So the rule here is relative rather than blanket
|
||
— a jump is refused exactly when a barrier stands between it and the loop it
|
||
names — and the two rules agree on the case they share, because a [return]
|
||
is a jump whose target is always outside every barrier.
|
||
|
||
A [defer]'s forms are a barrier for a different reason with the same shape:
|
||
they are copied into the function's exit paths, where the loop they were
|
||
written next to no longer exists. A loop *inside* the defer is fine, which
|
||
is again the relative rule and not a blanket one.
|
||
|
||
A handler clause is not on this list at all: it is lifted into a function of
|
||
its own and gets a fresh [ctx], so its loops start empty and nothing inside
|
||
it can name a loop outside it. *)
|
||
type lentry =
|
||
| Lloop of string option
|
||
(* A [(loop ...)], carrying the slot and type of each of its names so that a
|
||
[recur] can rebind them. It is *also* a barrier for [break] and
|
||
[continue]: a loop answers with the value of its body, so a jump that left
|
||
one would have no value to give. A [while] written inside a loop is
|
||
unaffected, which is the relative rule doing its job again. *)
|
||
| Lrecur of (int * Types.t) list
|
||
| Lbarrier of string
|
||
|
||
(* Per-function state. Slots are never reused, so [slots] is also the frame
|
||
size — the interpreter allocates one array of this length per call. *)
|
||
type ctx = {
|
||
env : env;
|
||
ret : Types.t;
|
||
mutable slots : int;
|
||
(* The type of each slot, newest first. A backend needs it to size the
|
||
frame — nothing else records it, since the IR refers to slots by index. *)
|
||
mutable slot_tys : Types.t list;
|
||
(* The source name of each slot, newest first, parallel to [slot_tys].
|
||
[None] for a slot the checker invented -- see [Tast.fn.snames]. Recorded
|
||
here rather than recovered later because this scope list is the only place
|
||
that ever knows it. *)
|
||
mutable slot_names : string option list;
|
||
mutable scope : (string * binding) list; (* innermost first *)
|
||
(* Deferred forms, most recently registered first — which is also the order
|
||
they run in. [defer] is function-scoped, so this list belongs to the
|
||
function and not to a block — see [defer_ok] for where one may be written
|
||
and [check_fn] for where the list is spliced onto the exit paths. *)
|
||
mutable defers : Tast.expr list;
|
||
(* Where a [defer] may be written, which is exactly: a form whose extent is
|
||
the whole function body. Two things have that extent and only two — a
|
||
top-level form of the body, and a form in the body of a [let] that itself
|
||
has it, to any depth. A [let] always registers and its bindings outlive
|
||
the block textually enclosing them, because a [let] is not a frame here:
|
||
its bindings are function slots like any other, and nothing is released at
|
||
scope exit (spec-memory.md, "When storage is released").
|
||
|
||
Everything else is refused, and the two that matter are refused for a
|
||
reason rather than by omission. [defer] is a *compile-time* construct —
|
||
the cleanup is copied into every exit path — so a branch would have to
|
||
express "maybe registered", which it cannot, and a loop body would fire
|
||
once at function exit rather than once per iteration.
|
||
|
||
The flag is set immediately before each form that may carry one, never
|
||
once around a body: [check] clears it on entry, so a body whose first form
|
||
set it would otherwise refuse the second. [defer_block] names the
|
||
innermost construct that cleared it, so the refusal says which. *)
|
||
mutable defer_ok : bool;
|
||
mutable defer_block : string;
|
||
(* Only for the two things a handler clause cannot do. [outer] is the
|
||
establishing function's scope, kept so that a reference to one of its
|
||
locals can be refused for the reason it is really refused for rather than
|
||
as an unknown name. *)
|
||
outer : (string * binding) list;
|
||
(* Set on the context of a body the checker lifted into a function of its
|
||
own — a handler clause, or an [fn] literal — and naming which, so the
|
||
refusal below says why the enclosing function's locals are not there. Both
|
||
are the same gap: capture does not exist. *)
|
||
mutable outer_what : string option;
|
||
(* True wherever handler or restart frames established by this function are
|
||
on the stack. A [return] from there would leave them pointing into a frame
|
||
that has gone, so it is refused — the same rule as [defer] inside a
|
||
block. *)
|
||
mutable in_frames : string option;
|
||
(* The loops and the barriers this form is inside, innermost first. See
|
||
[lentry]: it is what [break] and [continue] resolve against, and the whole
|
||
of why they are not a goto — a label that names no loop on this list is
|
||
refused, so control can only leave a loop it is already in. *)
|
||
mutable loops : lentry list;
|
||
(* True where this form's value is the value of the enclosing [loop]'s body,
|
||
which is the only place a [recur] may stand. Read and withdrawn at the top
|
||
of [check] exactly as [defer_ok] is, and granted again by the three forms
|
||
that pass a tail through: the last form of a block, both arms of an [if],
|
||
and a [match] arm. Everything else is therefore non-tail by construction,
|
||
and no walk has to enumerate the cases that are not. *)
|
||
mutable tail : bool;
|
||
(* True inside a [defer]'s forms. A defer is the cleanup a transfer runs on
|
||
its way out (§5), so a transfer *starting* there has no answer: this
|
||
function's defers are already half run and the first transfer's target is
|
||
already in hand. Refused where it is written. *)
|
||
mutable in_defer : bool;
|
||
(* The function being checked, so a clause lifted out of it can be named
|
||
after it. The name has to be stable and has to say whose it is: a
|
||
redefinition module emits the clauses belonging to the bodies it is
|
||
replacing, and nothing else in the program can tell it which those are. *)
|
||
owner : string;
|
||
}
|
||
|
||
(* [?name] is the source name, when there is one. It is optional so that the
|
||
several places that allocate a hidden slot say nothing and get [None] --
|
||
a synthesized slot cannot accidentally acquire a name it was never given. *)
|
||
let fresh_slot ?name ctx ty =
|
||
let s = ctx.slots in
|
||
ctx.slots <- s + 1;
|
||
ctx.slot_tys <- ty :: ctx.slot_tys;
|
||
ctx.slot_names <- name :: ctx.slot_names;
|
||
s
|
||
|
||
(* Shadowing is legal -- [(let [v 11] (let [v 22] ...))] is two slots, both
|
||
named [v] -- and the debug info has nowhere to put the distinction. Every
|
||
[!DILocalVariable] is scoped to the subprogram, because the typed IR has no
|
||
block structure for a [!DILexicalBlock] to be built from, so two variables
|
||
called [v] land in one flat scope and lldb answers [p v] with whichever it
|
||
finds first. Measured, not assumed: it answers with the *outer* one, so it
|
||
prints 11 while the body it is stopped in is computing with 22, and the
|
||
inner binding is not listed at all.
|
||
|
||
That is the one outcome worse than printing [s3]: a name the debugger is
|
||
confident about and wrong about. So a repeat of a name already bound in this
|
||
function gets a suffix, and both bindings are then visible and unambiguous.
|
||
[~] is the reader's delimiter and cannot occur in a source symbol (the same
|
||
reason [destructure~nth] is spelled that way), so [v~2] is visibly the
|
||
compiler's doing and can never collide with something the programmer wrote.
|
||
|
||
This is a way of not lying, not a way of being right: [v] is still the outer
|
||
binding everywhere, including inside the inner one's extent. Scoping the
|
||
variables properly means emitting a [!DILexicalBlock] per [Let] and moving
|
||
the [llvm.dbg.declare]s out of the entry block to the binding sites, which
|
||
needs block structure this IR does not carry. *)
|
||
let bind ctx name bty ~assignable =
|
||
let taken n = List.exists (fun s -> s = Some n) ctx.slot_names in
|
||
let name' =
|
||
if not (taken name) then name
|
||
else
|
||
let rec go k =
|
||
let c = Printf.sprintf "%s~%d" name k in
|
||
if taken c then go (k + 1) else c
|
||
in
|
||
go 2
|
||
in
|
||
let slot = fresh_slot ~name:name' ctx bty in
|
||
(* [ctx.scope] keeps the *source* name: the suffix is a debug-info artifact
|
||
and resolving [v] must still find the innermost binding. *)
|
||
ctx.scope <- (name, { slot; bty; assignable }) :: ctx.scope;
|
||
slot
|
||
|
||
let lookup ctx name = List.assoc_opt name ctx.scope
|
||
|
||
(* A handler clause is lifted into a function of its own, so the establishing
|
||
function's locals are simply not there. Capturing them is a closure with an
|
||
explicit environment — spec-memory.md's case 2, a non-escaping [fn] capturing
|
||
by value into a stack environment, since a handler frame does not outlive the
|
||
function that pushed it — and until that exists a reference to one is refused
|
||
for the reason it is really refused for, rather than as a name nobody has
|
||
heard of. *)
|
||
let captured ctx loc name =
|
||
match ctx.outer_what with
|
||
| Some what when List.mem_assoc name ctx.outer ->
|
||
let why =
|
||
if String.equal what "a handler" then
|
||
"a handler runs from wherever the signal was. Use a global, or pass \
|
||
it on the condition"
|
||
else
|
||
"an fn is lifted into a function of its own and is handed nothing but \
|
||
its parameters. Pass it in, or use a global"
|
||
in
|
||
Loc.failk "check/capture" loc
|
||
"%s cannot see %s: it is a local of the enclosing function, and %s."
|
||
what name why
|
||
| _ -> ()
|
||
|
||
let scoped ctx f =
|
||
let saved = ctx.scope in
|
||
let r = f () in
|
||
ctx.scope <- saved;
|
||
r
|
||
|
||
(* A scope that is also a named blocker for [defer]. An arm of an [if] or a
|
||
[match] runs only sometimes, and "maybe registered" is not something a
|
||
compile-time construct can express — the cleanup is copied into every exit
|
||
path or into none — so the refusal is about the branch and says so.
|
||
|
||
Outside the [check] recursion on purpose: inside it the inferred type would
|
||
be monomorphic, and the two callers pass functions returning different
|
||
things. *)
|
||
let branch ctx f =
|
||
let blocker = ctx.defer_block in
|
||
ctx.defer_block <- "a branch";
|
||
let r = scoped ctx f in
|
||
ctx.defer_block <- blocker;
|
||
r
|
||
|
||
(* ── Type resolution ───────────────────────────────────────────────── *)
|
||
|
||
let unimplemented loc what milestone =
|
||
fail loc "%s is not implemented yet — milestone %d (see plan.org)"
|
||
what milestone
|
||
|
||
(* ── where predicates ──────────────────────────────────────────────────
|
||
A predicate is a compile-time question about a type, and that is the whole
|
||
of it. It carries no implementation, selects no instance, and is not
|
||
extensible: it gates a builtin the compiler already has. So there are no
|
||
dictionaries, no coherence rules and no run-time cost — and the ceiling is
|
||
that nobody can supply a [<] of their own, which does not bind because
|
||
every operation the prelude and the containers need is a primitive.
|
||
|
||
Odin's [where] clause is the same shape ([core/slice/slice.odin:289] is
|
||
[where intrinsics.type_is_ordered(T)]) with forty-one predicates against
|
||
these four. There is no [copyable?] any more and no Odin counterpart
|
||
either: Odin has no move semantics, and since the repeal neither does this
|
||
language, so [$T] never has to answer the question. *)
|
||
let predicate_names = [ "ordered?"; "equal?"; "hashable?"; "numeric?" ]
|
||
|
||
(* ── What a type owns, transitively ────────────────────────────────────
|
||
The one structural ownership question that survived the repeal, because it
|
||
is not about copying at all.
|
||
|
||
What it decides, and the only thing it decides, is whether a container of
|
||
this element type has to be built against a region allocator — see
|
||
[region_only] below and [flan_alloc_region_only] in the runtime. That is a
|
||
question about *release*, so it is asked of every arm a release would have
|
||
to reach and would not: a Vec or Map owns a block outright; an Option,
|
||
a fixed array, a struct or a data type's case owns whatever its payload
|
||
does.
|
||
|
||
It does not live in [Types] for the reason [Types.keyable] gives: that
|
||
module has no field table. The [seen] list is the cycle guard, and the cycle
|
||
is real — the recursive dynamic value this exists for holds a [(Vec Value)],
|
||
so [Value]'s walk reaches [Value]. Answering [false] for a name already on
|
||
the path is right rather than merely terminating: whatever made the outer
|
||
name own something was found by the arm that got here, and a name cannot
|
||
contain itself by value anyway — [check_finite] refuses that — only through
|
||
a container, which is an arm that answers for itself.
|
||
|
||
[env.unions], the untagged ones, are deliberately not consulted: nothing
|
||
anywhere records which member of one is live, so there is no fact this
|
||
walk could read — an untagged union is treated as owning nothing, and what
|
||
its members point at is the program's, through whatever tag it keeps
|
||
beside the union. *)
|
||
let owning_fields env n =
|
||
match Hashtbl.find_opt env.structs n with
|
||
| Some s -> [ s.Tast.fields ]
|
||
| None ->
|
||
match Hashtbl.find_opt env.datas n with
|
||
| Some d -> List.map (fun (c : Tast.variant) -> c.Tast.vfields) d.Tast.cases
|
||
| None -> []
|
||
|
||
let rec owning env ?(seen = []) (t : Types.t) =
|
||
match t with
|
||
| Types.Vec _ | Types.Map _ -> true
|
||
| Types.Option e | Types.Array (_, e) -> owning env ~seen e
|
||
| Types.Named n ->
|
||
not (List.mem n seen)
|
||
&& List.exists
|
||
(List.exists
|
||
(fun (f : Tast.field) -> owning env ~seen:(n :: seen) f.Tast.fty))
|
||
(owning_fields env n)
|
||
| _ -> false
|
||
|
||
(* Does a container of this type have to be built against an allocator that
|
||
cannot free one block? Only the half a release would have to walk is asked:
|
||
a map's key cannot own anything — [map_type] refuses one, because a key that
|
||
owned storage would hash its header rather than what it points at — so the
|
||
value is the whole of the question there. *)
|
||
let region_only env (t : Types.t) =
|
||
match t with
|
||
| Types.Vec e -> owning env e
|
||
| Types.Map (_, v) -> owning env v
|
||
| _ -> false
|
||
|
||
(* Does a concrete type answer yes? Checked at every instantiation, against
|
||
the type the call site asked for. *)
|
||
let pred_holds p (t : Types.t) =
|
||
match p with
|
||
| "ordered?" -> Types.is_comparable t
|
||
| "equal?" -> Types.is_equatable t
|
||
(* [Types.keyable] says yes to a struct and leaves its fields to [key_pair],
|
||
which walks them at the operation. That split is the existing one and is
|
||
kept: a generic declared [hashable?] and instantiated at a struct whose
|
||
fields are not keyable is refused where every other program is, by
|
||
[key_pair]. *)
|
||
| "hashable?" -> Types.keyable t
|
||
| "numeric?" -> Types.is_numeric t
|
||
| _ -> false
|
||
|
||
(* What one declared predicate *also* gives you. These are entailments over
|
||
the type system as it stands, not conveniences: every type [is_comparable]
|
||
admits is a number or an enum, so it is equatable. The table is only sound
|
||
while that is true — an ordered type with no [=] would make it wrong — so
|
||
it lives in one place and says so. The gain is real ergonomics:
|
||
[{:where (ordered? $t)}] is enough for a [sort!] that also compares,
|
||
rather than two predicates on one line. *)
|
||
let pred_entails ~declared ~wanted =
|
||
String.equal declared wanted
|
||
|| match wanted, declared with
|
||
| "ordered?", "numeric?" -> true
|
||
| "equal?", ("numeric?" | "ordered?") -> true
|
||
| _ -> false
|
||
|
||
let declares preds v wanted =
|
||
List.exists
|
||
(fun (p : Ast.pred) ->
|
||
String.equal p.Ast.pvar v && pred_entails ~declared:p.Ast.pname ~wanted)
|
||
preds
|
||
|
||
(* Which variable, if any, a type bottoms out at. Only a bare variable can
|
||
carry a predicate: [(Vec t)] is a Vec whatever [t] is, and its own
|
||
properties are the Vec's. *)
|
||
let tyvar_of (t : Types.t) = match t with Types.Var v -> Some v | _ -> None
|
||
|
||
(* ── (Map K V), spec-memory.md ──────────────────────────────────────────
|
||
Both halves are checked where the type is written, not where an operation
|
||
is, so that a map nothing ever uses is still refused if it cannot work.
|
||
[Check.key_pair] emits the hash and equality pair later, at the operation,
|
||
and repeats these refusals rather than assuming: the two are reached by
|
||
different paths and a silent disagreement between them would be worse than
|
||
saying the same thing twice. *)
|
||
let map_type ?(preds = []) loc (k : Types.t) (v : Types.t) =
|
||
ignore preds;
|
||
(* The value used to be refused here when it owned anything, in the same
|
||
words [(Vec (Vec T))] used, and the refusal is gone for the reason set out
|
||
over [map-new]: it was about *teardown*, and which tier this map will be
|
||
built against is not knowable where its type is written. The question is
|
||
asked at the construction instead, of the allocator, once. *)
|
||
(* () has no bytes, so a slot for one is a slot of nothing: the cell
|
||
geometry divides the cache line by the element size and there is nothing
|
||
to divide by. It is also the natural spelling of a *set*, which is why
|
||
someone will write it, so it is refused by name rather than by a crash. *)
|
||
if Types.equal v Types.Unit then
|
||
fail loc
|
||
"a map value cannot be () — there is nothing to store. A set of keys \
|
||
is not built yet; use (Map %s bool) and ignore the value"
|
||
(Types.to_string k);
|
||
if Types.equal k Types.Unit then
|
||
fail loc "a map key cannot be () — every key would be the same key";
|
||
(* The key, as far as the type alone can say. A struct passes here and is
|
||
decided at the operation, by [key_pair], which walks its fields — the
|
||
struct table is not necessarily complete while a type is being resolved,
|
||
and every map that exists reaches an operation anyway, because a global
|
||
map starts zeroed and a local needs (map-new). *)
|
||
(* A type variable is a map key exactly when the [where] clause says it is
|
||
hashable. Nothing else about it is knowable here, and falling through to
|
||
[Types.keyable] would answer no for a variable that is about to be
|
||
instantiated at [string]. *)
|
||
if not (match k with
|
||
| Types.Var v -> declares preds v "hashable?"
|
||
| k -> Types.keyable k) then
|
||
fail loc
|
||
"%s is not a map key. The first implementation takes integers, enums, \
|
||
bools, strings, fixed arrays of those, and value structs composed of \
|
||
those (spec-memory.md, \"Maps — first implementation\"). A float has \
|
||
no usable equality — NaN is not equal to itself — and a Ptr, a slice, \
|
||
a Vec or a Map would hash an address rather than what it points at"
|
||
(Types.to_string k);
|
||
Types.Map (k, v)
|
||
|
||
(* The positions a function value may not be written in, and the one reason
|
||
they are all the same position: something zeroes it.
|
||
|
||
ZII is the language's rule — an omitted struct field, a fixed array's
|
||
elements, a [defvar] with no initialiser are all all-bytes-zero — and a
|
||
zeroed function value is a null pointer with a signature on it, which is the
|
||
one kind of zero that cannot be used for anything. Every other type's zero
|
||
is a value: 0, false, an empty slice, [None], a data type's first case. So these
|
||
are refused where they are written rather than left to crash at the call.
|
||
|
||
A parameter, a return type, a [let] binding and an [(Option (Fn ...))] are
|
||
not on the list: none of them is ever conjured, and an [Option]'s zero is a
|
||
[None] whose tag nobody may look past. *)
|
||
let rec no_zeroed_fn loc what (t : Types.t) =
|
||
match t with
|
||
| Types.Fn _ ->
|
||
fail loc
|
||
"%s cannot be %s: it would be zeroed, and a zeroed function value is \
|
||
a null pointer — every other type's zero is a value it can have, and \
|
||
this one is not. Pass it as a parameter, or hold it in a let"
|
||
what (Types.to_string t)
|
||
| Types.Array (_, e) -> no_zeroed_fn loc what e
|
||
| _ -> ()
|
||
|
||
let rec resolve env ?(seen = []) (t : Ast.texpr) : Types.t =
|
||
let loc = t.Ast.tloc in
|
||
match t.Ast.t with
|
||
| Ast.Tname n -> resolve_name env ~seen loc n
|
||
| Ast.Tslice e -> Types.Slice (resolve env ~seen e)
|
||
| Ast.Tarray (l, e) ->
|
||
let e = resolve env ~seen e in
|
||
no_zeroed_fn loc "a fixed array's element" e;
|
||
Types.Array (array_len env loc l, e)
|
||
(* {K V} is the type spelling. There is no map *literal*: a bare map form in
|
||
expression position is a struct literal's field list, and giving the same
|
||
braces two meanings is what the colon-to-dot change was for. A map is
|
||
built with (map-new) and filled with (put). *)
|
||
| Ast.Tmap (k, v) ->
|
||
map_type ~preds:env.tvpreds loc (resolve env ~seen k)
|
||
(resolve env ~seen v)
|
||
(* (Fn [T ...] R): a function value, which is one code address and no
|
||
environment beside it. There is no capture — [check_fn] refuses a
|
||
reference to an enclosing local by name — so this is a pointer with a
|
||
signature and nothing about it can dangle.
|
||
|
||
Where one may be *written* is narrower than where the type resolves, and
|
||
the two rules live apart on purpose: this is what the spelling means, and
|
||
[no_zeroed_fn] is where a position that would zero one is refused. A
|
||
parameter, a return type and a let binding are the positions that work. *)
|
||
| Ast.Tfn (ps, r) ->
|
||
Types.Fn (List.map (resolve env ~seen) ps, resolve env ~seen r)
|
||
| Ast.Tapp (name, args) ->
|
||
(match name, args with
|
||
| "Ptr", [ a ] -> Types.Ptr (resolve env ~seen a)
|
||
| "Option", [ a ] -> Types.Option (resolve env ~seen a)
|
||
| ("Ptr" | "Option"), _ -> fail loc "(%s T) takes exactly one type" name
|
||
| "Vec", [ a ] ->
|
||
let e = resolve env ~seen a in
|
||
(* A Vec of a Vec used to be refused here, and the refusal named two
|
||
different failures under one sentence: that [clone] would duplicate
|
||
inner headers instead of copying, and that [free] would drop their
|
||
buffers on the floor. Only the second one was about *teardown*, and
|
||
only the second one an arena answers — [free-all] takes the region
|
||
and the inner blocks with it, because they came out of the same
|
||
region. So the type is admitted, the tier is checked at the
|
||
construction where the allocator is a value that exists (see
|
||
[vec-new]), and [clone] stays refused at the operation, on its own
|
||
merits, in its own words.
|
||
|
||
It cannot be refused *here* because nothing here knows the tier:
|
||
[with-allocator] rebinds a dynamic variable, so which allocator a
|
||
[(vec-new)] meets is not a property of where the type is written. *)
|
||
Types.Vec e
|
||
| "Vec", _ -> fail loc "(Vec T) takes exactly one type"
|
||
| "Map", [ k; v ] ->
|
||
map_type ~preds:env.tvpreds loc (resolve env ~seen k)
|
||
(resolve env ~seen v)
|
||
| "Map", _ -> fail loc "(Map K V) takes exactly two types"
|
||
| "Result", _ -> unimplemented loc "(Result T E)" 6
|
||
| _ ->
|
||
fail loc
|
||
"%s takes no type arguments — generics are milestone 5" name)
|
||
|
||
(* One edit away from a type that exists — a substitution, an insertion, a
|
||
deletion or a transposition of neighbours. Bounded at one, because two edits
|
||
is no longer a typo, it is a guess. *)
|
||
and near_miss env n =
|
||
let one_edit a b =
|
||
let la = String.length a and lb = String.length b in
|
||
if abs (la - lb) > 1 then false
|
||
else begin
|
||
(* Walk both until they diverge, then require the tails to match with the
|
||
single edit applied. *)
|
||
let i = ref 0 in
|
||
while !i < la && !i < lb && a.[!i] = b.[!i] do incr i done;
|
||
let ta s k = String.sub s k (String.length s - k) in
|
||
if la = lb then
|
||
!i < la
|
||
&& (ta a (!i + 1) = ta b (!i + 1)
|
||
(* stirng/string: two neighbours swapped. *)
|
||
|| (!i + 1 < la && a.[!i] = b.[!i + 1] && a.[!i + 1] = b.[!i]
|
||
&& ta a (!i + 2) = ta b (!i + 2)))
|
||
else if la < lb then ta a !i = ta b (!i + 1)
|
||
else ta a (!i + 1) = ta b !i
|
||
end
|
||
in
|
||
let candidates =
|
||
Types.primitive_names
|
||
@ Hashtbl.fold (fun k _ acc -> k :: acc) env.aliases []
|
||
@ Hashtbl.fold (fun k _ acc -> k :: acc) env.structs []
|
||
@ Hashtbl.fold (fun k _ acc -> k :: acc) env.datas []
|
||
@ Hashtbl.fold (fun k _ acc -> k :: acc) env.unions []
|
||
@ Hashtbl.fold (fun k _ acc -> k :: acc) env.enums []
|
||
in
|
||
List.find_opt (fun c -> c <> n && one_edit n c) candidates
|
||
|
||
and resolve_name env ~seen loc n =
|
||
(* ── Type variables, with a sigil at the binding site ─────────────────
|
||
[$t] *introduces* a variable and bare [t] uses it, which is Odin's
|
||
spelling ([$T] in the signature, [T] in the body). The sigil is read as
|
||
an ordinary symbol character, so the whole decision lives here: nothing
|
||
in the reader, the parser or the AST knows the character means anything.
|
||
|
||
Which names are variables is decided before this is ever called —
|
||
[signature_tyvars] scans the signature for the sigil and puts the bare
|
||
names in [env.tyvars] — so an unknown lowercase name is still the
|
||
unknown-type error it always was. That is the point of the sigil: without
|
||
one, a mistyped type name silently became a type parameter and made the
|
||
function more permissive than it was written to be. *)
|
||
let bare = if n <> "" && n.[0] = '$' then String.sub n 1 (String.length n - 1) else n in
|
||
match List.assoc_opt bare env.subst with
|
||
(* Inside an instantiation: the variable is this concrete type, and every
|
||
node checked under it is as concrete as if it had been written out. *)
|
||
| Some t -> t
|
||
| None ->
|
||
if List.mem bare env.tyvars then Types.Var bare
|
||
else if n <> bare then
|
||
(* A sigil somewhere that is not a [defn] signature: a struct field, a
|
||
global, a [let] annotation. There is nowhere for it to bind, so it is
|
||
the error rather than a variable with no scope. *)
|
||
Loc.failk "check/unbound-type-variable" loc
|
||
"%s introduces a type variable, and only a defn signature can — write \
|
||
the concrete type here" n
|
||
else
|
||
match Types.ikind_of_name n with
|
||
| Some k -> Types.Int k
|
||
| None ->
|
||
match Types.fkind_of_name n with
|
||
| Some k -> Types.Float k
|
||
| None ->
|
||
match n with
|
||
| "bool" -> Types.Bool
|
||
| "string" -> Types.String
|
||
| "Unit" -> Types.Unit
|
||
| "Never" -> Types.Never
|
||
(* A builtin opaque type, the way [string] is a builtin ptr+len. There is
|
||
no user-writable constructor and no way to name its procedure: see
|
||
Types, and NEXT.md's "the escape is real". *)
|
||
| "Allocator" -> Types.Alloc
|
||
| _ when Hashtbl.mem env.aliases n ->
|
||
if List.mem n seen then
|
||
fail loc "the type alias %s is defined in terms of itself" n
|
||
else resolve env ~seen:(n :: seen) (Hashtbl.find env.aliases n)
|
||
| _ when Hashtbl.mem env.structs n -> Types.Named n
|
||
(* A data type is [Named] exactly as a struct is: one case in [Types.t]
|
||
covers both, and which table the name is in is what tells them apart.
|
||
Keeping them one case is what lets a data type be a field, a parameter, a
|
||
return type and a slot without a single one of those paths learning
|
||
that data types exist. *)
|
||
| _ when Hashtbl.mem env.datas n -> Types.Named n
|
||
(* And so is an untagged union, for the same reason: it is a value of a
|
||
size and an alignment, and nothing that carries one has to know it is
|
||
a union rather than a struct. *)
|
||
| _ when Hashtbl.mem env.unions n -> Types.Named n
|
||
| _ when Hashtbl.mem env.enums n -> Types.Enum n
|
||
(* A typo in a primitive is lowercase too, and the type-variable rule
|
||
below would otherwise report [f65] as unimplemented generics and send
|
||
you to plan.org instead of to the character you mistyped. *)
|
||
| _ when near_miss env n <> None ->
|
||
Loc.failk "check/unknown-type" loc "unknown type %s — did you mean %s?" n
|
||
(Option.get (near_miss env n))
|
||
(* Lowercase is a type variable, Capitalized is concrete — no sigil
|
||
(plan.org, Types). A variable parses, but nothing at milestone 2 can
|
||
give a value one, so it is rejected here rather than later. *)
|
||
| _ when n <> "" && n.[0] = Char.lowercase_ascii n.[0] ->
|
||
unimplemented loc
|
||
(Printf.sprintf "generic code over the type variable %s" n) 5
|
||
| _ -> Loc.failk "check/unknown-type" loc "unknown type %s" n
|
||
|
||
and array_len env loc = function
|
||
| Ast.Lint n -> n
|
||
| Ast.Lname n ->
|
||
(match Hashtbl.find_opt env.consts n with
|
||
| Some v -> v
|
||
| None ->
|
||
fail loc "%s is not a compile-time integer constant, so it cannot be \
|
||
an array length" n)
|
||
|
||
(* ── Generics: the four operations monomorphisation needs ───────────────
|
||
Naming a variable, binding one from an argument, substituting the binding
|
||
back in, and spelling the result as a symbol. Everything else about the
|
||
feature is where these are called from. *)
|
||
|
||
(* The variables a signature introduces: every [$t] written in it, in the
|
||
order written, once each. Only a [defn] signature is scanned, which is what
|
||
makes the binding site a *place* and not merely a spelling. *)
|
||
let signature_tyvars (fn : Ast.fn) =
|
||
let acc = ref [] in
|
||
let name loc n =
|
||
if n <> "" && n.[0] = '$' then begin
|
||
let bare = String.sub n 1 (String.length n - 1) in
|
||
if bare = "" then fail loc "$ on its own does not name a type variable";
|
||
(* [$i32] would shadow a machine type inside the body and read as one
|
||
everywhere else. There is no reason to want it. *)
|
||
if List.mem bare Types.primitive_names
|
||
|| Types.ikind_of_name bare <> None
|
||
|| Types.fkind_of_name bare <> None then
|
||
fail loc "%s is a type, so $%s cannot be a type variable" bare bare;
|
||
if not (List.mem bare !acc) then acc := bare :: !acc
|
||
end
|
||
in
|
||
let rec ty (t : Ast.texpr) =
|
||
match t.Ast.t with
|
||
| Ast.Tname n -> name t.Ast.tloc n
|
||
| Ast.Tslice e -> ty e
|
||
| Ast.Tarray (_, e) -> ty e
|
||
| Ast.Tmap (k, v) -> ty k; ty v
|
||
(* The head of an application is a constructor — [Ptr], [Option], [Vec] —
|
||
and a variable cannot stand there: this spike is generic over types,
|
||
not over type constructors. A [$t] inside the arguments is ordinary. *)
|
||
| Ast.Tapp (_, args) -> List.iter ty args
|
||
| Ast.Tfn (ps, r) -> List.iter ty ps; ty r
|
||
in
|
||
List.iter (fun (p : Ast.field) -> ty p.Ast.fty) fn.Ast.params;
|
||
(match fn.Ast.ret with Some r -> ty r | None -> ());
|
||
List.rev !acc
|
||
|
||
(* Bind the variables in a parameter's written type from the type an argument
|
||
turned out to have. Odin's [is_polymorphic_type_assignable], structurally
|
||
and with the same rule: a variable already bound must match what it is
|
||
bound to, so [(pair 1 2.0)] over [a $t b $t] is a refusal and not a
|
||
second instantiation. *)
|
||
let rec bind_ty subst (pat : Types.t) (arg : Types.t) =
|
||
match pat, arg with
|
||
| Types.Var v, a ->
|
||
(match List.assoc_opt v !subst with
|
||
| None -> subst := (v, a) :: !subst; true
|
||
| Some b -> Types.equal a b)
|
||
| Types.Slice p, Types.Slice a
|
||
| Types.Ptr p, Types.Ptr a
|
||
| Types.Vec p, Types.Vec a
|
||
| Types.Option p, Types.Option a -> bind_ty subst p a
|
||
| Types.Array (n, p), Types.Array (m, a) -> Int64.equal n m && bind_ty subst p a
|
||
| Types.Map (k, v), Types.Map (k', v') ->
|
||
bind_ty subst k k' && bind_ty subst v v'
|
||
| Types.Fn (ps, r), Types.Fn (ps', r') ->
|
||
List.length ps = List.length ps'
|
||
&& List.for_all2 (bind_ty subst) ps ps' && bind_ty subst r r'
|
||
(* Nothing generic left on the pattern side: this is ordinary type
|
||
equality, and [Never] fits anywhere exactly as it does elsewhere. *)
|
||
| p, a -> Types.fits ~expected:p ~actual:a
|
||
|
||
let rec subst_ty subst (t : Types.t) =
|
||
match t with
|
||
| Types.Var v -> (match List.assoc_opt v subst with Some c -> c | None -> t)
|
||
| Types.Slice e -> Types.Slice (subst_ty subst e)
|
||
| Types.Array (n, e) -> Types.Array (n, subst_ty subst e)
|
||
| Types.Map (k, v) -> Types.Map (subst_ty subst k, subst_ty subst v)
|
||
| Types.Ptr e -> Types.Ptr (subst_ty subst e)
|
||
| Types.Vec e -> Types.Vec (subst_ty subst e)
|
||
| Types.Option e -> Types.Option (subst_ty subst e)
|
||
| Types.Fn (ps, r) -> Types.Fn (List.map (subst_ty subst) ps, subst_ty subst r)
|
||
| t -> t
|
||
|
||
(* Does this resolved type still mention a variable? *)
|
||
let rec generic_ty (t : Types.t) =
|
||
match t with
|
||
| Types.Var _ -> true
|
||
| Types.Slice e | Types.Array (_, e) | Types.Ptr e | Types.Vec e
|
||
| Types.Option e -> generic_ty e
|
||
| Types.Map (k, v) -> generic_ty k || generic_ty v
|
||
| Types.Fn (ps, r) -> List.exists generic_ty ps || generic_ty r
|
||
| _ -> false
|
||
|
||
(* The refusal plan.org's Types section asks for, in one place so that every
|
||
operator says the same thing: with no constraints a type variable supports
|
||
only what *every* type supports, so [=], [<], [+] and [hash] over one are
|
||
rejected rather than silently instantiated at whatever type the first call
|
||
site happened to use.
|
||
|
||
With [where] there are now two ways out and the message names both: declare
|
||
the predicate, or take the operation as a function value the way
|
||
[sort-by!] does. Declaring it is the one that keeps the call site short,
|
||
which is the whole reason predicates exist — under the no-constraint rule
|
||
[(sort! xs)] had to become [(sort-by! xs (fn [a b] (< a b)))] at every call
|
||
site in the corpus. *)
|
||
let unconstrained env loc op ~needs (t : Types.t) =
|
||
if generic_ty t then
|
||
match tyvar_of t with
|
||
| Some v when declares env.tvpreds v needs -> ()
|
||
| _ ->
|
||
Loc.failk "check/unconstrained-type-variable" loc
|
||
"%s over the type variable %s is refused: a type variable supports \
|
||
only what it is declared to support, and nothing here says %s is \
|
||
%s. Write {:where (%s $%s)} at the head of the body, or take the \
|
||
operation as a parameter — a (Fn [%s %s] ...) — and call it here"
|
||
op (Types.to_string t) (Types.to_string t) needs needs
|
||
(Types.to_string t) (Types.to_string t) (Types.to_string t)
|
||
|
||
|
||
(* How a concrete type is spelled inside an instantiation's name. The prelude
|
||
already writes this by hand — [filter-i32], [sum-f32], [append-i64] — so a
|
||
generated name reads like the handwritten one it replaces, which is what a
|
||
backtrace, a [Reach] edge and a dev-build cell all end up showing.
|
||
[Types.to_string] cannot serve: [[i32]] and [(Vec i32)] are not symbols. *)
|
||
let rec mangle_ty (t : Types.t) =
|
||
match t with
|
||
| Types.Unit -> "unit"
|
||
| Types.Slice e -> "slice-" ^ mangle_ty e
|
||
| Types.Array (n, e) -> Printf.sprintf "arr%Ld-%s" n (mangle_ty e)
|
||
| Types.Map (k, v) -> Printf.sprintf "map-%s-%s" (mangle_ty k) (mangle_ty v)
|
||
| Types.Ptr e -> "ptr-" ^ mangle_ty e
|
||
| Types.Vec e -> "vec-" ^ mangle_ty e
|
||
| Types.Option e -> "opt-" ^ mangle_ty e
|
||
| Types.Fn (ps, r) ->
|
||
Printf.sprintf "fn-%s-to-%s"
|
||
(String.concat "-" (List.map mangle_ty ps)) (mangle_ty r)
|
||
| t -> Types.to_string t
|
||
|
||
(* ── The runaway instantiation, refused by name rather than by depth ────
|
||
[(defn grow [x $t] () (grow [x x]))] asks for a copy at [[t]], which asks
|
||
for one at [[[t]]], forever. Before this the checker did not fail, it
|
||
*hung*, and [Session.eval] runs the same code — so what hung was [C-c C-c],
|
||
with the dev daemon wedged behind it and nothing to show the editor. That
|
||
is the project's stated priority stopped by three lines of ordinary-looking
|
||
Flan, which is why this is a refusal and not a cap.
|
||
|
||
The spike stopped it with a depth counter refusing past 32. A number is the
|
||
wrong thing to say: 32 is not in the program, the programmer cannot act on
|
||
it, and a legitimate deep instantiation and a runaway one look identical in
|
||
the message. **The structural test is exact.** A generic that is already on
|
||
the chain and is being asked for again at a type that *contains* the type
|
||
it was asked for before is growing, and growing without a smaller case is
|
||
not going to stop. A generic that recurses at the *same* types never
|
||
reaches here — the cache entry goes in before the body is checked — and one
|
||
that recurses at a *smaller* or unrelated type is fine and stays fine.
|
||
|
||
The message prints the chain, which is what the programmer can act on: each
|
||
link is a call site and a type, and the place the type started growing is
|
||
visible in the list.
|
||
|
||
Odin has no cap of its own to copy, so there was nothing to borrow and this
|
||
is the whole design. The depth backstop below stays as a backstop only: it
|
||
catches a growth this test does not recognise, and it is never the thing
|
||
the message is about. *)
|
||
let rec occurs_in ~needle (t : Types.t) =
|
||
Types.equal needle t
|
||
||
|
||
match t with
|
||
| Types.Slice e | Types.Array (_, e) | Types.Ptr e | Types.Vec e
|
||
| Types.Option e -> occurs_in ~needle e
|
||
| Types.Map (k, v) -> occurs_in ~needle k || occurs_in ~needle v
|
||
| Types.Fn (ps, r) ->
|
||
List.exists (occurs_in ~needle) ps || occurs_in ~needle r
|
||
| _ -> false
|
||
|
||
(* [b] is [a] with something built around it: same shape, strictly bigger. *)
|
||
let grows ~from_:a ~to_:b =
|
||
List.length a = List.length b
|
||
&& List.for_all2 (fun x y -> occurs_in ~needle:x y) a b
|
||
&& not (List.for_all2 Types.equal a b)
|
||
|
||
let runaway env loc gname cparams =
|
||
let chain_text () =
|
||
String.concat "\n "
|
||
(List.map
|
||
(fun (g, ps, l) ->
|
||
Printf.sprintf "%s at (%s), asked for at %s" g
|
||
(String.concat " " (List.map Types.to_string ps))
|
||
(Loc.to_string l))
|
||
(env.chain @ [ (gname, cparams, loc) ]))
|
||
in
|
||
let earlier =
|
||
List.find_opt
|
||
(fun (g, ps, _) -> String.equal g gname && grows ~from_:ps ~to_:cparams)
|
||
env.chain
|
||
in
|
||
(match earlier with
|
||
| Some _ ->
|
||
Loc.failk "check/runaway-instantiation" loc
|
||
"%s instantiates itself without end. Each copy asks for another at a \
|
||
type built around the one before, so there is no last copy to \
|
||
generate:\n %s\nA generic function may call itself, but not at a \
|
||
type built out of its own type variable — the argument has to get \
|
||
smaller, or stay the same"
|
||
gname (chain_text ())
|
||
| None -> ());
|
||
(* The backstop. Nothing known reaches it; it exists so that a growth the
|
||
test above does not recognise is still a refusal with the chain in it
|
||
rather than a hang. *)
|
||
if List.length env.chain >= 64 then
|
||
Loc.failk "check/runaway-instantiation" loc
|
||
"%s has been instantiated 64 deep and is still going:\n %s"
|
||
gname (chain_text ())
|
||
|
||
(* [check_fn] is defined after the expression checker and an instantiation is
|
||
made from inside it, so the knot is tied here and closed at the bottom of
|
||
the file. One forward reference rather than moving a 90-line function. *)
|
||
let check_fn_ref : (env -> Ast.fn -> Tast.fn) ref =
|
||
ref (fun _ _ -> assert false)
|
||
|
||
(* ── Small helpers over the AST ────────────────────────────────────── *)
|
||
|
||
(* Untyped literals: their machine type comes from context, so when one is an
|
||
operand of a binary operator we look at the *other* operand first. *)
|
||
let is_literal (e : Ast.expr) =
|
||
match e.Ast.e with Ast.Int _ | Ast.Float _ | Ast.Byte _ -> true | _ -> false
|
||
|
||
(* [addr] takes the address of a place, but the parser only builds places for
|
||
[set]. Recover one from the expression it parsed instead. *)
|
||
let place_of_expr (e : Ast.expr) : Ast.place option =
|
||
match e.Ast.e with
|
||
| Ast.Var s -> Some (Ast.Pvar s)
|
||
| Ast.Field (t, f) -> Some (Ast.Pfield (t, f))
|
||
| Ast.Call ({ Ast.e = Ast.Var "at"; _ }, t :: idx) when idx <> [] ->
|
||
Some (Ast.Pindex (t, idx))
|
||
| Ast.Call ({ Ast.e = Ast.Var "deref"; _ }, [ p ]) -> Some (Ast.Pderef p)
|
||
| _ -> None
|
||
|
||
let mk loc ty e : Tast.expr = { Tast.e; ty; loc }
|
||
|
||
let unit_at loc = mk loc Types.Unit Tast.Unit
|
||
|
||
(* A source location as a value, for a runtime trap that has to name the site
|
||
rather than the runtime. The bounds and slice traps get theirs from [Emit],
|
||
which renders the [Loc.t] it is already carrying; a trap reached through a
|
||
plain runtime call has no such carrier, so the string is built here and
|
||
crosses as ptr+len like any other. *)
|
||
let here loc = mk loc Types.String (Tast.Str (Loc.to_string loc))
|
||
|
||
(* A runtime call, with the result type spelled at the site. *)
|
||
let rt loc ty sym args = mk loc ty (Tast.Prim (Tast.Rt sym, args))
|
||
|
||
(* ── The allocation registry's note, NEXT.md ───────────────────────────
|
||
|
||
One after every operation that may have allocated — which is *here*, and
|
||
nowhere else, because here is the only place the concrete type is known. A
|
||
Flan struct is exactly its C layout with no header and no tag word, so
|
||
nothing at run time can say what is at an address; the allocator's caller
|
||
knew, and this is the caller writing it down.
|
||
|
||
The type is spelled with [Types.to_string], the same spelling a slot
|
||
fingerprint and a DWARF node already key on, so a name that appears in a
|
||
registry answer is a name the programmer wrote.
|
||
|
||
It is built unconditionally and dropped by the backend in a release build
|
||
(see [Emit]'s [Rt] arm). The checker does not know which kind of build this
|
||
is and must not learn: a note that existed only in a dev build would make
|
||
the two builds different *trees*, and every pass between here and the
|
||
backend would have to agree about which one it was looking at.
|
||
|
||
[target] is the container, passed by address like every other container
|
||
operation; the extent comes off its header in the runtime, because the
|
||
header is the only thing that knows where the storage landed. *)
|
||
let reg_note loc sym (target : Tast.expr) sizes ty =
|
||
rt loc Types.Unit sym
|
||
((target :: sizes) @ [ mk loc Types.String (Tast.Str (Types.to_string ty)) ])
|
||
|
||
(* [(do attempt note)] — the note runs only once the guard's retry loop has
|
||
stopped, so it describes the storage the program ended up with rather than
|
||
one of the attempts that failed. *)
|
||
let with_note loc (guarded : Tast.expr) (note : Tast.expr) =
|
||
mk loc Types.Unit (Tast.Do [ guarded; note ])
|
||
|
||
(* ── Reading a file at compile time, decision 1 ────────────────────────
|
||
The path is a *literal*, because the bytes have to be in hand before any
|
||
value exists — this is Odin's rule too (check_load_directive rejects
|
||
anything that is not Addressing_Constant) and it is what makes the result
|
||
cost nothing at run time.
|
||
|
||
It resolves relative to the directory of the file the form is written in,
|
||
which is again Odin's rule (dir_from_path of the call's file). Relative to
|
||
the compiler's working directory would make a package's assets depend on
|
||
where flan was invoked from, which is the thing that cannot be right. An
|
||
absolute path is taken as written. *)
|
||
let embed_path loc (p : Ast.expr) =
|
||
match p.Ast.e with
|
||
| Ast.Str "" -> Loc.fail p.Ast.loc "an embedded path cannot be empty"
|
||
| Ast.Str s when Filename.is_relative s ->
|
||
let base = Filename.dirname loc.Loc.file in
|
||
if String.equal base "" then s else Filename.concat base s
|
||
| Ast.Str s -> s
|
||
| _ ->
|
||
Loc.fail p.Ast.loc
|
||
"an embedded path must be a literal string — the bytes are read at \
|
||
compile time, so there is nothing here to compute it from"
|
||
|
||
(* The whole read is guarded, not only the open. On Linux [open_in_bin] on a
|
||
*directory* succeeds and [in_channel_length] answers a number; the read is
|
||
where EISDIR arrives. Guarding only the open therefore turned (embed "dir")
|
||
— someone who meant embed-dir — into an uncaught OCaml exception out of the
|
||
checker, which is the one way a user can make the compiler crash rather than
|
||
refuse. *)
|
||
let read_embed_file path loc =
|
||
match
|
||
let ch = open_in_bin path in
|
||
Fun.protect ~finally:(fun () -> close_in_noerr ch)
|
||
(fun () -> really_input_string ch (in_channel_length ch))
|
||
with
|
||
| s -> s
|
||
| exception Sys_error msg ->
|
||
if Sys.file_exists path && (try Sys.is_directory path with Sys_error _ -> false)
|
||
then
|
||
Loc.fail loc
|
||
"cannot embed %s: it is a directory — (embed-dir \"...\") embeds one \
|
||
of those, as a [n EmbedFile]"
|
||
path
|
||
else Loc.fail loc "cannot embed %s: %s" path msg
|
||
| exception End_of_file ->
|
||
Loc.fail loc "cannot embed %s: it changed size while being read" path
|
||
|
||
(* Non-recursive, files only, sorted by name — the three things Odin's
|
||
#load_directory settles, and the sort is the one that matters most here:
|
||
readdir order is filesystem-dependent, so an unsorted embed would make the
|
||
emitted .ll differ between two builds of identical sources. *)
|
||
let read_embed_dir path loc =
|
||
let names =
|
||
match Sys.readdir path with
|
||
| exception Sys_error msg -> Loc.fail loc "cannot embed %s: %s" path msg
|
||
| a -> Array.to_list a
|
||
in
|
||
(* [Sys.is_directory] *raises* on a path that does not resolve, so the
|
||
existence test has to come first: a dangling symlink in an embedded
|
||
directory would otherwise crash the compiler before it was ever asked
|
||
about. Non-recursive and files only, which is Odin's rule too. *)
|
||
let files =
|
||
List.filter
|
||
(fun n ->
|
||
let full = Filename.concat path n in
|
||
Sys.file_exists full
|
||
&& not (try Sys.is_directory full with Sys_error _ -> true))
|
||
names
|
||
in
|
||
List.map
|
||
(fun n -> (n, read_embed_file (Filename.concat path n) loc))
|
||
(List.sort String.compare files)
|
||
|
||
let i64_at loc n = mk loc (Types.Int Types.I64) (Tast.Int (n, Types.I64))
|
||
|
||
(* spec-memory.md, "Alignment": the number is produced where the concrete
|
||
element type is known, which without generics is simply the call site. *)
|
||
let size_of loc t = mk loc (Types.Int Types.I64) (Tast.Prim (Tast.SizeOf t, []))
|
||
let align_of loc t = mk loc (Types.Int Types.I64) (Tast.Prim (Tast.AlignOf t, []))
|
||
|
||
(* The address of an expression, place or not: the type-erased runtime takes
|
||
the element [push] copies by pointer. *)
|
||
let addr_of loc (e : Tast.expr) =
|
||
mk loc (Types.Ptr e.Tast.ty) (Tast.Prim (Tast.AddrOf, [ e ]))
|
||
|
||
(* ── Where a rendered number's bytes live ──────────────────────────────
|
||
|
||
The three number-to-text conversions used to answer a slice into one static
|
||
buffer in the runtime, shared by every call in the process, and nothing
|
||
copied it: (print a) (print b) over two of them printed the second number
|
||
twice. No crash and nothing for a sanitizer to find, because the read was
|
||
inside a buffer that was perfectly alive — the wrong bytes, alive.
|
||
|
||
The buffer is now the caller's, one frame slot per call site, and it is
|
||
allocated here rather than in either backend on purpose: a slot is a
|
||
function-lifetime frame location in both of them — an entry-block alloca in
|
||
[Emit], a prologue-allocated offset in [X86] — where a backend temporary in
|
||
[X86] is bump-allocated and reclaimed at the end of the expression that made
|
||
it, which is exactly the lifetime a returned slice must outlive. Doing it
|
||
once here also keeps the two backends symmetric by construction: each gains
|
||
one pointer argument and no lifetime reasoning of its own.
|
||
|
||
64 bytes is agreed with flan_rt.c's FLAN_NUM_BYTES, which clamps the length
|
||
it publishes to it. The zeroing the [Let] does is one 64-byte clear beside
|
||
an snprintf. *)
|
||
let num_bytes = 64L
|
||
|
||
let to_bytes ctx loc pr (x : Tast.expr) =
|
||
let bty = Types.Array (num_bytes, Types.Int Types.U8) in
|
||
let bslice = Types.Slice (Types.Int Types.U8) in
|
||
let s = fresh_slot ctx bty in
|
||
mk loc bslice
|
||
(Tast.Let
|
||
([ (s, mk loc bty (Tast.Zero bty)) ],
|
||
[ mk loc bslice
|
||
(Tast.Prim (pr, [ x; addr_of loc (mk loc bty (Tast.Local s)) ])) ]))
|
||
|
||
(* ── The region requirement, emitted ───────────────────────────────────
|
||
spec-memory.md's arena rule, and the whole of what replaced the three
|
||
refusals a container of owning elements used to meet at its *type*. The
|
||
question those refusals asked was about teardown: the type-erased runtime
|
||
copies and releases slots bytewise, so a [free] would release the slots and
|
||
leave everything inside them stranded. A region never releases a slot —
|
||
[free-all] takes the whole thing, inner blocks included, because they came
|
||
out of the same region — so the premise does not hold there and the refusal
|
||
was over-broad.
|
||
|
||
What could not move with it is *where* the question is asked. [can-free] is
|
||
a capability on an allocator value, read at run time, and [with-allocator]
|
||
rebinds a dynamic variable, so the tier a [(vec-new)] will meet is not a
|
||
property of the place its type is written. The compile-time half is
|
||
therefore only the decision to ask — [region_only], a property of the
|
||
element type and settled here — and the run-time half is the answer.
|
||
|
||
One branch per container and never per element, which spec-memory.md fixes
|
||
and which is a performance decision before it is a safety one: the
|
||
alternative is a walk at release, and a walk at release is the registry of
|
||
destructors the frame tier's reset exists to not have.
|
||
|
||
Emitted at every site that can *allocate* for such a container, not only at
|
||
its construction, and the extra sites are not belt and braces. ZII means a
|
||
container can exist without ever passing through [vec-new]: a data type
|
||
case's field left out of a literal, a [(defvar xs (Vec Value))] a global
|
||
starts as. Those are zeroed, they have no allocator at all, and the first
|
||
[push] is what adopts the context — so a guard only at the construction
|
||
would have a hole exactly the width of ZII.
|
||
|
||
The *container* is what is asked in both places, and at a construction that
|
||
means the guard runs immediately after the init rather than before it. The
|
||
allocator is right there as an argument of the site, but naming it twice in
|
||
the emitted tree is not free: it is an arbitrary expression, and [(vec-new
|
||
Value (arena-new 4096))] would build two arenas and guard the one it threw
|
||
away. The container has recorded it by the time the init returns, so asking
|
||
the container asks that one expression exactly once. It is still the point
|
||
of construction and still before anything is put in; what a trap there costs
|
||
is the empty block just taken, on a process that is about to die.
|
||
|
||
At a growth the guard runs first, because there the container already exists
|
||
and the allocation is what has to be stopped. A zeroed one answers from the
|
||
context it is about to adopt, which is not a guess — [flan_vec_adopt] is the
|
||
code that will take it, on this same call. *)
|
||
let region_sym (t : Types.t) =
|
||
match t with
|
||
| Types.Vec _ -> "flan_vec_region_only"
|
||
| Types.Map _ -> "flan_map_region_only"
|
||
| _ -> assert false
|
||
|
||
let region_check env loc (target : Tast.expr) (after : Tast.expr) =
|
||
if not (region_only env target.Tast.ty) then after
|
||
else
|
||
mk loc after.Tast.ty
|
||
(Tast.Do
|
||
[ rt loc Types.Unit (region_sym target.Tast.ty) [ target; here loc ];
|
||
after ])
|
||
|
||
(* Every integer index into an array or slice is i32 at milestone 2. *)
|
||
let index_ty = Types.Int Types.I32
|
||
|
||
(* A condition's type at run time is a number, and it has to be the *same*
|
||
number in a module compiled later against a program already running. So it
|
||
is a hash of the name and not an index into anything: an index would shift
|
||
the moment a struct were added, and every handler pushed by the old code
|
||
would then match the wrong type. FNV-1a over the name, 32 bits. *)
|
||
let type_id name =
|
||
let h = ref 0x811c9dc5 in
|
||
String.iter
|
||
(fun c ->
|
||
h := (!h lxor Char.code c) land 0xffffffff;
|
||
h := (!h * 0x01000193) land 0xffffffff)
|
||
name;
|
||
!h
|
||
|
||
(* How a restart's parameter list is spelled, and with it what the two ends of
|
||
an [invoke-restart] compare — spec-conditions.md §3's run-time check. A
|
||
restart is found by name on a dynamic stack, so neither end can see the
|
||
other and nothing static can be checked: what is compared at run time is
|
||
this string's hash, alongside the count, and the string itself is carried so
|
||
that a mismatch can say what was wanted and what was given.
|
||
|
||
Comparing a 32-bit hash means two different parameter lists could in
|
||
principle collide. The count is checked separately, which rules out every
|
||
practical case (a collision would have to be between two lists of the same
|
||
length), and the types are parenthesised so that [(Option i32)] cannot read
|
||
as two parameters. *)
|
||
let restart_sig tys =
|
||
"(" ^ String.concat " " (List.map Types.to_string tys) ^ ")"
|
||
|
||
let expect loc ~want (got : Tast.expr) =
|
||
match want with
|
||
| None -> got
|
||
| Some w ->
|
||
if Types.fits ~expected:w ~actual:got.Tast.ty then got
|
||
else
|
||
fail loc "expected %s, found %s" (Types.to_string w)
|
||
(Types.to_string got.Tast.ty)
|
||
|
||
(* Something a [break] may not jump out of, named so the refusal can say which.
|
||
See [lentry]: it is a barrier and not a blanket refusal, so a loop written
|
||
wholly inside one keeps its own perfectly good local break. Outside the
|
||
recursive group below because its callers hand it bodies of two shapes — one
|
||
expression and a list of them — and inside it would be monomorphic. *)
|
||
let barrier ctx what f =
|
||
let loops = ctx.loops in
|
||
ctx.loops <- Lbarrier what :: loops;
|
||
let r = f () in
|
||
ctx.loops <- loops;
|
||
r
|
||
|
||
(* ── Expressions ───────────────────────────────────────────────────── *)
|
||
|
||
(* ── (Map K V): the key's hash and equality pair ────────────────────────
|
||
spec-memory.md restricts the first implementation to built-in structural
|
||
key types — integers, enums, strings, fixed arrays, and value structs
|
||
composed recursively from those — and makes equality and hashing for them
|
||
compiler-provided structural operations rather than type classes. So there
|
||
is no dispatch to design: every key type resolves, here, to a pair of
|
||
symbols, and the pair is passed to the type-erased runtime the way Odin
|
||
hangs its two contextless procs off a Map_Info.
|
||
|
||
Most key types need no emitted function at all. A key whose equality is
|
||
bytewise and whose bytes are all present is served by one runtime pair over
|
||
(pointer, size), which is what [bytewise_key] identifies. Two kinds are not:
|
||
|
||
- a [string] is ptr+len and its bytes are elsewhere, so two equal strings at
|
||
different addresses must still hash the same;
|
||
- a struct may have padding, whose bytes are indeterminate, so two structs
|
||
that are equal field by field can differ bytewise — and it may hold a
|
||
string, which brings the first problem inside it.
|
||
|
||
A struct therefore gets a pair emitted for it, walking its fields, and that
|
||
is the only case that does. *)
|
||
|
||
let rec bytewise_key = function
|
||
| Types.Int _ | Types.Enum _ | Types.Bool -> true
|
||
| Types.Array (_, t) -> bytewise_key t
|
||
| _ -> false
|
||
|
||
let hash_ty = Types.Int Types.U64
|
||
|
||
(* A context for a function the checker is about to invent. Nothing is
|
||
reachable from it: no outer scope, no defers, and [defer_ok] false, because
|
||
none of these is a body anyone wrote. *)
|
||
let invented_ctx env ret =
|
||
{ env; ret; slots = 0; slot_tys = []; slot_names = []; scope = [];
|
||
defers = []; outer = []; outer_what = None; in_frames = None; loops = []; tail = false;
|
||
in_defer = false; defer_ok = false; defer_block = "a nested form";
|
||
owner = "<none>" }
|
||
|
||
(* The address of field [i] of the struct the pointer in slot [p] points at. *)
|
||
let field_addr_of loc sty fty p i =
|
||
let target = mk loc sty (Tast.Deref (mk loc (Types.Ptr sty) (Tast.Local p))) in
|
||
mk loc (Types.Ptr fty) (Tast.Addr (Tast.Pfield (target, i)))
|
||
|
||
(* The pointer form is what a Map_Info holds; the direct form is what an
|
||
emitted hasher calls. See flan_rt.c on why they are two symbols. *)
|
||
let direct = function
|
||
| "flan_hash_flat" -> "flan_key_hash_flat"
|
||
| "flan_eq_flat" -> "flan_key_eq_flat"
|
||
| "flan_hash_str" -> "flan_key_hash_str"
|
||
| "flan_eq_str" -> "flan_key_eq_str"
|
||
| s -> s
|
||
|
||
(* The pair for [k]: (hash, equality), each a symbol to be taken the address
|
||
of. Emits a function for a struct key the first time it sees one, and finds
|
||
it in [env.lifted] every time after — the name is derived from the type, so
|
||
two maps with the same key type share one pair. *)
|
||
let rec key_pair env loc (k : Types.t) : Tast.fnref * Tast.fnref =
|
||
match k with
|
||
(* A hash and an equality for a type variable would have to be *chosen*,
|
||
and nothing here can choose: the pair is emitted as concrete symbols and
|
||
the concrete type does not exist until the instantiation. Refused rather
|
||
than assumed — falling through to [bytewise_key] would hash whatever
|
||
bytes the variable turned out to have, which is the wrong answer for a
|
||
[string] and for any struct with padding.
|
||
|
||
**This arm is a backstop and nothing normal reaches it.** Two things get
|
||
there first. Inside an instantiation [env.subst] has already made [k]
|
||
concrete, so there is no variable left. Outside one — in the abstract
|
||
pass over a generic body — the map operations are *deferred*
|
||
([deferred_key] below): a key that is a variable declared [hashable?]
|
||
never asks for a pair here, and a variable that is not declared it never
|
||
gets as far as a [(Map $t V)] to operate on, because [map_type] refuses
|
||
the type where it is written. What is left for this arm is a key that is
|
||
a variable by some route neither of those covers, and the honest answer
|
||
to that is still a refusal rather than a guessed pair. *)
|
||
| Types.Var v ->
|
||
Loc.failk "check/generic-map-key" loc
|
||
"a map keyed by the type variable %s has no hash and no equality here: \
|
||
both are emitted as concrete symbols chosen from the concrete key \
|
||
type, and there is none until this generic is instantiated. The map \
|
||
operations are deferred to the instantiation when {:where (hashable? \
|
||
$%s)} is declared — declare it, or write the operation in a function \
|
||
over the concrete key type and call that" v v
|
||
| Types.String -> Tast.Rtfn "flan_hash_str", Tast.Rtfn "flan_eq_str"
|
||
| t when bytewise_key t ->
|
||
Tast.Rtfn "flan_hash_flat", Tast.Rtfn "flan_eq_flat"
|
||
| Types.Named n when Hashtbl.mem env.structs n -> struct_key_pair env loc n
|
||
(* A data type key would have to hash the tag and then only the bytes the
|
||
case in hand actually uses — the rest of the payload is indeterminate,
|
||
exactly as a struct's padding is, so hashing the blob would make two equal values
|
||
hash differently. That is a per-case walk driven by a switch, which is a
|
||
different shape from the field list [struct_key_pair] emits and which
|
||
nothing has yet wanted. Refused by name rather than written untested. *)
|
||
| Types.Named n when Hashtbl.mem env.datas n ->
|
||
fail loc
|
||
"%s is a data type, and a data type is not a map key: the payload past \
|
||
the case in hand is indeterminate, so hashing the bytes would make two equal \
|
||
values hash differently. Hashing one needs a per-case walk, which is \
|
||
not written — key on the tag, or on a struct holding what you meant" n
|
||
(* And an untagged union is refused for the half of that reason which has
|
||
nothing to do with a tag: a member smaller than the union leaves the rest
|
||
of the storage indeterminate, so two values that agree about every byte
|
||
anybody wrote hash differently. There is no per-member walk to write here
|
||
either — nothing records which member was written, which is the type. *)
|
||
| Types.Named n when Hashtbl.mem env.unions n ->
|
||
fail loc
|
||
"%s is a union, and a union is not a map key: a member narrower than \
|
||
the union leaves the rest of the bytes indeterminate, so two values \
|
||
that agree about everything written would still hash differently. Key \
|
||
on the member you meant" n
|
||
| Types.Array (_, e) ->
|
||
(* A fixed array of a struct or of strings would need the same per-element
|
||
walk a struct key gets, driven by a loop rather than by a field list.
|
||
Nothing has wanted one, so it is refused by name rather than written
|
||
untested — and refused with the shape that does work named beside it. *)
|
||
fail loc
|
||
"a fixed array is a map key only when its elements are compared \
|
||
bytewise, and %s is not — a struct or a string element needs a \
|
||
per-element walk that is not written. A struct key holding the array \
|
||
works, because a struct key is walked field by field"
|
||
(Types.to_string e)
|
||
| Types.Float _ ->
|
||
(* Not a milestone question, which is why it is said separately: NaN is not
|
||
equal to itself, and 0.0 and -0.0 are equal while differing bytewise. A
|
||
float key therefore has no equality for a hash map to use, whatever the
|
||
implementation does. *)
|
||
fail loc
|
||
"a float is not a map key: NaN is not equal to itself, and 0.0 and -0.0 \
|
||
are equal but differ bytewise, so there is no equality here for a map \
|
||
to hash. Key on an integer, or on a quantised integer of your choosing"
|
||
| other ->
|
||
fail loc
|
||
"%s is not a map key. The first implementation takes integers, enums, \
|
||
bools, strings, fixed arrays of those, and value structs composed of \
|
||
those (spec-memory.md, \"Maps — first implementation\"). A Ptr, a \
|
||
slice, a Vec or a Map would hash an address rather than what it points \
|
||
at, which is a different operation"
|
||
(Types.to_string other)
|
||
|
||
and struct_key_pair env loc n =
|
||
let hname = "map/hash/" ^ n and ename = "map/eq/" ^ n in
|
||
let known name =
|
||
List.exists (fun (f : Tast.fn) -> f.Tast.name = name) env.lifted
|
||
in
|
||
if known hname then Tast.Flanfn hname, Tast.Flanfn ename
|
||
else begin
|
||
let sty = Types.Named n in
|
||
let fields = (Hashtbl.find env.structs n).Tast.fields in
|
||
if fields = [] then
|
||
fail loc
|
||
"%s has no fields, so every value of it is equal to every other — a \
|
||
map keyed on it holds at most one entry, which is not a map" n;
|
||
let hparams = [ Types.Ptr sty; hash_ty; Types.Int Types.I64 ] in
|
||
let eparams = [ Types.Ptr sty; Types.Ptr sty; Types.Int Types.I64 ] in
|
||
(* Registered before the fields are walked, so a struct reached twice
|
||
through two different fields emits one pair and not two. A struct cannot
|
||
contain itself by value, so there is no cycle to break — only sharing.
|
||
The body is filled in below; nothing can call these in between. *)
|
||
let placeholder name ret params =
|
||
{ Tast.name; params; slots = Array.of_list params;
|
||
snames = Array.make (List.length params) None;
|
||
ret; body = []; fdefers = []; fparent = None; floc = loc }
|
||
in
|
||
env.lifted <-
|
||
placeholder hname hash_ty hparams
|
||
:: placeholder ename (Types.Int Types.I8) eparams
|
||
:: env.lifted;
|
||
|
||
(* The hash: seed, then one combine per field, in declaration order. Each
|
||
field is hashed by its own pair — the same recursion, so a string field
|
||
hashes its bytes and a nested struct hashes field by field. Padding is
|
||
never reached, because nothing here addresses anything but a field. *)
|
||
let hctx = invented_ctx env hash_ty in
|
||
let kp = fresh_slot ~name:"key" hctx (Types.Ptr sty) in
|
||
let seed = fresh_slot ~name:"seed" hctx hash_ty in
|
||
ignore (fresh_slot ~name:"size" hctx (Types.Int Types.I64));
|
||
let acc = fresh_slot ~name:"h" hctx hash_ty in
|
||
let steps =
|
||
List.mapi
|
||
(fun i (fl : Tast.field) ->
|
||
let fty = fl.Tast.fty in
|
||
let h, _ = key_pair env loc fty in
|
||
let args =
|
||
[ field_addr_of loc sty fty kp i;
|
||
mk loc hash_ty (Tast.Local seed); size_of loc fty ]
|
||
in
|
||
let one =
|
||
match h with
|
||
| Tast.Rtfn s -> rt loc hash_ty (direct s) args
|
||
| Tast.Flanfn s | Tast.Fnval s ->
|
||
mk loc hash_ty (Tast.Call (s, args))
|
||
in
|
||
mk loc Types.Unit
|
||
(Tast.Set (Tast.Plocal acc,
|
||
rt loc hash_ty "flan_hash_combine"
|
||
[ mk loc hash_ty (Tast.Local acc); one ])))
|
||
fields
|
||
in
|
||
let hbody =
|
||
(mk loc Types.Unit
|
||
(Tast.Set (Tast.Plocal acc, mk loc hash_ty (Tast.Local seed))))
|
||
:: steps
|
||
@ [ mk loc hash_ty (Tast.Local acc) ]
|
||
in
|
||
|
||
(* The equality: one early return per field, then true. Written as returns
|
||
rather than as a conjunction so that the comparison stops at the first
|
||
field that differs, which for a struct with a string field is the
|
||
difference between one memcmp and two. *)
|
||
let ectx = invented_ctx env (Types.Int Types.I8) in
|
||
let ap = fresh_slot ~name:"a" ectx (Types.Ptr sty) in
|
||
let bp = fresh_slot ~name:"b" ectx (Types.Ptr sty) in
|
||
ignore (fresh_slot ~name:"size" ectx (Types.Int Types.I64));
|
||
let i8 v = mk loc (Types.Int Types.I8) (Tast.Int (v, Types.I8)) in
|
||
let checks =
|
||
List.mapi
|
||
(fun i (fl : Tast.field) ->
|
||
let fty = fl.Tast.fty in
|
||
let _, eq = key_pair env loc fty in
|
||
let args =
|
||
[ field_addr_of loc sty fty ap i;
|
||
field_addr_of loc sty fty bp i; size_of loc fty ]
|
||
in
|
||
let call =
|
||
match eq with
|
||
| Tast.Rtfn s -> rt loc (Types.Int Types.I8) (direct s) args
|
||
| Tast.Flanfn s | Tast.Fnval s ->
|
||
mk loc (Types.Int Types.I8) (Tast.Call (s, args))
|
||
in
|
||
let differs =
|
||
mk loc Types.Bool (Tast.Prim (Tast.Eq, [ call; i8 0L ]))
|
||
in
|
||
mk loc Types.Unit
|
||
(Tast.If (differs,
|
||
mk loc Types.Never (Tast.Return (Some (i8 0L))),
|
||
unit_at loc)))
|
||
fields
|
||
in
|
||
let ebody = checks @ [ i8 1L ] in
|
||
|
||
let finish name ret params ctx body =
|
||
{ Tast.name; params;
|
||
slots = Array.of_list (List.rev ctx.slot_tys);
|
||
snames = Array.of_list (List.rev ctx.slot_names);
|
||
ret; body; fdefers = []; fparent = None; floc = loc }
|
||
in
|
||
env.lifted <-
|
||
finish hname hash_ty hparams hctx hbody
|
||
:: finish ename (Types.Int Types.I8) eparams ectx ebody
|
||
:: List.filter
|
||
(fun (f : Tast.fn) ->
|
||
f.Tast.name <> hname && f.Tast.name <> ename)
|
||
env.lifted;
|
||
Tast.Flanfn hname, Tast.Flanfn ename
|
||
end
|
||
|
||
(* The pair as two expressions, ready to be passed. Their Flan type is
|
||
[Alloc]: an opaque pointer-width value with no user-writable constructor,
|
||
which is all the backend needs and all any Flan type ever says about it. *)
|
||
let key_fns env loc k =
|
||
let h, e = key_pair env loc k in
|
||
mk loc Types.Alloc (Tast.FnAddr h), mk loc Types.Alloc (Tast.FnAddr e)
|
||
|
||
(* ── The map operations, deferred to the instantiation ─────────────────
|
||
True when the key is a type variable, which means the operation cannot be
|
||
built here and must be answered by the copy: [key_fns] emits concrete
|
||
symbols and there is no concrete key type yet. The caller checks its
|
||
arguments first and then returns a placeholder of the operation's own type,
|
||
exactly as [print] does — see the allow-list comment at the [print] arm for
|
||
what being on that list costs and why these are on it.
|
||
|
||
The predicate is *required* before deferring, and that is the whole safety
|
||
argument: with {:where (hashable? $t)} in the signature, the instantiation
|
||
refuses at the call site against a requirement the author wrote down. A
|
||
variable with no such clause is refused here and now, at the definition,
|
||
which is where the abstract pass wants every refusal that has nothing to
|
||
point at. In practice [map_type] has already refused such a signature where
|
||
the type was written; this repeats it rather than relying on that, the same
|
||
way [key_pair] repeats [map_type]'s key check. *)
|
||
let deferred_key env loc what (k : Types.t) =
|
||
match k with
|
||
| Types.Var v ->
|
||
if not (declares env.tvpreds v "hashable?") then
|
||
Loc.failk "check/generic-map-key" loc
|
||
"%s over a map keyed by the type variable %s is refused: the hash and \
|
||
the equality are emitted as concrete symbols chosen from the \
|
||
concrete key type, and nothing here declares %s hashable. Write \
|
||
{:where (hashable? $%s)} at the head of the body — then the \
|
||
operation is deferred to each instantiation, and a call site that \
|
||
asks for a key type that cannot be hashed is refused there, against \
|
||
the clause"
|
||
what (Types.to_string k) (Types.to_string k) v;
|
||
true
|
||
| _ -> false
|
||
|
||
let rec check ctx ?want (e : Ast.expr) : Tast.expr =
|
||
let loc = e.Ast.loc in
|
||
(* Read the permission this form was given and withdraw it in the same
|
||
breath, so that nothing reached from here inherits it. The two callers
|
||
that may grant it — [check_fn]'s body walk and [check_let]'s, below —
|
||
grant it again before the *next* form rather than once around the body. *)
|
||
let defer_ok = ctx.defer_ok in
|
||
ctx.defer_ok <- false;
|
||
(* The same read-and-withdraw, for the same reason: a [recur] is in tail
|
||
position only if *this* form was, and nothing reached from here inherits
|
||
it unless the arm below hands it on deliberately. *)
|
||
let tail = ctx.tail in
|
||
ctx.tail <- false;
|
||
match e.Ast.e with
|
||
| Ast.Int n -> int_literal loc ~want n
|
||
| Ast.Byte b -> int_literal loc ~want ~default:Types.U8 (Int64.of_int b)
|
||
| Ast.Float x ->
|
||
let k =
|
||
match want with
|
||
| Some (Types.Float k) -> k
|
||
| Some other when other <> Types.Never ->
|
||
fail loc "expected %s, found the float literal %g"
|
||
(Types.to_string other) x
|
||
| _ -> Types.F64
|
||
in
|
||
mk loc (Types.Float k) (Tast.Float (x, k))
|
||
| Ast.Str s -> expect loc ~want (mk loc Types.String (Tast.Str s))
|
||
| Ast.Kw k ->
|
||
(* A keyword resolves at compile time against the enum the site expects,
|
||
and a typo is an error here rather than a wrong number at run time
|
||
(plan.org, settled: keywords at typed call sites). It has no meaning
|
||
without that expectation — there is no keyword type to fall back on. *)
|
||
(match want with
|
||
| Some (Types.Enum name) ->
|
||
let members = Hashtbl.find ctx.env.enums name in
|
||
(match List.assoc_opt k members with
|
||
| Some v -> mk loc (Types.Enum name) (Tast.Int (v, Types.I32))
|
||
| None ->
|
||
fail loc "%s has no member :%s — it has %s" name k
|
||
(String.concat " "
|
||
(List.map (fun (m, _) -> ":" ^ m) members)))
|
||
| Some other ->
|
||
fail loc ":%s is an enum member, but %s is expected here" k
|
||
(Types.to_string other)
|
||
| None ->
|
||
fail loc
|
||
":%s only means something where an enum type is expected — there is \
|
||
no keyword type" k)
|
||
| Ast.Quote _ ->
|
||
unimplemented loc "a quoted symbol (restart names)" 6
|
||
| Ast.Var name -> var ctx loc ~want name
|
||
| Ast.Do body -> ctx.tail <- tail; block ctx ?want loc body
|
||
(* [defer_ok] rides through: a [let] at the top level of a function body has
|
||
exactly the function's extent, and so does a [let] nested inside one.
|
||
[tail] rides through for the same shape of reason: a [recur] written as
|
||
the last form of a [let] inside a loop body is in the loop's tail. *)
|
||
| Ast.Let (bs, body) -> check_let ctx ~tail ?want ~defer_ok loc bs body
|
||
| Ast.If (c, t, e') -> check_if ctx ~tail ?want loc c t e'
|
||
| Ast.While (label, c, body) ->
|
||
(* The condition is part of the loop even though it is written outside the
|
||
braces — emit puts it in the header block, so it is re-evaluated at the
|
||
top of every trip — but it stays outside [in_loop], because a [break]
|
||
in a condition still means the enclosing loop and a [defer] there is
|
||
still the outer block's. *)
|
||
let c = check ctx ~want:Types.Bool c in
|
||
let body = in_loop ctx ?label (fun () ->
|
||
scoped ctx (fun () -> map_lr (fun b -> check ctx b) body))
|
||
in
|
||
(* No latch: a [while] has nothing to run between the body and the test, so
|
||
a [continue] can branch straight at the condition. *)
|
||
expect loc ~want (mk loc Types.Unit (Tast.While (c, body, [])))
|
||
(* [Never], as [exit] and [return] are: nothing after one of these runs, and
|
||
an [if] arm that ends in a break does not have to agree with the other. *)
|
||
(* (loop [x 0 acc 1] body ...) — a loop that answers with the value of its
|
||
body, and the only place a [recur] may stand. Not an IR node: it is a
|
||
[let] over the names, a [While] whose condition is [true], and a jump.
|
||
See [check_loop]. *)
|
||
| Ast.Loop (bs, body) -> check_loop ctx ?want loc bs body
|
||
| Ast.Recur args -> check_recur ctx ~tail loc args
|
||
| Ast.Break label ->
|
||
mk loc Types.Never (Tast.Break (loop_target ctx loc "break" label))
|
||
| Ast.Continue label ->
|
||
mk loc Types.Never (Tast.Continue (loop_target ctx loc "continue" label))
|
||
| Ast.Return v when ctx.in_frames <> None ->
|
||
ignore v;
|
||
(* The frames are pushed and popped around the body, so an early exit would
|
||
leave them on the handler or restart stack pointing into a frame that
|
||
has gone. Rejected rather than left to corrupt it, the same rule as
|
||
defer inside a block. *)
|
||
fail loc
|
||
"return is not allowed inside %s yet — the frames it established are \
|
||
popped on the way out and an early exit would leave them on the stack"
|
||
(match ctx.in_frames with Some n -> n | None -> assert false)
|
||
|
||
| Ast.Return v ->
|
||
let v =
|
||
match v with
|
||
| None ->
|
||
if not (Types.equal ctx.ret Types.Unit) then
|
||
fail loc "this function returns %s, so return needs a value"
|
||
(Types.to_string ctx.ret);
|
||
None
|
||
| Some v -> Some (check ctx ~want:ctx.ret v)
|
||
in
|
||
(* Whatever has been deferred *so far* runs first: a defer written below
|
||
this return has not executed yet and must not fire. *)
|
||
let r = mk loc Types.Never (Tast.Return v) in
|
||
(match ctx.defers with
|
||
| [] -> r
|
||
| ds -> mk loc Types.Never (Tast.Do (ds @ [ r ])))
|
||
| Ast.Set (p, v) ->
|
||
let p, pty = check_place ctx loc p in
|
||
let v = check ctx ~want:pty v in
|
||
expect loc ~want (mk loc Types.Unit (Tast.Set (p, v)))
|
||
| Ast.Field (target, name) ->
|
||
let target, sname = struct_target ctx target in
|
||
let s = Option.get (fields_named ctx.env sname) in
|
||
(match Tast.field_index s name with
|
||
| None ->
|
||
Loc.failk "check/unknown-field" loc ~notes:(declared_note ctx.env sname)
|
||
"%s has no field %s" sname name
|
||
| Some i ->
|
||
let fty = (List.nth s.Tast.fields i).Tast.fty in
|
||
expect loc ~want (mk loc fty (Tast.Field (target, i))))
|
||
| Ast.Struct (name, kvs) -> check_struct ctx ~want loc name kvs
|
||
| Ast.Arr items -> check_arr ctx ~want loc items
|
||
(* (array 4 rl/Vector2). Parse already assembled the whole array type, so
|
||
there is nothing to infer: resolve it and hand back its all-bytes-zero
|
||
value, which is what a declared array with no initialiser gets. *)
|
||
| Ast.ArrayOf t ->
|
||
let ty = resolve ctx.env t in
|
||
expect loc ~want (mk loc ty (Tast.Zero ty))
|
||
| Ast.Match (scrutinee, arms) -> check_match ctx ~tail ?want loc scrutinee arms
|
||
| Ast.Call (head, args) -> check_call ctx ~want loc head args
|
||
| Ast.Unwrap (Ast.Usome, v) ->
|
||
(* Unwrap Some, else early-return None from the enclosing function, so the
|
||
enclosing function must itself return an Option (plan.org). *)
|
||
(match ctx.ret with
|
||
| Types.Option _ ->
|
||
let v = check ctx v in
|
||
(match v.Tast.ty with
|
||
| Types.Option t ->
|
||
expect loc ~want (mk loc t (Tast.UnwrapSome v))
|
||
| other ->
|
||
fail loc "some takes an (Option T), found %s" (Types.to_string other))
|
||
| other ->
|
||
fail loc
|
||
"some early-returns None, so the enclosing function must return an \
|
||
Option; this one returns %s" (Types.to_string other))
|
||
| Ast.Unwrap (Ast.Utry, _) -> unimplemented loc "try (Result)" 6
|
||
| Ast.Fn (params, body) -> check_fn ctx ~want loc params body
|
||
| Ast.Dotimes (label, name, count, body) ->
|
||
check_dotimes ctx ~want loc label name count body
|
||
(* (signal c) : Unit, always — spec-conditions.md §1. A handler that returns
|
||
normally leaves the signalling function to carry on, and with nothing
|
||
matching this is a no-op, so nothing about it alters control flow. That is
|
||
what makes it checkable here rather than needing the transfer machinery
|
||
restart-case will want. *)
|
||
| Ast.Signal (kind, c) ->
|
||
let c = check ctx c in
|
||
let name =
|
||
match c.Tast.ty with
|
||
| Types.Named n -> n
|
||
| t ->
|
||
fail c.Tast.loc
|
||
"a condition is a struct, not %s — matching is by type and there is \
|
||
no condition hierarchy"
|
||
(Types.to_string t)
|
||
in
|
||
(* §1 and §2. [signal] is Unit whatever it finds; [error] is Never,
|
||
because the only way past it is a handler that transfers — one that
|
||
returns normally has not answered it, and the program stops. *)
|
||
let ty, kind =
|
||
match kind with
|
||
| Ast.Ssignal -> (Types.Unit, Tast.Ssignal)
|
||
| Ast.Serror -> (Types.Never, Tast.Serror)
|
||
in
|
||
expect loc ~want (mk loc ty (Tast.Signal (kind, type_id name, c)))
|
||
|
||
| Ast.HandlerBind (clauses, body) -> check_handler_bind ctx ?want loc clauses body
|
||
|
||
(* spec-conditions.md §3–§6: the transfer. Neither of these is a call — one
|
||
establishes frames around a body, and the other leaves the function it is
|
||
written in — so both are their own nodes all the way down. *)
|
||
| Ast.RestartCase (body, clauses) -> check_restart_case ctx ?want loc body clauses
|
||
| Ast.InvokeRestart (name, args) ->
|
||
(* Never: control resumes at the restart-case, which yields the clause's
|
||
value to *its* continuation, so nothing here has a value and nothing
|
||
after it runs. The lookup is at run time because restarts are
|
||
dynamically scoped and named — §4 — and so, for the same reason, is the
|
||
check that these arguments are the ones the clause takes (§3). *)
|
||
if ctx.in_defer then
|
||
fail loc
|
||
"invoke-restart is not allowed inside a defer — a defer is the cleanup \
|
||
a transfer runs on its way out, so starting one there would leave \
|
||
this function's defers half run with two targets and no way to \
|
||
choose";
|
||
let args = map_lr (fun a -> check ctx a) args in
|
||
List.iter
|
||
(fun (a : Tast.expr) ->
|
||
match a.Tast.ty with
|
||
| Types.Unit | Types.Never ->
|
||
fail a.Tast.loc
|
||
"a restart argument must be a value, and this one is %s"
|
||
(Types.to_string a.Tast.ty)
|
||
| _ -> ())
|
||
args;
|
||
let sg = restart_sig (List.map (fun (a : Tast.expr) -> a.Tast.ty) args) in
|
||
(* Evaluated into slots first, so that an argument which transfers on its
|
||
own is guarded before this form aims the channel, and so that a call
|
||
written in an argument is on the ordinary walk rather than hidden
|
||
inside a node that [Reach] and [Load] treat as a leaf. *)
|
||
let binds =
|
||
List.map (fun (a : Tast.expr) -> (fresh_slot ctx a.Tast.ty, a)) args
|
||
in
|
||
let locals =
|
||
List.map
|
||
(fun (s, (a : Tast.expr)) -> mk a.Tast.loc a.Tast.ty (Tast.Local s))
|
||
binds
|
||
in
|
||
let invoke =
|
||
mk loc Types.Never
|
||
(Tast.InvokeRestart (type_id name, name, locals, sg, type_id sg, loc))
|
||
in
|
||
expect loc ~want
|
||
(if binds = [] then invoke
|
||
else mk loc Types.Never (Tast.Let (binds, [ invoke ])))
|
||
|
||
| Ast.Defer forms ->
|
||
(* Registering is the whole of it: the forms are checked here, where they
|
||
can see the scope they are written in, and the node left behind is
|
||
[unit]. [check_fn] splices the registered list onto both exit paths.
|
||
|
||
[defer_ok] is true for a top-level form of the body and for a form in a
|
||
[let] whose extent is the body — see the field's comment. Anywhere else
|
||
the cleanup would run at function exit rather than at the exit of the
|
||
construct it was written in, so it is refused, and named. *)
|
||
if not defer_ok then
|
||
fail loc
|
||
"defer is not allowed inside %s — a defer is copied into every exit \
|
||
path of the function, so it always registers and always runs at \
|
||
function exit. Write it at the top level of the function body, or in \
|
||
a let that is (a let has the function's extent, because nothing is \
|
||
released at scope exit)"
|
||
ctx.defer_block;
|
||
register_defer ctx loc forms
|
||
|
||
and int_literal loc ~want ?(default = Types.I32) n =
|
||
match want with
|
||
| Some (Types.Int k) -> mk loc (Types.Int k) (Tast.Int (in_range loc k n, k))
|
||
(* An untyped integer constant is usable where a float is wanted, as in
|
||
Odin. A float literal is never usable where an integer is wanted. *)
|
||
| Some (Types.Float k) ->
|
||
mk loc (Types.Float k) (Tast.Float (Int64.to_float n, k))
|
||
| Some other when other <> Types.Never ->
|
||
fail loc "expected %s, found the integer literal %Ld"
|
||
(Types.to_string other) n
|
||
| _ -> mk loc (Types.Int default) (Tast.Int (in_range loc default n, default))
|
||
|
||
(* Arithmetic wraps, but a literal that does not fit its type is a typo, not a
|
||
wrap — 300 is never what someone meant by a u8. *)
|
||
and in_range loc k n =
|
||
let bits = Types.bits k in
|
||
let ok =
|
||
if Types.signed k then
|
||
bits = 64
|
||
|| (Int64.compare n (Int64.neg (Int64.shift_left 1L (bits - 1))) >= 0
|
||
&& Int64.compare n (Int64.shift_left 1L (bits - 1)) < 0)
|
||
else if bits = 64 then
|
||
(* A u64 literal is its 64-bit pattern, so anything at or above 2^63
|
||
arrives here as a negative [int64] and is still in range —
|
||
0xcbf29ce484222325 is a real u64 and not an error. The cost is that a
|
||
negative *decimal* literal is accepted as a u64 too, because the
|
||
reader records only the value and not how it was written. Narrower
|
||
unsigned types keep the strict check, which is where a typo like 300
|
||
for a u8 actually shows up. *)
|
||
true
|
||
else
|
||
Int64.compare n 0L >= 0
|
||
&& Int64.compare n (Int64.shift_left 1L bits) < 0
|
||
in
|
||
if ok then n
|
||
else fail loc "%Ld does not fit in %s" n (Types.ikind_name k)
|
||
|
||
and var ctx loc ~want name =
|
||
match name with
|
||
| "true" | "false" ->
|
||
expect loc ~want (mk loc Types.Bool (Tast.Bool (name = "true")))
|
||
| "None" ->
|
||
(match want with
|
||
| Some (Types.Option t) -> mk loc (Types.Option t) Tast.None_
|
||
| Some other when other <> Types.Never ->
|
||
fail loc "expected %s, found None" (Types.to_string other)
|
||
| _ ->
|
||
fail loc
|
||
"nothing here says what None is an Option of — annotate the \
|
||
function's return type or the binding")
|
||
(* spec-memory.md puts the allocator in the calling convention as
|
||
[context/allocator] and [context/temp]. They read as names rather than
|
||
calls because that is how the spec writes them, and they are dynamic
|
||
variables at run time rather than extra parameters — see docs/BUILT.md for why
|
||
the literal reading of "calling convention" is deferred. *)
|
||
| "context/allocator" ->
|
||
expect loc ~want
|
||
(mk loc Types.Alloc (Tast.Prim (Tast.Rt "flan_context_allocator", [])))
|
||
| "context/temp" ->
|
||
expect loc ~want
|
||
(mk loc Types.Alloc (Tast.Prim (Tast.Rt "flan_context_temp", [])))
|
||
| _ ->
|
||
match lookup ctx name with
|
||
| Some b ->
|
||
expect loc ~want (mk loc b.bty (Tast.Local b.slot))
|
||
| None ->
|
||
match Hashtbl.find_opt ctx.env.globals name with
|
||
| Some (ty, _) ->
|
||
expect loc ~want (mk loc ty (Tast.Global name))
|
||
| None ->
|
||
match Hashtbl.find_opt ctx.env.cases name with
|
||
(* A case with no fields is a whole value on its own, so it is written
|
||
as a name and not as a call — the same shape [None] has, and for the
|
||
same reason: there is nothing to put in the braces. A case that does
|
||
have fields is refused here rather than silently zeroed, because ZII
|
||
on a constructor would quietly produce a value nobody wrote. *)
|
||
| Some (dname, c) when String.contains name '.' ->
|
||
if c.Tast.vfields <> [] then
|
||
fail loc
|
||
"%s has fields, so it needs them — write (%s {.%s ...})"
|
||
name name
|
||
(List.hd c.Tast.vfields).Tast.fname;
|
||
expect loc ~want
|
||
(mk loc (Types.Named dname)
|
||
(Tast.MakeCase (dname, c.Tast.vname, [])))
|
||
| Some (dname, c) ->
|
||
fail loc
|
||
"%s is a case of the data type %s, and a data type value names both — \
|
||
write %s.%s" name dname dname c.Tast.vname
|
||
| None ->
|
||
(* A bare function name *is* the function. This is a Lisp-1 — one
|
||
top-level namespace, enforced, so a defn and a defvar cannot share
|
||
a name — and that is exactly what makes (map double xs) safe to
|
||
read: there is no second binding of [double] for it to have meant
|
||
instead, so Common Lisp's #'double would be punctuation answering
|
||
a question this language does not ask. *)
|
||
(match Hashtbl.find_opt ctx.env.fns name with
|
||
| Some (params, ret) ->
|
||
(* A foreign function is in [fns] too, and its emitted signature
|
||
is C's: no transfer channel, and an aggregate flattened by the
|
||
shim. Nothing could call the resulting pointer correctly, so it
|
||
is refused for what it is rather than handed out. *)
|
||
if Hashtbl.mem ctx.env.externs name then
|
||
fail loc
|
||
"%s is a foreign function, and its address is not a Flan \
|
||
function value: a Flan function's signature ends with the \
|
||
transfer channel and a C one does not. Wrap it in a defn \
|
||
and pass that" name;
|
||
expect loc ~want
|
||
(mk loc (Types.Fn (params, ret)) (Tast.FnAddr (Tast.Fnval name)))
|
||
| None -> captured ctx loc name;
|
||
Loc.failk "check/unknown-name" loc "unknown name %s" name)
|
||
|
||
(* What remains of spec-memory.md's ownership section after the repeals of
|
||
2026-09-18 is the allocator's side alone: the region rule decides where a
|
||
container of owning elements may be built, and the allocator's capability
|
||
decides what a free means at run time. Everything copies — a container as
|
||
its header, the copies aliasing one buffer — and which frees run, and in
|
||
what order, is the program's own business, the same contract Odin ships
|
||
with; the dev build's epoch words are the net under it. The flow analysis
|
||
that used to live here (a per-function dead set, a borrow flag, a
|
||
loop-iteration diff) went in the first repeal; the move-only concept
|
||
itself — copy refusals, [copyable?], the struct/union owning rules — went
|
||
in the second. See spec-memory.md, "The repeal". *)
|
||
|
||
(* [defer_ok] is granted again before *every* form, not once before the block:
|
||
[check] withdraws it as it starts, so granting it once would let the first
|
||
form carry a defer and refuse the second — and two resources acquired in one
|
||
[let] is the case the relaxation exists for. *)
|
||
and block ctx ?want ?(defer_ok = false) loc body =
|
||
match body with
|
||
(* Withdrawn here too. An empty body has no last form to be the tail, so
|
||
leaving the permission set would hand it to whatever is checked next. *)
|
||
| [] -> ctx.tail <- false; expect loc ~want (unit_at loc)
|
||
| _ ->
|
||
(* A block's tail is its last form and nothing else. Callers that must not
|
||
pass one on need do nothing: [check] withdrew it before they were
|
||
reached, so [tail] is already false here for all of them. *)
|
||
let tail = ctx.tail in
|
||
let rec go = function
|
||
| [ last ] ->
|
||
ctx.defer_ok <- defer_ok;
|
||
ctx.tail <- tail;
|
||
let l = check ctx ?want last in [ l ], l.Tast.ty
|
||
| x :: rest ->
|
||
ctx.defer_ok <- defer_ok;
|
||
ctx.tail <- false;
|
||
let x = check ctx x in
|
||
let rest, ty = go rest in x :: rest, ty
|
||
| [] -> assert false
|
||
in
|
||
let body, ty = go body in
|
||
mk loc ty (Tast.Do body)
|
||
|
||
(* (fn [x y] BODY...) — a function value, lifted into a function of its own.
|
||
|
||
The same arrangement a handler clause already uses, and deliberately so:
|
||
this compiler has built and called function values internally since the Map
|
||
landed, and the surface feature is that machinery given a name rather than a
|
||
second one invented beside it.
|
||
|
||
**No capture, and that is the scope of this milestone.** The body sees its
|
||
parameters and the program's globals and nothing else; a reference to a
|
||
local of the enclosing function is refused by name (see [captured]) rather
|
||
than resolved to something it did not mean. That is what makes the value a
|
||
bare code address with no environment behind it, which in turn is what makes
|
||
it safe to pass down, return, and store: there is nothing that can outlive
|
||
anything. spec-memory.md's capture cases, and escaping closures with them,
|
||
stay deferred.
|
||
|
||
**The parameter types come from the position.** [Ast.Fn] carries names and
|
||
no types — that is the surface syntax, not an omission here — so an fn is
|
||
checkable exactly where something says what is wanted. An argument position
|
||
does, because [named_call] threads the callee's parameter type into each
|
||
argument; a bare [(let [f (fn [x] x)])] does not, and is refused saying so. *)
|
||
and check_fn ctx ~want loc (params : string list) body =
|
||
let pts, ret =
|
||
match want with
|
||
| Some (Types.Fn (ps, r)) when List.length ps = List.length params -> ps, r
|
||
| Some (Types.Fn (ps, r)) ->
|
||
fail loc
|
||
"this fn has %d parameter%s and %s was wanted here"
|
||
(List.length params)
|
||
(if List.length params = 1 then "" else "s")
|
||
(Types.to_string (Types.Fn (ps, r)))
|
||
| Some other when other <> Types.Never ->
|
||
fail loc "expected %s, found an fn" (Types.to_string other)
|
||
| _ ->
|
||
fail loc
|
||
"nothing here says what this fn's parameters are — an fn takes its \
|
||
types from the position it is written in, so it goes in an argument \
|
||
whose parameter is a (Fn [T ...] R), and a name already written as a \
|
||
defn goes anywhere"
|
||
in
|
||
(* Its own frame and its own empty scope, with [outer] kept only so that a
|
||
reference to the enclosing function's locals is refused for the reason it
|
||
is really refused for. *)
|
||
let fctx =
|
||
{ env = ctx.env; ret; slots = 0; slot_tys = []; slot_names = [];
|
||
scope = []; defers = []; outer = ctx.scope;
|
||
outer_what = Some "an fn"; in_frames = None; loops = []; tail = false;
|
||
in_defer = false; defer_ok = false; defer_block = "a nested form";
|
||
owner = ctx.owner }
|
||
in
|
||
List.iter2
|
||
(fun n t -> ignore (bind fctx n t ~assignable:false)) params pts;
|
||
let fbody = map_lr (fun e -> check fctx e) body in
|
||
(* The same rule an ordinary defn's body follows: the last form is the
|
||
answer, and it has to be the declared return type. *)
|
||
let fbody =
|
||
match List.rev fbody with
|
||
| [] -> fbody
|
||
| last :: rest ->
|
||
List.rev (expect last.Tast.loc ~want:(Some ret) last :: rest)
|
||
in
|
||
(* Named after the function it was written in and numbered within it, which
|
||
is the handler clause's rule and is stable for the same reason: a
|
||
redefinition module emits the lifted functions belonging to the bodies it
|
||
replaces, and an index into the whole program's list could not say which
|
||
those were. *)
|
||
let fname =
|
||
(* Counted per *kind*, not over everything this function has lifted. A
|
||
handler clause and an fn share one list, and a shared counter would
|
||
renumber every fn in a function the moment a handler-bind was added
|
||
above one — a rename for a body that did not change, in the names a
|
||
redefinition module emits. Two counters, two stable sequences. *)
|
||
let mine =
|
||
List.filter
|
||
(fun (l : Tast.fn) ->
|
||
l.Tast.fparent = Some ctx.owner
|
||
&& String.length l.Tast.name >= 3
|
||
&& String.sub l.Tast.name 0 3 = "fn/")
|
||
ctx.env.lifted
|
||
in
|
||
Printf.sprintf "fn/%s/%d" ctx.owner (List.length mine)
|
||
in
|
||
ctx.env.lifted <-
|
||
{ Tast.name = fname; params = pts;
|
||
slots = Array.of_list (List.rev fctx.slot_tys);
|
||
snames = Array.of_list (List.rev fctx.slot_names);
|
||
ret; body = fbody; fdefers = [];
|
||
fparent = Some ctx.owner; floc = loc }
|
||
:: ctx.env.lifted;
|
||
expect loc ~want
|
||
(mk loc (Types.Fn (pts, ret)) (Tast.FnAddr (Tast.Fnval fname)))
|
||
|
||
(* A handler runs where the *signal* was, not where it was established, so it
|
||
cannot be a branch in the function that wrote it: it is lifted into a
|
||
function of its own and reached through a pointer.
|
||
|
||
Which means it cannot see the establishing function's locals. Capturing them
|
||
is a closure with an explicit environment — the non-escaping kind, captured
|
||
by value onto this frame — and until that exists a reference to one is
|
||
rejected by name rather than silently resolving to something else. Globals and the condition itself are
|
||
in scope, which is enough for the accumulation case §1 is about.
|
||
|
||
The body may not [return] either. The frames are pushed and popped around
|
||
it, and an early exit would leave them on the stack pointing into a function
|
||
that has gone. *)
|
||
and check_handler_bind ctx ?want loc clauses body =
|
||
ignore want;
|
||
let frames =
|
||
List.map
|
||
(fun (c : Ast.hclause) ->
|
||
let ty = resolve ctx.env c.Ast.hty in
|
||
let name =
|
||
match ty with
|
||
| Types.Named n -> n
|
||
| t ->
|
||
fail c.Ast.hloc
|
||
"a handler matches a struct type, not %s" (Types.to_string t)
|
||
in
|
||
(* Its own context: a fresh frame, an empty scope, and no way to reach
|
||
the enclosing one. *)
|
||
let hctx =
|
||
{ env = ctx.env; ret = Types.Unit; slots = 0; slot_tys = []; slot_names = [];
|
||
scope = []; defers = []; outer = ctx.scope; outer_what = Some "a handler"; in_frames = None; loops = []; tail = false; in_defer = false; defer_ok = false; defer_block = "a nested form"; owner = "<none>" }
|
||
in
|
||
(* The condition crosses as a pointer, because the handler runs while
|
||
the signalling frame is still alive and there is nothing to copy.
|
||
What the clause binds is the condition itself, though, so the
|
||
pointer is a hidden parameter and the name is a slot loaded from
|
||
it — a handler that passed [c] to something expecting the struct
|
||
would otherwise be handed an address. *)
|
||
let pslot = fresh_slot hctx (Types.Ptr ty) in
|
||
let cslot = bind hctx c.Ast.hname ty ~assignable:false in
|
||
let hbody = map_lr (fun e -> check hctx e) c.Ast.hbody in
|
||
let hbody =
|
||
[ mk c.Ast.hloc Types.Unit
|
||
(Tast.Let
|
||
([ (cslot,
|
||
mk c.Ast.hloc ty
|
||
(Tast.Deref
|
||
(mk c.Ast.hloc (Types.Ptr ty) (Tast.Local pslot)))) ],
|
||
hbody)) ]
|
||
in
|
||
(* Named after the function it came out of, and numbered within it:
|
||
stable against an unrelated handler-bind being added elsewhere,
|
||
which an index into the whole program's lifted list would not be. *)
|
||
let fname =
|
||
(* Per kind, for the reason [check_fn] gives: an fn lifted out of
|
||
the same function must not shift this sequence. *)
|
||
let mine =
|
||
List.filter
|
||
(fun (l : Tast.fn) ->
|
||
l.Tast.fparent = Some ctx.owner
|
||
&& String.length l.Tast.name >= 8
|
||
&& String.sub l.Tast.name 0 8 = "handler/")
|
||
ctx.env.lifted
|
||
in
|
||
Printf.sprintf "handler/%s/%d/%s" ctx.owner (List.length mine) name
|
||
in
|
||
ctx.env.lifted <-
|
||
{ Tast.name = fname; params = [ Types.Ptr ty ];
|
||
slots = Array.of_list (List.rev hctx.slot_tys);
|
||
snames = Array.of_list (List.rev hctx.slot_names);
|
||
ret = Types.Unit; body = hbody; fdefers = [];
|
||
fparent = Some ctx.owner; floc = c.Ast.hloc }
|
||
:: ctx.env.lifted;
|
||
{ Tast.htype = type_id name; hfn = fname })
|
||
clauses
|
||
in
|
||
(* The flag is set on [ctx] itself and restored, not on a copy: [ctx.slots]
|
||
and [ctx.slot_tys] are mutable, so a copy would allocate the body's slots
|
||
into a record the function never sees again and the indices would
|
||
collide. *)
|
||
let saved = ctx.in_frames in
|
||
ctx.in_frames <- Some "handler-bind";
|
||
let body =
|
||
barrier ctx "a handler-bind" (fun () -> map_lr (fun e -> check ctx e) body)
|
||
in
|
||
ctx.in_frames <- saved;
|
||
mk loc Types.Unit (Tast.Handled (frames, body))
|
||
|
||
(* (restart-case BODY (name [] BODY-1) ...) — spec-conditions.md §3 and §6.
|
||
|
||
Unlike a handler, a clause runs *at* the restart-case, which is where it was
|
||
written, so it is a branch in this function and sees this function's scope.
|
||
What arrives from elsewhere is only the answer to "which clause": a transfer
|
||
names the frame it is aimed at, and this form compares that against the
|
||
frames it itself pushed.
|
||
|
||
Every clause body and the body have the same type, and that is the type of
|
||
the whole form — which is what makes the fall-through path visible in the
|
||
source (§1): a restart-case in value position has to produce its type when
|
||
no restart is invoked too. *)
|
||
and check_restart_case ctx ?want loc body clauses =
|
||
let saved = ctx.in_frames in
|
||
ctx.in_frames <- Some "restart-case";
|
||
let tbody = barrier ctx "a restart-case" (fun () -> check ctx ?want body) in
|
||
ctx.in_frames <- saved;
|
||
(* With no expectation from outside, the body's own type is the expectation
|
||
the clauses are checked against — unless it produced no value at all, in
|
||
which case the first clause that does decides. *)
|
||
let want =
|
||
match want with
|
||
| Some _ -> want
|
||
| None -> if tbody.Tast.ty = Types.Never then None else Some tbody.Tast.ty
|
||
in
|
||
let ty = ref (match want with Some t -> Some t | None -> None) in
|
||
let seen = ref [] in
|
||
let clauses =
|
||
map_lr
|
||
(fun (c : Ast.rclause) ->
|
||
(* Two clauses of one name would make §4's "the first frame offering
|
||
the name" pick between them by an order nothing in the source
|
||
shows. *)
|
||
if List.mem c.Ast.rname !seen then
|
||
fail c.Ast.rloc "this restart-case offers %s twice" c.Ast.rname;
|
||
seen := c.Ast.rname :: !seen;
|
||
(* §3's parameters. They are slots in *this* function — a clause runs
|
||
here, not where the invoke was — and the invoker stores into a
|
||
buffer this frame owns, because its own frame is gone by the time
|
||
the clause body starts (§5). Bound like a function's parameters:
|
||
visible only in the clause, and not assignable. *)
|
||
let params, b =
|
||
scoped ctx (fun () ->
|
||
let params =
|
||
List.map
|
||
(fun (p : Ast.field) ->
|
||
let ty = resolve ctx.env p.Ast.fty in
|
||
(match ty with
|
||
| Types.Unit | Types.Never ->
|
||
fail p.Ast.floc
|
||
"%s would be a restart parameter of type %s, which is \
|
||
not a value" p.Ast.fname (Types.to_string ty)
|
||
| _ -> ());
|
||
(bind ctx p.Ast.fname ty ~assignable:false, ty))
|
||
c.Ast.rparams
|
||
in
|
||
(* Each is checked against what the form has settled on so far, so
|
||
a clause that disagrees fails where it is written. The first one
|
||
to produce a value is what settles it when nothing outside
|
||
did. *)
|
||
(params,
|
||
(* The same barrier the body gets, and for the same reason: a
|
||
clause runs after a transfer landed at this restart-case, with
|
||
its frames still to be popped. *)
|
||
barrier ctx "a restart-case"
|
||
(fun () -> block ctx ?want:!ty c.Ast.rloc c.Ast.rbody)))
|
||
in
|
||
if !ty = None && b.Tast.ty <> Types.Never then ty := Some b.Tast.ty;
|
||
let sg = restart_sig (List.map snd params) in
|
||
{ Tast.rname_id = type_id c.Ast.rname; rname = c.Ast.rname;
|
||
rparams = params; rsig = sg; rsig_id = type_id sg; rbody = [ b ] })
|
||
clauses
|
||
in
|
||
let ty = match !ty with Some t -> t | None -> Types.Never in
|
||
mk loc ty (Tast.RestartCase (clauses, tbody))
|
||
|
||
(* The forms of a [defer], checked in place and hung on the function. It emits
|
||
nothing where it stands, so what is left behind is [unit]. *)
|
||
and register_defer ctx loc forms =
|
||
ctx.in_defer <- true;
|
||
(* A barrier, for the reason [defer] itself exists: these forms are *copied*
|
||
into every exit path of the function, where the loop they were written
|
||
beside is not running. A loop written inside the defer is below the
|
||
barrier and breaks out of itself perfectly well. *)
|
||
let forms =
|
||
barrier ctx "a defer" (fun () -> map_lr (fun d -> check ctx d) forms)
|
||
in
|
||
ctx.in_defer <- false;
|
||
ctx.defers <- mk loc Types.Unit (Tast.Do forms) :: ctx.defers;
|
||
unit_at loc
|
||
|
||
(* [defer_ok] says whether *this* let has the function's extent. If it does, so
|
||
does every form in its body, including a nested let — which is why the flag
|
||
is handed to the body rather than consumed here. *)
|
||
and check_let ctx ?(tail = false) ?want ?(defer_ok = false) loc bs body =
|
||
scoped ctx (fun () ->
|
||
let bs =
|
||
map_lr
|
||
(fun (b : Ast.binding) ->
|
||
let want = Option.map (resolve ctx.env) b.Ast.bty in
|
||
let v = check ctx ?want b.Ast.bval in
|
||
(match v.Tast.ty with
|
||
| Types.Unit | Types.Never ->
|
||
fail b.Ast.bloc "%s would be bound to %s, which is not a value"
|
||
b.Ast.bname (Types.to_string v.Tast.ty)
|
||
| _ -> ());
|
||
(* Locals are assignable places; parameters are not. *)
|
||
let slot = bind ctx b.Ast.bname v.Tast.ty ~assignable:true in
|
||
(slot, v))
|
||
bs
|
||
in
|
||
(* After the bindings, because checking each of them withdrew it. *)
|
||
ctx.tail <- tail;
|
||
let body = block ctx ?want ~defer_ok loc body in
|
||
mk loc body.Tast.ty (Tast.Let (bs, [ body ])))
|
||
|
||
(* (dotimes [i n] body...) is a counting loop, not a new IR node: bind [i] to 0
|
||
and the bound to a hidden slot — [n] is evaluated once, before the loop, so
|
||
a body that changes it cannot change the trip count — then step [i] at the
|
||
end of the body. [i] is not assignable, so the step below is the only writer. *)
|
||
(* What a loop still contributes to checking after the repeal is scoping, not
|
||
ownership: the entry below is what [break] and [continue] resolve against,
|
||
and the defer_block name is what makes a [defer] in here refused as "a loop
|
||
body" — it would fire once at function exit rather than once per iteration,
|
||
and the message says so. [fresh] and the iteration move-diff that used it
|
||
are gone with the flow analysis. *)
|
||
and in_loop ctx ?label ?entry f =
|
||
(* The loop goes on the stack before the body is checked and comes off after,
|
||
so a [break] inside it can see it and one outside it cannot. *)
|
||
let loops = ctx.loops in
|
||
ctx.loops <- (match entry with Some e -> e | None -> Lloop label) :: loops;
|
||
let blocker = ctx.defer_block in
|
||
ctx.defer_block <- "a loop body";
|
||
let r = f () in
|
||
ctx.defer_block <- blocker;
|
||
ctx.loops <- loops;
|
||
r
|
||
|
||
(* Which loop a [break] or a [continue] means, as a count of loops outwards
|
||
from the innermost — which is what [Tast.Break] carries and what [emit]
|
||
indexes. Refuses three things, each by its own reason: nothing to break out
|
||
of, a label naming no loop this form is inside, and a jump that would cross
|
||
a barrier. *)
|
||
and loop_target ctx loc verb label =
|
||
let rec go depth = function
|
||
| [] ->
|
||
(match label with
|
||
| None ->
|
||
fail loc "%s is only allowed inside a loop" verb
|
||
| Some l ->
|
||
fail loc
|
||
"no loop named :%s encloses this %s. A label names one of the loops \
|
||
this form is written inside — it is not a goto, so it cannot name a \
|
||
loop somewhere else" l verb)
|
||
| Lloop name :: rest ->
|
||
(match label with
|
||
| None -> depth
|
||
| Some l when name = Some l -> depth
|
||
| Some _ -> go (depth + 1) rest)
|
||
(* A [loop] answers with the value of its body. A jump out of one would
|
||
have to produce that value from somewhere and there is nowhere, so it is
|
||
a barrier like the others, named as what it is. A [while] written inside
|
||
a loop sits below this entry and keeps its own break. *)
|
||
| Lrecur _ :: _ ->
|
||
(match label with
|
||
| None ->
|
||
fail loc
|
||
"%s is not allowed here: the nearest loop is a (loop ...), which \
|
||
answers with the value of its body, so leaving it this way would \
|
||
have no value to give. Answer with the value, or use a while"
|
||
verb
|
||
| Some l ->
|
||
fail loc
|
||
"%s :%s would leave a (loop ...), which it may not: a loop answers \
|
||
with the value of its body and a jump out of one has no value to \
|
||
give" verb l)
|
||
| Lbarrier what :: rest ->
|
||
(* Crossing it would skip whatever the construct does on the way out —
|
||
the handler or restart frames it pushed, or, for a defer, would jump
|
||
to a loop that is not there on the path the forms were copied into.
|
||
A loop nested inside the construct is below this entry and is never
|
||
reached here, which is the whole point of the rule being relative. *)
|
||
ignore rest;
|
||
(match label with
|
||
| None ->
|
||
fail loc
|
||
"%s is not allowed here: the nearest loop is outside %s, and leaving \
|
||
it that way would skip what %s does on the way out. Write the loop \
|
||
inside it, or leave with a value and test that after"
|
||
verb what what
|
||
| Some l ->
|
||
fail loc
|
||
"%s :%s would leave %s, which it may not: whatever %s does on the way \
|
||
out would be skipped. A break may only leave loops that are inside \
|
||
the same %s it is"
|
||
verb l what what what)
|
||
in
|
||
go 0 ctx.loops
|
||
|
||
and check_dotimes ctx ~want loc label name count body =
|
||
let count = check ctx ~want:index_ty count in
|
||
scoped ctx (fun () ->
|
||
let i = bind ctx name index_ty ~assignable:false in
|
||
let limit = fresh_slot ctx index_ty in
|
||
let body = in_loop ctx ?label (fun () -> map_lr (fun b -> check ctx b) body) in
|
||
let iv = mk loc index_ty (Tast.Local i) in
|
||
let one = mk loc index_ty (Tast.Int (1L, Types.I32)) in
|
||
let cond =
|
||
mk loc Types.Bool
|
||
(Tast.Prim (Tast.Lt, [ iv; mk loc index_ty (Tast.Local limit) ]))
|
||
in
|
||
let step =
|
||
mk loc Types.Unit
|
||
(Tast.Set (Tast.Plocal i,
|
||
mk loc index_ty (Tast.Prim (Tast.Add, [ iv; one ]))))
|
||
in
|
||
let zero = mk loc index_ty (Tast.Int (0L, Types.I32)) in
|
||
(* The step is the *latch* and not the last form of the body. Folded onto
|
||
the body it would be skipped by a [continue], which branches past the
|
||
rest of the body — so [i] would never advance and the loop would hang.
|
||
That is the whole reason [Tast.While] carries a third list. *)
|
||
let loop = mk loc Types.Unit (Tast.While (cond, body, [ step ])) in
|
||
expect loc ~want
|
||
(mk loc Types.Unit (Tast.Let ([ (i, zero); (limit, count) ], [ loop ]))))
|
||
|
||
(* ── (loop [...] ...) and (recur ...) ───────────────────────────────────
|
||
|
||
A loop is a [let] over its names, a [While] whose condition is [true], and
|
||
two jumps: [recur] rebinds every name and continues, and falling off the end
|
||
of the body breaks. Nothing new reaches the backend, which is the whole
|
||
argument for [recur] over tail calls — the machinery is the one [while] and
|
||
the labelled [break]/[continue] already needed.
|
||
|
||
**The value.** A loop answers with the value of its body, so the result is
|
||
written into a slot of its own on the way out and read after the loop. A
|
||
body that is [Unit] needs no slot, and a body that is [Never] — one that
|
||
only ever recurs or returns — needs neither a slot nor the break, because
|
||
nothing falls off the end of it.
|
||
|
||
**Why [Set] of a [Never] body is safe.** [emit] closes a block at its
|
||
terminator and drops what follows ([ins] checks [f.live]), so when the body
|
||
ends in a jump the store is simply never written. The one ordering that
|
||
matters is inside [Tast.Set]: the place is resolved before the value, and a
|
||
local's place is an address with no instruction behind it.
|
||
|
||
**Why the invented [While] may carry jumps.** [tast.ml] says a [While] the
|
||
checker invents contains none, because the depths it would carry were minted
|
||
against a stack it is not on. This one is different and the difference is
|
||
the licence: it is pushed on [ctx.loops] like any other, so the [Break 0]
|
||
below and every [continue] a [recur] mints count from the same stack [emit]
|
||
indexes. *)
|
||
and check_loop ctx ?want loc bs body =
|
||
scoped ctx (fun () ->
|
||
(* Each initial value is evaluated once, before the loop, exactly as a
|
||
[let]'s is and as [dotimes]'s bound is. *)
|
||
let inits =
|
||
map_lr
|
||
(fun (n, v) ->
|
||
let v = check ctx v in
|
||
(match v.Tast.ty with
|
||
| Types.Unit | Types.Never ->
|
||
fail v.Tast.loc "%s would be bound to %s, which is not a value" n
|
||
(Types.to_string v.Tast.ty)
|
||
| _ -> ());
|
||
(n, v))
|
||
bs
|
||
in
|
||
let binds =
|
||
List.map (fun (n, v) -> (bind ctx n v.Tast.ty ~assignable:true, v)) inits
|
||
in
|
||
let names = List.map (fun (slot, v) -> (slot, v.Tast.ty)) binds in
|
||
(* The singleton is [in_loop]'s doing: it sits in this recursive group and
|
||
is therefore monomorphic, and every other caller hands it a list. *)
|
||
let tbody =
|
||
match
|
||
in_loop ctx ~entry:(Lrecur names) (fun () ->
|
||
[ scoped ctx (fun () ->
|
||
(* The body's last form is the loop's tail, which is the only
|
||
place a [recur] may stand. [block] distributes it. *)
|
||
ctx.tail <- true;
|
||
block ctx ?want loc body) ])
|
||
with
|
||
| [ b ] -> b
|
||
| _ -> assert false
|
||
in
|
||
let ty = tbody.Tast.ty in
|
||
let yes = mk loc Types.Bool (Tast.Bool true) in
|
||
let leave = mk loc Types.Never (Tast.Break 0) in
|
||
let inner, result =
|
||
if ty = Types.Never then ([ tbody ], None)
|
||
else if ty = Types.Unit then ([ tbody; leave ], None)
|
||
else
|
||
let r = fresh_slot ctx ty in
|
||
([ mk loc Types.Unit (Tast.Set (Tast.Plocal r, tbody)); leave ], Some r)
|
||
in
|
||
let loop = mk loc Types.Unit (Tast.While (yes, inner, [])) in
|
||
match result with
|
||
| None -> expect loc ~want (mk loc ty (Tast.Let (binds, [ loop ])))
|
||
| Some r ->
|
||
expect loc ~want
|
||
(mk loc ty
|
||
(Tast.Let (binds @ [ (r, mk loc ty (Tast.Zero ty)) ],
|
||
[ loop; mk loc ty (Tast.Local r) ]))))
|
||
|
||
(* Which loop a [recur] means, and what it has to rebind. The same walk
|
||
[break] and [continue] make, over the same stack and refusing on the same
|
||
barriers — [recur] asks "may this jump cross that" and gets the answer that
|
||
was already settled, not a second mechanism. *)
|
||
and recur_target ctx loc =
|
||
let rec go depth = function
|
||
| [] ->
|
||
fail loc
|
||
"recur is only allowed inside a (loop ...). There are no tail calls in \
|
||
this compiler, so a function cannot recur into itself and two \
|
||
functions cannot recur into each other — write the repetition as a \
|
||
loop with a recur in its tail"
|
||
| Lrecur names :: _ -> (depth, names)
|
||
(* Unreachable while the tail rule holds — a loop body is not a tail
|
||
position, so no [recur] is ever written inside one — but the depth is
|
||
counted rather than assumed, because it is what [emit] indexes. *)
|
||
| Lloop _ :: rest -> go (depth + 1) rest
|
||
| Lbarrier what :: _ ->
|
||
fail loc
|
||
"recur would leave %s, which it may not: whatever %s does on the way \
|
||
out would be skipped. Write the loop inside it, or leave with a value \
|
||
and test that after"
|
||
what what
|
||
in
|
||
go 0 ctx.loops
|
||
|
||
and check_recur ctx ~tail loc args =
|
||
let depth, names = recur_target ctx loc in
|
||
(* Checked, which is the whole of why this is better than a silent TCO: a
|
||
recur that is not in tail position is a compile error here, where under
|
||
tail calls it would have been a stack overflow at run time. *)
|
||
if not tail then
|
||
fail loc
|
||
"recur must be in the tail position of its loop — the last thing the \
|
||
body does, or the last thing in an if, match or let arm that is itself \
|
||
in the tail. Here something would still have to run afterwards, and a \
|
||
recur is a jump back to the top, not a call that returns";
|
||
let want = List.length names and got = List.length args in
|
||
if want <> got then
|
||
fail loc "this loop binds %d name%s and this recur passes %d" want
|
||
(if want = 1 then "" else "s") got;
|
||
let vals = List.map2 (fun a (_, ty) -> check ctx ~want:ty a) args names in
|
||
(* Every name is rebound at once. The new values go into temporaries first,
|
||
so that (recur y x) swaps rather than writing y over x and then reading it
|
||
back — the same reason Clojure's recur is simultaneous. *)
|
||
let temps = List.map2 (fun v (_, ty) -> (fresh_slot ctx ty, v)) vals names in
|
||
let sets =
|
||
List.map2
|
||
(fun (t, _) (slot, ty) ->
|
||
mk loc Types.Unit
|
||
(Tast.Set (Tast.Plocal slot, mk loc ty (Tast.Local t))))
|
||
temps names
|
||
in
|
||
mk loc Types.Never
|
||
(Tast.Let (temps, sets @ [ mk loc Types.Never (Tast.Continue depth) ]))
|
||
|
||
and check_if ctx ?(tail = false) ?want loc c t e =
|
||
let c = check ctx ~want:Types.Bool c in
|
||
(* Both arms are the tail, and a one-armed [if] counts: [(when c (recur ...))]
|
||
is how nearly every loop is written, and the branch is still the last
|
||
thing the body does. *)
|
||
let in_tail f = ctx.tail <- tail; f () in
|
||
match e with
|
||
| None ->
|
||
(* A one-armed if produces Unit whatever the branch evaluates to: there is
|
||
no value on the missing side. `when` desugars to this. *)
|
||
let t = branch ctx (fun () -> in_tail (fun () -> check ctx t)) in
|
||
expect loc ~want (mk loc Types.Unit (Tast.If (c, t, unit_at loc)))
|
||
| Some e ->
|
||
let t = branch ctx (fun () -> in_tail (fun () -> check ctx ?want t)) in
|
||
(* With no expectation the then-branch supplies one for the else-branch,
|
||
unless it diverges, in which case the else-branch decides. *)
|
||
let ewant =
|
||
match want with
|
||
| Some _ -> want
|
||
| None -> if t.Tast.ty = Types.Never then None else Some t.Tast.ty
|
||
in
|
||
let e = branch ctx (fun () -> in_tail (fun () -> check ctx ?want:ewant e)) in
|
||
let ty =
|
||
if t.Tast.ty = Types.Never then e.Tast.ty
|
||
else if e.Tast.ty = Types.Never then t.Tast.ty
|
||
else if Types.equal t.Tast.ty e.Tast.ty then t.Tast.ty
|
||
else
|
||
fail loc "the branches of this if have different types: %s and %s"
|
||
(Types.to_string t.Tast.ty) (Types.to_string e.Tast.ty)
|
||
in
|
||
mk loc ty (Tast.If (c, t, e))
|
||
|
||
(* A record-shaped literal: one form for both, because [(Name {.f v})] is the
|
||
same syntax whether [Name] is a struct or a data type case, and the two differ
|
||
only in what is built at the end. Deciding here rather than in the parser is
|
||
what lets the decision be made against the tables, exactly. *)
|
||
and check_struct ctx ~want loc name kvs =
|
||
match Hashtbl.find_opt ctx.env.structs name with
|
||
| None when Hashtbl.mem ctx.env.unions name ->
|
||
check_union ctx ~want loc name kvs
|
||
| None ->
|
||
(match Hashtbl.find_opt ctx.env.cases name with
|
||
(* The full spelling [U.C], which is how a data type value is written. Checked
|
||
before the diagnostics below, since the bare-name entry in the same
|
||
table is only ever a hint. *)
|
||
| Some (dname, c) when String.contains name '.' ->
|
||
check_case ctx ~want loc dname c kvs
|
||
(* A bare case name. This is the bug NEXT.md listed under "Bugs found and
|
||
not yet fixed": [(A {.x 1})] on a case of a data type reported "unknown
|
||
struct A", because nothing in [env] could tell a case name from a
|
||
misspelling. It can now, so it says what was meant. *)
|
||
| Some (dname, c) ->
|
||
fail loc
|
||
"%s is a case of the data type %s, not a struct — a data type value names \
|
||
both, as (%s.%s {.field value ...})"
|
||
name dname dname c.Tast.vname
|
||
| None ->
|
||
if Hashtbl.mem ctx.env.datas name then
|
||
fail loc
|
||
"%s is a data type, and a data type value names the case as well as the \
|
||
type — write (%s.%s {.field value ...}) for one of %s"
|
||
name name (first_case_name ctx.env name) (case_list ctx.env name)
|
||
else
|
||
Loc.failk "check/unknown-struct" loc ~notes:(declared_note ctx.env name)
|
||
"unknown struct %s" name)
|
||
| Some s ->
|
||
let seen = Hashtbl.create 8 in
|
||
List.iter
|
||
(fun (k, (v : Ast.expr)) ->
|
||
(match Hashtbl.find_opt seen k with
|
||
| Some (first : Ast.expr) ->
|
||
Loc.failk "check/duplicate-field" v.Ast.loc
|
||
~notes:[ Loc.note first.Ast.loc (k ^ " is given here first") ]
|
||
"field %s is given twice" k
|
||
| None -> ());
|
||
if Tast.field_index s k = None then
|
||
Loc.failk "check/unknown-field" v.Ast.loc
|
||
~notes:(declared_note ctx.env name)
|
||
"%s has no field %s" name k;
|
||
Hashtbl.add seen k v)
|
||
kvs;
|
||
(* Omitted fields are zeroed — ZII, the same rule as a declaration with no
|
||
initialiser (plan.org, Data model). Every field is present from here on,
|
||
in declaration order, so no backend has to know about omission. *)
|
||
let fields =
|
||
map_lr
|
||
(fun (f : Tast.field) ->
|
||
match Hashtbl.find_opt seen f.Tast.fname with
|
||
| Some v -> check ctx ~want:f.Tast.fty v
|
||
| None -> mk loc f.Tast.fty (Tast.Zero f.Tast.fty))
|
||
s.Tast.fields
|
||
in
|
||
expect loc ~want (mk loc (Types.Named name) (Tast.Make (name, fields)))
|
||
|
||
(* [(U {.member v})] — an untagged union value.
|
||
|
||
At most one member, because the members are one storage: giving two would
|
||
be writing two values over each other and the result would be whichever the
|
||
compiler happened to store last. That is a real question with no answer, so
|
||
it is refused rather than ordered. Giving none is the ordinary ZII value and
|
||
is all-bytes-zero, the same as a struct with every field omitted.
|
||
|
||
The one member is lowered here into a zeroed temporary and a store, rather
|
||
than into a node of its own. A union value *is* a store into overlaid
|
||
storage — [Set] over [Pfield] is exactly that operation and every backend
|
||
already has it — so a [MakeUnion] node would have been the same three
|
||
instructions written a fourth and fifth time, in each backend, with the
|
||
layout rule spelled out again in each. Nothing downstream learns anything
|
||
new from this form. *)
|
||
and check_union ctx ~want loc name kvs =
|
||
let u = Hashtbl.find ctx.env.unions name in
|
||
List.iter
|
||
(fun (k, (v : Ast.expr)) ->
|
||
if Tast.field_index u k = None then
|
||
Loc.failk "check/unknown-field" v.Ast.loc
|
||
~notes:(declared_note ctx.env name)
|
||
"%s has no member %s" name k)
|
||
kvs;
|
||
let seen = Hashtbl.create 8 in
|
||
List.iter
|
||
(fun (k, (v : Ast.expr)) ->
|
||
(* Before the two-member refusal below, so [(U {.i 1 .i 2})] is told it
|
||
named one member twice rather than that [i] and [i] are the same
|
||
bytes — which is true and useless. Same words and same note as the
|
||
struct path, because it is the same mistake. *)
|
||
(match Hashtbl.find_opt seen k with
|
||
| Some (first : Ast.expr) ->
|
||
Loc.failk "check/duplicate-field" v.Ast.loc
|
||
~notes:[ Loc.note first.Ast.loc (k ^ " is given here first") ]
|
||
"member %s is given twice" k
|
||
| None -> ());
|
||
Hashtbl.add seen k v)
|
||
kvs;
|
||
(match kvs with
|
||
| (a, _) :: (b, (second : Ast.expr)) :: _ ->
|
||
Loc.failk "check/union-two-members" second.Ast.loc
|
||
"%s is a union, so %s and %s are the same bytes and only one of them \
|
||
can be written — give the one this value is, and read the other \
|
||
member when you want to see those bytes that way"
|
||
name a b
|
||
| _ -> ());
|
||
match kvs with
|
||
(* The two-member case left above, so this sees one or none. *)
|
||
| _ :: _ :: _ -> assert false
|
||
| [] -> expect loc ~want (mk loc (Types.Named name) (Tast.Zero (Types.Named name)))
|
||
| [ (k, v) ] ->
|
||
let i = Option.get (Tast.field_index u k) in
|
||
let fty = (List.nth u.Tast.fields i).Tast.fty in
|
||
let v = check ctx ~want:fty v in
|
||
let slot = fresh_slot ctx (Types.Named name) in
|
||
let here = mk loc (Types.Named name) (Tast.Local slot) in
|
||
expect loc ~want
|
||
(mk loc (Types.Named name)
|
||
(Tast.Let
|
||
([ (slot, mk loc (Types.Named name) (Tast.Zero (Types.Named name))) ],
|
||
[ mk loc Types.Unit (Tast.Set (Tast.Pfield (here, i), v)); here ])))
|
||
|
||
(* The cases of a data type, as written, for a message that has to name them. *)
|
||
and case_list env dname =
|
||
match Hashtbl.find_opt env.datas dname with
|
||
| None -> "its cases"
|
||
| Some u ->
|
||
String.concat ", "
|
||
(List.map (fun (c : Tast.variant) -> dname ^ "." ^ c.Tast.vname)
|
||
u.Tast.cases)
|
||
|
||
and first_case_name env dname =
|
||
match Hashtbl.find_opt env.datas dname with
|
||
| Some { Tast.cases = c :: _; _ } -> c.Tast.vname
|
||
| _ -> "Case"
|
||
|
||
(* [(U.C {.f v ...})]. The fields are checked and filled in exactly as a
|
||
struct's are — same ZII, same duplicate and unknown-field refusals — and the
|
||
only difference is the node at the end and the type it carries. *)
|
||
and check_case ctx ~want loc dname (c : Tast.variant) kvs =
|
||
let full = dname ^ "." ^ c.Tast.vname in
|
||
let seen = Hashtbl.create 8 in
|
||
List.iter
|
||
(fun (k, (v : Ast.expr)) ->
|
||
(match Hashtbl.find_opt seen k with
|
||
| Some (first : Ast.expr) ->
|
||
Loc.failk "check/duplicate-field" v.Ast.loc
|
||
~notes:[ Loc.note first.Ast.loc (k ^ " is given here first") ]
|
||
"field %s is given twice" k
|
||
| None -> ());
|
||
if Tast.vfield_index c k = None then
|
||
Loc.failk "check/unknown-field" v.Ast.loc
|
||
~notes:(declared_note ctx.env dname)
|
||
"%s has no field %s" full k;
|
||
Hashtbl.add seen k v)
|
||
kvs;
|
||
let fields =
|
||
map_lr
|
||
(fun (f : Tast.field) ->
|
||
match Hashtbl.find_opt seen f.Tast.fname with
|
||
| Some v -> check ctx ~want:f.Tast.fty v
|
||
| None -> mk loc f.Tast.fty (Tast.Zero f.Tast.fty))
|
||
c.Tast.vfields
|
||
in
|
||
expect loc ~want
|
||
(mk loc (Types.Named dname) (Tast.MakeCase (dname, c.Tast.vname, fields)))
|
||
|
||
and check_arr ctx ~want loc items =
|
||
let elem_want =
|
||
match want with
|
||
| Some (Types.Array (_, t)) -> Some t
|
||
| Some (Types.Slice t) -> Some t
|
||
| _ -> None
|
||
in
|
||
let items = map_lr (fun i -> check ctx ?want:elem_want i) items in
|
||
let n = Int64.of_int (List.length items) in
|
||
let elem =
|
||
match elem_want, items with
|
||
| Some t, _ -> t
|
||
| None, first :: _ -> first.Tast.ty
|
||
| None, [] ->
|
||
fail loc "an empty array literal needs a type — annotate the binding"
|
||
in
|
||
List.iter
|
||
(fun (i : Tast.expr) ->
|
||
if not (Types.fits ~expected:elem ~actual:i.Tast.ty) then
|
||
fail i.Tast.loc "this array's elements are %s, but this one is %s"
|
||
(Types.to_string elem) (Types.to_string i.Tast.ty))
|
||
items;
|
||
(match want with
|
||
| Some (Types.Array (m, _)) when not (Int64.equal m n) ->
|
||
fail loc "expected %Ld elements, found %Ld" m n
|
||
| _ -> ());
|
||
(* [n T] and [T] are distinct in type and in ownership (spec-memory.md), so
|
||
an array literal does not satisfy a slice expectation. *)
|
||
expect loc ~want (mk loc (Types.Array (n, elem)) (Tast.Arr items))
|
||
|
||
and check_match ctx ?(tail = false) ?want loc scrutinee arms =
|
||
let s = check ctx scrutinee in
|
||
(* What the arms are alternatives over. An [Option] is a two-case data type
|
||
wearing a special coat, so the two shapes below are the same shape: a set
|
||
of case names, an arity and a payload type per case, and a tag. Keeping
|
||
them apart here rather than desugaring [Option] into a declared data type is
|
||
deliberate — [Option] is generic and no declared data type is, so the coat is
|
||
the part that cannot yet be taken off. *)
|
||
let subject =
|
||
match s.Tast.ty with
|
||
| Types.Option t -> `Option t
|
||
| Types.Named n when Hashtbl.mem ctx.env.datas n ->
|
||
`Data (Hashtbl.find ctx.env.datas n)
|
||
(* An enum is the one scrutinee that is not a milestone away: it is an i32
|
||
at run time and its members are all known, so the arms would be a chain
|
||
of [=] with an exhaustiveness check over [env.enums] — a desugaring, not
|
||
a new IR node. What blocks it is upstream of here: a keyword has no case
|
||
in [Ast.pattern], and [lib/load.ml] matches that type exhaustively, so
|
||
the variant cannot be added. Said as itself rather than folded into the
|
||
milestone answer below, because the milestone is not the reason. *)
|
||
| Types.Enum n ->
|
||
fail loc
|
||
"match over the enum %s is not implemented — the lowering is a chain \
|
||
of (= k :member), but a keyword has no case in the pattern type yet. \
|
||
Use cond" n
|
||
(* An untagged union has nothing for the arms to be alternatives over.
|
||
This is not a milestone and not a missing lowering: [match] reads a tag
|
||
and decides, and the absence of a tag is the whole definition of this
|
||
type. Said by name, because the two kinds of union are one keyword
|
||
apart in the source and someone will write it. *)
|
||
| Types.Named n when Hashtbl.mem ctx.env.unions n ->
|
||
fail loc
|
||
"%s is a union, and there is nothing in one to match on: its members \
|
||
overlay the same bytes and nothing records which was written. Read \
|
||
the member you mean with (.member u), or keep a tag of your own \
|
||
beside it in a struct and match on that. A tagged alternative is \
|
||
what defdata is" n
|
||
| other ->
|
||
fail loc "match works on an Option or a data type, not on %s"
|
||
(Types.to_string other)
|
||
in
|
||
(* Which case each arm names, and the type of each name it binds. This is the
|
||
whole of what differs between the two subjects; everything below it is
|
||
shared. *)
|
||
let resolve_pat (a : Ast.arm) =
|
||
match subject, a.Ast.pat with
|
||
| _, Ast.Pwild -> None, []
|
||
| `Option elem, Ast.Pctor ("Some", [ x ]) -> Some "Some", [ (x, elem) ]
|
||
| `Option _, Ast.Pctor ("Some", _) ->
|
||
fail a.Ast.aloc "the Some pattern binds exactly one name"
|
||
| `Option _, Ast.Pctor ("None", []) -> Some "None", []
|
||
| `Option _, Ast.Pctor ("None", _) -> fail a.Ast.aloc "None binds no names"
|
||
| `Option _, Ast.Pctor (c, _) ->
|
||
fail a.Ast.aloc
|
||
"%s is not a case of Option — the cases are Some and None" c
|
||
| `Data u, Ast.Pctor (c, names) ->
|
||
(* A pattern names the case bare: the scrutinee's type already says which
|
||
data type, so [(Node l r)] is unambiguous even where two data types
|
||
share the case name. The qualified spelling is accepted too, since
|
||
that is how
|
||
the value was written and writing it again should not be an error. *)
|
||
let bare =
|
||
let full = u.Tast.dname ^ "." in
|
||
let n = String.length full in
|
||
if String.length c > n && String.sub c 0 n = full then
|
||
String.sub c n (String.length c - n)
|
||
else c
|
||
in
|
||
(match Tast.case_index u bare with
|
||
| None ->
|
||
fail a.Ast.aloc "%s is not a case of %s — the cases are %s" c
|
||
u.Tast.dname
|
||
(String.concat ", "
|
||
(List.map (fun (v : Tast.variant) -> v.Tast.vname) u.Tast.cases))
|
||
| Some (_, v) ->
|
||
(* Positional, in declaration order, and all of them or none: a
|
||
pattern that bound some of a case's fields would be silently
|
||
reading the wrong one after a field is inserted. Refused with the
|
||
count, which is the thing that is wrong. *)
|
||
if List.length names <> List.length v.Tast.vfields then
|
||
fail a.Ast.aloc
|
||
"%s.%s has %d field%s, and this pattern binds %d — a case pattern \
|
||
binds every field, in declaration order (%s)"
|
||
u.Tast.dname bare (List.length v.Tast.vfields)
|
||
(if List.length v.Tast.vfields = 1 then "" else "s")
|
||
(List.length names)
|
||
(String.concat " "
|
||
(List.map (fun (f : Tast.field) -> f.Tast.fname)
|
||
v.Tast.vfields));
|
||
Some bare,
|
||
List.map2 (fun n (f : Tast.field) -> (n, f.Tast.fty))
|
||
names v.Tast.vfields)
|
||
in
|
||
let want = ref want in
|
||
let seen = Hashtbl.create 8 in
|
||
let saw_wild = ref false in
|
||
let arms =
|
||
map_lr
|
||
(fun (a : Ast.arm) ->
|
||
let ctor, binds = resolve_pat a in
|
||
(match ctor with
|
||
| None -> saw_wild := true
|
||
| Some c ->
|
||
if Hashtbl.mem seen c then
|
||
fail a.Ast.aloc "this match has two %s arms" c;
|
||
Hashtbl.add seen c ());
|
||
branch ctx (fun () ->
|
||
let binds =
|
||
List.map
|
||
(fun (n, ty) -> bind ctx n ty ~assignable:false) binds
|
||
in
|
||
(* Every arm is the tail, exactly as an [if]'s two arms are.
|
||
Restored here because checking the scrutinee withdrew it. *)
|
||
ctx.tail <- tail;
|
||
let body = block ctx ?want:!want a.Ast.aloc a.Ast.body in
|
||
if !want = None && body.Tast.ty <> Types.Never then
|
||
want := Some body.Tast.ty;
|
||
{ Tast.acase = ctor; binds; abody = [ body ] }))
|
||
arms
|
||
in
|
||
(* Exhaustiveness is refused, not defaulted. A match that silently fell
|
||
through would have to produce a value of the match's type out of nothing,
|
||
and there is no such value for most types; and the case a data type grows
|
||
tomorrow is exactly the one a reader wants to be told about today. A [_]
|
||
arm is the way to say "the rest", written where it can be seen. *)
|
||
let missing =
|
||
match subject with
|
||
| `Option _ -> List.filter (fun c -> not (Hashtbl.mem seen c)) [ "Some"; "None" ]
|
||
| `Data u ->
|
||
List.filter_map
|
||
(fun (c : Tast.variant) ->
|
||
if Hashtbl.mem seen c.Tast.vname then None
|
||
else Some (u.Tast.dname ^ "." ^ c.Tast.vname))
|
||
u.Tast.cases
|
||
in
|
||
if not !saw_wild && missing <> [] then
|
||
(* The data type's declaration, because that is where the case list this match
|
||
failed to cover actually lives, and because adding a case there is what
|
||
makes a match non-exhaustive in the first place. *)
|
||
Loc.failk "check/non-exhaustive-match" loc
|
||
~notes:(match subject with `Data u -> declared_note ctx.env u.Tast.dname
|
||
| _ -> [])
|
||
"this match is not exhaustive — %s %s no arm. Add %s, or a _ arm for \
|
||
the rest"
|
||
(String.concat ", " missing)
|
||
(if List.length missing = 1 then "has" else "have")
|
||
(if List.length missing = 1 then "it" else "them");
|
||
let ty = match !want with Some t -> t | None -> Types.Never in
|
||
mk loc ty (Tast.Match (s, arms))
|
||
|
||
(* ── Places ────────────────────────────────────────────────────────── *)
|
||
|
||
(* The fields a name has, whether it is a struct or an untagged union. The two
|
||
are one record and differ only in what the offsets come out as, which is a
|
||
question for the layout and not for this — so [.x] is one path and not two,
|
||
and a union member is read with the accessor everything else is read with.
|
||
That is the whole of what makes punning ordinary code. *)
|
||
and fields_named env n : Tast.structure option =
|
||
match Hashtbl.find_opt env.structs n with
|
||
| Some s -> Some s
|
||
| None -> Hashtbl.find_opt env.unions n
|
||
|
||
(* The target of [.field] is a struct or an untagged union, or one level of
|
||
pointer to one. The auto-deref is inserted here as a real node, so no
|
||
backend re-derives it. *)
|
||
and struct_target ctx (target : Ast.expr) : Tast.expr * string =
|
||
let t = check ctx target in
|
||
let has n = fields_named ctx.env n <> None in
|
||
match t.Tast.ty with
|
||
| Types.Named n when has n -> t, n
|
||
| Types.Ptr (Types.Named n) when has n ->
|
||
mk t.Tast.loc (Types.Named n) (Tast.Deref t), n
|
||
(* A data type's fields belong to one case, and which case it is holding is
|
||
only known after the tag has been read. [.field] would have to be a read
|
||
that might be reading something else, so it is not one: [match] is how a
|
||
data type is opened, and it binds the fields it has proved are there. *)
|
||
| (Types.Named n | Types.Ptr (Types.Named n))
|
||
when Hashtbl.mem ctx.env.datas n ->
|
||
fail target.Ast.loc
|
||
"%s is a data type, and a data type's fields belong to a case — which \
|
||
one it is holding is what the tag says, so they are reached by (match ...), \
|
||
whose arms bind the fields of the case they matched"
|
||
n
|
||
| other ->
|
||
fail target.Ast.loc "%s is not a struct, so it has no fields"
|
||
(Types.to_string other)
|
||
|
||
and check_place ctx loc (p : Ast.place) : Tast.place * Types.t =
|
||
match p with
|
||
| Ast.Pvar name ->
|
||
(match lookup ctx name with
|
||
| Some b ->
|
||
if not b.assignable then
|
||
fail loc
|
||
"%s is a parameter, and parameters are not assignable places \
|
||
(spec-memory.md) — bind a local with let" name;
|
||
Tast.Plocal b.slot, b.bty
|
||
| None ->
|
||
match Hashtbl.find_opt ctx.env.globals name with
|
||
| Some (_, true) -> fail loc "%s is a constant" name
|
||
| Some (ty, false) -> Tast.Pglobal name, ty
|
||
| None -> captured ctx loc name;
|
||
Loc.failk "check/unknown-name" loc "unknown name %s" name)
|
||
| Ast.Pfield (target, name) ->
|
||
let target, sname = struct_target ctx target in
|
||
let s = Option.get (fields_named ctx.env sname) in
|
||
(match Tast.field_index s name with
|
||
| None ->
|
||
Loc.failk "check/unknown-field" loc ~notes:(declared_note ctx.env sname)
|
||
"%s has no field %s" sname name
|
||
| Some i -> Tast.Pfield (target, i), (List.nth s.Tast.fields i).Tast.fty)
|
||
| Ast.Pindex (target, idx) ->
|
||
let target = check ctx target in
|
||
(match target.Tast.ty with
|
||
(* The same bounds and epoch check the value form gets, through the same
|
||
helper: an element of a Vec is a place because a Vec element is
|
||
assignable, and a set that skipped the checks would be the asymmetry
|
||
[nth] was removed for. *)
|
||
| Types.Vec _ ->
|
||
let p, ty = vec_at ctx loc target idx in
|
||
Tast.Pderef p, ty
|
||
| _ ->
|
||
let idx, ty = indexed ctx target idx in
|
||
Tast.Pindex (target, idx), ty)
|
||
| Ast.Pderef target ->
|
||
let target = check ctx target in
|
||
(match target.Tast.ty with
|
||
| Types.Ptr t -> Tast.Pderef target, t
|
||
| other ->
|
||
fail loc "deref takes a (Ptr T), found %s" (Types.to_string other))
|
||
|
||
(* An index or a slice bound that is a literal is known now, so it is an error
|
||
now rather than a trap later. Only literals: a [defconst] is a global in the
|
||
typed IR, not a folded constant, so [(at arr size)] still traps at runtime —
|
||
which is what the emitted bounds check is for. A negative literal is wrong
|
||
whatever the target, but a length is static only for [n T]. *)
|
||
and static_index loc (ty : Types.t) ~past_end what k =
|
||
if k < 0L then
|
||
fail loc "%s %Ld is negative — indices count from 0" what k;
|
||
match ty with
|
||
(* [past_end] is the difference between an index and a slice bound: the last
|
||
valid index is len - 1, but a slice may end at len. *)
|
||
| Types.Array (n, _) when if past_end then k > n else k >= n ->
|
||
fail loc "%s %Ld is out of bounds for length %Ld" what k n
|
||
| _ -> ()
|
||
|
||
(* The literal value of a checked expression, if it has one. *)
|
||
and literal (e : Tast.expr) =
|
||
match e.Tast.e with Tast.Int (k, _) -> Some k | _ -> None
|
||
|
||
(* An index is [i32] internally, but a *narrower* integer may be written as
|
||
one: indexing is not arithmetic on the value, so there is nothing for a
|
||
visible cast to warn about, and requiring (i32 c) at every subscript would
|
||
be noise. A u32 is included because it cannot lose a value the bounds check
|
||
would then miss — anything above 2^31 truncates to a negative i32, which
|
||
the unsigned comparison rejects. i64 and u64 are not: 2^32 + 5 truncates to
|
||
5 and would read the wrong element with no trap at all, so those need the
|
||
cast written out. *)
|
||
and index_expr ctx (e : Ast.expr) =
|
||
(* No [want]: an expectation of [i32] would reject a [u32] index outright,
|
||
before there is anything here to convert. An untyped literal still
|
||
defaults to [i32] on its own. *)
|
||
let v = check ctx e in
|
||
match v.Tast.ty with
|
||
| Types.Int Types.I32 -> v
|
||
| Types.Int k when Types.bits k <= 32 ->
|
||
{ v with Tast.ty = index_ty;
|
||
Tast.e = Tast.Prim (Tast.Cast index_ty, [ v ]) }
|
||
| Types.Int k ->
|
||
fail e.Ast.loc
|
||
"an index is an i32, and %s is wider — write (i32 …), because a value \
|
||
that does not fit truncates to one that does and would read the wrong \
|
||
element without tripping the bounds check" (Types.ikind_name k)
|
||
| other ->
|
||
fail e.Ast.loc "an index is an integer, found %s" (Types.to_string other)
|
||
|
||
(* [(at a i)] and [(at grid row col)]: one index per dimension. *)
|
||
and indexed ctx (target : Tast.expr) (idx : Ast.expr list) =
|
||
let rec go ty = function
|
||
| [] -> [], ty
|
||
| i :: rest ->
|
||
let elem =
|
||
match ty with
|
||
| Types.Array (_, t) | Types.Slice t -> t
|
||
| other ->
|
||
fail i.Ast.loc "%s cannot be indexed" (Types.to_string other)
|
||
in
|
||
let loc = i.Ast.loc in
|
||
let i = index_expr ctx i in
|
||
(match literal i with
|
||
| Some k -> static_index loc ty ~past_end:false "index" k
|
||
| None -> ());
|
||
let rest, ty = go elem rest in
|
||
i :: rest, ty
|
||
in
|
||
go target.Tast.ty idx
|
||
|
||
(* ── Calls ─────────────────────────────────────────────────────────── *)
|
||
|
||
and check_call ctx ~want loc (head : Ast.expr) (args : Ast.expr list) =
|
||
match head.Ast.e with
|
||
| Ast.Var name -> named_call ctx ~want loc name args
|
||
(* A computed head: ((choose k) 3). The head is an ordinary expression and
|
||
the only thing asked of it is that it be a function. *)
|
||
| _ -> call_value ctx ~want loc (check ctx head) args
|
||
|
||
(* The indirect call, once the callee is checked. Shared by the computed head
|
||
above and by a name that resolved to a local or a parameter of function
|
||
type, which is the shape every caller of [map] has. *)
|
||
and call_value ctx ~want loc (callee : Tast.expr) args =
|
||
match callee.Tast.ty with
|
||
| Types.Fn (params, ret) ->
|
||
if List.length args <> List.length params then
|
||
fail loc "this function value takes %d argument%s, given %d"
|
||
(List.length params)
|
||
(if List.length params = 1 then "" else "s")
|
||
(List.length args);
|
||
let args = map2_lr (fun p a -> check ctx ~want:p a) params args in
|
||
expect loc ~want (mk loc ret (Tast.CallPtr (callee, args)))
|
||
| other ->
|
||
fail loc "this is a %s and not a function, so it cannot be called"
|
||
(Types.to_string other)
|
||
|
||
and arity loc name n args =
|
||
if List.length args <> n then
|
||
fail loc "%s takes %d argument%s, given %d" name n
|
||
(if n = 1 then "" else "s") (List.length args)
|
||
|
||
(* The operators that fold: [+ - * /], [min]/[max] and the three bitwise
|
||
combining operators all take two operands or more, and mean the same thing
|
||
applied left to right. [%] and the shifts are not in that set — a chain of
|
||
remainders or of shifts has no reading a reader would agree on in advance,
|
||
so there the arity error is the useful answer.
|
||
|
||
Two is the floor, and the two missing cases are refused rather than
|
||
invented. Zero operands would have to mean an identity element, 0 for + and
|
||
1 for *, and a sum with no terms in it is a typo far more often than it is
|
||
an intent. One operand would have to mean negation for [-] and reciprocal
|
||
for [/], and this language has no unary minus anywhere: the prelude writes
|
||
every negation as [(- 0 n)] or [(- 0.0 x)], and [(- x)] meaning something
|
||
else than the [-] two lines above it is a rule a reader has to carry rather
|
||
than see. *)
|
||
and fold_arity loc name args =
|
||
match args with
|
||
| _ :: _ :: _ -> ()
|
||
| [ _ ] when String.equal name "-" ->
|
||
fail loc
|
||
"- takes two arguments or more, given 1 — there is no unary minus; \
|
||
write (- 0 x) to negate, which is what the prelude does"
|
||
| [ _ ] when String.equal name "/" ->
|
||
fail loc
|
||
"/ takes two arguments or more, given 1 — there is no reciprocal; \
|
||
write (/ 1.0 x)"
|
||
| _ ->
|
||
fail loc "%s takes two arguments or more, given %d" name (List.length args)
|
||
|
||
(* The first two operands decide the type — [binary] picks which of them is
|
||
allowed to, and that decision is not re-made per pair — and every operand
|
||
after them is checked against it. *)
|
||
and fold_left_prim ctx ~want loc name p ok what args =
|
||
let x, y, rest =
|
||
match args with x :: y :: rest -> x, y, rest | _ -> assert false
|
||
in
|
||
let a, b = binary ctx name loc ~want:(numeric_want want) [ x; y ] in
|
||
unconstrained ctx.env loc name ~needs:"numeric?" a.Tast.ty;
|
||
(* Past [unconstrained] a variable here is one the [where] clause admitted,
|
||
so the concrete predicate below has nothing to say about it — it is
|
||
answered again, per copy, at the instantiation. *)
|
||
if not (ok a.Tast.ty || generic_ty a.Tast.ty) then
|
||
fail loc "%s takes %s, found %s" name what (Types.to_string a.Tast.ty);
|
||
let ty = a.Tast.ty in
|
||
let acc =
|
||
List.fold_left
|
||
(fun acc arg ->
|
||
mk loc ty (Tast.Prim (p, [ acc; check ctx ~want:ty arg ])))
|
||
(mk loc ty (Tast.Prim (p, [ a; b ])))
|
||
rest
|
||
in
|
||
expect loc ~want acc
|
||
|
||
(* ── Allocation failure, spec-memory.md ────────────────────────────────
|
||
No allocating operation returns an error and none can fail silently. When
|
||
the allocator cannot satisfy a request the operation signals
|
||
|
||
(StorageExhausted {.bytes n .align a .allocator id})
|
||
|
||
with [error] — whose type is Never — inside a [restart-case] offering
|
||
[retry]. That is one rule over every allocating operation, which is what
|
||
keeps [push] and [reserve] at Unit, [clone] at the container, and no
|
||
signature anywhere growing a Result. Odin's [append] returns an ignorable
|
||
Allocator_Error and its type-erased path returns the old length on a failed
|
||
reserve; an append that appends nothing and says nothing is the outcome this
|
||
rule exists to make impossible.
|
||
|
||
It is *compiler-emitted at the point of failure*, which spec-memory.md names
|
||
as the exception to plan.org's "restarts go at the resync point, once": a
|
||
restart established at a parser's top-level loop cannot re-attempt an
|
||
allocation, and only the allocation site can.
|
||
|
||
The shape is built out of nodes that already exist — a while, a restart-case
|
||
and an error — so the backend learns nothing new about allocation:
|
||
|
||
(let [ok false]
|
||
(while (not ok)
|
||
(restart-case
|
||
(do (set ok ATTEMPT)
|
||
(if (not ok) (error (StorageExhausted {...}))))
|
||
(retry []))))
|
||
|
||
A handler that frees something, releases a scratch region or grows the arena
|
||
and then invokes [retry] lands in the clause, the clause falls through, and
|
||
the while re-tests and re-attempts the *same* request. With nothing handling
|
||
it, [error] stops the program on the frame that erred, as §2 says.
|
||
|
||
[attempt] must be a call that can be repeated: every argument to it is bound
|
||
to a slot before the loop, so a retry does not re-evaluate the element
|
||
expression a push was given. *)
|
||
and alloc_guard ctx loc (attempt : Tast.expr) =
|
||
let ok = fresh_slot ctx Types.Bool in
|
||
let okv = mk loc Types.Bool (Tast.Local ok) in
|
||
let notok () = mk loc Types.Bool (Tast.Prim (Tast.Not, [ okv ])) in
|
||
let i8 n = mk loc (Types.Int Types.I8) (Tast.Int (n, Types.I8)) in
|
||
(* The runtime answers 1 or 0 and never reports failure any other way. *)
|
||
let attempt = mk loc Types.Bool (Tast.Prim (Tast.Ne, [ attempt; i8 0L ])) in
|
||
(* A value struct on the signalling frame's stack, with fixed numeric fields
|
||
and no rendered message: formatting would allocate, and this is the one
|
||
path that must not. Rendering happens in the handler or the break loop,
|
||
where a working allocator is known. *)
|
||
let cond =
|
||
mk loc (Types.Named "StorageExhausted")
|
||
(Tast.Make
|
||
("StorageExhausted",
|
||
[ rt loc (Types.Int Types.I64) "flan_alloc_fail_bytes" [];
|
||
rt loc (Types.Int Types.I64) "flan_alloc_fail_align" [];
|
||
rt loc (Types.Int Types.I64) "flan_alloc_fail_id" [] ]))
|
||
in
|
||
let signal =
|
||
mk loc Types.Never
|
||
(Tast.Signal (Tast.Serror, type_id "StorageExhausted", cond))
|
||
in
|
||
let attempt_then_signal =
|
||
mk loc Types.Unit
|
||
(Tast.Do
|
||
[ mk loc Types.Unit (Tast.Set (Tast.Plocal ok, attempt));
|
||
mk loc Types.Unit (Tast.If (notok (), signal, unit_at loc)) ])
|
||
in
|
||
let clause =
|
||
(* Compiler-emitted, so it takes no parameters: nothing outside can hand
|
||
this one a value. [rsig] is therefore the empty signature, and its hash
|
||
the same one a written [(retry [] ...)] gets — the two must agree, since
|
||
an [invoke-restart] cannot tell them apart. *)
|
||
let sg = restart_sig [] in
|
||
{ Tast.rname_id = type_id "retry"; rname = "retry"; rparams = [];
|
||
rsig = sg; rsig_id = type_id sg; rbody = [ unit_at loc ] }
|
||
in
|
||
let body =
|
||
mk loc Types.Unit (Tast.RestartCase ([ clause ], attempt_then_signal))
|
||
in
|
||
mk loc Types.Unit
|
||
(Tast.Let ([ (ok, mk loc Types.Bool (Tast.Bool false)) ],
|
||
[ mk loc Types.Unit (Tast.While (notok (), [ body ], [])) ]))
|
||
|
||
(* ── File failure, decisions 2 and 5 ───────────────────────────────────
|
||
The same shape [alloc_guard] has, for the same reason and out of the same
|
||
nodes: the operation signals inside a [restart-case] it establishes itself,
|
||
so nothing anywhere grows a Result and neither [slurp] nor [barf] can fail
|
||
silently. Compiler-emitted at the point of failure, which spec-memory.md
|
||
already names as the exception to plan.org's "restarts go at the resync
|
||
point, once" — a restart at an outer loop cannot re-open a file.
|
||
|
||
Two restarts, and they are the textbook pair Common Lisp establishes for a
|
||
file-error:
|
||
|
||
retry the file may be there now — the handler made a
|
||
directory, mounted something, or waited.
|
||
use-value [p string] try this other path instead.
|
||
|
||
[use-value]'s parameter *is* the path slot, so the clause body is [unit]:
|
||
emit.ml's [bind_params] stores the invoker's argument straight into the slot
|
||
the attempt reads, the clause falls through, and the while re-tests and
|
||
re-attempts against the new path. Typed restarts landed this session and
|
||
this is the first thing the compiler itself emits one for.
|
||
|
||
[attempt] must be repeatable, so the path is a slot read at each turn of the
|
||
loop rather than an expression re-evaluated. *)
|
||
and file_guard ctx loc ~path_slot ~op mk_steps =
|
||
let ok = fresh_slot ctx Types.Bool in
|
||
let okv = mk loc Types.Bool (Tast.Local ok) in
|
||
let notok () = mk loc Types.Bool (Tast.Prim (Tast.Not, [ okv ])) in
|
||
let i8 n = mk loc (Types.Int Types.I8) (Tast.Int (n, Types.I8)) in
|
||
(* Fixed fields and no rendered message, exactly as StorageExhausted: the
|
||
condition is built on the failing frame's stack and formatting is the
|
||
handler's job. [path] is whatever the attempt last used, so a handler that
|
||
supplied one through [use-value] sees the path that actually failed. *)
|
||
let cond =
|
||
mk loc (Types.Named "FileError")
|
||
(Tast.Make
|
||
("FileError",
|
||
[ mk loc Types.String (Tast.Local path_slot);
|
||
mk loc (Types.Int Types.I32) (Tast.Int (Int64.of_int op, Types.I32));
|
||
mk loc (Types.Int Types.I32)
|
||
(Tast.Prim (Tast.Cast (Types.Int Types.I32),
|
||
[ rt loc (Types.Int Types.I64)
|
||
"flan_file_fail_reason" [] ])) ]))
|
||
in
|
||
let signal () =
|
||
mk loc Types.Never (Tast.Signal (Tast.Serror, type_id "FileError", cond))
|
||
in
|
||
(* One step of the attempt: run the runtime call, record whether it worked,
|
||
and signal if it did not. The last step a caller gives is what leaves [ok]
|
||
true, which is what stops the loop. *)
|
||
let try_ (attempt : Tast.expr) =
|
||
mk loc Types.Unit
|
||
(Tast.Do
|
||
[ mk loc Types.Unit
|
||
(Tast.Set (Tast.Plocal ok,
|
||
mk loc Types.Bool (Tast.Prim (Tast.Ne, [ attempt; i8 0L ]))));
|
||
mk loc Types.Unit (Tast.If (notok (), signal (), unit_at loc)) ])
|
||
in
|
||
let clause name params =
|
||
let sg = restart_sig (List.map snd params) in
|
||
{ Tast.rname_id = type_id name; rname = name; rparams = params;
|
||
rsig = sg; rsig_id = type_id sg; rbody = [ unit_at loc ] }
|
||
in
|
||
let body =
|
||
mk loc Types.Unit
|
||
(Tast.RestartCase
|
||
([ clause "retry" [];
|
||
clause "use-value" [ (path_slot, Types.String) ] ],
|
||
mk loc Types.Unit (Tast.Do (mk_steps try_))))
|
||
in
|
||
mk loc Types.Unit
|
||
(Tast.Let ([ (ok, mk loc Types.Bool (Tast.Bool false)) ],
|
||
[ mk loc Types.Unit (Tast.While (notok (), [ body ], [])) ]))
|
||
|
||
(* Is this bare symbol the name of a type? Every table [resolve_name] will look
|
||
in, and the data type table is one of them: a data type is [Named] exactly as a
|
||
struct is, so (vec-new Form) is as ordinary as (vec-new Cell). It was left
|
||
out when data types landed, which made the prelude's own (vec-new Form) fail
|
||
with "nothing here says what (vec-new) is a Vec of" — a message about a
|
||
missing annotation for a program that had written one. One list, read by
|
||
both callers, so the next kind of type added cannot be added to one of
|
||
them. *)
|
||
and type_named ctx n =
|
||
(* A type variable names a type here too, which is what lets [(vec-new t)]
|
||
be written in a generic body: inside an instantiation [resolve_name]
|
||
answers with the concrete element type, and during the abstract pass it
|
||
answers [Var t] and the [Vec] that comes back is a [(Vec t)] — generic,
|
||
and refused by anything that needs a size. *)
|
||
List.mem n ctx.env.tyvars
|
||
|| List.mem_assoc n ctx.env.subst
|
||
|| List.mem n Types.primitive_names
|
||
|| Hashtbl.mem ctx.env.structs n
|
||
|| Hashtbl.mem ctx.env.datas n
|
||
|| Hashtbl.mem ctx.env.unions n
|
||
|| Hashtbl.mem ctx.env.enums n
|
||
|| Hashtbl.mem ctx.env.aliases n
|
||
|
||
(* The element type for [vec-new]: a leading bare symbol naming a type, or the
|
||
expectation at the site. A bare symbol shadowed by a local or a global is
|
||
that binding — an allocator, in practice — and not a type. *)
|
||
and vec_new_elem ctx ~want loc args =
|
||
let named =
|
||
match args with
|
||
| { Ast.e = Ast.Var n; _ } :: rest
|
||
when lookup ctx n = None
|
||
&& (not (Hashtbl.mem ctx.env.globals n))
|
||
&& type_named ctx n ->
|
||
Some (resolve_name ctx.env ~seen:[] loc n, rest)
|
||
| _ -> None
|
||
in
|
||
match named with
|
||
| Some (t, rest) -> t, rest
|
||
| None ->
|
||
(match want with
|
||
| Some (Types.Vec t) -> t, args
|
||
| _ ->
|
||
fail loc
|
||
"nothing here says what (vec-new) is a Vec of — write the element \
|
||
type, as (vec-new i32), or give the binding a type")
|
||
|
||
(* The key and value types, or the reason this is not a Map. *)
|
||
and map_kv loc what (t : Types.t) =
|
||
match t with
|
||
| Types.Map (k, v) -> k, v
|
||
| other -> fail loc "%s takes a (Map K V), found %s" what (Types.to_string other)
|
||
|
||
(* The key and value for [map-new]: two leading bare symbols naming types, or
|
||
the expectation at the site. The same rule [vec-new] uses, with the same
|
||
escape for a symbol that is really a binding — an allocator, in practice —
|
||
and the pair is written together or not at all, because (map-new string)
|
||
says half of a type and half is not a type. *)
|
||
and map_new_types ctx ~want loc args =
|
||
let is_type n =
|
||
lookup ctx n = None
|
||
&& (not (Hashtbl.mem ctx.env.globals n))
|
||
&& type_named ctx n
|
||
in
|
||
match args with
|
||
| { Ast.e = Ast.Var k; _ } :: { Ast.e = Ast.Var v; _ } :: rest
|
||
when is_type k && is_type v ->
|
||
resolve_name ctx.env ~seen:[] loc k, resolve_name ctx.env ~seen:[] loc v, rest
|
||
| { Ast.e = Ast.Var k; _ } :: rest when is_type k && rest = [] ->
|
||
fail loc
|
||
"(map-new %s) names a key and no value — write both, as (map-new %s \
|
||
i32), or give the binding a type" k k
|
||
| _ ->
|
||
(match want with
|
||
| Some (Types.Map (k, v)) -> k, v, args
|
||
| _ ->
|
||
fail loc
|
||
"nothing here says what (map-new) maps — write the key and value \
|
||
types, as (map-new string i32), or give the binding a type")
|
||
|
||
(* The element type, or the reason this is not a Vec. *)
|
||
and vec_elem loc what (t : Types.t) =
|
||
match t with
|
||
| Types.Vec e -> e
|
||
| other -> fail loc "%s takes a (Vec T), found %s" what (Types.to_string other)
|
||
|
||
(* The allocator an operation uses: the one named at the site, or the current
|
||
implicit one. spec-memory.md: an operation never falls back to a hidden
|
||
global allocator, and an explicit allocator can override the context. *)
|
||
and allocator_arg ctx loc = function
|
||
| [] -> rt loc Types.Alloc "flan_context_allocator" []
|
||
| [ a ] -> check ctx ~want:Types.Alloc a
|
||
| _ -> fail loc "at most one allocator may be named here"
|
||
|
||
(* The address of an element, bounds-checked, with the allocator's epoch
|
||
checked first. Both the value form [(at v i)] and the place form
|
||
[(set (at v i) x)] come through here, so they cannot drift apart — which is
|
||
the asymmetry [nth] was removed for. *)
|
||
and vec_at ctx loc (target : Tast.expr) (idx : Ast.expr list) =
|
||
let elem = vec_elem loc "at" target.Tast.ty in
|
||
match idx with
|
||
| [ i ] ->
|
||
let i = index_expr ctx i in
|
||
rt loc (Types.Ptr elem) "flan_vec_at"
|
||
[ target; i; size_of loc elem; here loc ], elem
|
||
| _ ->
|
||
fail loc
|
||
"a Vec takes exactly one index — (at v i) — and its element is indexed \
|
||
separately"
|
||
|
||
and named_call ctx ~want loc name args =
|
||
let prim p ty args = expect loc ~want (mk loc ty (Tast.Prim (p, args))) in
|
||
match name with
|
||
(* ── arithmetic and comparison ─────────────────────────────────── *)
|
||
| "+" | "-" | "*" | "/" ->
|
||
let p = match name with
|
||
| "+" -> Tast.Add | "-" -> Tast.Sub | "*" -> Tast.Mul
|
||
| _ -> Tast.Div
|
||
in
|
||
fold_arity loc name args;
|
||
fold_left_prim ctx ~want loc name p Types.is_numeric "numbers" args
|
||
(* Remainder stays at two: (% a b c) is (% (% a b) c), which is a thing
|
||
nobody writes on purpose. *)
|
||
| "%" ->
|
||
arity loc name 2 args;
|
||
let a, b = binary ctx name loc ~want:(numeric_want want) args in
|
||
unconstrained ctx.env loc name ~needs:"numeric?" a.Tast.ty;
|
||
if not (Types.is_numeric a.Tast.ty || generic_ty a.Tast.ty) then
|
||
fail loc "%s takes numbers, found %s" name (Types.to_string a.Tast.ty);
|
||
prim Tast.Rem a.Tast.ty [ a; b ]
|
||
| "=" | "!=" | "<" | "<=" | ">" | ">=" ->
|
||
let p = match name with
|
||
| "=" -> Tast.Eq | "!=" -> Tast.Ne | "<" -> Tast.Lt
|
||
| "<=" -> Tast.Le | ">" -> Tast.Gt | _ -> Tast.Ge
|
||
in
|
||
arity loc name 2 args;
|
||
let a, b = binary ctx name loc ~want:None args in
|
||
(* [=] and [!=] admit one type [<] does not: a handle, which is a pair of
|
||
numbers in one word and where "the same entity" is the question the
|
||
type exists to answer. Ordering handles would order a slot index, which
|
||
is a free-list artefact and means nothing. *)
|
||
let ok =
|
||
match name with
|
||
| "=" | "!=" -> Types.is_equatable a.Tast.ty
|
||
| _ -> Types.is_comparable a.Tast.ty
|
||
in
|
||
unconstrained ctx.env loc name
|
||
~needs:(match name with "=" | "!=" -> "equal?" | _ -> "ordered?")
|
||
a.Tast.ty;
|
||
if not (ok || generic_ty a.Tast.ty) then
|
||
fail loc
|
||
"%s compares machine numbers; %s has no built-in comparison \
|
||
(plan.org, Types)" name (Types.to_string a.Tast.ty);
|
||
prim p Types.Bool [ a; b ]
|
||
| "not" ->
|
||
arity loc name 1 args;
|
||
prim Tast.Not Types.Bool [ check ctx ~want:Types.Bool (List.hd args) ]
|
||
(* Bitwise operators are integers-only, and the shift count has the same type
|
||
as the value shifted — there is no implicit widening anywhere else either. *)
|
||
| "bit-and" | "bit-or" | "bit-xor" ->
|
||
let p = match name with
|
||
| "bit-and" -> Tast.BitAnd | "bit-or" -> Tast.BitOr
|
||
| _ -> Tast.BitXor
|
||
in
|
||
fold_arity loc name args;
|
||
fold_left_prim ctx ~want loc name p
|
||
(function Types.Int _ -> true | _ -> false) "integers" args
|
||
(* The shifts stay at two, and not only because a shift chain reads badly:
|
||
each count would be checked against the same width below, so (<< x 30 30)
|
||
would pass two legal shifts and still shift the value away entirely. *)
|
||
| "<<" | ">>" ->
|
||
let p = if String.equal name "<<" then Tast.Shl else Tast.Shr in
|
||
arity loc name 2 args;
|
||
let a, b = binary ctx name loc ~want:(numeric_want want) args in
|
||
(match a.Tast.ty with
|
||
| Types.Int _ -> ()
|
||
| other -> fail loc "%s takes integers, found %s" name
|
||
(Types.to_string other));
|
||
(* A shift by the operand's own width or more is poison in LLVM, which at
|
||
-O2 turns the whole function into an undefined value rather than into a
|
||
wrong number. A literal count is rejected here — that is the typo — and
|
||
[emit] masks a computed one, so no shift can reach the hardware out of
|
||
range. *)
|
||
(match a.Tast.ty, b.Tast.e with
|
||
| Types.Int k, Tast.Int (n, _) when p = Tast.Shl || p = Tast.Shr ->
|
||
let w = Int64.of_int (Types.bits k) in
|
||
if Int64.unsigned_compare n w >= 0 then
|
||
fail loc
|
||
"%s by %Ld is out of range for %s, which is %d bits wide" name n
|
||
(Types.to_string a.Tast.ty) (Types.bits k)
|
||
| _ -> ());
|
||
prim p a.Tast.ty [ a; b ]
|
||
(* (min a b) and (max a b) evaluate each operand once — hence the slots —
|
||
because a min over two calls must not call either of them twice.
|
||
|
||
Which is also why this one does not go through [fold_left_prim]: there is
|
||
no Prim to fold, and the pair it folds is a whole comparison. Each step
|
||
puts *both* of its sides in slots, the accumulated pick included, so the
|
||
three-operand form is two nested lets and still exactly one evaluation of
|
||
each operand — where reusing the previous [If] as an operand of the next
|
||
would have duplicated everything inside it. *)
|
||
| "min" | "max" ->
|
||
fold_arity loc name args;
|
||
let x, y, rest =
|
||
match args with x :: y :: rest -> x, y, rest | _ -> assert false
|
||
in
|
||
let a, b = binary ctx name loc ~want:(numeric_want want) [ x; y ] in
|
||
(* [min] and [max] are [<] with a pick, so [ordered?] is what they want —
|
||
not [numeric?]. A generic that declares [ordered?] gets both. *)
|
||
unconstrained ctx.env loc name ~needs:"ordered?" a.Tast.ty;
|
||
if not (Types.is_numeric a.Tast.ty || generic_ty a.Tast.ty) then
|
||
fail loc "%s takes numbers, found %s" name (Types.to_string a.Tast.ty);
|
||
let ty = a.Tast.ty in
|
||
let cmp = if String.equal name "min" then Tast.Lt else Tast.Gt in
|
||
let pick a b =
|
||
let sa = fresh_slot ctx ty and sb = fresh_slot ctx ty in
|
||
let la = mk loc ty (Tast.Local sa) and lb = mk loc ty (Tast.Local sb) in
|
||
let test = mk loc Types.Bool (Tast.Prim (cmp, [ la; lb ])) in
|
||
mk loc ty (Tast.Let ([ (sa, a); (sb, b) ],
|
||
[ mk loc ty (Tast.If (test, la, lb)) ]))
|
||
in
|
||
expect loc ~want
|
||
(List.fold_left (fun acc arg -> pick acc (check ctx ~want:ty arg))
|
||
(pick a b) rest)
|
||
(* (zeroed) is the all-bytes-zero value of whatever it is being stored into,
|
||
so it only means anything where a type is expected of it. *)
|
||
| "zeroed" ->
|
||
arity loc name 0 args;
|
||
(match want with
|
||
| Some ty when ty <> Types.Never ->
|
||
no_zeroed_fn loc "this" ty;
|
||
mk loc ty (Tast.Zero ty)
|
||
| _ ->
|
||
fail loc
|
||
"zeroed needs to know the type it is zeroing — use it where one is \
|
||
expected, as in (set grid (zeroed))")
|
||
|
||
(* The one half of a destructuring [let] that [Parse] cannot do on its own.
|
||
Everything else about a pattern is bindings and field accesses it already
|
||
wrote; the arity is a *type* question — how many elements the value has —
|
||
and there are no types in the parser. So the pattern's shape travels here
|
||
as arguments: which element this binding wants, how many names the pattern
|
||
binds, and whether that count is exact or a minimum (it is a minimum when
|
||
the pattern ends in [& rest]).
|
||
|
||
No source symbol can contain a [~] — the reader makes it a delimiter — so
|
||
this name is unspellable and nothing but [Parse] can reach it. *)
|
||
| "destructure~nth" ->
|
||
(match args with
|
||
| [ target;
|
||
{ Ast.e = Ast.Int i; _ }; { Ast.e = Ast.Int n; _ };
|
||
{ Ast.e = Ast.Int exact; _ } ] ->
|
||
let plural k = if Int64.equal k 1L then "" else "s" in
|
||
let target = check ctx target in
|
||
(match target.Tast.ty with
|
||
| Types.Array (m, elem) ->
|
||
if Int64.equal exact 1L && not (Int64.equal m n) then
|
||
fail loc
|
||
"this pattern binds %Ld name%s, but %s has %Ld element%s — a \
|
||
pattern over a fixed array names every element, or ends in \
|
||
[& rest]"
|
||
n (plural n) (Types.to_string target.Tast.ty) m (plural m);
|
||
if Int64.equal exact 0L && Int64.compare m n < 0 then
|
||
fail loc
|
||
"this pattern binds %Ld name%s before the &, but %s has only %Ld \
|
||
element%s" n (plural n) (Types.to_string target.Tast.ty) m
|
||
(plural m);
|
||
prim Tast.At elem
|
||
[ target; mk loc index_ty (Tast.Int (i, Types.I32)) ]
|
||
(* The asymmetry is real and is the reason this is refused rather than
|
||
lowered to a bounds-checked [at]: a fixed array's length is in its
|
||
type, so [[a b]] over a [[2 f32]] is a claim the checker can settle,
|
||
and over a [[T]] it is a claim about a number that does not exist
|
||
until the program runs. Turning it into a runtime trap would be a
|
||
pattern that type checks and then kills the program, which is the
|
||
trade this language does not make. *)
|
||
| Types.Slice _ ->
|
||
fail loc
|
||
"a pattern cannot destructure %s: a slice's length is a runtime \
|
||
value, so nothing here can check that it has %Ld element%s. Use \
|
||
(at s i) and test (len s) yourself"
|
||
(Types.to_string target.Tast.ty) n (plural n)
|
||
| other ->
|
||
fail loc
|
||
"%s is not a fixed array, so [a b ...] cannot destructure it"
|
||
(Types.to_string other))
|
||
| _ ->
|
||
fail loc
|
||
"destructure~nth is written by the compiler and cannot be called")
|
||
|
||
(* ── allocators, spec-memory.md ────────────────────────────────── *)
|
||
(* Every one of these is an ordinary named call, which is the whole of the
|
||
escape NEXT.md describes: [check_call] already routes a named call through
|
||
here, so none of the four function-value refusals is anywhere near it. *)
|
||
(* A *user-written* allocator, and the reason it is still refused now that
|
||
function values exist. NEXT.md said it needed "a defn's name in value
|
||
position"; it has that, and it is still two things short, both of them
|
||
nameable and neither of them a function-value question any more.
|
||
|
||
The built-in set needs none of it: heap-allocator and arena-new are C
|
||
symbols the emitter names, and no Flan type mentions them. *)
|
||
| "make-allocator" | "allocator-from" | "allocator" ->
|
||
fail loc
|
||
"a user-written allocator is not implemented yet, and a defn's name in \
|
||
value position — which is what this used to wait for — is no longer \
|
||
what is missing. Two things are. The runtime calls an allocator as \
|
||
proc(a, mode, p, old, size, align): six C arguments and no transfer \
|
||
channel, and every Flan function value's signature ends with one, so \
|
||
the pointer would be called with the wrong shape (the same mismatch a \
|
||
foreign function's address is refused for). And Allocator is opaque \
|
||
and pointer-width, so there is nowhere for a program to put the \
|
||
flan_allocator the pointer would have to point at. Use \
|
||
(arena-new ...) with a backing buffer, which is the parameterised \
|
||
allocator that does exist"
|
||
| "heap-allocator" ->
|
||
arity loc name 0 args;
|
||
expect loc ~want
|
||
(mk loc Types.Alloc (Tast.Prim (Tast.Rt "flan_heap_allocator", [])))
|
||
(* The capacity is explicit and there is no growing backing store: an arena
|
||
whose size is decided by the program is one a program can reason about,
|
||
and it is the only shape under which "exhausted" is a state a test can
|
||
reach on purpose. *)
|
||
| "arena-new" ->
|
||
arity loc name 1 args;
|
||
let cap = check ctx ~want:(Types.Int Types.I64) (List.hd args) in
|
||
expect loc ~want
|
||
(mk loc Types.Alloc (Tast.Prim (Tast.Rt "flan_arena_new", [ cap ])))
|
||
(* Hands the pages back, which [free-all] deliberately does not — see
|
||
docs/BUILT.md, "free-all is retain-capacity". *)
|
||
| "arena-destroy" ->
|
||
arity loc name 1 args;
|
||
let a = check ctx ~want:Types.Alloc (List.hd args) in
|
||
expect loc ~want
|
||
(mk loc Types.Unit (Tast.Prim (Tast.Rt "flan_arena_destroy", [ a ])))
|
||
(* One of spec-memory.md's two release points. It takes the source location
|
||
as a string so that an allocator with no region to release names the site
|
||
rather than the runtime. *)
|
||
| "free-all" ->
|
||
arity loc name 1 args;
|
||
let a = check ctx ~want:Types.Alloc (List.hd args) in
|
||
expect loc ~want
|
||
(mk loc Types.Unit
|
||
(Tast.Prim (Tast.Rt "flan_alloc_free_all", [ a; here loc ])))
|
||
(* The capability set, read off the allocator value. Odin asks its procedure
|
||
(Query_Features returning an Allocator_Mode_Set); a field is the same
|
||
answer without the round trip, which is NEXT.md's call. *)
|
||
| "can-free?" ->
|
||
arity loc name 1 args;
|
||
let a = check ctx ~want:Types.Alloc (List.hd args) in
|
||
expect loc ~want
|
||
(mk loc Types.Bool
|
||
(Tast.Prim (Tast.Ne,
|
||
[ mk loc (Types.Int Types.I8)
|
||
(Tast.Prim (Tast.Rt "flan_alloc_can_free", [ a ]));
|
||
mk loc (Types.Int Types.I8) (Tast.Int (0L, Types.I8)) ])))
|
||
| "can-free-all?" ->
|
||
arity loc name 1 args;
|
||
let a = check ctx ~want:Types.Alloc (List.hd args) in
|
||
expect loc ~want
|
||
(mk loc Types.Bool
|
||
(Tast.Prim (Tast.Ne,
|
||
[ mk loc (Types.Int Types.I8)
|
||
(Tast.Prim (Tast.Rt "flan_alloc_can_free_all", [ a ]));
|
||
mk loc (Types.Int Types.I8) (Tast.Int (0L, Types.I8)) ])))
|
||
(* The counter [free-all] bumps. A container records it and traps if it
|
||
moved; this is the same number, readable, so a program can say what it
|
||
saw. *)
|
||
| "alloc-epoch" ->
|
||
arity loc name 1 args;
|
||
let a = check ctx ~want:Types.Alloc (List.hd args) in
|
||
expect loc ~want
|
||
(mk loc (Types.Int Types.I64)
|
||
(Tast.Prim (Tast.Rt "flan_alloc_epoch", [ a ])))
|
||
(* The allocator's identity — its address — which is what the condition's
|
||
:allocator field carries, so a handler holding several regions can tell
|
||
which one ran out. *)
|
||
| "alloc-id" ->
|
||
arity loc name 1 args;
|
||
let a = check ctx ~want:Types.Alloc (List.hd args) in
|
||
expect loc ~want
|
||
(mk loc (Types.Int Types.I64) (Tast.Prim (Tast.Rt "flan_alloc_id", [ a ])))
|
||
(* A ceiling on live bytes, 0 for none. spec-memory.md's retry restart is
|
||
answerable only by a handler that can make the *same* request succeed, and
|
||
for a fixed backing store the handler that works is the one that grows it:
|
||
releasing the region a container lives in invalidates the container, which
|
||
is what the epoch check catches. So the spec's "grows the arena and then
|
||
invokes retry" needs a ceiling to raise, and this is it. It is also how a
|
||
program exhausts an allocator on purpose. *)
|
||
| "alloc-budget" ->
|
||
arity loc name 1 args;
|
||
let a = check ctx ~want:Types.Alloc (List.hd args) in
|
||
expect loc ~want
|
||
(mk loc (Types.Int Types.I64)
|
||
(Tast.Prim (Tast.Rt "flan_alloc_budget", [ a ])))
|
||
| "set-alloc-budget" ->
|
||
arity loc name 2 args;
|
||
(match args with
|
||
| [ a; n ] ->
|
||
let a = check ctx ~want:Types.Alloc a in
|
||
let n = check ctx ~want:(Types.Int Types.I64) n in
|
||
expect loc ~want
|
||
(mk loc Types.Unit (Tast.Prim (Tast.Rt "flan_alloc_set_budget", [ a; n ])))
|
||
| _ -> assert false)
|
||
(* "Did you forget to free" is an allocator-tier question and this is the
|
||
tier answering it — spec-memory.md, "Leaking is defined behaviour". *)
|
||
| "alloc-live-blocks" ->
|
||
arity loc name 1 args;
|
||
let a = check ctx ~want:Types.Alloc (List.hd args) in
|
||
expect loc ~want
|
||
(mk loc (Types.Int Types.I64)
|
||
(Tast.Prim (Tast.Rt "flan_alloc_live_blocks", [ a ])))
|
||
(* (with-allocator A BODY...). It rebinds and releases nothing: not at the
|
||
end of the body, not anywhere. spec-memory.md is explicit that this is not
|
||
a scope-end release point and that it is the point on which Odin's
|
||
[defer delete] and Carp's scope-end frees were both rejected. *)
|
||
| "with-allocator" ->
|
||
(match args with
|
||
| [] -> fail loc "with-allocator is (with-allocator allocator body ...)"
|
||
| a :: body ->
|
||
let a = check ctx ~want:Types.Alloc a in
|
||
let body, ty =
|
||
scoped ctx (fun () ->
|
||
match body with
|
||
| [] -> [ unit_at loc ], Types.Unit
|
||
| _ ->
|
||
let rec go = function
|
||
| [ last ] -> let l = check ctx ?want last in [ l ], l.Tast.ty
|
||
| e :: rest ->
|
||
let e = check ctx e in
|
||
let rest, ty = go rest in
|
||
e :: rest, ty
|
||
| [] -> assert false
|
||
in
|
||
go body)
|
||
in
|
||
expect loc ~want (mk loc ty (Tast.WithAlloc (a, body))))
|
||
|
||
(* ── (Vec T), spec-memory.md ───────────────────────────────────── *)
|
||
(* Every one of these is a named call over a type-erased runtime, with
|
||
size_of and align_of produced here because here is where the concrete
|
||
element type is known. No generics are involved and none are needed. *)
|
||
(* (vec-new), (vec-new T), (vec-new a), (vec-new T a).
|
||
[let] has no type annotation — parse.ml settles that a triple binding is
|
||
ambiguous and types are inferred — so a local Vec has nowhere to say what
|
||
it holds, and the element type is written at the call instead. This is not
|
||
the explicit instantiation syntax the generics section rules out: nothing
|
||
here is generic, and the name is resolved as an ordinary type, not bound
|
||
to a type variable. Where the context does say — a defvar's type, a
|
||
function's return type, an argument — it is not needed and may be left
|
||
out. *)
|
||
| "vec-new" ->
|
||
let elem, args = vec_new_elem ctx ~want loc args in
|
||
let a = allocator_arg ctx loc args in
|
||
let v = fresh_slot ctx (Types.Vec elem) in
|
||
let attempt =
|
||
rt loc (Types.Int Types.I8) "flan_vec_init"
|
||
[ mk loc (Types.Vec elem) (Tast.Local v); a; i64_at loc 0L;
|
||
size_of loc elem; align_of loc elem; here loc ]
|
||
in
|
||
expect loc ~want
|
||
(mk loc (Types.Vec elem)
|
||
(Tast.Let ([ (v, mk loc (Types.Vec elem) (Tast.Zero (Types.Vec elem))) ],
|
||
[ with_note loc (alloc_guard ctx loc attempt)
|
||
(reg_note loc "flan_dev_reg_note_vec"
|
||
(mk loc (Types.Vec elem) (Tast.Local v))
|
||
[ size_of loc elem ] elem);
|
||
region_check ctx.env loc
|
||
(mk loc (Types.Vec elem) (Tast.Local v))
|
||
(mk loc (Types.Vec elem) (Tast.Local v)) ])))
|
||
(* Unit, not a Result and not an ignorable error code: see [alloc_guard]. *)
|
||
| "push" ->
|
||
arity loc name 2 args;
|
||
(match args with
|
||
| [ target; x ] ->
|
||
let target = check ctx target in
|
||
let elem = vec_elem loc "push" target.Tast.ty in
|
||
let x = check ctx ~want:elem x in
|
||
(* The element is bound before the loop so that a [retry] re-attempts
|
||
the allocation and not the expression that produced the value. *)
|
||
let e = fresh_slot ctx elem in
|
||
let attempt =
|
||
rt loc (Types.Int Types.I8) "flan_vec_push"
|
||
[ target; addr_of loc (mk loc elem (Tast.Local e));
|
||
size_of loc elem; align_of loc elem; here loc ]
|
||
in
|
||
(* Re-noted after every push, not only the first: a push that grows the
|
||
Vec moves the storage, and the note is keyed on the base address, so
|
||
an unmoved block costs a probe and an overwrite with the same
|
||
numbers. This is the insert per allocation NEXT.md settles on, and
|
||
the settled answer to what it costs is "measure a real program". *)
|
||
expect loc ~want
|
||
(mk loc Types.Unit
|
||
(Tast.Let ([ (e, x) ],
|
||
[ region_check ctx.env loc target
|
||
(with_note loc (alloc_guard ctx loc attempt)
|
||
(reg_note loc "flan_dev_reg_note_vec" target
|
||
[ size_of loc elem ] elem)) ])))
|
||
| _ -> assert false)
|
||
| "reserve" ->
|
||
arity loc name 2 args;
|
||
(match args with
|
||
| [ target; n ] ->
|
||
let target = check ctx target in
|
||
let n = check ctx ~want:index_ty n in
|
||
let n64 =
|
||
mk loc (Types.Int Types.I64) (Tast.Prim (Tast.Cast (Types.Int Types.I64), [ n ]))
|
||
in
|
||
(* Deferred: the sizes are known abstractly but the hash is not, so
|
||
the node is a unit no-op and the copy builds the real one. *)
|
||
if (match target.Tast.ty with
|
||
| Types.Map (k, _) -> deferred_key ctx.env loc "reserve" k
|
||
| _ -> false) then
|
||
expect loc ~want (mk loc Types.Unit Tast.Unit)
|
||
else
|
||
let attempt, note =
|
||
match target.Tast.ty with
|
||
(* For a map the number is entries, not slots: the runtime sizes the
|
||
block so that [n] still sits under the 75% load factor, which is
|
||
the only reading of "room for n" that does not reallocate on the
|
||
nth put. *)
|
||
| Types.Map (k, v) ->
|
||
let hash, _ = key_fns ctx.env loc k in
|
||
rt loc (Types.Int Types.I8) "flan_map_reserve"
|
||
[ target; n64; size_of loc k; size_of loc v; hash; here loc ],
|
||
reg_note loc "flan_dev_reg_note_map" target
|
||
[ size_of loc k; size_of loc v ] target.Tast.ty
|
||
| _ ->
|
||
let elem = vec_elem loc "reserve" target.Tast.ty in
|
||
rt loc (Types.Int Types.I8) "flan_vec_reserve"
|
||
[ target; n64; size_of loc elem; align_of loc elem; here loc ],
|
||
reg_note loc "flan_dev_reg_note_vec" target
|
||
[ size_of loc elem ] elem
|
||
in
|
||
expect loc ~want
|
||
(region_check ctx.env loc target
|
||
(with_note loc (alloc_guard ctx loc attempt) note))
|
||
| _ -> assert false)
|
||
(* (as-slice v) and (as-slice v lo hi) — spec-memory.md, "Borrowing". The
|
||
result is a non-owning view: copying it copies ptr+len and never the
|
||
elements, and it carries no allocator, so freeing through one is not
|
||
expressible. A push, a put or a reserve may invalidate it; that is the
|
||
explicit Zig/Odin contract the spec chose over a borrow checker. *)
|
||
| "as-slice" ->
|
||
(match args with
|
||
| target :: rest when List.length rest = 0 || List.length rest = 2 ->
|
||
let target = check ctx target in
|
||
let elem = vec_elem loc "as-slice" target.Tast.ty in
|
||
let lo, hi =
|
||
match rest with
|
||
| [] ->
|
||
mk loc index_ty (Tast.Int (0L, Types.I32)),
|
||
(* -1 is "to the end": (as-slice v) has no static length to pass. *)
|
||
mk loc index_ty (Tast.Int (-1L, Types.I32))
|
||
| [ lo; hi ] -> index_expr ctx lo, index_expr ctx hi
|
||
| _ -> assert false
|
||
in
|
||
let out = fresh_slot ctx (Types.Slice elem) in
|
||
let fill =
|
||
rt loc Types.Unit "flan_vec_as_slice"
|
||
[ target; addr_of loc (mk loc (Types.Slice elem) (Tast.Local out));
|
||
lo; hi; size_of loc elem; here loc ]
|
||
in
|
||
expect loc ~want
|
||
(mk loc (Types.Slice elem)
|
||
(Tast.Let ([ (out, mk loc (Types.Slice elem)
|
||
(Tast.Zero (Types.Slice elem))) ],
|
||
[ fill; mk loc (Types.Slice elem) (Tast.Local out) ])))
|
||
| _ -> fail loc "as-slice is (as-slice v) or (as-slice v lo hi)")
|
||
(* spec-memory.md's first release point. Since the repeal, what it consumes
|
||
it consumes at run time only: nothing marks the binding dead, so a second
|
||
[free] or a read after this one type-checks and misbehaves at run time —
|
||
the allocator aborts on a double free it can see, and the epoch word
|
||
traps a read through a released region. That is the Odin contract: free
|
||
is a thing you write, and writing it twice is yours to not do. *)
|
||
| "free" ->
|
||
arity loc name 1 args;
|
||
let target = check ctx (List.hd args) in
|
||
(* A container of owning elements is refused here, and a reader will
|
||
assume the opposite — that [free] recurses — so this says why it does
|
||
not and what does.
|
||
|
||
The bytes this container holds are element *headers*, and releasing the
|
||
block those headers sit in says nothing about the blocks they point at.
|
||
Nothing type-erased can walk them: the runtime sees a size and an
|
||
alignment and has never heard of the element type. That is the same
|
||
fact the type-level refusals used to state, and the arena did not change
|
||
it — what the arena changed is that it no longer matters there, because
|
||
the inner blocks came out of the same region and [free-all] takes them
|
||
with everything else.
|
||
|
||
So the honest answer is not to recurse, and it is not to release the
|
||
backing store quietly either. Releasing the outer block alone would be
|
||
"I freed it" spelt over a program that leaked everything inside, and
|
||
this file refuses that collapse everywhere else — [flan_alloc_free_all]
|
||
traps rather than no-op for the same reason. It is refused instead, at
|
||
the one place a reader is looking when they want to know.
|
||
|
||
The guard at construction is what makes the advice reachable: such a
|
||
container is region-allocated or it does not exist, so there is always a
|
||
[free-all] to point at. *)
|
||
(match target.Tast.ty with
|
||
| (Types.Vec _ | Types.Map _)
|
||
when region_only ctx.env target.Tast.ty ->
|
||
fail loc
|
||
"%s holds elements that own storage, and free releases the block \
|
||
those elements sit in — not the blocks they point at, which nothing \
|
||
type-erased can reach. This container was built against a region \
|
||
allocator, because the guard at its construction admits no other, so \
|
||
release the region: (free-all a) takes it and everything its \
|
||
elements own, in one operation and with no per-element teardown"
|
||
(Types.to_string target.Tast.ty)
|
||
| Types.Vec elem ->
|
||
expect loc ~want
|
||
(rt loc Types.Unit "flan_vec_free"
|
||
[ target; size_of loc elem; align_of loc elem; here loc ])
|
||
| Types.Map (k, v) ->
|
||
expect loc ~want
|
||
(rt loc Types.Unit "flan_map_free"
|
||
[ target; size_of loc k; size_of loc v; here loc ])
|
||
| other ->
|
||
(* A field is never freed on its own: it would leave its owner partly
|
||
dead with no way to say so. *)
|
||
fail loc
|
||
"free takes an owning container — a Vec or a Map — found %s. A \
|
||
resource type with a drop hook is step 5 and does not exist yet"
|
||
(Types.to_string other))
|
||
(* (clone v) uses the current allocator, (clone v a) names one. A deep,
|
||
independent copy: spec-memory.md's "copying is always explicit". *)
|
||
| "clone" ->
|
||
(match args with
|
||
| target :: rest when List.length rest <= 1 ->
|
||
(* Checked once, then dispatched on what it turned out to be: checking
|
||
it inside a guard as well would allocate the target's slots twice and
|
||
evaluate whatever it was written as twice. *)
|
||
let target = check ctx target in
|
||
let a = allocator_arg ctx loc rest in
|
||
(match target.Tast.ty with
|
||
(* The refusal that did *not* come down with the type-level ones, and
|
||
the distinction is worth being exact about, because the sentence
|
||
they all used to share bundled two different failures: that a clone
|
||
would duplicate inner headers instead of copying, and that a free
|
||
would leak what those headers own. Only the second was about
|
||
teardown, and only the second is answered by a region.
|
||
|
||
What disqualifies [clone] is not that it copies a header — so do
|
||
[at] and [get], and they are fine, because they promise nothing and
|
||
hand back an alias into a region nobody individually frees. It is
|
||
that [clone] *allocates a new block and promises independence*.
|
||
spec-memory.md calls it a deep copy; what a memcpy of the slots
|
||
delivers is a second container whose elements still point into the
|
||
first one's blocks. Two containers, one set of inner buffers, under
|
||
a name that says otherwise — and putting the copy in a second arena
|
||
makes it worse, not better, because tipping that arena leaves the
|
||
copy's elements pointing into an arena that is still live while its
|
||
own storage is gone.
|
||
|
||
Refused at the operation rather than at the type, because that is
|
||
where the promise is made. *)
|
||
| (Types.Vec _ | Types.Map _) when region_only ctx.env target.Tast.ty ->
|
||
fail loc
|
||
"%s cannot be cloned: clone is a deep, independent copy, and the \
|
||
type-erased runtime copies slots bytewise — so the copy's \
|
||
elements would still point at the original's blocks, which is an \
|
||
alias under a name that promises the opposite. Nothing here can \
|
||
walk an element to copy what it owns. Build a second container \
|
||
and insert into it, or keep the one you have — a region makes \
|
||
sharing safe, not copying"
|
||
(Types.to_string target.Tast.ty)
|
||
(* A map's clone reinserts rather than copying the block, because the
|
||
seed is derived from the block's address — see flan_rt.c. That is
|
||
the runtime's business; from here it is one more allocating call
|
||
under the same guard. *)
|
||
| Types.Map (k, v) when deferred_key ctx.env loc "clone" k ->
|
||
(* Deferred, and the placeholder is a zeroed map of the same type —
|
||
the value a (map-new) starts from, so everything written around
|
||
the clone still checks against the type it will have. *)
|
||
let mty = Types.Map (k, v) in
|
||
expect loc ~want (mk loc mty (Tast.Zero mty))
|
||
| Types.Map (k, v) ->
|
||
let mty = Types.Map (k, v) in
|
||
let hash, _ = key_fns ctx.env loc k in
|
||
let d = fresh_slot ctx mty in
|
||
let attempt =
|
||
rt loc (Types.Int Types.I8) "flan_map_clone"
|
||
[ mk loc mty (Tast.Local d); target; a;
|
||
size_of loc k; size_of loc v; hash; here loc ]
|
||
in
|
||
expect loc ~want
|
||
(mk loc mty
|
||
(Tast.Let ([ (d, mk loc mty (Tast.Zero mty)) ],
|
||
[ with_note loc (alloc_guard ctx loc attempt)
|
||
(reg_note loc "flan_dev_reg_note_map"
|
||
(mk loc mty (Tast.Local d))
|
||
[ size_of loc k; size_of loc v ] mty);
|
||
mk loc mty (Tast.Local d) ])))
|
||
| _ ->
|
||
let elem = vec_elem loc "clone" target.Tast.ty in
|
||
let d = fresh_slot ctx (Types.Vec elem) in
|
||
let attempt =
|
||
rt loc (Types.Int Types.I8) "flan_vec_clone"
|
||
[ mk loc (Types.Vec elem) (Tast.Local d); target; a;
|
||
size_of loc elem; align_of loc elem; here loc ]
|
||
in
|
||
expect loc ~want
|
||
(mk loc (Types.Vec elem)
|
||
(Tast.Let ([ (d, mk loc (Types.Vec elem)
|
||
(Tast.Zero (Types.Vec elem))) ],
|
||
[ with_note loc (alloc_guard ctx loc attempt)
|
||
(reg_note loc "flan_dev_reg_note_vec"
|
||
(mk loc (Types.Vec elem) (Tast.Local d))
|
||
[ size_of loc elem ] elem);
|
||
mk loc (Types.Vec elem) (Tast.Local d) ]))))
|
||
| _ -> fail loc "clone is (clone v) or (clone v allocator)")
|
||
|
||
(* ── (Map K V), spec-memory.md ─────────────────────────────────── *)
|
||
(* Every one of these is a named call over the same type-erased runtime the
|
||
Vec uses, with the two sizes and the key's hash and equality pair produced
|
||
here because here is where the concrete types are known. No generics are
|
||
involved and none are needed — which is exactly what Odin's Map_Info says
|
||
too, being two sizes and two contextless procs. *)
|
||
|
||
(* (map-new), (map-new K V), (map-new a), (map-new K V a). The same shape
|
||
[vec-new] has and for the same reason: a [let] has no type annotation, so
|
||
a local map has nowhere else to say what it holds. Where the context does
|
||
say — a defvar's type, a parameter, a return type — the pair may be left
|
||
out. *)
|
||
| "map-new" ->
|
||
let k, v, args = map_new_types ctx ~want loc args in
|
||
let a = allocator_arg ctx loc args in
|
||
let mty = map_type ~preds:ctx.env.tvpreds loc k v in
|
||
let m = fresh_slot ctx mty in
|
||
let attempt =
|
||
rt loc (Types.Int Types.I8) "flan_map_init"
|
||
[ mk loc mty (Tast.Local m); a; size_of loc k; size_of loc v;
|
||
here loc ]
|
||
in
|
||
expect loc ~want
|
||
(mk loc mty
|
||
(Tast.Let ([ (m, mk loc mty (Tast.Zero mty)) ],
|
||
[ with_note loc (alloc_guard ctx loc attempt)
|
||
(reg_note loc "flan_dev_reg_note_map"
|
||
(mk loc mty (Tast.Local m))
|
||
[ size_of loc k; size_of loc v ] mty);
|
||
region_check ctx.env loc (mk loc mty (Tast.Local m))
|
||
(mk loc mty (Tast.Local m)) ])))
|
||
|
||
(* (put m k v) — the upsert. Unit, not a Result and not an ignorable error
|
||
code: see [alloc_guard]. spec-memory.md is explicit that it either
|
||
inserts or replaces, and that (set (get m k) v) is not map syntax. *)
|
||
| "put" ->
|
||
arity loc name 3 args;
|
||
(match args with
|
||
| [ target; k; v ] ->
|
||
let target = check ctx target in
|
||
let kt, vt = map_kv loc "put" target.Tast.ty in
|
||
let k = check ctx ~want:kt k in
|
||
let v = check ctx ~want:vt v in
|
||
(* Deferred: the arguments are checked — so a move here is still a move
|
||
and a borrow still a borrow — and the node itself is a unit no-op,
|
||
thrown away with the rest of the abstract pass. *)
|
||
if deferred_key ctx.env loc "put" kt then
|
||
expect loc ~want (mk loc Types.Unit Tast.Unit)
|
||
else
|
||
(* Both are bound before the loop, so that a [retry] re-attempts the
|
||
allocation and not the expressions that produced the key and the
|
||
value. The same rule [push] follows for its element. *)
|
||
let ks = fresh_slot ctx kt and vs = fresh_slot ctx vt in
|
||
let hash, eq = key_fns ctx.env loc kt in
|
||
let attempt =
|
||
rt loc (Types.Int Types.I8) "flan_map_put"
|
||
[ target; addr_of loc (mk loc kt (Tast.Local ks));
|
||
addr_of loc (mk loc vt (Tast.Local vs));
|
||
size_of loc kt; size_of loc vt; hash; eq; here loc ]
|
||
in
|
||
expect loc ~want
|
||
(mk loc Types.Unit
|
||
(Tast.Let ([ (ks, k); (vs, v) ],
|
||
[ region_check ctx.env loc target
|
||
(with_note loc (alloc_guard ctx loc attempt)
|
||
(reg_note loc "flan_dev_reg_note_map" target
|
||
[ size_of loc kt; size_of loc vt ]
|
||
target.Tast.ty)) ])))
|
||
| _ -> assert false)
|
||
|
||
(* (get m k) -> (Option V). Absence is None, not an untyped nil, and the
|
||
answer is a copy of the value's bytes — for an owning value, a copy of
|
||
its header, aliasing what the map's slot points at.
|
||
There is no allocation here and therefore no guard: a lookup that finds
|
||
nothing is an answer, not a failure. *)
|
||
| "get" ->
|
||
arity loc name 2 args;
|
||
(match args with
|
||
| [ target; k ] ->
|
||
let target = check ctx target in
|
||
let kt, vt = map_kv loc "get" target.Tast.ty in
|
||
let k = check ctx ~want:kt k in
|
||
(* Deferred, and the placeholder is [None] rather than [Unit]: this
|
||
form answers an (Option V), and the abstract pass still has to
|
||
type-check whatever the body does with the answer. *)
|
||
if deferred_key ctx.env loc "get" kt then
|
||
expect loc ~want (mk loc (Types.Option vt) Tast.None_)
|
||
else
|
||
let hash, eq = key_fns ctx.env loc kt in
|
||
let ks = fresh_slot ctx kt in
|
||
let out = fresh_slot ctx vt in
|
||
let found =
|
||
rt loc (Types.Int Types.I8) "flan_map_get"
|
||
[ target; addr_of loc (mk loc kt (Tast.Local ks));
|
||
addr_of loc (mk loc vt (Tast.Local out));
|
||
size_of loc kt; size_of loc vt; hash; eq; here loc ]
|
||
in
|
||
let oty = Types.Option vt in
|
||
(* The runtime answers 1/0 and fills [out] only when it answers 1, so
|
||
the Option is built here rather than there: the runtime has no idea
|
||
what an Option's layout is, and keeping it that way is what lets one
|
||
entry point serve every value type. *)
|
||
let some = mk loc oty (Tast.Some_ (mk loc vt (Tast.Local out))) in
|
||
let none = mk loc oty Tast.None_ in
|
||
let cond =
|
||
mk loc Types.Bool
|
||
(Tast.Prim (Tast.Ne,
|
||
[ found;
|
||
mk loc (Types.Int Types.I8) (Tast.Int (0L, Types.I8)) ]))
|
||
in
|
||
expect loc ~want
|
||
(mk loc oty
|
||
(Tast.Let ([ (ks, k);
|
||
(out, mk loc vt (Tast.Zero vt)) ],
|
||
[ mk loc oty (Tast.If (cond, some, none)) ])))
|
||
| _ -> assert false)
|
||
|
||
(* (map-remove! m k) -> (Option V): the value that was there, or None when
|
||
the key was not. The same answer [get] gives, for the same reason — a key
|
||
that is not in the map is an answer and not a failure — and the value
|
||
comes back rather than being dropped on the floor, which is what makes
|
||
"take this out and use it" one call instead of a get and a remove that
|
||
hash the key twice.
|
||
|
||
It allocates nothing and releases nothing, so unlike [put] there is no
|
||
alloc_guard and no region check around it: a key and a value live inside
|
||
the one block the map allocated, and removal moves entries within that
|
||
block. That is what makes it mean the same thing on a map backed by an
|
||
arena — or by any allocator that refuses can-free — as on a heap-backed
|
||
one. Nothing is freed per entry because nothing was allocated per entry.
|
||
|
||
The [!] is the mutation the naming rule asks for ([map-next!], and the
|
||
note below on the two suffixes). *)
|
||
| "map-remove!" ->
|
||
arity loc name 2 args;
|
||
(match args with
|
||
| [ target; k ] ->
|
||
let target = check ctx target in
|
||
let kt, vt = map_kv loc "map-remove!" target.Tast.ty in
|
||
let k = check ctx ~want:kt k in
|
||
(* Deferred exactly as [get] is, and with [None] for the same reason:
|
||
the abstract pass still has to check whatever the body does with the
|
||
answer. *)
|
||
if deferred_key ctx.env loc "map-remove!" kt then
|
||
expect loc ~want (mk loc (Types.Option vt) Tast.None_)
|
||
else
|
||
let hash, eq = key_fns ctx.env loc kt in
|
||
let ks = fresh_slot ctx kt in
|
||
let out = fresh_slot ctx vt in
|
||
let found =
|
||
rt loc (Types.Int Types.I8) "flan_map_remove"
|
||
[ target; addr_of loc (mk loc kt (Tast.Local ks));
|
||
addr_of loc (mk loc vt (Tast.Local out));
|
||
size_of loc kt; size_of loc vt; hash; eq; here loc ]
|
||
in
|
||
let oty = Types.Option vt in
|
||
(* Built here and not there, as [get]'s is: the runtime fills [out] only
|
||
when it answers 1 and has no idea what an Option's layout is. *)
|
||
let some = mk loc oty (Tast.Some_ (mk loc vt (Tast.Local out))) in
|
||
let none = mk loc oty Tast.None_ in
|
||
let cond =
|
||
mk loc Types.Bool
|
||
(Tast.Prim (Tast.Ne,
|
||
[ found;
|
||
mk loc (Types.Int Types.I8) (Tast.Int (0L, Types.I8)) ]))
|
||
in
|
||
expect loc ~want
|
||
(mk loc oty
|
||
(Tast.Let ([ (ks, k);
|
||
(out, mk loc vt (Tast.Zero vt)) ],
|
||
[ mk loc oty (Tast.If (cond, some, none)) ])))
|
||
| _ -> assert false)
|
||
|
||
(* (map-next! m (addr cur) (addr k) (addr v)) -> bool, and the whole of map
|
||
iteration. Before it there was no way to read a map's keys or its values
|
||
at all: every other map operation addresses one entry by hashing it, and
|
||
nothing walked the block.
|
||
|
||
Three out-pointers rather than a returned pair, because there are no
|
||
tuples and a (Option K) would answer only half of an entry — the value
|
||
would then cost a second hash of the key just answered. The cursor is an
|
||
i64 the caller owns and the loop reads as one:
|
||
|
||
(let [cur 0 k 0 v 0]
|
||
(while (map-next! m (addr cur) (addr k) (addr v))
|
||
...))
|
||
|
||
It is *not* a generic (map-keys m): a Vec of them needs a signature naming
|
||
K, and a prelude defn cannot be written at every K. That one is generics,
|
||
not iteration, and it stays refused for that reason.
|
||
|
||
No hash and no equality pair go with it — walking asks nothing about a
|
||
key — so this is the one map entry point whose signature carries neither,
|
||
and the sizes are still needed because the runtime is type-erased. *)
|
||
| "map-next!" ->
|
||
arity loc name 4 args;
|
||
(match args with
|
||
| [ target; cur; k; v ] ->
|
||
let target = check ctx target in
|
||
let kt, vt = map_kv loc "map-next!" target.Tast.ty in
|
||
let cur = check ctx ~want:(Types.Ptr (Types.Int Types.I64)) cur in
|
||
let k = check ctx ~want:(Types.Ptr kt) k in
|
||
let v = check ctx ~want:(Types.Ptr vt) v in
|
||
let found =
|
||
rt loc (Types.Int Types.I8) "flan_map_next"
|
||
[ target; cur; k; v; size_of loc kt; size_of loc vt; here loc ]
|
||
in
|
||
expect loc ~want
|
||
(mk loc Types.Bool
|
||
(Tast.Prim
|
||
(Tast.Ne,
|
||
[ found;
|
||
mk loc (Types.Int Types.I8) (Tast.Int (0L, Types.I8)) ])))
|
||
| _ -> assert false)
|
||
|
||
(* (has-key? m k). (get m k) answers the same question, but through an
|
||
Option the caller then has to match; this is the form a condition wants,
|
||
and it copies no value. *)
|
||
| "has-key?" ->
|
||
arity loc name 2 args;
|
||
(match args with
|
||
| [ target; k ] ->
|
||
let target = check ctx target in
|
||
let kt, vt = map_kv loc "has-key?" target.Tast.ty in
|
||
let k = check ctx ~want:kt k in
|
||
(* Deferred, and the placeholder is a [bool] — the form a condition
|
||
wants, so the condition around it still has to check. *)
|
||
if deferred_key ctx.env loc "has-key?" kt then
|
||
expect loc ~want (mk loc Types.Bool (Tast.Bool false))
|
||
else
|
||
let hash, eq = key_fns ctx.env loc kt in
|
||
let ks = fresh_slot ctx kt in
|
||
let found =
|
||
rt loc (Types.Int Types.I8) "flan_map_has"
|
||
[ target; addr_of loc (mk loc kt (Tast.Local ks));
|
||
size_of loc kt; size_of loc vt; hash; eq; here loc ]
|
||
in
|
||
expect loc ~want
|
||
(mk loc Types.Bool
|
||
(Tast.Let ([ (ks, k) ],
|
||
[ mk loc Types.Bool
|
||
(Tast.Prim
|
||
(Tast.Ne,
|
||
[ found;
|
||
mk loc (Types.Int Types.I8)
|
||
(Tast.Int (0L, Types.I8)) ])) ])))
|
||
| _ -> assert false)
|
||
|
||
(* ── Assets, decision 1: embedded at compile time ──────────────
|
||
Odin's #load and #load_directory are the model (src/parser.cpp,
|
||
src/check_builtin.cpp's check_load_directive), and the reason it is the
|
||
right answer here is the one NEXT.md gives: it is a *compiler* feature, so
|
||
it needs no build flags, no linker arguments and no per-target packaging,
|
||
and it works identically on desktop and web. That matters more here than
|
||
it does for Odin, because [Load] gives link flags only to a directory
|
||
package — the single file doing (rl/load-texture "brush.png") is
|
||
structurally the one file with no link channel. Embedding has no such
|
||
hole.
|
||
|
||
Odin's `#` is not imported. An s-expression language already has a head
|
||
position for a name, so these are ordinary named calls spelled [embed] and
|
||
[embed-dir], resolved here exactly as [vec-new] and [heap-allocator] are.
|
||
|
||
The result costs nothing at run time: the bytes become a
|
||
`private unnamed_addr constant` string, the same one every string literal
|
||
already becomes, and emit.ml's [escape] is byte-exact, so a PNG survives
|
||
the round trip through the .ll. Bound with [defconst], an [embed-dir]
|
||
becomes an LLVM constant outright (emit.ml's [const]).
|
||
|
||
The one sharp edge, and it is not new: the slice this hands back points
|
||
into .rodata, so a store through it either segfaults at -O0 or is deleted
|
||
at -O2 — the same measured trap the prelude's ASCII-case note describes
|
||
for (bytes "Hi"). Clone the bytes into a Vec for a mutable copy. Nothing
|
||
here widens that hole; it inherits it, and provenance is what would close
|
||
it. *)
|
||
| "embed" ->
|
||
(match args with
|
||
| [ p ] | [ p; _ ] ->
|
||
(* The spelling is settled before the file is opened, so a program that
|
||
asks for a type embed cannot read a file as is told that, rather than
|
||
being told the file is missing and left to discover the other half
|
||
after fixing it. *)
|
||
(match args with
|
||
| [ _; { Ast.e = Ast.Var "string"; _ } ] | [ _ ] -> ()
|
||
| [ _; t ] ->
|
||
fail t.Ast.loc
|
||
"embed's second argument is the type to read the file as, and \
|
||
`string` is the only one — (embed \"p\") is the [u8]"
|
||
| _ -> ());
|
||
let data = read_embed_file (embed_path loc p) p.Ast.loc in
|
||
let as_string () = mk loc Types.String (Tast.Str data) in
|
||
(* A [Str] node typed [u8] rather than a [Bytes] prim over one. [Bytes]
|
||
is identity — emit.ml lowers String and Slice _ to the same %slice —
|
||
and the prim would make the node non-constant, so an (embed-dir) in a
|
||
defconst could not be an LLVM constant. Both of emit.ml's string
|
||
emitters take the bytes and ignore the node's type, so this is the
|
||
same constant either way, and it is one a global can hold. *)
|
||
let as_bytes () = mk loc (Types.Slice (Types.Int Types.U8)) (Tast.Str data) in
|
||
(* Two spellings rather than one that changes type with its context.
|
||
Odin threads a type_hint everywhere and can afford (embed "p") to
|
||
mean a string here and a []u8 there; with structural equality and no
|
||
implicit widening anywhere, the same text meaning two types would be
|
||
a wart. [want] is a fallback only, and nothing depends on it. *)
|
||
(match args with
|
||
| [ _; { Ast.e = Ast.Var "string"; _ } ] ->
|
||
expect loc ~want (as_string ())
|
||
| _ ->
|
||
(match want with
|
||
| Some Types.String -> as_string ()
|
||
| _ -> expect loc ~want (as_bytes ())))
|
||
| _ ->
|
||
fail loc
|
||
"embed is (embed \"path\") for a [u8], or (embed \"path\" string)")
|
||
| "embed-dir" ->
|
||
arity loc name 1 args;
|
||
let arg = List.hd args in
|
||
let entries = read_embed_dir (embed_path loc arg) arg.Ast.loc in
|
||
if not (Hashtbl.mem ctx.env.structs "EmbedFile") then
|
||
fail loc
|
||
"embed-dir answers a [n EmbedFile] and EmbedFile is not in scope — it \
|
||
is a prelude type and something has replaced the prelude";
|
||
let ety = Types.Named "EmbedFile" in
|
||
let elems =
|
||
List.map
|
||
(fun (nm, data) ->
|
||
mk loc ety
|
||
(Tast.Make
|
||
("EmbedFile",
|
||
[ mk loc Types.String (Tast.Str nm);
|
||
mk loc (Types.Slice (Types.Int Types.U8)) (Tast.Str data) ])))
|
||
entries
|
||
in
|
||
expect loc ~want
|
||
(mk loc (Types.Array (Int64.of_int (List.length entries), ety))
|
||
(Tast.Arr elems))
|
||
|
||
(* ── slurp and barf, decisions 2 and 5 ─────────────────────────
|
||
[slurp] reads a whole file and answers a (Vec u8). It allocates, which is
|
||
why it waited for Vec, and it follows spec-memory.md's rule to the letter:
|
||
no allocating operation returns an error, so there is no Result here and
|
||
no out-parameter — a failure to allocate is StorageExhausted under [retry]
|
||
and a failure to read is FileError under [retry] and [use-value].
|
||
|
||
The two guards nest rather than merge, and that is the point: they are two
|
||
different failures with two different answerable questions, and a handler
|
||
that grows an arena is not the handler that supplies another path.
|
||
|
||
Everything is inside the file loop, so a [use-value] that names a
|
||
different file re-measures it and re-allocates for its size. The Vec is
|
||
freed at the top of each turn, which is why a retry does not leak; freeing
|
||
a Vec that never allocated is a no-op (flan_rt.c, flan_vec_free). *)
|
||
| "slurp" ->
|
||
(match args with
|
||
| path :: rest when List.length rest <= 1 ->
|
||
let path = check ctx ~want:Types.String path in
|
||
let a = allocator_arg ctx loc rest in
|
||
let ps = fresh_slot ctx Types.String in
|
||
let psv () = mk loc Types.String (Tast.Local ps) in
|
||
let u8 = Types.Int Types.U8 in
|
||
let vt = Types.Vec u8 in
|
||
let v = fresh_slot ctx vt in
|
||
let vv () = mk loc vt (Tast.Local v) in
|
||
let n = fresh_slot ctx (Types.Int Types.I64) in
|
||
let nv () = mk loc (Types.Int Types.I64) (Tast.Local n) in
|
||
let steps try_ =
|
||
[ (* The size first, because it is the step that does not allocate:
|
||
a missing file is found before any storage is committed to it. *)
|
||
try_ (rt loc (Types.Int Types.I8) "flan_file_size"
|
||
[ psv (); addr_of loc (nv ()) ]);
|
||
(* Previous turn's storage, if a retry brought us back here. *)
|
||
rt loc Types.Unit "flan_vec_free"
|
||
[ vv (); size_of loc u8; align_of loc u8; here loc ];
|
||
with_note loc
|
||
(alloc_guard ctx loc
|
||
(rt loc (Types.Int Types.I8) "flan_vec_init"
|
||
[ vv (); a; nv (); size_of loc u8; align_of loc u8;
|
||
here loc ]))
|
||
(reg_note loc "flan_dev_reg_note_vec" (vv ())
|
||
[ size_of loc u8 ] u8);
|
||
(* Fills the Vec the line above sized. A file that grew since the
|
||
measurement is truncated to the buffer; one that shrank leaves a
|
||
shorter Vec. Both are successful reads of what was there. *)
|
||
try_ (rt loc (Types.Int Types.I8) "flan_slurp_into"
|
||
[ vv (); psv (); size_of loc u8; here loc ]) ]
|
||
in
|
||
expect loc ~want
|
||
(mk loc vt
|
||
(Tast.Let
|
||
([ (ps, path);
|
||
(n, i64_at loc 0L);
|
||
(v, mk loc vt (Tast.Zero vt)) ],
|
||
[ file_guard ctx loc ~path_slot:ps ~op:0 steps; vv () ])))
|
||
| _ -> fail loc "slurp is (slurp path) or (slurp path allocator)")
|
||
(* [barf] writes a whole file, and on the web target it signals — every time,
|
||
with the path in the condition. Decision 2, and the reason is worth having
|
||
at the call site: Flan has NO conditional compilation, so "isolate this to
|
||
desktop" is not expressible in source and a build-time refusal would be
|
||
unusable; a silent no-op is worse than either, because that is how a save
|
||
file disappears with nothing said. So the program gets a condition and
|
||
decides. Nothing here reads the target — the refusal is flan_rt.c's, one
|
||
#ifdef in the host layer, which is exactly where the two targets are
|
||
already implemented twice. *)
|
||
| "barf" ->
|
||
arity loc name 2 args;
|
||
(match args with
|
||
| [ path; data ] ->
|
||
let path = check ctx ~want:Types.String path in
|
||
let data = byte_slice ctx data in
|
||
let ps = fresh_slot ctx Types.String in
|
||
let ds = fresh_slot ctx (Types.Slice (Types.Int Types.U8)) in
|
||
let steps try_ =
|
||
[ try_ (rt loc (Types.Int Types.I8) "flan_file_write"
|
||
[ mk loc Types.String (Tast.Local ps);
|
||
mk loc (Types.Slice (Types.Int Types.U8)) (Tast.Local ds) ]) ]
|
||
in
|
||
(* Both operands are bound before the loop so that a retry re-attempts
|
||
the write and not the expressions that produced it — the same rule
|
||
alloc_guard states for push. *)
|
||
expect loc ~want
|
||
(mk loc Types.Unit
|
||
(Tast.Let ([ (ps, path); (ds, data) ],
|
||
[ file_guard ctx loc ~path_slot:ps ~op:1 steps ])))
|
||
| _ -> assert false)
|
||
|
||
(* ── the three that change the filesystem ──────────────────────────
|
||
[delete-file], [rename-file] and [make-directory] are [barf]'s shape with
|
||
a different runtime call, and they are here rather than as prelude
|
||
[declare]s for the one thing a declare cannot do: signal [FileError] with
|
||
the two restarts the compiler emits. A declare could only answer a bool,
|
||
and "the delete failed, here is a boolean" is the shape decision 5 exists
|
||
to keep out of this language — a handler that made the parent directory
|
||
and wants [retry], or that has another path and wants [use-value], has
|
||
nothing to hold onto.
|
||
|
||
Each answers [()] and not a bool for the same reason [barf] does: the
|
||
failure is the condition, so a return value would only ever be true. The
|
||
questions that are *not* failures — does this exist, how big is it —
|
||
answer a value instead, and those two are prelude functions over one
|
||
[declare] because nothing about them needs a restart.
|
||
|
||
[op] continues the FileError numbering the prelude names: 0 read, 1 write,
|
||
and 2, 3, 4 here. A handler matching on it is matching on the prelude's
|
||
[file-op-delete] and friends, not on a literal. *)
|
||
| "delete-file" | "make-directory" ->
|
||
arity loc name 1 args;
|
||
let sym, op =
|
||
if String.equal name "delete-file" then "flan_file_delete", 2
|
||
else "flan_file_mkdir", 4
|
||
in
|
||
let path = check ctx ~want:Types.String (List.hd args) in
|
||
let ps = fresh_slot ctx Types.String in
|
||
let steps try_ =
|
||
[ try_ (rt loc (Types.Int Types.I8) sym
|
||
[ mk loc Types.String (Tast.Local ps) ]) ]
|
||
in
|
||
expect loc ~want
|
||
(mk loc Types.Unit
|
||
(Tast.Let ([ (ps, path) ],
|
||
[ file_guard ctx loc ~path_slot:ps ~op steps ])))
|
||
|
||
(* Two paths and one restart slot, so the guard holds the *source*: a
|
||
[use-value] renames a different file to the same destination. That is the
|
||
direction a handler can act on — the destination it asked for is the one
|
||
thing it already knows — and it is written down here because the other
|
||
reading is equally plausible until somebody says which it is.
|
||
|
||
The destination is bound before the loop, exactly as [barf] binds its
|
||
data, so a retry re-attempts the rename and not the expression that
|
||
computed where to. *)
|
||
| "rename-file" ->
|
||
arity loc name 2 args;
|
||
(match args with
|
||
| [ from_; to_ ] ->
|
||
let from_ = check ctx ~want:Types.String from_ in
|
||
let to_ = check ctx ~want:Types.String to_ in
|
||
let ps = fresh_slot ctx Types.String in
|
||
let ds = fresh_slot ctx Types.String in
|
||
let steps try_ =
|
||
[ try_ (rt loc (Types.Int Types.I8) "flan_file_rename"
|
||
[ mk loc Types.String (Tast.Local ps);
|
||
mk loc Types.String (Tast.Local ds) ]) ]
|
||
in
|
||
expect loc ~want
|
||
(mk loc Types.Unit
|
||
(Tast.Let ([ (ps, from_); (ds, to_) ],
|
||
[ file_guard ctx loc ~path_slot:ps ~op:3 steps ])))
|
||
| _ -> assert false)
|
||
|
||
(* ── containers ────────────────────────────────────────────────── *)
|
||
(* [at] and [len] were already the names for a fixed array and a slice, so a
|
||
Vec extends them rather than adding a parallel pair — which is the
|
||
asymmetry [nth] was removed for. A Vec's length is i32 like every other
|
||
length here (index_ty): widening indices is one change across all of them
|
||
and not a Vec question. *)
|
||
| "len" ->
|
||
arity loc name 1 args;
|
||
let target = List.hd args in
|
||
let a = check ctx target in
|
||
(match a.Tast.ty with
|
||
| Types.Array _ | Types.Slice _ | Types.String ->
|
||
prim Tast.Len index_ty [ a ]
|
||
| Types.Vec _ ->
|
||
let n = rt loc (Types.Int Types.I64) "flan_vec_len" [ a; here loc ] in
|
||
expect loc ~want (mk loc index_ty (Tast.Prim (Tast.Cast index_ty, [ n ])))
|
||
(* Extended rather than given a name of its own, for the reason [at] and
|
||
[len] were extended over Vec: one question, one word. *)
|
||
| Types.Map _ ->
|
||
let n = rt loc (Types.Int Types.I64) "flan_map_len" [ a; here loc ] in
|
||
expect loc ~want (mk loc index_ty (Tast.Prim (Tast.Cast index_ty, [ n ])))
|
||
| other ->
|
||
fail loc
|
||
"len takes an array, a slice, a string, a Vec or a Map, found %s"
|
||
(Types.to_string other))
|
||
| "at" ->
|
||
(match args with
|
||
| target :: idx when idx <> [] ->
|
||
let target = check ctx target in
|
||
(match target.Tast.ty with
|
||
| Types.Vec _ ->
|
||
let p, elem = vec_at ctx loc target idx in
|
||
expect loc ~want (mk loc elem (Tast.Deref p))
|
||
| _ ->
|
||
let idx, ty = indexed ctx target idx in
|
||
prim Tast.At ty (target :: idx))
|
||
| _ -> fail loc "%s is (%s collection index ...)" name name)
|
||
| "slice" ->
|
||
arity loc name 3 args;
|
||
(match args with
|
||
| [ target; lo; hi ] ->
|
||
let target = check ctx target in
|
||
let elem = match target.Tast.ty with
|
||
| Types.Array (_, t) | Types.Slice t -> t
|
||
| other -> fail loc "slice takes an array or a slice, found %s"
|
||
(Types.to_string other)
|
||
in
|
||
prim Tast.Slice (Types.Slice elem)
|
||
(let lo_loc = lo.Ast.loc and hi_loc = hi.Ast.loc in
|
||
let lo = check ctx ~want:index_ty lo in
|
||
let hi = check ctx ~want:index_ty hi in
|
||
let ty = target.Tast.ty in
|
||
(* A bound may sit one past the end, so the length is checked against
|
||
lo and hi both, not against the last valid index. *)
|
||
(match literal lo with
|
||
| Some k -> static_index lo_loc ty ~past_end:true "slice bound" k
|
||
| None -> ());
|
||
(match literal hi with
|
||
| Some k -> static_index hi_loc ty ~past_end:true "slice bound" k
|
||
| None -> ());
|
||
(match literal lo, literal hi with
|
||
| Some a, Some b when a > b ->
|
||
fail loc "slice [%Ld %Ld) runs backwards — lo must not exceed hi" a b
|
||
| _ -> ());
|
||
[ target; lo; hi ])
|
||
| _ -> assert false)
|
||
|
||
(* (slice-from-ptr p n) — NEXT.md, "a pointer from C needs a length before
|
||
it can be indexed". A (Ptr T) that came back from C is readable at
|
||
element 0 through [deref] and nowhere else, because [indexed] takes an
|
||
Array or a Slice and a pointer is neither. C hands back an address and no
|
||
length, so the length has to come from the caller, and this is the form
|
||
that says so out loud.
|
||
|
||
**What the caller is promising**, and the compiler checks none of it: that
|
||
[p] really addresses [n] consecutive [T], that they are initialised, and
|
||
that they outlive every use of the result. Get it wrong and this reads
|
||
memory that is not there — the bounds check the result carries will agree
|
||
with a length that was a lie, because the length *is* the lie. It is the
|
||
same trust [declare-c] already extends, written at the one site where
|
||
somebody had to know the answer anyway.
|
||
|
||
No marker on the name. A [!] in this language means *mutates*
|
||
([map-next!]) and a [?] means *asks* ([font-valid?]), and this does
|
||
neither; [zeroed], the nearest neighbour — a value conjured rather than
|
||
derived — carries no marker either. [ptr] is the marker: a (Ptr T) only
|
||
ever arrives from a [declare-c], so the word already names the C boundary,
|
||
and a reader who sees it has already been told where the promise comes
|
||
from.
|
||
|
||
**It owns nothing.** The result is a [Types.Slice], which carries no
|
||
allocator and is the same non-owning view (as-slice v) answers — so
|
||
[free] refuses it by the rule it already had ("free takes an owning
|
||
container"). *)
|
||
| "slice-from-ptr" ->
|
||
arity loc name 2 args;
|
||
(match args with
|
||
| [ target; n ] ->
|
||
let target = check ctx target in
|
||
let elem =
|
||
match target.Tast.ty with
|
||
| Types.Ptr t -> t
|
||
| other ->
|
||
fail loc
|
||
"slice-from-ptr takes a (Ptr T) and the number of elements behind \
|
||
it, found %s. It is for a pointer that came back from C, whose \
|
||
length only the caller knows"
|
||
(Types.to_string other)
|
||
in
|
||
let n_loc = n.Ast.loc in
|
||
let n = check ctx ~want:index_ty n in
|
||
(* A negative literal is a lie the checker can see, so it does not wait
|
||
for the run-time test emit.ml plants beside it. *)
|
||
(match literal n with
|
||
| Some k when k < 0L ->
|
||
fail n_loc
|
||
"slice-from-ptr length %Ld is negative — the length is what the \
|
||
caller promises the pointer addresses, and no pointer addresses \
|
||
fewer than zero elements" k
|
||
| _ -> ());
|
||
prim Tast.SliceFromPtr (Types.Slice elem) [ target; n ]
|
||
| _ -> assert false)
|
||
|
||
(* ── pointers ──────────────────────────────────────────────────── *)
|
||
| "addr" ->
|
||
arity loc name 1 args;
|
||
let a = List.hd args in
|
||
(match place_of_expr a with
|
||
| None ->
|
||
fail a.Ast.loc
|
||
"addr takes the address of a place — a name, (.field x), (at a i) \
|
||
or (deref p)"
|
||
| Some p ->
|
||
let p, ty = check_place ctx a.Ast.loc p in
|
||
expect loc ~want (mk loc (Types.Ptr ty) (Tast.Addr p)))
|
||
| "deref" ->
|
||
arity loc name 1 args;
|
||
let a = check ctx (List.hd args) in
|
||
(match a.Tast.ty with
|
||
| Types.Ptr t -> expect loc ~want (mk loc t (Tast.Deref a))
|
||
| other -> fail loc "deref takes a (Ptr T), found %s"
|
||
(Types.to_string other))
|
||
|
||
(* ── Option ────────────────────────────────────────────────────── *)
|
||
| "Some" ->
|
||
arity loc name 1 args;
|
||
let inner = match want with Some (Types.Option t) -> Some t | _ -> None in
|
||
let a = check ctx ?want:inner (List.hd args) in
|
||
expect loc ~want (mk loc (Types.Option a.Tast.ty) (Tast.Some_ a))
|
||
|
||
(* ── the milestone-2 host primitives (plan.org) ────────────────── *)
|
||
| "bytes" ->
|
||
arity loc name 1 args;
|
||
prim Tast.Bytes (Types.Slice (Types.Int Types.U8))
|
||
[ check ctx ~want:Types.String (List.hd args) ]
|
||
|
||
(* (string b): a [u8] seen as a string. The mirror of (bytes s), spelled the
|
||
same way — a type name in head position, like (bytes s) and unlike the
|
||
numeric casts, which go through [is_cast] and really do convert.
|
||
|
||
It costs nothing. emit.ml lowers Types.String and Types.Slice _ to the
|
||
same %slice, 16 bytes at align 8, so a string and a [u8] are already the
|
||
identical value at run time; both this and [Bytes] emit as the argument
|
||
itself. What changes is only what the checker will let the value be
|
||
passed to — which is the whole gap: i64->bytes answers a [u8] and every
|
||
declare-c text parameter wants a string, and nothing joined them.
|
||
|
||
Two decisions are baked in here.
|
||
|
||
1. It does NOT check UTF-8, because `string` does not claim UTF-8. The
|
||
prelude settles this: valid-utf8? is an ordinary function you call when
|
||
you care, decode-rune/rune-at/rune-count all take [u8] rather than
|
||
string, and decode-rune answers {.ok false .width 1} on a malformed
|
||
byte rather than assuming its input is well-formed. The one place the
|
||
runtime treats a string differently from a byte slice is
|
||
flan_escape_bytes, for a string nested in a printed structure, and that
|
||
is a byte-wise escape table with no decoding in it. So there is no code
|
||
that would be wrong about a string of arbitrary bytes, and a check here
|
||
would be the only enforcement point in the language — a claim the rest
|
||
of it does not make.
|
||
|
||
2. It does not widen the literal-write hole (NEXT.md, "Writing through a
|
||
string literal"). That hole is the other direction: (bytes "Hi") hands
|
||
you a writable-looking slice over constant data. This direction only
|
||
loses the ability to write — a string is read-only everywhere — so the
|
||
result of (string b) can reach strictly fewer stores than b could.
|
||
Provenance is still what the other direction needs; nothing here
|
||
depends on having it.
|
||
|
||
The sharp edge left here is one of lifetime and no longer one of sharing:
|
||
the slice that i64->bytes / f64->bytes / u64->bytes answer is a view into
|
||
a frame slot belonging to *that call site* (see [to_bytes]), so two of
|
||
them can be held at once and the text of one survives the making of the
|
||
next. What it does not survive is its frame — calling it a string does not
|
||
copy it, so storing one in a container or returning it hands back a view
|
||
of storage that has been reused. Copy the bytes for that. *)
|
||
| "string" ->
|
||
arity loc name 1 args;
|
||
prim Tast.StrOfBytes Types.String [ byte_slice ctx (List.hd args) ]
|
||
| "bytes->f64" ->
|
||
arity loc name 1 args;
|
||
prim Tast.BytesToF64 (Types.Float Types.F64) [ byte_slice ctx (List.hd args) ]
|
||
| "bytes->i64" ->
|
||
arity loc name 1 args;
|
||
prim Tast.BytesToI64 (Types.Int Types.I64) [ byte_slice ctx (List.hd args) ]
|
||
| "f64->bytes" ->
|
||
arity loc name 1 args;
|
||
expect loc ~want
|
||
(to_bytes ctx loc Tast.F64ToBytes
|
||
(check ctx ~want:(Types.Float Types.F64) (List.hd args)))
|
||
| "i64->bytes" ->
|
||
arity loc name 1 args;
|
||
expect loc ~want
|
||
(to_bytes ctx loc Tast.I64ToBytes
|
||
(check ctx ~want:(Types.Int Types.I64) (List.hd args)))
|
||
| "write-stdout" ->
|
||
arity loc name 1 args;
|
||
prim Tast.WriteStdout Types.Unit [ byte_slice ctx (List.hd args) ]
|
||
|
||
(* (println x) and (print x): the structural printer, selected on the type
|
||
the argument checked to. plan.org, Milestone 5 — "compiler-provided,
|
||
per concrete type". That is not overloading and needs no type variables:
|
||
there is no dispatch at run time and no user-supplied printer to pick
|
||
between. The walk itself is render.ml, shared with the REPL, which is what
|
||
stops the two from drifting apart.
|
||
|
||
[min]/[max]/[zeroed] above dispatch on the resolved argument type the same
|
||
way. The slots the slice arm needs come out of the frame of whatever
|
||
function this call is written in, via [fresh_slot] — allocated once per
|
||
call site, at check time, not once per iteration of a loop around it.
|
||
|
||
A string prints raw here and quoted inside a structure. Those are not in
|
||
conflict: (println "hello") has to print hello or it is useless, and
|
||
(println b) where b has a string field has to quote it or the field
|
||
cannot be told from the punctuation. The split is exactly top level vs
|
||
nested, which is why it lives here and not in the walk. *)
|
||
| "print" | "println" ->
|
||
arity loc name 1 args;
|
||
(* Printing is a read, not a move: the walk goes over the value and keeps
|
||
nothing. Without this, (println v) would consume a Vec and every
|
||
printing of one would be its last. *)
|
||
let target = List.hd args in
|
||
let a = check ctx target in
|
||
(* ── The allow-list, and what it takes to get on it ───────────────
|
||
plan.org names [println] as the one compiler-provided exception — it
|
||
"selects a structural printer at each concrete instantiation" — and
|
||
that cannot be reconciled with an abstract pass as written: a pass that
|
||
decides an operator's legality *without* substituting cannot make an
|
||
exception for the one operator whose legality is only decidable after
|
||
substituting. So the exception is made explicit: these two forms are
|
||
*deferred* to instantiation, and every other operator is answered where
|
||
it is written.
|
||
|
||
Every member of this list is a place where a refusal moves from the
|
||
definition to a call site, which is the thing the abstract pass exists
|
||
to prevent. **That cost is not the same for every member, and the list
|
||
is not closed.** What makes it bearable is whether the call site has a
|
||
*stated requirement* to be refused against.
|
||
|
||
[print] and [println] have none and need none: every type prints, so
|
||
there is no [where] predicate for printability — one would always hold
|
||
and would be noise on a signature — and there is correspondingly no
|
||
call site these can be refused at. They are deferred and then always
|
||
succeed. That is the cheapest possible membership.
|
||
|
||
The map operations — [put], [get], [has-key?], [map-remove!], [reserve], [clone],
|
||
through [deferred_key] beside [key_fns] — are the other kind, and they
|
||
are here on a different argument. They *can* fail at a concrete type,
|
||
so deferring them does move a refusal. But [{:where (hashable? $t)}] is
|
||
in the signature, and it is the author's own written requirement: an
|
||
instantiation at a non-hashable type is refused against that clause, by
|
||
name, at the call that asked for the type. That is a refusal the caller
|
||
can act on and one the generic's author chose to be responsible for —
|
||
categorically different from an unconstrained [(+ a b)] failing deep in
|
||
a body with no signature to blame, which is the case the abstract pass
|
||
exists to prevent and which stays refused at the definition. A generic
|
||
that does *not* declare the predicate gets no deferral: [deferred_key]
|
||
checks first, and [map_type] has usually refused the signature already.
|
||
|
||
So the rule for adding to this list is not a headcount. It is: either
|
||
the operation cannot fail after substituting, or a declared predicate
|
||
gives its failure a place to land. Anything else is answered here.
|
||
|
||
The node produced here is a unit no-op, thrown away with the rest of
|
||
the abstract pass. The real printer is selected when the copy is
|
||
checked with [t] concrete. *)
|
||
if generic_ty a.Tast.ty then
|
||
mk loc Types.Unit Tast.Unit
|
||
else
|
||
let bslice = Types.Slice (Types.Int Types.U8) in
|
||
let write x = mk loc Types.Unit (Tast.Prim (Tast.WriteStdout, [ x ])) in
|
||
(* One frame slot per conversion the printer emits, which is what
|
||
[to_bytes] is for. The printer writes each number out before making the
|
||
next, so a shared buffer would in fact have served it — but the slot is
|
||
what the node now carries, and a printer that assembled its own buffer
|
||
would be a second answer to the same question. [escape] is the one that
|
||
still renders into a static: it is reachable from nowhere but here, and
|
||
its 1KB buffer per printed string field is a frame cost with no bug
|
||
behind it. Said here so the asymmetry is a decision and not an
|
||
oversight. *)
|
||
let conv pr x = to_bytes ctx loc pr x in
|
||
let emitter : Render.emitter =
|
||
{ Render.ebytes = write;
|
||
estr = (fun x -> write (mk loc bslice
|
||
(Tast.Prim (Tast.EscapeBytes, [ x ]))));
|
||
ei64 = (fun x -> write (conv Tast.I64ToBytes x));
|
||
eu64 = (fun x -> write (conv Tast.U64ToBytes x));
|
||
ef64 = (fun x -> write (conv Tast.F64ToBytes x)) }
|
||
in
|
||
let rc =
|
||
{ Render.structs =
|
||
Hashtbl.fold (fun _ v acc -> v :: acc) ctx.env.structs [];
|
||
datas = Hashtbl.fold (fun _ v acc -> v :: acc) ctx.env.datas [];
|
||
unions = Hashtbl.fold (fun _ v acc -> v :: acc) ctx.env.unions [];
|
||
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) ctx.env.enums [];
|
||
emit = emitter;
|
||
(* [println] never follows a pointer, and the allocation registry does
|
||
not change that. spec-memory.md fixes what it prints — "Ptr and
|
||
Handle print their address or identity rather than recursively
|
||
dereferencing" — and a printed line belongs to the program, so it
|
||
must read the same in a release build, where there is no registry to
|
||
ask. Following one is the *inspector's* move, and session.ml is
|
||
where that context is built. *)
|
||
ptrs = None;
|
||
alloc = (fun ty -> fresh_slot ctx ty) }
|
||
in
|
||
let parts =
|
||
match a.Tast.ty with
|
||
| Types.String | Types.Slice (Types.Int Types.U8) ->
|
||
[ write (mk loc bslice (Tast.Prim (Tast.Bytes, [ a ]))) ]
|
||
| _ -> Render.render rc 0 a
|
||
in
|
||
let nl =
|
||
if String.equal name "println" then
|
||
[ write
|
||
(mk loc bslice
|
||
(Tast.Prim (Tast.Bytes, [ mk loc Types.String (Tast.Str "\n") ])))
|
||
]
|
||
else []
|
||
in
|
||
expect loc ~want (mk loc Types.Unit (Tast.Do (parts @ nl)))
|
||
| "exit" ->
|
||
arity loc name 1 args;
|
||
prim Tast.Exit Types.Never [ check ctx ~want:index_ty (List.hd args) ]
|
||
| "argv" ->
|
||
arity loc name 0 args;
|
||
prim Tast.Argv (Types.Slice Types.String) []
|
||
|
||
(* ── casts: (i32 x), (f64 x), and an enum both ways ────────────────
|
||
|
||
(i32 e) and (GamepadAxis n) are written here rather than in an arm of
|
||
their own because they are the same operation: an enum is an i32 at run
|
||
time — Types.Enum says so — and emit.ml's [cast] already reduces one to
|
||
its i32 before choosing an instruction. So both directions cost nothing:
|
||
src and target are equal after that reduction and [cast] answers the
|
||
value unchanged.
|
||
|
||
Why this does not give the typo back. The property worth keeping is that
|
||
:spcae at a call site is an error at that site, and it still is: a
|
||
keyword resolves against the parameter's enum and a bare integer does not
|
||
fit one. What changes is only that a program can *say* it means the
|
||
conversion, by name, at the site. The rule was never "an integer is
|
||
dangerous", it was "an integer must not arrive silently", and a written
|
||
(GamepadAxis i) is not silent.
|
||
|
||
Three sub-decisions:
|
||
|
||
1. enum → any numeric is always allowed and never checked. It is lossless
|
||
to i32 by construction, and a narrower target truncates by the same
|
||
rule every int→int cast already follows — no special case, and (f32 e)
|
||
means (f32 (i32 e)) rather than an arbitrary refusal.
|
||
|
||
2. integer → enum accepts a value that is not a declared member. raylib's
|
||
gesture is a bitfield and an OR of flags is a legal Gesture that is no
|
||
single member, so refusing it would refuse correct programs; and
|
||
session.ml's printer already falls through to the number for an
|
||
out-of-range enum, on purpose, so refusing to *construct* one while
|
||
blessing its display would be incoherent. An Option would make every
|
||
site unwrap for no safety bought, and a literal-only refusal would
|
||
catch nothing — the bitfield case is a run-time value.
|
||
|
||
3. Only an integer converts *to* an enum. Not a float, which has no
|
||
meaning here, and not another enum: an enum-to-enum hop goes through
|
||
(i32 x) so that both ends are written down. *)
|
||
| _ when Hashtbl.mem ctx.env.enums name ->
|
||
arity loc name 1 args;
|
||
let target = resolve_name ctx.env ~seen:[] loc name in
|
||
let a = check ctx (List.hd args) in
|
||
(match a.Tast.ty with
|
||
| Types.Int _ -> ()
|
||
| other ->
|
||
fail loc "%s converts an integer to an enum, found %s — an enum or a \
|
||
float goes through (i32 x) first" name
|
||
(Types.to_string other));
|
||
prim (Tast.Cast target) target [ a ]
|
||
(* A cast to a *type variable*: [(t x)] inside a generic body. The name is
|
||
not one [is_cast] knows, because [is_cast] asks whether the name is a
|
||
machine type and [t] is not — so this is its own arm, above the ordinary
|
||
one and below the enums, and it reaches the same [Cast] prim.
|
||
|
||
Inside an instantiation [resolve_name] has already answered with the
|
||
concrete target, so the copy casts to a real type and the emitter sees
|
||
nothing unusual. During the abstract pass the target is [Var t] and the
|
||
[where] clause is what says the cast means anything at all: a cast
|
||
produces a number, so [numeric?] is what admits it. *)
|
||
| _ when (List.mem name ctx.env.tyvars || List.mem_assoc name ctx.env.subst)
|
||
&& List.length args = 1 ->
|
||
let target = resolve_name ctx.env ~seen:[] loc name in
|
||
unconstrained ctx.env loc ("a cast to " ^ name) ~needs:"numeric?" target;
|
||
let a = check ctx (List.hd args) in
|
||
(match a.Tast.ty with
|
||
| Types.Enum _ -> ()
|
||
| t when Types.is_numeric t || generic_ty t -> ()
|
||
| t -> fail loc "%s converts a number, found %s" name (Types.to_string t));
|
||
prim (Tast.Cast target) target [ a ]
|
||
| _ when is_cast name && List.length args = 1 ->
|
||
let target = resolve_name ctx.env ~seen:[] loc name in
|
||
let a = check ctx (List.hd args) in
|
||
(match a.Tast.ty with
|
||
| Types.Enum _ -> ()
|
||
| t when Types.is_numeric t -> ()
|
||
| t -> fail loc "%s converts a number, found %s" name (Types.to_string t));
|
||
prim (Tast.Cast target) target [ a ]
|
||
|
||
(* ── ordinary calls ────────────────────────────────────────────── *)
|
||
(* A local or a parameter holding a function value, called by the name it is
|
||
bound to — which is what the body of [map] looks like. It is checked
|
||
before the global function table and after every builtin: a binding
|
||
shadows a defn of the same name (one namespace, ordinary lexical
|
||
scoping), and nothing shadows [+]. A local of any *other* type falls
|
||
through to the table, so a program that shadows a function name with an
|
||
i32 and then calls the function still means the function. *)
|
||
| _ when (match lookup ctx name with
|
||
| Some b -> (match b.bty with Types.Fn _ -> true | _ -> false)
|
||
| None -> false) ->
|
||
(* The binding the guard already found, read directly. Going back through
|
||
[check] would repeat the lookup and walk the capture path for a type
|
||
that is not capturable. *)
|
||
(match lookup ctx name with
|
||
| Some b -> call_value ctx ~want loc (mk loc b.bty (Tast.Local b.slot)) args
|
||
| None -> assert false)
|
||
| _ when Hashtbl.mem ctx.env.gsigs name ->
|
||
let vars, params, ret = Hashtbl.find ctx.env.gsigs name in
|
||
generic_call ctx ~want loc name vars params ret args
|
||
| _ ->
|
||
match Hashtbl.find_opt ctx.env.fns name with
|
||
| Some (params, ret) ->
|
||
if List.length args <> List.length params then
|
||
fail loc "%s takes %d argument%s, given %d" name
|
||
(List.length params)
|
||
(if List.length params = 1 then "" else "s")
|
||
(List.length args);
|
||
let args = map2_lr (fun p a -> check ctx ~want:p a) params args in
|
||
expect loc ~want (mk loc ret (Tast.Call (name, args)))
|
||
| None ->
|
||
if Hashtbl.mem ctx.env.datas name then
|
||
fail loc
|
||
"%s is a data type — a data type value names the case too, as (%s.%s {.field value ...})"
|
||
name name (first_case_name ctx.env name)
|
||
else if Hashtbl.mem ctx.env.cases name then
|
||
(* [(U.C)] and [(C)]: a case written as a call. Both are how someone
|
||
reaches for a constructor, and neither is one. *)
|
||
let dname, c = Hashtbl.find ctx.env.cases name in
|
||
fail loc
|
||
"%s is a case of the data type %s — write (%s.%s {.field value ...}), \
|
||
or %s.%s on its own when it has no fields"
|
||
name dname dname c.Tast.vname dname c.Tast.vname
|
||
else if Hashtbl.mem ctx.env.structs name then
|
||
fail loc
|
||
"%s is a type — a struct value is written (%s {.field value ...})"
|
||
name name
|
||
else if String.contains name '/' then
|
||
unimplemented loc
|
||
(Printf.sprintf "the call %s into an imported package" name) 4
|
||
else Loc.failk "check/unknown-function" loc "unknown function %s" name
|
||
|
||
(* ── A call to a generic function ───────────────────────────────────────
|
||
The whole of instantiation, and it is at the call site because the call
|
||
site is the only place the concrete types exist. Odin does the same thing
|
||
in the same place: [check_expr.cpp]'s
|
||
[find_or_generate_polymorphic_procedure] runs from call checking, builds
|
||
the concrete proc type from the operands, scans the base entity's
|
||
[gen_procs] for an [are_types_identical] match, and generates a new
|
||
[Entity] only on a miss. *)
|
||
and generic_call ctx ~want loc name vars pats pret args =
|
||
if List.length args <> List.length pats then
|
||
fail loc "%s takes %d argument%s, given %d" name (List.length pats)
|
||
(if List.length pats = 1 then "" else "s") (List.length args);
|
||
(* Arguments first, and with no expectation where the parameter's type still
|
||
mentions a variable — there is nothing to expect until the argument has
|
||
said what it is. So an untyped literal falls to its own default and
|
||
[(id 3)] instantiates at i32, which is the one place inference at a
|
||
generic call site is weaker than at a monomorphic one.
|
||
|
||
A variable already bound by an earlier argument is substituted back into
|
||
the parameters still to come, so [(sort-by! (slice ns 0 4) (fn [a b] (< a
|
||
b)))] works: by the time the [fn] is reached, [(Fn [$t $t] bool)] has
|
||
become [(Fn [i32 i32] bool)] and the literal has the position it needs to
|
||
take its types from. Left to right, which is the order Odin's operands
|
||
are gathered in and the order [map2_lr] already guarantees. *)
|
||
let subst = ref [] in
|
||
let targs =
|
||
map2_lr
|
||
(fun p a ->
|
||
let p = subst_ty !subst p in
|
||
let a = if generic_ty p then check ctx a else check ctx ~want:p a in
|
||
if not (bind_ty subst p a.Tast.ty) then
|
||
fail a.Tast.loc "%s expects %s here, found %s" name
|
||
(Types.to_string p) (Types.to_string a.Tast.ty);
|
||
a)
|
||
pats args
|
||
in
|
||
(* Every variable has to be determined by an argument. A return-only
|
||
variable has nothing to bind it — there is no explicit instantiation
|
||
syntax by design (plan.org) — so it is refused here, where the signature
|
||
can be named, rather than producing a copy with a hole in it. *)
|
||
List.iter
|
||
(fun v ->
|
||
if not (List.mem_assoc v !subst) then
|
||
fail loc
|
||
"%s's type variable $%s is not determined by any argument — a \
|
||
generic function is instantiated from its call site, and there is \
|
||
no syntax for naming the type" name v)
|
||
vars;
|
||
let cparams = List.map (subst_ty !subst) pats in
|
||
let cret = subst_ty !subst pret in
|
||
if List.exists generic_ty cparams || generic_ty cret then begin
|
||
(* One generic function calling another at its *own* variable, seen from
|
||
the abstract pass over the caller's body — [sort-by!] calling [swap!]
|
||
at [t]. There is no copy to make yet: [t] is not a type. The node is
|
||
built so the call still type-checks and is thrown away with the rest of
|
||
the abstract pass; the real copy is generated when the caller is
|
||
instantiated and the same call site resolves [t] to a concrete type.
|
||
|
||
But the callee's [where] clause is answerable here, and has to be. The
|
||
whole promise of the abstract pass is that a generic's refusals arrive
|
||
at its definition; if the predicate were left to the instantiation,
|
||
[(defn f [x $t] () (sort! [x]))] would be accepted at its definition
|
||
and refused at whichever call site first instantiated it — a refusal in
|
||
code the caller did not write, which is the thing the pass exists to
|
||
avoid. So the caller has to declare at least what the callee asks for,
|
||
and [pred_entails] means [ordered?] covers a callee wanting
|
||
[equal?] without anyone writing both. *)
|
||
(match Hashtbl.find_opt ctx.env.generics name with
|
||
| None -> ()
|
||
| Some gfn ->
|
||
List.iter
|
||
(fun (p : Ast.pred) ->
|
||
match List.assoc_opt p.Ast.pvar !subst with
|
||
| Some (Types.Var v) when not (declares ctx.env.tvpreds v p.Ast.pname) ->
|
||
Loc.failk "check/predicate-not-carried" loc
|
||
"%s is written {:where (%s $%s)}, and this call passes the \
|
||
type variable %s, which nothing here declares %s. Add \
|
||
{:where (%s $%s)} to this function's own clause — a \
|
||
predicate a body relies on has to be carried by every \
|
||
signature between it and the call site"
|
||
name p.Ast.pname p.Ast.pvar v p.Ast.pname p.Ast.pname v
|
||
| Some t when not (generic_ty t) && not (pred_holds p.Ast.pname t) ->
|
||
Loc.failk "check/predicate-unsatisfied" loc
|
||
"%s is written {:where (%s $%s)}, and this call passes %s, \
|
||
which is not %s"
|
||
name p.Ast.pname p.Ast.pvar (Types.to_string t) p.Ast.pname
|
||
| _ -> ())
|
||
gfn.Ast.fwhere);
|
||
expect loc ~want (mk loc cret (Tast.Call (name, targs)))
|
||
end
|
||
else
|
||
let sym = instantiate ctx.env loc name vars !subst cparams cret in
|
||
expect loc ~want (mk loc cret (Tast.Call (sym, targs)))
|
||
|
||
(* Cache or generate, Odin's loop. The key is the whole concrete signature
|
||
compared pairwise with [Types.equal] — [are_types_identical] — so calling
|
||
at the same type twice makes one copy. *)
|
||
and instantiate env loc gname vars subst cparams cret =
|
||
let cache =
|
||
match Hashtbl.find_opt env.insts gname with
|
||
| Some r -> r
|
||
| None -> let r = ref [] in Hashtbl.replace env.insts gname r; r
|
||
in
|
||
let same (ps, r, _) =
|
||
List.length ps = List.length cparams
|
||
&& List.for_all2 Types.equal ps cparams && Types.equal r cret
|
||
in
|
||
match List.find_opt same !cache with
|
||
| Some (_, _, sym) -> sym
|
||
| None ->
|
||
let sym =
|
||
gname ^ "-"
|
||
^ String.concat "-" (List.map (fun v -> mangle_ty (List.assoc v subst)) vars)
|
||
in
|
||
if Hashtbl.mem env.fns sym then
|
||
fail loc
|
||
"%s at these types is called %s, and %s is already defined — rename \
|
||
one of them" gname sym sym;
|
||
runaway env loc gname cparams;
|
||
(* Each instantiation checks the concrete types answer the [where] clause.
|
||
This is the half of the feature that only exists per copy: the abstract
|
||
pass took the predicates on trust, and here is where the trust is
|
||
settled, at the call site that asked, naming it. *)
|
||
let fn = Hashtbl.find env.generics gname in
|
||
List.iter
|
||
(fun (p : Ast.pred) ->
|
||
match List.assoc_opt p.Ast.pvar subst with
|
||
| None -> ()
|
||
| Some t ->
|
||
if not (pred_holds p.Ast.pname t) then
|
||
Loc.failk "check/predicate-unsatisfied" loc
|
||
"this call instantiates %s at $%s = %s, and %s does not \
|
||
answer %s — which %s requires, being written {:where (%s \
|
||
$%s)}. The requirement is the signature's, so the refusal is \
|
||
here, at the call that asked for the type: pass one the \
|
||
predicate admits"
|
||
gname p.Ast.pvar (Types.to_string t) (Types.to_string t)
|
||
p.Ast.pname gname p.Ast.pname p.Ast.pvar)
|
||
fn.Ast.fwhere;
|
||
(* The entry goes in *before* the body is checked, which is what makes a
|
||
recursive generic function terminate: the call to itself at the same
|
||
types finds this and does not generate a second copy. *)
|
||
cache := (cparams, cret, sym) :: !cache;
|
||
Hashtbl.replace env.fns sym (cparams, cret);
|
||
let saved_subst = env.subst and saved_vars = env.tyvars
|
||
and saved_preds = env.tvpreds and saved_chain = env.chain in
|
||
(* Inside the copy there are no variables left: [resolve_name] answers
|
||
[t] with the concrete type, so every node the body produces is as
|
||
concrete as one written out by hand. The [where] clause goes out of
|
||
scope with them — there is nothing abstract left for it to permit, and
|
||
every operator is answered by the concrete type it now has. *)
|
||
env.subst <- List.map (fun v -> (v, List.assoc v subst)) vars;
|
||
env.tyvars <- [];
|
||
env.tvpreds <- [];
|
||
env.chain <- env.chain @ [ (gname, cparams, loc) ];
|
||
let restore () =
|
||
env.subst <- saved_subst; env.tyvars <- saved_vars;
|
||
env.tvpreds <- saved_preds; env.chain <- saved_chain
|
||
in
|
||
let tfn =
|
||
match !check_fn_ref env { fn with Ast.name = sym } with
|
||
| tfn -> restore (); tfn
|
||
| exception e ->
|
||
restore ();
|
||
(* A copy whose body did not check is not a copy. Both entries go back
|
||
out, so a second call at the same types is the same refusal again
|
||
rather than a cache hit on a function that does not exist. *)
|
||
cache := List.filter (fun (_, _, s) -> s <> sym) !cache;
|
||
Hashtbl.remove env.fns sym;
|
||
raise e
|
||
in
|
||
env.instances <- tfn :: env.instances;
|
||
sym
|
||
|
||
and is_cast name =
|
||
Types.ikind_of_name name <> None || Types.fkind_of_name name <> None
|
||
|
||
and byte_slice ctx (a : Ast.expr) =
|
||
check ctx ~want:(Types.Slice (Types.Int Types.U8)) a
|
||
|
||
and numeric_want want =
|
||
match want with Some (Types.Int _ | Types.Float _) -> want | _ -> None
|
||
|
||
(* Both operands of a binary operator have one type, and there is no implicit
|
||
widening, so one side has to decide it. Check the side that carries the most
|
||
information first: a non-literal over a literal, and a float literal over an
|
||
integer one, since an integer constant converts to a float and not back. *)
|
||
and binary ctx name loc ~want args =
|
||
match args with
|
||
| [ x; y ] ->
|
||
let y_decides =
|
||
(is_literal x && not (is_literal y))
|
||
|| (match x.Ast.e, y.Ast.e with
|
||
| (Ast.Int _ | Ast.Byte _), Ast.Float _ -> true
|
||
| _ -> false)
|
||
in
|
||
if y_decides then begin
|
||
let b = check ctx ?want y in
|
||
let a = check ctx ~want:b.Tast.ty x in
|
||
a, b
|
||
end else begin
|
||
let a = check ctx ?want x in
|
||
let b = check ctx ~want:a.Tast.ty y in
|
||
a, b
|
||
end
|
||
| _ -> fail loc "%s takes two arguments" name
|
||
|
||
(* ── Declarations: pass 1, collect ─────────────────────────────────── *)
|
||
|
||
(* Constant folding, only over integers and only for defconst — enough for an
|
||
array length like (/ screen-height cell-size). *)
|
||
let rec const_int env (e : Ast.expr) : int64 option =
|
||
match e.Ast.e with
|
||
| Ast.Int n -> Some n
|
||
| Ast.Byte b -> Some (Int64.of_int b)
|
||
| Ast.Var n -> Hashtbl.find_opt env.consts n
|
||
(* Left to right over any number of operands, because that is how the
|
||
checker reads the same form: an array length that type-checks as a
|
||
product of three literals and is then not a constant would be a
|
||
distinction with nothing behind it. [%] is still two, as it is there. *)
|
||
| Ast.Call ({ Ast.e = Ast.Var op; _ }, x :: y :: rest) ->
|
||
let step a b =
|
||
match op with
|
||
| "+" -> Some (Int64.add a b)
|
||
| "-" -> Some (Int64.sub a b)
|
||
| "*" -> Some (Int64.mul a b)
|
||
| "/" when b <> 0L -> Some (Int64.div a b)
|
||
| "%" when b <> 0L && rest = [] -> Some (Int64.rem a b)
|
||
| _ -> None
|
||
in
|
||
List.fold_left
|
||
(fun acc e ->
|
||
match acc, const_int env e with
|
||
| Some a, Some b -> step a b
|
||
| _ -> None)
|
||
(const_int env x) (y :: rest)
|
||
| _ -> None
|
||
|
||
let collect env (decls : Ast.decl list) =
|
||
(* One pass over every declaration kind before any of the others, because
|
||
the tables below are per-kind — structs, data types, aliases, enums, functions
|
||
and globals each have their own — and a collision between two of them
|
||
would otherwise be found by LLVM, as [redefinition of function
|
||
'@flan.item'], or not at all. A [defn item] and a [defvar item] are two
|
||
declarations of one name and are rejected here. *)
|
||
let claimed = Hashtbl.create 64 in
|
||
List.iter
|
||
(fun (d : Ast.decl) ->
|
||
match Ast.declared_name d with
|
||
| None -> ()
|
||
| Some n ->
|
||
(match Hashtbl.find_opt claimed n with
|
||
| Some first ->
|
||
(* The second one is the error, because it is the one to delete;
|
||
the first is the note, because without it the message is a
|
||
claim the reader has to go and verify. *)
|
||
Loc.failk "check/defined-twice" d.Ast.dloc
|
||
~notes:[ Loc.note first (n ^ " is already defined here") ]
|
||
"%s is defined twice" n
|
||
| None -> ());
|
||
Hashtbl.add claimed n d.Ast.dloc)
|
||
decls;
|
||
(* Names first, so a struct may mention one declared below it. *)
|
||
List.iter
|
||
(fun (d : Ast.decl) ->
|
||
match d.Ast.d with
|
||
| Ast.Defstruct (n, _) ->
|
||
Hashtbl.replace env.locs n d.Ast.dloc;
|
||
Hashtbl.replace env.structs n { Tast.sname = n; fields = [] }
|
||
| Ast.Defdata (n, _) ->
|
||
Hashtbl.replace env.locs n d.Ast.dloc;
|
||
Hashtbl.replace env.datas n { Tast.dname = n; cases = [] }
|
||
| Ast.Defunion (n, _) ->
|
||
Hashtbl.replace env.locs n d.Ast.dloc;
|
||
Hashtbl.replace env.unions n { Tast.sname = n; fields = [] }
|
||
| Ast.Defalias (n, t) -> Hashtbl.replace env.aliases n t
|
||
| _ -> ())
|
||
decls;
|
||
(* Compile-time integer constants next, to a fixpoint, because an array
|
||
length may name a constant declared below it — top-level names in a
|
||
package are order-independent (plan.org, Modules). *)
|
||
let fold_consts () =
|
||
let progress = ref false in
|
||
List.iter
|
||
(fun (d : Ast.decl) ->
|
||
match d.Ast.d with
|
||
| Ast.Defconst (n, _, v) when not (Hashtbl.mem env.consts n) ->
|
||
(match const_int env v with
|
||
| Some i -> Hashtbl.replace env.consts n i; progress := true
|
||
| None -> ())
|
||
| _ -> ())
|
||
decls;
|
||
!progress
|
||
in
|
||
while fold_consts () do () done;
|
||
let field (f : Ast.field) : Tast.field =
|
||
let fty = resolve env f.Ast.fty in
|
||
no_zeroed_fn f.Ast.fty.Ast.tloc
|
||
(Printf.sprintf "the field %s" f.Ast.fname) fty;
|
||
{ Tast.fname = f.Ast.fname; fty }
|
||
in
|
||
(* Constants with no declared type are inferred from their value, which needs
|
||
every other signature in hand — so they are deferred to a pass of their
|
||
own below. *)
|
||
let untyped = ref [] in
|
||
(* Enums come first, in a pass of their own: a signature below may name one,
|
||
and [resolve] has to find it before it resolves that signature. *)
|
||
List.iter
|
||
(fun (d : Ast.decl) ->
|
||
match d.Ast.d with
|
||
| Ast.Defenum (n, members) ->
|
||
let names = List.map fst members in
|
||
if List.length (List.sort_uniq compare names) <> List.length names then
|
||
fail d.Ast.dloc "%s declares the same member twice" n;
|
||
Hashtbl.replace env.enums n members;
|
||
Hashtbl.replace env.locs n d.Ast.dloc
|
||
| _ -> ())
|
||
decls;
|
||
List.iter
|
||
(fun (d : Ast.decl) ->
|
||
let loc = d.Ast.dloc in
|
||
match d.Ast.d with
|
||
| Ast.Package _ -> ()
|
||
| Ast.Defenum _ -> ()
|
||
(* Imports are gone by now: [Load] resolved them into these very decls,
|
||
so one reaching the checker is a driver that skipped that step. *)
|
||
| Ast.Import (alias, _) ->
|
||
fail loc "internal: the import of %s was not resolved before checking"
|
||
alias
|
||
(* [Shim.expand] rewrote every one of these into a [Declare] and a
|
||
[Defn] before [collect] ran, so one arriving here is a driver that
|
||
skipped that step. *)
|
||
| Ast.DeclareC (fn, _) ->
|
||
fail loc "internal: the declare-c of %s was not expanded before checking"
|
||
fn.Ast.name
|
||
| Ast.Declare (fn, csym) ->
|
||
if Hashtbl.mem env.fns fn.Ast.name then
|
||
fail loc "%s is declared twice" fn.Ast.name;
|
||
let params =
|
||
List.map (fun (p : Ast.field) -> resolve env p.Ast.fty) fn.Ast.params
|
||
in
|
||
let ret =
|
||
match fn.Ast.ret with None -> Types.Unit | Some t -> resolve env t
|
||
in
|
||
(* What may cross the boundary. A slice or a string goes as ptr+len,
|
||
a scalar as itself; an aggregate does not go at all, because how
|
||
one is passed differs per target and reproducing that here would
|
||
be three calling conventions to maintain. Pass (Ptr T) instead and
|
||
let the C shim dereference it — that is what the shim is for. *)
|
||
let crossable what (t : Types.t) =
|
||
match t with
|
||
| Types.Int _ | Types.Float _ | Types.Bool | Types.Ptr _
|
||
| Types.Enum _ | Types.Unit -> ()
|
||
| Types.String | Types.Slice _ when what = "a parameter" -> ()
|
||
| _ ->
|
||
fail loc
|
||
"%s of %s is %s, which cannot cross to C directly — pass \
|
||
(Ptr %s) and let the shim read it" what fn.Ast.name
|
||
(Types.to_string t) (Types.to_string t)
|
||
in
|
||
List.iter (crossable "a parameter") params;
|
||
crossable "the return type" ret;
|
||
Hashtbl.replace env.fns fn.Ast.name (params, ret);
|
||
Hashtbl.replace env.externs fn.Ast.name csym
|
||
| Ast.Defalias _ -> ()
|
||
| Ast.Defstruct (n, fs) ->
|
||
let names = List.map (fun (f : Ast.field) -> f.Ast.fname) fs in
|
||
if List.length (List.sort_uniq compare names) <> List.length names then
|
||
fail loc "%s declares the same field twice" n;
|
||
let fields = List.map field fs in
|
||
(* Recorded before the refusal below rather than after it, because the
|
||
refusal asks [region_only], which walks this very declaration: a
|
||
recursive value's field is a [(Vec Value)] and answering for it
|
||
means reading [Value]'s own cases back out of the table. A [fail]
|
||
aborts the whole compilation, so an entry left behind by a
|
||
declaration that is about to be refused is never read. *)
|
||
Hashtbl.replace env.structs n { Tast.sname = n; fields };
|
||
(* A struct field may own storage. Since the repeal a struct
|
||
holding a [(Vec i32)] is an ordinary value: assignment copies the
|
||
header bytes, the copies alias one buffer, and freeing through
|
||
two copies is the program's bug — Odin's contract, kept whole.
|
||
|
||
The region rule is separate and survives on its own ground: a
|
||
field whose container holds *owning* elements can only have been
|
||
built against a region allocator — the guard at its construction
|
||
is what makes sure of it (see [vec-new]) — so that graph is
|
||
released by one [free-all] and no teardown recurses anywhere. *)
|
||
| Ast.Defdata (n, vs) ->
|
||
(* A data type with no cases has no value, so nothing could ever be given
|
||
one, and a parameter of that type would be a function nothing can
|
||
call. It parses; it is refused here rather than surviving to a
|
||
layout with a tag and no case for the tag to name. *)
|
||
if vs = [] then
|
||
fail loc
|
||
"%s declares no cases, so no value of it can exist — a data type is \
|
||
(defdata %s [(Case [field Type ...]) ...])" n n;
|
||
let cnames = List.map (fun (v : Ast.variant) -> v.Ast.vname) vs in
|
||
if List.length (List.sort_uniq compare cnames) <> List.length cnames
|
||
then fail loc "%s declares the same case twice" n;
|
||
let cases_with_loc =
|
||
List.map
|
||
(fun (v : Ast.variant) ->
|
||
let fnames =
|
||
List.map (fun (f : Ast.field) -> f.Ast.fname) v.Ast.vfields
|
||
in
|
||
if List.length (List.sort_uniq compare fnames)
|
||
<> List.length fnames then
|
||
fail v.Ast.vloc "%s.%s declares the same field twice"
|
||
n v.Ast.vname;
|
||
let vfields = List.map field v.Ast.vfields in
|
||
v.Ast.vloc, { Tast.vname = v.Ast.vname; vfields })
|
||
vs
|
||
in
|
||
let cases = List.map snd cases_with_loc in
|
||
(* Registered before the field refusal below, not after, for the
|
||
reason the struct's copy of this gives: [region_only] has to read
|
||
this data type's own cases back out to answer for a [(Vec Value)]
|
||
that names [Value]. The two declarations do this identically
|
||
because a data type that could hold a container where a struct
|
||
could not would be a hole in the same rule. *)
|
||
Hashtbl.replace env.datas n { Tast.dname = n; cases };
|
||
(* A case's fields are a struct and may own storage, on the struct's
|
||
terms since the repeal: copies alias, and the free is the
|
||
program's to write. The region rule still applies on its own
|
||
ground — a [(Vec Value)] case field can only have been built
|
||
against a region, so the recursive dynamic value parses into an
|
||
arena and one [free-all] releases the graph, no teardown
|
||
anywhere. *)
|
||
List.iter
|
||
(fun (c : Tast.variant) ->
|
||
Hashtbl.replace env.cases (n ^ "." ^ c.Tast.vname) (n, c);
|
||
Hashtbl.replace env.cases c.Tast.vname (n, c))
|
||
cases
|
||
(* Nothing records which member of a union is live, so nothing — the
|
||
program included — can free the right one through the union itself.
|
||
Since the repeal that is a fact about the value and not a refusal:
|
||
a member may own storage, and freeing it is done through whatever
|
||
tag the program keeps beside the union, as C does. *) | Ast.Defunion (n, ms) ->
|
||
if ms = [] then
|
||
fail loc
|
||
"%s declares no members, so it has no size and nothing could be \
|
||
read out of it — a union is (defunion %s [member Type ...])" n n;
|
||
let names = List.map (fun (f : Ast.field) -> f.Ast.fname) ms in
|
||
if List.length (List.sort_uniq compare names) <> List.length names then
|
||
fail loc "%s declares the same member twice" n;
|
||
let fields = List.map field ms in
|
||
Hashtbl.replace env.unions n { Tast.sname = n; fields }
|
||
| Ast.Defn fn ->
|
||
(* A signature that introduces a type variable is a *pattern*, not a
|
||
signature: it goes in [gsigs] and the function goes nowhere near
|
||
[fns], because nothing can be called at [t]. Every call site turns
|
||
it into an ordinary entry. *)
|
||
let vars = signature_tyvars fn in
|
||
(* The [where] clause is checked against the signature here, once,
|
||
rather than at every use of it: a predicate nobody has heard of,
|
||
or one about a variable the signature never bound, is a mistake
|
||
about this definition and is refused at this definition. *)
|
||
List.iter
|
||
(fun (p : Ast.pred) ->
|
||
if not (List.mem p.Ast.pname predicate_names) then
|
||
Loc.failk "check/unknown-predicate" p.Ast.ploc
|
||
"%s is not a type predicate. The ones there are: %s"
|
||
p.Ast.pname (String.concat ", " predicate_names);
|
||
if not (List.mem p.Ast.pvar vars) then
|
||
Loc.failk "check/unbound-predicate-variable" p.Ast.ploc
|
||
"$%s is not a type variable of %s — a where clause \
|
||
constrains the variables the signature binds%s"
|
||
p.Ast.pvar fn.Ast.name
|
||
(if vars = [] then ", and this signature binds none"
|
||
else
|
||
", which here are "
|
||
^ String.concat ", " (List.map (fun v -> "$" ^ v) vars)))
|
||
fn.Ast.fwhere;
|
||
env.tyvars <- vars;
|
||
env.tvpreds <- fn.Ast.fwhere;
|
||
let params =
|
||
List.map (fun (p : Ast.field) -> resolve env p.Ast.fty) fn.Ast.params
|
||
in
|
||
let ret =
|
||
match fn.Ast.ret with None -> Types.Unit | Some t -> resolve env t
|
||
in
|
||
env.tyvars <- [];
|
||
env.tvpreds <- [];
|
||
if vars = [] then Hashtbl.replace env.fns fn.Ast.name (params, ret)
|
||
else begin
|
||
Hashtbl.replace env.generics fn.Ast.name fn;
|
||
Hashtbl.replace env.gsigs fn.Ast.name (vars, params, ret)
|
||
end
|
||
| Ast.Defvar (n, t, _) ->
|
||
let ty = match t with
|
||
| Some t -> resolve env t
|
||
| None -> fail loc "defvar %s needs a type" n
|
||
in
|
||
Hashtbl.replace env.globals n (ty, false)
|
||
| Ast.Defconst (n, Some t, _) ->
|
||
Hashtbl.replace env.globals n (resolve env t, true)
|
||
| Ast.Defconst (n, None, v) -> untyped := (n, v) :: !untyped)
|
||
decls;
|
||
(* Also to a fixpoint, and for the same reason: one untyped constant may be
|
||
defined in terms of another declared after it. A constant that still does
|
||
not check once no progress is left has a real error, so the last round is
|
||
run without swallowing it. *)
|
||
let infer (_, v) =
|
||
(check { env; ret = Types.Unit; slots = 0; slot_tys = []; slot_names = []; scope = []; defers = [];
|
||
outer = []; outer_what = None; in_frames = None; loops = []; tail = false; in_defer = false; defer_ok = false; defer_block = "a nested form"; owner = "<none>" } v).Tast.ty
|
||
in
|
||
let pending = ref (List.rev !untyped) in
|
||
let rec settle () =
|
||
let left =
|
||
List.filter
|
||
(fun ((n, _) as c) ->
|
||
match infer c with
|
||
| ty -> Hashtbl.replace env.globals n (ty, true); false
|
||
| exception Loc.Error _ -> true)
|
||
!pending
|
||
in
|
||
let progressed = List.length left < List.length !pending in
|
||
pending := left;
|
||
if progressed && left <> [] then settle ()
|
||
in
|
||
settle ();
|
||
List.iter (fun c -> ignore (infer c)) !pending
|
||
|
||
(* A type that contains itself by value has no finite size. [(Ptr T)] and a
|
||
slice are indirections and break the cycle; a fixed array does not, because
|
||
it is inline. Caught here rather than when a backend tries to lay the type
|
||
out or a zero value is built for it — which would not fail, it would hang. *)
|
||
let check_finite env =
|
||
let rec walk seen name =
|
||
if List.mem name seen then
|
||
fail (Option.value (Hashtbl.find_opt env.locs name) ~default:Loc.unknown)
|
||
"%s contains itself by value, so it has no size — go through (Ptr %s)"
|
||
name name;
|
||
let seen = name :: seen in
|
||
match Hashtbl.find_opt env.structs name with
|
||
| Some s -> List.iter (fun (f : Tast.field) -> ty seen f.Tast.fty) s.Tast.fields
|
||
| None ->
|
||
match Hashtbl.find_opt env.datas name with
|
||
| Some u ->
|
||
List.iter
|
||
(fun (c : Tast.variant) ->
|
||
List.iter (fun (f : Tast.field) -> ty seen f.Tast.fty) c.Tast.vfields)
|
||
u.Tast.cases
|
||
| None ->
|
||
(* A union whose member is itself is the same infinite type a struct's
|
||
is — the size is the largest member and the largest member is the
|
||
whole thing. Nothing about overlaying storage makes the recursion
|
||
finite, so it is on the same walk rather than left to hang the
|
||
layout calculator. *)
|
||
match Hashtbl.find_opt env.unions name with
|
||
| None -> ()
|
||
| Some u ->
|
||
List.iter (fun (f : Tast.field) -> ty seen f.Tast.fty) u.Tast.fields
|
||
and ty seen = function
|
||
| Types.Named n -> walk seen n
|
||
| Types.Array (_, e) | Types.Option e -> ty seen e
|
||
| _ -> ()
|
||
in
|
||
Hashtbl.iter (fun n _ -> walk [] n) env.structs;
|
||
Hashtbl.iter (fun n _ -> walk [] n) env.datas;
|
||
Hashtbl.iter (fun n _ -> walk [] n) env.unions
|
||
|
||
(* No [bool] and no data type anywhere inside a union, at any depth — see the [Defunion] arm in
|
||
[collect] for why an [i1] read out of a union is the one punning hazard
|
||
Flan refuses rather than defines. It runs here, after [collect], because it
|
||
has to look through a member's *struct* to reach the fields inside it and
|
||
the struct table is only complete once every declaration has been walked. A
|
||
union that contains itself is impossible by [check_finite] above, so the
|
||
recursion terminates without a seen set — except through a [Ptr], which
|
||
this does not follow: a bool behind a pointer is a bool in someone else's
|
||
storage and is loaded from an address, not reinterpreted out of a blob. *)
|
||
let check_union_members env =
|
||
let rec walk uname where (t : Types.t) =
|
||
match t with
|
||
| Types.Bool ->
|
||
fail (Option.value (Hashtbl.find_opt env.locs uname) ~default:Loc.unknown)
|
||
"%s is a bool, and a union may not hold one at any depth: writing a \
|
||
member that overlays it leaves a byte that is neither 0 nor 1, and \
|
||
an i1 with that byte in it is a value the optimiser is entitled to \
|
||
assume cannot exist. Hold a u8 in the union and compare it yourself"
|
||
where
|
||
(* An [Option] is deliberately not on this list, and the difference is
|
||
worth stating because a reader will ask. Its [match] lowers to a test of
|
||
the tag byte and a branch, so a scribbled tag reads as a [Some] with a
|
||
garbage payload — a number nobody stored, which is exactly what this
|
||
language says a union read is. A data type's lowers to a chain of
|
||
comparisons with an [unreachable] after the last one. *)
|
||
| Types.Array (_, e) | Types.Option e -> walk uname where e
|
||
| Types.Named n when Hashtbl.mem env.datas n ->
|
||
fail (Option.value (Hashtbl.find_opt env.locs uname) ~default:Loc.unknown)
|
||
"%s is %s, a data type, and a union may not hold one at any depth: a \
|
||
data type's tag steers every match over it, and overlaying another \
|
||
member leaves that tag arbitrary — a tag no case names falls past \
|
||
every comparison into a block the optimiser may treat as \
|
||
unreachable. This is the same refusal uninit on a data type gets, \
|
||
and it arrives here because a union is the other way to hand one \
|
||
bytes nobody wrote. Hold the %s beside the union"
|
||
where n n
|
||
| Types.Named n ->
|
||
(match Hashtbl.find_opt env.structs n with
|
||
| Some st ->
|
||
List.iter
|
||
(fun (f : Tast.field) ->
|
||
walk uname (where ^ "." ^ f.Tast.fname) f.Tast.fty)
|
||
st.Tast.fields
|
||
| None ->
|
||
match Hashtbl.find_opt env.unions n with
|
||
| None -> ()
|
||
| Some u ->
|
||
List.iter
|
||
(fun (f : Tast.field) ->
|
||
walk uname (where ^ "." ^ f.Tast.fname) f.Tast.fty)
|
||
u.Tast.fields)
|
||
| _ -> ()
|
||
in
|
||
Hashtbl.iter
|
||
(fun n (u : Tast.structure) ->
|
||
List.iter
|
||
(fun (f : Tast.field) -> walk n (n ^ "'s member " ^ f.Tast.fname) f.Tast.fty)
|
||
u.Tast.fields)
|
||
env.unions
|
||
|
||
(* ── Declarations: pass 2, check bodies ────────────────────────────── *)
|
||
|
||
let rec check_fn env (fn : Ast.fn) : Tast.fn =
|
||
let params, ret = Hashtbl.find env.fns fn.Ast.name in
|
||
let ctx = { env; ret; slots = 0; slot_tys = []; slot_names = []; scope = []; defers = [];
|
||
outer = []; outer_what = None; in_frames = None; loops = []; tail = false; in_defer = false; defer_ok = false; defer_block = "a nested form";
|
||
owner = fn.Ast.name } in
|
||
List.iter2
|
||
(fun (p : Ast.field) ty ->
|
||
if List.mem_assoc p.Ast.fname ctx.scope then begin
|
||
let first =
|
||
List.find_opt
|
||
(fun (q : Ast.field) -> q.Ast.fname = p.Ast.fname)
|
||
fn.Ast.params
|
||
in
|
||
let notes =
|
||
match first with
|
||
| Some q when q != p ->
|
||
[ Loc.note q.Ast.floc ("the first " ^ p.Ast.fname ^ " is here") ]
|
||
| _ -> []
|
||
in
|
||
Loc.failk "check/duplicate-parameter" p.Ast.floc ~notes
|
||
"%s has two parameters named %s" fn.Ast.name p.Ast.fname
|
||
end;
|
||
ignore (bind ctx p.Ast.fname ty ~assignable:false))
|
||
fn.Ast.params params;
|
||
let body =
|
||
match fn.Ast.fbody with
|
||
| [] ->
|
||
if Types.equal ret Types.Unit then []
|
||
else fail fn.Ast.nloc "%s returns %s but has no body" fn.Ast.name
|
||
(Types.to_string ret)
|
||
| body ->
|
||
(* The last form is the return value, unless the function returns Unit,
|
||
in which case whatever it evaluates to is discarded. *)
|
||
let want = if Types.equal ret Types.Unit then None else Some ret in
|
||
(* Every form here is at the top level of the function body, so every one
|
||
of them may carry a [defer] — and so may a form inside a [let] written
|
||
here, which is what [ctx.defer_ok] carries down. [check] registers it
|
||
and yields [unit]; the permission is granted again before each form
|
||
because [check] withdraws it as it starts.
|
||
|
||
A trailing [defer] is still a [defer] and not the return value, so the
|
||
expectation is not put to it: it would only ever report [Unit] against
|
||
the declared return type, which names the wrong problem. *)
|
||
let is_defer (e : Ast.expr) =
|
||
match e.Ast.e with Ast.Defer _ -> true | _ -> false
|
||
in
|
||
let rec go = function
|
||
| [ last ] ->
|
||
ctx.defer_ok <- true;
|
||
[ (if is_defer last then check ctx last else check ctx ?want last) ]
|
||
| x :: rest ->
|
||
ctx.defer_ok <- true;
|
||
let x = check ctx x in
|
||
x :: go rest
|
||
| [] -> assert false
|
||
in
|
||
go body
|
||
in
|
||
(* Function exit runs the defers, innermost first. An explicit [return] ran
|
||
its own (see [check]); this is the fall-off-the-end path. A trap does not
|
||
run them — it is [noreturn] and then [unreachable] — and that is the same
|
||
rule the bounds checks already follow. *)
|
||
let body =
|
||
match ctx.defers with
|
||
| [] -> body
|
||
| ds when Types.equal ret Types.Unit -> body @ ds
|
||
| ds ->
|
||
(* The result is computed before the defers run and returned after, so it
|
||
goes through a slot rather than staying the last form. *)
|
||
let rec split = function
|
||
| [ last ] -> ([], last)
|
||
| x :: rest -> let (init, last) = split rest in (x :: init, last)
|
||
| [] -> assert false
|
||
in
|
||
let init, last = split body in
|
||
let s = fresh_slot ctx ret in
|
||
let loc = last.Tast.loc in
|
||
init @ [ mk loc ret
|
||
(Tast.Let ([ (s, last) ], ds @ [ mk loc ret (Tast.Local s) ])) ]
|
||
in
|
||
{ Tast.name = fn.Ast.name; params;
|
||
slots = Array.of_list (List.rev ctx.slot_tys);
|
||
snames = Array.of_list (List.rev ctx.slot_names);
|
||
(* The same defers again, for the transfer exit path §5 describes. The
|
||
normal path has them spliced into [body] above. *)
|
||
ret; body; fdefers = ctx.defers; fparent = None; floc = fn.Ast.nloc }
|
||
|
||
(* The generic body, checked once with its variables abstract. Nothing is kept
|
||
— the [Tast.fn] it produces is thrown away, and so is anything it lifted —
|
||
because a generic function has no code: only its instantiations do. What is
|
||
kept is the *refusal*: an operator an unconstrained variable does not
|
||
support fails here, at the definition, naming the variable, rather than at
|
||
whichever call site happened to instantiate it at a type that worked.
|
||
|
||
The holes in it are real and are the report's business: [println] is
|
||
plan.org's one compiler-provided exception and this pass rejects it. *)
|
||
and check_generic env (fn : Ast.fn) =
|
||
let vars, params, ret = Hashtbl.find env.gsigs fn.Ast.name in
|
||
let saved_lifted = env.lifted and saved_vars = env.tyvars
|
||
and saved_preds = env.tvpreds in
|
||
env.tyvars <- vars;
|
||
(* What the abstract pass may assume. Every operator the body reaches asks
|
||
[env.tvpreds] whether the variable was declared to support it, and every
|
||
instantiation asks the concrete type the same question again. *)
|
||
env.tvpreds <- fn.Ast.fwhere;
|
||
Hashtbl.replace env.fns fn.Ast.name (params, ret);
|
||
let finish () =
|
||
Hashtbl.remove env.fns fn.Ast.name;
|
||
env.lifted <- saved_lifted;
|
||
env.tyvars <- saved_vars;
|
||
env.tvpreds <- saved_preds
|
||
in
|
||
(match check_fn env fn with
|
||
| _ -> finish ()
|
||
| exception e -> finish (); raise e)
|
||
|
||
(* The knot from [instantiate]: a call site makes a copy, and making one is
|
||
checking a function. *)
|
||
let () = check_fn_ref := check_fn
|
||
|
||
(* A container's only compile-time constant is the zeroed one: a Vec's or a
|
||
Map's real value exists at run time, behind an allocator. That is a fact
|
||
about initialisers and it survived both repeals untouched — nothing here
|
||
is about copying or moving.
|
||
|
||
What this pass decides is how such a global may be *started*, and the
|
||
answer is zeroed and nothing else. A zeroed Vec is a real empty Vec — null
|
||
block, zero length, zero capacity — so the ZII value is the value a program
|
||
would have written anyway, and filling it is an ordinary (set g (slurp
|
||
"...")) in whichever function loads it. The alternative, a computed
|
||
initialiser, does not exist to be relaxed into: [Emit.const] says so in as
|
||
many words ("there is no init-at-startup path, by design"), and the backend
|
||
that does run initialisers at startup, [x86.ml], runs them from .init_array
|
||
before main and deliberately omits them from a reload module, because
|
||
re-running one would wipe the live state reloading exists to preserve. A
|
||
rule that held on one backend and not the other would not be a rule.
|
||
|
||
That fits what a runtime-loaded global is for. The data is loaded by
|
||
whoever loads it, once, and it outlives main: a main that returns and is
|
||
entered again finds the global exactly as it left it, because nothing
|
||
between the two runs touches it. Assigning a second time overwrites the
|
||
first block and leaks it — there is no [drop] and no cross-function flow
|
||
analysis that could see the second assignment, so that is the manual-memory
|
||
answer and the language's own: free is a thing you write.
|
||
|
||
A global *Allocator* is not any of this — an allocator is a copyable opaque
|
||
handle — which is what makes the handler-owns-the-arena shape in
|
||
exhausted.flan expressible. *)
|
||
let rec zero_only (t : Types.t) =
|
||
match t with
|
||
| Types.Vec _ | Types.Map _ -> true
|
||
| Types.Option e | Types.Array (_, e) -> zero_only e
|
||
| _ -> false
|
||
|
||
let container_global_init loc n (ty : Types.t) (init : Ast.init) =
|
||
if zero_only ty then
|
||
match init with
|
||
| Ast.Zeroed -> ()
|
||
| _ ->
|
||
fail loc
|
||
"the global %s is %s, and such a global starts zeroed: a global's \
|
||
initialiser is a compile-time constant, %s is not one, and a \
|
||
container's only constant value is the empty one. Write (defvar %s %s) with no initialiser — a zeroed \
|
||
%s is an empty one, and that is a value, not a placeholder — then \
|
||
load it with (set %s ...) in the function that loads it, which runs \
|
||
once and whose result outlives every call to main"
|
||
n (Types.to_string ty)
|
||
(match init with Ast.Uninit -> "uninit" | _ -> "this initialiser")
|
||
n (Types.to_string ty) (Types.to_string ty) n
|
||
|
||
(* A container global has to be a [defvar]. A [defconst] is not an assignable
|
||
place — [check_place] refuses one by name — and a container's only constant
|
||
is the zeroed one, so a constant Vec could only ever hold the empty value
|
||
it was declared with: nothing could ever put the file's bytes in it.
|
||
Refused here, where the fix is one keyword, rather than at the (set ...)
|
||
that discovers it three forms later. *)
|
||
let no_container_defconst loc n (ty : Types.t) =
|
||
if zero_only ty then
|
||
fail loc
|
||
"the global %s is %s, and a %s global is a defvar and not a defconst: \
|
||
a constant is not an assignable place, so nothing could ever load \
|
||
this one — it would stay the empty %s it was declared as. Write \
|
||
(defvar %s %s) and fill it in a function"
|
||
n (Types.to_string ty) (Types.to_string ty) (Types.to_string ty)
|
||
n (Types.to_string ty)
|
||
|
||
(* A union member written into a global would have to be encoded into the blob
|
||
at link time, which is the byte-level encoder a data type case does not have
|
||
either — and a global's initialiser is a constant, while a union value is a
|
||
store. Refused here, where the message can name the way through, rather than
|
||
at the emitter as "this one is computed", which is true and says nothing. A
|
||
zeroed union needs none of this and is the ordinary declaration. Both kinds
|
||
of global, because a defconst reaches the same emitter by a different
|
||
path. *)
|
||
let no_union_init env loc n what (v : Tast.expr) =
|
||
match v.Tast.ty, v.Tast.e with
|
||
(* The all-bytes-zero value is a constant and needs none of this, so it is
|
||
the one initialiser that goes through — which is what makes (U {}) and a
|
||
declaration with no value the same thing here as everywhere else. *)
|
||
| _, (Tast.Zero _ | Tast.Uninit _) -> ()
|
||
| Types.Named un, _ when Hashtbl.mem env.unions un ->
|
||
fail loc
|
||
"the global %s is the union %s, and a union member cannot be written \
|
||
into a %s: the initialiser is a constant and storing a member is a \
|
||
store. Leave it zeroed and write the member in a function"
|
||
n un what
|
||
| _ -> ()
|
||
|
||
let check_global env (d : Ast.decl) : Tast.global option =
|
||
let ctx () = { env; ret = Types.Unit; slots = 0; slot_tys = []; slot_names = []; scope = []; defers = [];
|
||
outer = []; outer_what = None; in_frames = None; loops = []; tail = false; in_defer = false; defer_ok = false; defer_block = "a nested form"; owner = "<none>" } in
|
||
match d.Ast.d with
|
||
| Ast.Defvar (n, _, init) ->
|
||
let ty, _ = Hashtbl.find env.globals n in
|
||
no_zeroed_fn d.Ast.dloc (Printf.sprintf "the global %s" n) ty;
|
||
container_global_init d.Ast.dloc n ty init;
|
||
let ginit =
|
||
match init with
|
||
| Ast.Zeroed -> { Tast.e = Tast.Zero ty; ty; loc = d.Ast.dloc }
|
||
| Ast.Uninit ->
|
||
(* Everywhere else [uninit] is an opt-out from ZII and the bytes are
|
||
whatever they were: a garbage f64 is a garbage number. A data type is
|
||
the one type where that is qualitatively worse — the tag steers
|
||
control flow, a tag no case names falls past every comparison in a
|
||
[match], and the block after them is [unreachable], which LLVM is
|
||
entitled to assume cannot happen. So the one place where garbage
|
||
becomes "the optimiser may do anything" is refused by name, and the
|
||
zeroed form, which is the first declared case, is named beside it. *)
|
||
(match ty with
|
||
| Types.Named un when Hashtbl.mem env.datas un ->
|
||
fail d.Ast.dloc
|
||
"%s is a data type, and uninit on one is refused: its tag steers \
|
||
every match, and a tag no case names has no arm to reach. Drop \
|
||
the uninit — a zeroed %s is %s, which is a real case"
|
||
(Types.to_string ty) un
|
||
(match Hashtbl.find_opt env.datas un with
|
||
| Some { Tast.cases = c :: _; _ } -> un ^ "." ^ c.Tast.vname
|
||
| _ -> "its first case")
|
||
| _ -> ());
|
||
{ Tast.e = Tast.Uninit ty; ty; loc = d.Ast.dloc }
|
||
| Ast.Init v ->
|
||
let v = check (ctx ()) ~want:ty v in
|
||
no_union_init env d.Ast.dloc n "global" v; v
|
||
in
|
||
Some { Tast.gname = n; gty = ty; ginit; gconst = false; gfolded = false }
|
||
| Ast.Defconst (n, _, v) ->
|
||
let ty, _ = Hashtbl.find env.globals n in
|
||
no_zeroed_fn d.Ast.dloc (Printf.sprintf "the global %s" n) ty;
|
||
no_container_defconst d.Ast.dloc n ty;
|
||
(* [collect] already folded the integer constants, because an array length
|
||
has to be known before any type resolves. Use that value here rather
|
||
than the expression it came from: a global's initialiser has to be a
|
||
compile-time constant, and [(/ screen-height cell-size)] is one — the
|
||
folding pass is the only thing that knows it. *)
|
||
let ginit =
|
||
match Hashtbl.find_opt env.consts n, ty with
|
||
| Some k, Types.Int kind ->
|
||
(* Still range-checked: this path skips [check], and [in_range] is the
|
||
only thing that rejects 300 as a u8. *)
|
||
{ Tast.e = Tast.Int (in_range d.Ast.dloc kind k, kind); ty;
|
||
loc = d.Ast.dloc }
|
||
| _ -> check (ctx ()) ~want:ty v
|
||
in
|
||
no_union_init env d.Ast.dloc n "constant" ginit;
|
||
(* [env.consts] holds exactly the constants the folding pass consumed, so
|
||
membership is the question "is this value in the program's shape?" *)
|
||
Some { Tast.gname = n; gty = ty; ginit; gconst = true;
|
||
gfolded = Hashtbl.mem env.consts n }
|
||
| _ -> None
|
||
|
||
(* The entry point, plan.org: (defn main [args [string]] i32), with both the
|
||
parameter and the return type optional. *)
|
||
(* Where [main] was written. [env.locs] is the table of where each *type* was
|
||
declared — [collect] fills it for structs, data types, unions and enums and
|
||
for nothing else — so a function's own location is not in it and the
|
||
[find_opt] idiom the rest of this file uses does not apply here. The
|
||
declaration list does have it, and the caller is holding the list anyway.
|
||
|
||
Without this both refusals below opened with <unknown>:0:0, which tells a
|
||
reader that a rule exists and not where they broke it, and gives
|
||
[next-error] nothing to jump to. A [main] that arrived some other way — a
|
||
[declare], say — still has no [defn] to point at, so that case keeps the
|
||
unknown span rather than inventing one. *)
|
||
let main_loc (decls : Ast.decl list) =
|
||
let is_main (d : Ast.decl) =
|
||
match d.Ast.d with Ast.Defn fn -> fn.Ast.name = "main" | _ -> false
|
||
in
|
||
match List.find_opt is_main decls with
|
||
| Some { Ast.d = Ast.Defn fn; _ } -> fn.Ast.nloc
|
||
| _ -> Loc.unknown
|
||
|
||
let check_main env decls =
|
||
let at = main_loc decls in
|
||
match Hashtbl.find_opt env.fns "main" with
|
||
| None -> () (* a library, or a file being checked on its own *)
|
||
| Some (params, ret) ->
|
||
let ok_params =
|
||
match params with
|
||
| [] -> true
|
||
| [ Types.Slice Types.String ] -> true
|
||
| _ -> false
|
||
in
|
||
if not ok_params then
|
||
fail at
|
||
"main takes no parameters or one [string], not (%s)"
|
||
(String.concat " " (List.map Types.to_string params));
|
||
if not (Types.equal ret Types.Unit || Types.equal ret (Types.Int Types.I32))
|
||
then
|
||
fail at "main returns i32 or nothing, not %s"
|
||
(Types.to_string ret)
|
||
|
||
(* The environment as well as the program. A session needs it to check an
|
||
expression typed at a REPL against the program the process is running — and
|
||
it has to be this one rather than anything rebuilt from declarations,
|
||
because [program] prepends the prelude and no accumulated AST contains it. *)
|
||
(* Separate entry points below rather than a flag on the one the session calls,
|
||
for the reason [Parse] gives at the same fork: [Loc.Errors] is a second
|
||
exception that the session and the daemon do not catch, so the guarantee
|
||
that they never see one should be structural and not a default argument. *)
|
||
let build_program ~keep_going (decls : Ast.decl list) : Tast.program * env =
|
||
let env = new_env () in
|
||
let decls = Parse.program (Prelude.forms ()) @ decls in
|
||
(* Before anything is collected: every (declare-c ...) becomes an ordinary
|
||
flattened [declare] with a Flan [defn] over it, and the C that does the
|
||
flattening comes back to be compiled into the build. Nothing below this
|
||
line knows the form exists. *)
|
||
let decls, cshim = Shim.expand decls in
|
||
(* Pass one, and it stops at the first thing it refuses. That is not
|
||
laziness: every name, type and signature in the file comes from here, so a
|
||
declaration this pass could not make sense of leaves a hole that pass two
|
||
would report once per mention. A wrong signature is one error; the thirty
|
||
"unknown name" lines under it are not errors, they are the same one.
|
||
|
||
Pass two is where the volume is, and it is where collecting pays. By the
|
||
time it runs every signature is sound, so a body that fails to check
|
||
cannot make the next body fail — which is what makes a declaration a
|
||
resync point that needs no resynchronising. *)
|
||
collect env decls;
|
||
check_finite env;
|
||
check_union_members env;
|
||
let s = Loc.sink ~on:keep_going in
|
||
ignore (Loc.caught s (fun () -> check_main env decls));
|
||
(* Every generic body, checked once with its variables left abstract, and
|
||
the result thrown away. This is the pass plan.org's rule needs and Odin
|
||
has no equivalent of: Odin checks a polymorphic body only per
|
||
instantiation, so [a + b] over a [$T] compiles there and fails only if
|
||
nobody ever calls it at a numeric type. plan.org says the opposite — an
|
||
unconstrained variable supports only what every type supports, and [=],
|
||
[<], [+] and [hash] over one are *rejected, not silently instantiated*.
|
||
Rejecting them means type-checking the body with nothing substituted,
|
||
which is this, and it is a second pass over the same source. *)
|
||
List.iter
|
||
(fun (d : Ast.decl) ->
|
||
match d.Ast.d with
|
||
| Ast.Defn fn when Hashtbl.mem env.gsigs fn.Ast.name ->
|
||
ignore (Loc.caught s (fun () -> check_generic env fn))
|
||
| _ -> ())
|
||
decls;
|
||
let globals =
|
||
List.filter_map
|
||
(fun d -> Option.join (Loc.caught s (fun () -> check_global env d)))
|
||
decls
|
||
in
|
||
let fns =
|
||
List.filter_map
|
||
(fun (d : Ast.decl) ->
|
||
match d.Ast.d with
|
||
(* A generic [defn] does not reach the typed IR at all. Only its
|
||
instantiations do, and they are collected below. *)
|
||
| Ast.Defn fn when Hashtbl.mem env.gsigs fn.Ast.name -> None
|
||
| Ast.Defn fn -> Loc.caught s (fun () -> check_fn env fn)
|
||
| _ -> None)
|
||
decls
|
||
in
|
||
Loc.finish s;
|
||
(* The handler clauses lifted out along the way. They are ordinary functions
|
||
from here down; nothing in the backend knows they were written inside
|
||
something else. *)
|
||
let fns = fns @ List.rev env.lifted in
|
||
(* The copies generics turned into, in the order they were generated. Like a
|
||
lifted clause they are ordinary functions from here down — but unlike one
|
||
they are reached *by name* from arbitrary call sites, so they carry no
|
||
[fparent] and a dev build gives each its own cell. *)
|
||
let fns = fns @ List.rev env.instances in
|
||
(* Sorted, so the emitted IR is reproducible build to build: a Hashtbl's
|
||
fold order is not. *)
|
||
let values name tbl =
|
||
Hashtbl.fold (fun _ v acc -> v :: acc) tbl []
|
||
|> List.sort (fun a b -> String.compare (name a) (name b))
|
||
in
|
||
let externs =
|
||
Hashtbl.fold
|
||
(fun name esym acc ->
|
||
let eparams, eret = Hashtbl.find env.fns name in
|
||
{ Tast.ename = name; esym; eparams; eret } :: acc)
|
||
env.externs []
|
||
|> List.sort (fun (a : Tast.extern) b -> String.compare a.Tast.esym b.Tast.esym)
|
||
in
|
||
({ Tast.structs = values (fun (s : Tast.structure) -> s.Tast.sname) env.structs;
|
||
datas = values (fun (u : Tast.data) -> u.Tast.dname) env.datas;
|
||
unions = values (fun (u : Tast.structure) -> u.Tast.sname) env.unions;
|
||
globals; externs; fns; cshim },
|
||
env)
|
||
|
||
(** The program and the environment, stopping at the first refusal. What a
|
||
session needs, and it raises [Loc.Error] and never [Loc.Errors]. *)
|
||
let program_with_env (decls : Ast.decl list) : Tast.program * env =
|
||
build_program ~keep_going:false decls
|
||
|
||
let program (decls : Ast.decl list) : Tast.program =
|
||
fst (build_program ~keep_going:false decls)
|
||
|
||
(** The same, reporting every declaration whose body it refuses rather than the
|
||
first. Raises [Loc.Errors], so only a caller prepared for a list should be
|
||
calling it. *)
|
||
let program_all (decls : Ast.decl list) : Tast.program =
|
||
fst (build_program ~keep_going:true decls)
|
||
|
||
(* ── What a session needs to know about instantiations ──────────────────
|
||
A generic [defn] never reaches [Tast.fns] — only its copies do — so the
|
||
editor's [C-c C-c], which installs the bodies named by the form it was
|
||
sent, would install nothing at all for a generic. These are what
|
||
[Session.eval] expands the name with. They are here rather than there
|
||
because [env]'s tables are the only record that a symbol was ever generic:
|
||
past this module an instantiation is an ordinary function and nothing knows
|
||
it was written once. *)
|
||
|
||
(* Is this name a generic definition rather than an ordinary one? *)
|
||
let is_generic env n = Hashtbl.mem env.gsigs n
|
||
|
||
(* Every copy of [gname] this check produced, by symbol. Transitivity needs no
|
||
walk: a whole-program check has already generated every copy every call
|
||
site asked for, including the ones a generic pulled in by calling another
|
||
generic at its own variable. *)
|
||
let instantiations env gname =
|
||
match Hashtbl.find_opt env.insts gname with
|
||
| None -> []
|
||
| Some l -> List.rev_map (fun (_, _, sym) -> sym) !l
|
||
|
||
(* The generic a symbol came from, and the types it was asked for — [None] for
|
||
an ordinary function. What a refusal about [sort!-i32] needs in order to
|
||
say which line the programmer should look at, since [sort!-i32] appears
|
||
nowhere in the source. *)
|
||
let instantiation_origin env sym =
|
||
Hashtbl.fold
|
||
(fun gname l acc ->
|
||
match acc with
|
||
| Some _ -> acc
|
||
| None ->
|
||
(match List.find_opt (fun (_, _, s) -> String.equal s sym) !l with
|
||
| Some (ps, _, _) -> Some (gname, ps)
|
||
| None -> None))
|
||
env.insts None
|
||
|
||
(* Checking one expression against a live session can *generate* a copy: the
|
||
first [C-x C-e] of [(id 3)] instantiates [id] at [i32] and the copy is in
|
||
[env.instances] and in no program anywhere. Without these two the module
|
||
that gets built calls a symbol it never defined. A mark before and the
|
||
difference after is the whole protocol. *)
|
||
let instance_mark env = List.length env.instances
|
||
|
||
let instances_since env mark =
|
||
let fresh = List.length env.instances - mark in
|
||
List.rev
|
||
(List.filteri (fun i _ -> i < fresh) env.instances)
|
||
|
||
(* One expression, checked against a program that is already running. The
|
||
frame is empty — a REPL expression has no parameters and no enclosing
|
||
function — so the slots it needs are whatever its own [let]s allocate. *)
|
||
let expression env (e : Ast.expr) :
|
||
Tast.expr * Types.t array * string option array =
|
||
let ctx =
|
||
{ env; ret = Types.Unit; slots = 0; slot_tys = []; slot_names = []; scope = []; defers = [];
|
||
outer = []; outer_what = None; in_frames = None; loops = []; tail = false; in_defer = false; defer_ok = false; defer_block = "a nested form"; owner = "<none>" }
|
||
in
|
||
let t = check ctx e in
|
||
(t, Array.of_list (List.rev ctx.slot_tys),
|
||
Array.of_list (List.rev ctx.slot_names))
|