JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
flan/lib/check.ml
Joseph Ferano 26c53e0a19 Every defn in the tree states its return type, and Unit is written () 
The mechanical half, ahead of the parser change that needs it. tools/unit-return.py
fills the empty slot with () and rewrites Unit as () wherever a type is spelled --
(Fn [i32] Unit), (Map i32 Unit), a return type written out.

Deciding whether a defn already had a return type is the whole difficulty, and
the script does it the way parse.ml did: is_type_form is transcribed rather than
improved, because being identical to the parser it replaces is what makes the
sweep meaning-preserving. It is re-runnable, so the lanes that branched before
this can have the same pass at merge:

    python3 tools/unit-return.py .
    python3 tools/unit-return.py --in-strings test/test_flan.ml test/test_acceptance.ml \
        test/test_session.ml emacs/test-flan-dev.el emacs/test-flan-mode.el
    python3 tools/unit-return.py --raw-ml lib/prelude.ml
    python3 tools/unit-return.py --in-html web/index.html

-v logs every defn it saw and what it decided, which is how a sweep of 440 sites
gets reviewed at all. Embedded modes pool a file's type declarations across all
its fragments, because a snippet split across concatenation -- decls ^ "(defn f
[s [u8]] Cursor ...)" -- cannot see the names the other half declared; pooled
names count only in bare-symbol position, for the same reason the prelude's do.
A fragment that cuts off mid-form is skipped rather than guessed at. Five sites
in test_flan.ml still needed a hand, and they are in this commit.

Two things ride along because the sweep needs them: parse.ml reads a lone () as
the return type of a function with no body, which was not a shape the old
optional slot could produce; and the map refusals name () rather than Unit, since
that is now the spelling a caller wrote.
2026-09-12 23:06:40 +07:00

4195 lines
197 KiB
OCaml
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

(** 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 unions, 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;
unions : (string, Tast.union) Hashtbl.t;
(* Every union 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 union'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 unions 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;
}
let new_env () = {
structs = 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 = [];
}
(* 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
| 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 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;
(* Move tracking, spec-memory.md's "(Vec T) and (Map K V) are move-only".
[dead] is the slots whose value has been moved out, with where it went, so
that a second use names the first rather than reporting a type error about
nothing. It is flow-sensitive at an [if]: the two arms are checked from
the same starting set and the *union* survives the join, so moving in one
arm only is still a move afterwards — and moving in both arms, which is
legal, is not two errors.
[borrow] is set only while checking the *target* of an operation that
reads a container without consuming it ([at], [len], [as-slice], [push],
[reserve], [clone]). Without it every one of those would look like a move
and no program could push twice. *)
mutable dead : (int * Loc.t) list;
mutable borrow : 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
raise
(Loc.Error
(loc,
Printf.sprintf
"%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
(* ── (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 loc (k : Types.t) (v : Types.t) =
(* The value. The restriction is the one [(Vec (Vec T))] already carries,
for the identical reason: the runtime copies and releases entries
bytewise, so an owning value would have its header duplicated by clone
and its buffer dropped on the floor by free. *)
if Types.is_move_only v then
fail loc
"(Map %s %s) holds a move-only value, and the type-erased runtime \
copies entries bytewise — so clone would duplicate headers instead of \
copying, and free would leak what they own. Owned entries arrive with \
drop (step 5 in NEXT.md)"
(Types.to_string k) (Types.to_string v);
(* () 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 of
move-only type is refused and a local needs (map-new). *)
if not (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 union'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 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 is representable and would be wrong. spec-memory.md
makes [clone] a deep copy and makes [free] recurse structurally into
owning fields; the type-erased runtime does neither — it memcpys, so
a clone would duplicate inner headers and a free would drop their
buffers on the floor. Recursive teardown is what step 5's [drop]
brings, and this is refused until it does rather than shipping the
shallow answer under the deep name. *)
if Types.is_move_only e then
fail loc
"(Vec %s) holds a move-only element, and the type-erased runtime \
copies and releases elements bytewise — so clone would duplicate \
headers instead of copying, and free would leak what they own. \
Recursive teardown arrives with drop (step 5 in NEXT.md)"
(Types.to_string e);
Types.Vec e
| "Vec", _ -> fail loc "(Vec T) takes exactly one type"
| "Map", [ k; v ] ->
map_type 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
| "Handle", _ -> unimplemented loc "(Handle T)" 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.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 =
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 union 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 union be a field, a parameter, a
return type and a slot without a single one of those paths learning
that unions exist. *)
| _ 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 ->
fail 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
| _ -> fail 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)
(* ── 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))
(* ── 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 ]))
(* 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 = [];
in_defer = false; defer_ok = false; defer_block = "a nested form";
dead = []; borrow = false; 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
| 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 union 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.unions n ->
fail loc
"%s is a union, and a union 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
| 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)
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;
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 -> 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. *)
| Ast.Let (bs, body) -> check_let ctx ?want ~defer_ok loc bs body
| Ast.If (c, t, e') -> check_if ctx ?want loc c t e'
| Ast.While (label, c, body) ->
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. *)
| 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 = Hashtbl.find ctx.env.structs sname in
(match Tast.field_index s name with
| None -> fail loc "%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 ?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 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 ->
if Types.is_move_only b.bty then moved ~ty:b.bty ctx loc name b.slot;
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 (uname, 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 uname)
(Tast.MakeCase (uname, c.Tast.vname, [])))
| Some (uname, c) ->
fail loc
"%s is a case of the union %s, and a union value names both — \
write %s.%s" name uname uname 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; fail loc "unknown name %s" name)
(* Reading a move-only local. Every read is a move unless the site said it was
a borrow, which is the conservative direction: passing one to a function,
binding it, returning it and [free]ing it are all moves and all reach here,
and the handful of operations that only look at a container say so. *)
and moved ?ty ctx loc name slot =
(match List.assoc_opt slot ctx.dead with
| Some where ->
fail loc
"%s was moved at %s and cannot be used again — %s is move-only, so \
binding, passing or returning one transfers ownership and the source \
binding is dead afterwards (spec-memory.md). That rule is what makes a \
double free unrepresentable; (clone %s) if you wanted a second one"
name (Loc.to_string where)
(match ty with Some t -> Types.to_string t | None -> "a Vec") name
| None -> ());
if not ctx.borrow then ctx.dead <- (slot, loc) :: ctx.dead
(* The target of an operation that reads a container without consuming it. Only
a syntactically simple target is treated as a borrow: in [(len (f v))] the
call still moves [v], and setting the flag over the whole subexpression
would have hidden that. *)
and borrowed ctx (a : Ast.expr) f =
let simple =
match a.Ast.e with
| Ast.Var _ | Ast.Field _ -> true
| Ast.Call ({ Ast.e = Ast.Var "at"; _ }, _) -> true
| _ -> false
in
if not simple then f ()
else begin
let saved = ctx.borrow in
ctx.borrow <- true;
let r = f () in
ctx.borrow <- saved;
r
end
(* [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
| [] -> expect loc ~want (unit_at loc)
| _ ->
let rec go = function
| [ last ] ->
ctx.defer_ok <- defer_ok;
let l = check ctx ?want last in [ l ], l.Tast.ty
| x :: rest ->
ctx.defer_ok <- defer_ok;
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 = [];
in_defer = false; defer_ok = false; defer_block = "a nested form";
dead = []; borrow = false; 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 = []; in_defer = false; defer_ok = false; defer_block = "a nested form"; dead = []; borrow = false; 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 ?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
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. *)
(* A loop body that moves a binding declared outside the loop is refused, and
this is the one place the dead set cannot answer on its own: the second
iteration would use what the first moved, and a set that is merged once at
the end of the body sees one move, not two. So it is a rule rather than an
inference, stated as one. *)
and in_loop ctx ?label f =
let outer_slots = List.map (fun (_, b) -> b.slot) ctx.scope in
let before = ctx.dead in
(* 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 <- Lloop label :: loops;
(* Named so that a defer written in here is refused as "a loop body" rather
than as a nested form: the reason is specific — it would fire once at
function exit rather than once per iteration — and the message says it. *)
let blocker = ctx.defer_block in
ctx.defer_block <- "a loop body";
let r = f () in
ctx.defer_block <- blocker;
ctx.loops <- loops;
List.iter
(fun (slot, where) ->
if (not (List.mem_assoc slot before)) && List.mem slot outer_slots then
fail where
"this moves a value that was bound outside the loop, so the next \
iteration would use what this one gave away. Move it out of the \
loop, or bind a fresh value inside it")
ctx.dead;
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)
| 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 ]))))
and check_if ctx ?want loc c t e =
let c = check ctx ~want:Types.Bool c 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 () -> check ctx t) in
expect loc ~want (mk loc Types.Unit (Tast.If (c, t, unit_at loc)))
| Some e ->
(* Both arms start from the same dead set and the union survives: moving in
one arm only still kills the binding afterwards, and moving in both —
which is legal and common — is not reported twice. A flat set would have
refused [(if c (free v) (free v))] and allowed the use after a one-armed
move, which are the two ways to be wrong here. *)
let before = ctx.dead in
let t = branch ctx (fun () -> check ctx ?want t) in
let after_then = ctx.dead in
ctx.dead <- before;
(* 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 () -> check ctx ?want:ewant e) in
ctx.dead <-
after_then
@ List.filter (fun (k, _) -> not (List.mem_assoc k after_then)) ctx.dead;
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 union 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 ->
(match Hashtbl.find_opt ctx.env.cases name with
(* The full spelling [U.C], which is how a union value is written. Checked
before the diagnostics below, since the bare-name entry in the same
table is only ever a hint. *)
| Some (uname, c) when String.contains name '.' ->
check_case ctx ~want loc uname 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 union 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 (uname, c) ->
fail loc
"%s is a case of the union %s, not a struct — a union value names \
both, as (%s.%s {.field value ...})"
name uname uname c.Tast.vname
| None ->
if Hashtbl.mem ctx.env.unions name then
fail loc
"%s is a union, and a union 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 fail loc "unknown struct %s" name)
| Some s ->
let seen = Hashtbl.create 8 in
List.iter
(fun (k, (v : Ast.expr)) ->
if Hashtbl.mem seen k then
fail v.Ast.loc "field %s is given twice" k;
if Tast.field_index s k = None then
fail v.Ast.loc "%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)))
(* The cases of a union, as written, for a message that has to name them. *)
and case_list env uname =
match Hashtbl.find_opt env.unions uname with
| None -> "its cases"
| Some u ->
String.concat ", "
(List.map (fun (c : Tast.variant) -> uname ^ "." ^ c.Tast.vname)
u.Tast.cases)
and first_case_name env uname =
match Hashtbl.find_opt env.unions uname 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 uname (c : Tast.variant) kvs =
let full = uname ^ "." ^ c.Tast.vname in
let seen = Hashtbl.create 8 in
List.iter
(fun (k, (v : Ast.expr)) ->
if Hashtbl.mem seen k then fail v.Ast.loc "field %s is given twice" k;
if Tast.vfield_index c k = None then
fail v.Ast.loc "%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 uname) (Tast.MakeCase (uname, 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 ?want loc scrutinee arms =
let s = check ctx scrutinee in
(* What the arms are alternatives over. An [Option] is a two-case union
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 union is
deliberate — [Option] is generic and no declared union 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.unions n ->
`Union (Hashtbl.find ctx.env.unions 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
| other ->
fail loc "match works on an Option or a union, 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
| `Union u, Ast.Pctor (c, names) ->
(* A pattern names the case bare: the scrutinee's type already says which
union, so [(Node l r)] is unambiguous even where two unions 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.uname ^ "." 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.uname
(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.uname 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
(* The same rule as [if], and for the same reason: the arms are alternatives,
so each is checked from the state before the match and the union of what
they moved survives the join. Checked in sequence against one mutating set
they would report the second arm's (free v) as a use after the first arm's
move, which is a legal program refused. *)
let before = ctx.dead in
let joined = ref [] 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 ());
ctx.dead <- before;
let arm =
branch ctx (fun () ->
let binds =
List.map
(fun (n, ty) -> bind ctx n ty ~assignable:false) binds
in
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 ] })
in
joined :=
!joined
@ List.filter (fun (k, _) -> not (List.mem_assoc k !joined)) ctx.dead;
arm)
arms
in
ctx.dead <- !joined;
(* 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 union 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" ]
| `Union u ->
List.filter_map
(fun (c : Tast.variant) ->
if Hashtbl.mem seen c.Tast.vname then None
else Some (u.Tast.uname ^ "." ^ c.Tast.vname))
u.Tast.cases
in
if not !saw_wild && missing <> [] then
fail loc
"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 target of [.field] is a struct, 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
match t.Tast.ty with
| Types.Named n when Hashtbl.mem ctx.env.structs n -> t, n
| Types.Ptr (Types.Named n) when Hashtbl.mem ctx.env.structs n ->
mk t.Tast.loc (Types.Named n) (Tast.Deref t), n
(* A union'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 union
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.unions n ->
fail target.Ast.loc
"%s is a union, and a union'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; fail loc "unknown name %s" name)
| Ast.Pfield (target, name) ->
let target, sname = struct_target ctx target in
let s = Hashtbl.find ctx.env.structs sname in
(match Tast.field_index s name with
| None -> fail loc "%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 = borrowed ctx target (fun () -> 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
if not (ok 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 union table is one of them: a union is [Named] exactly as a
struct is, so (vec-new Form) is as ordinary as (vec-new Cell). It was left
out when unions 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 =
List.mem n Types.primitive_names
|| Hashtbl.mem ctx.env.structs 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
if not (Types.is_numeric 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
if not (Types.is_comparable 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
if not (Types.is_numeric 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
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))) ],
[ alloc_guard ctx loc attempt;
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 = borrowed ctx target (fun () -> 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
expect loc ~want
(mk loc Types.Unit
(Tast.Let ([ (e, x) ], [ alloc_guard ctx loc attempt ])))
| _ -> assert false)
| "reserve" ->
arity loc name 2 args;
(match args with
| [ target; n ] ->
let target = borrowed ctx target (fun () -> 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
let attempt =
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 ]
| _ ->
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 ]
in
expect loc ~want (alloc_guard ctx loc attempt)
| _ -> 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 = borrowed ctx target (fun () -> 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. It consumes its argument exactly as
any other move does — the source binding is dead afterwards and using it
is a compile error — which is the rule that already makes a double free
unrepresentable, so [free] needs no analysis of its own. *)
| "free" ->
arity loc name 1 args;
let target = check ctx (List.hd args) in
(match target.Tast.ty with
| 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 a move-only value — a Vec, a Map, or a struct that owns \
one — 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 = borrowed ctx target (fun () -> check ctx target) in
let a = allocator_arg ctx loc rest in
(match target.Tast.ty with
(* 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) ->
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)) ],
[ alloc_guard ctx loc attempt;
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))) ],
[ alloc_guard ctx loc attempt;
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 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)) ],
[ alloc_guard ctx loc attempt;
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 = borrowed ctx target (fun () -> 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
(* 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) ], [ alloc_guard ctx loc attempt ])))
| _ -> assert false)
(* (get m k) -> (Option V). Absence is None, not an untyped nil, and the
first implementation admits copyable values only, so this is a copy.
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 = borrowed ctx target (fun () -> check ctx target) in
let kt, vt = map_kv loc "get" target.Tast.ty in
let k = check ctx ~want:kt k in
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-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 = borrowed ctx target (fun () -> 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 = borrowed ctx target (fun () -> check ctx target) in
let kt, vt = map_kv loc "has-key?" target.Tast.ty in
let k = check ctx ~want:kt k in
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 ];
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 ]);
(* 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 () ]) ]
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)
(* ── 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 = borrowed ctx target (fun () -> 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 = borrowed ctx target (fun () -> 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)
(* ── 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 one sharp edge is not new but is easier to trip over now: the slice
that i64->bytes / f64->bytes / u64->bytes answer is a view into one shared
static buffer in the runtime, overwritten by the next such call. Calling
it a string does not copy it. Use it before formatting the next number;
you cannot hold two at once. *)
| "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;
prim Tast.F64ToBytes (Types.Slice (Types.Int Types.U8))
[ check ctx ~want:(Types.Float Types.F64) (List.hd args) ]
| "i64->bytes" ->
arity loc name 1 args;
prim Tast.I64ToBytes (Types.Slice (Types.Int Types.U8))
[ 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 = borrowed ctx target (fun () -> check ctx target) in
let bslice = Types.Slice (Types.Int Types.U8) in
let write x = mk loc Types.Unit (Tast.Prim (Tast.WriteStdout, [ x ])) in
let conv pr x = mk loc bslice (Tast.Prim (pr, [ x ])) in
let emitter : Render.emitter =
{ Render.ebytes = write;
estr = (fun x -> write (conv 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 [];
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;
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 ]
| _ 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 move and capture paths for
a type that is neither move-only nor 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)
| _ ->
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.unions name then
fail loc
"%s is a union type — a union 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 uname, c = Hashtbl.find ctx.env.cases name in
fail loc
"%s is a case of the union %s — write (%s.%s {.field value ...}), \
or %s.%s on its own when it has no fields"
name uname uname c.Tast.vname uname 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 fail loc "unknown function %s" name
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, unions, 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 ->
if Hashtbl.mem claimed n then
fail d.Ast.dloc "%s is defined twice" n;
Hashtbl.add claimed n ())
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.Defunion (n, _) ->
Hashtbl.replace env.locs n d.Ast.dloc;
Hashtbl.replace env.unions n { Tast.uname = n; cases = [] }
| 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
(* spec-memory.md: "Ownership is structural, not declared" — a struct
containing a Vec is itself move-only, and freeing one recurses into
its owning fields while (free (.items b)) is refused because it
would leave the owner partly dead. None of that transitive
machinery exists yet: it is the same recursive teardown [drop]
brings, and it lands with it. Until then the field is refused at
the declaration, where the message can say so, rather than
accepted into a struct that copies its header on assignment and
gives two owners one buffer. *)
List.iter
(fun (f : Tast.field) ->
if Types.is_move_only f.Tast.fty then
fail loc
"%s's field %s is %s, which is move-only, and a struct that \
owns one is move-only too — transitively, with recursive \
teardown and with a field that cannot be freed on its own. \
That rule arrives with drop (step 5 in NEXT.md); until then \
hold the %s in a local and pass it"
n f.Tast.fname (Types.to_string f.Tast.fty)
(Types.to_string f.Tast.fty))
fields;
Hashtbl.replace env.structs n { Tast.sname = n; fields }
| Ast.Defunion (n, vs) ->
(* A union 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 union is \
(defunion %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 =
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
(* The same refusal a struct field gets, for the same reason
and in the same words: a union case's fields are a struct,
the union copies bytewise on assignment, and recursive
teardown arrives with [drop]. Refusing it here rather than
at a use keeps the two declarations honest with each other
— a union that could hold a Vec where a struct could not
would be a hole in the same rule. *)
List.iter
(fun (f : Tast.field) ->
if Types.is_move_only f.Tast.fty then
fail v.Ast.vloc
"%s.%s's field %s is %s, which is move-only, and a \
union case that owns one makes the union move-only \
too — transitively, with recursive teardown. That \
rule arrives with drop (step 5 in NEXT.md); until \
then hold the %s in a local and pass it"
n v.Ast.vname f.Tast.fname (Types.to_string f.Tast.fty)
(Types.to_string f.Tast.fty))
vfields;
{ Tast.vname = v.Ast.vname; vfields })
vs
in
Hashtbl.replace env.unions n { Tast.uname = n; cases };
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
| Ast.Defn fn ->
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
Hashtbl.replace env.fns fn.Ast.name (params, ret)
| 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 = []; in_defer = false; defer_ok = false; defer_block = "a nested form"; dead = []; borrow = false; 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.unions name with
| None -> ()
| 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
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.unions
(* ── Declarations: pass 2, check bodies ────────────────────────────── *)
let 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 = []; in_defer = false; defer_ok = false; defer_block = "a nested form"; dead = []; borrow = false;
owner = fn.Ast.name } in
List.iter2
(fun (p : Ast.field) ty ->
if List.mem_assoc p.Ast.fname ctx.scope then
fail p.Ast.floc "%s has two parameters named %s" fn.Ast.name p.Ast.fname;
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 }
(* A global of move-only type is refused. The dead set is per function, so two
functions each freeing the same global is a double free nothing here could
see; and within one function a global read does not go through [var]'s move
path at all, so even the local case would be accepted. Rather than half a
rule, the type is refused where it is declared. A global *Allocator* is not
this — an allocator is a copyable opaque handle — which is what makes the
handler-owns-the-arena shape in exhausted.flan expressible. *)
let no_move_only_global loc n (ty : Types.t) =
no_zeroed_fn loc (Printf.sprintf "the global %s" n) ty;
if Types.is_move_only ty then
fail loc
"the global %s is %s, which is move-only, and ownership of a global \
cannot be tracked: the dead set is per function, so two functions each \
freeing it is a double free nothing would catch. Hold it in a local and \
pass it, or hold the allocator globally instead"
n (Types.to_string ty)
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 = []; in_defer = false; defer_ok = false; defer_block = "a nested form"; dead = []; borrow = false; owner = "<none>" } in
match d.Ast.d with
| Ast.Defvar (n, _, init) ->
let ty, _ = Hashtbl.find env.globals n in
no_move_only_global d.Ast.dloc n ty;
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 union 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.unions un ->
fail d.Ast.dloc
"%s is a union, 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.unions 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 -> check (ctx ()) ~want:ty 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_move_only_global 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
(* [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. *)
let check_main env =
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 Loc.unknown
"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 Loc.unknown "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. *)
let program_with_env (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
collect env decls;
check_finite env;
check_main env;
let globals = List.filter_map (check_global env) decls in
let fns =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with
| Ast.Defn fn -> Some (check_fn env fn)
| _ -> None)
decls
in
(* 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
(* 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;
unions = values (fun (u : Tast.union) -> u.Tast.uname) env.unions;
globals; externs; fns; cshim },
env)
let program (decls : Ast.decl list) : Tast.program = fst (program_with_env decls)
(* 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 = []; in_defer = false; defer_ok = false; defer_block = "a nested form"; dead = []; borrow = false; 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))
Reference in New Issue View Git Blame Copy Permalink