Joseph Ferano
6ebcea6d3a
flan_dev_reg_dead was reaching for the containment scan, and it is on the free path: a dev build would have paid a 4096-entry sweep per free. A free hands back the base address the allocator gave out, which is what the slot is keyed on, so the question there is equality and never containment. Only free-all needs the scan, and that runs once a frame. The table is allocated when it is armed, not declared. A fixed array was a quarter of a megabyte of BSS in a shipped game for a table that build never writes; now a release build carries a null pointer and the not-taken branch. The pointer arm binds its subject to a slot before naming it three times — the slice arm's rule, and its reason: an inspect with a path reaches a leaf through a bounds check, and three of those to render one pointer is the walk paying for its own shape. dev-ptr.flan shows both halves on a stopped stack. It was read by hand; the test_dev.ml case that would drive it is another lane's file, and NEXT.md says so.
361 lines
17 KiB
OCaml
361 lines
17 KiB
OCaml
(** The structural printer: a compile-time walk over a [Tast] type that emits
|
|
the calls which print a value of it.
|
|
|
|
It lives apart from its two callers because there are two, and they differ
|
|
in exactly one thing: where the pieces go. The REPL sends them to
|
|
[flan_dev_emit] ([session.ml]); [println] sends them to stdout
|
|
([check.ml]). Everything else — which arm a type takes, how an enum
|
|
recovers its member names, the depth and span caps — has to be the same in
|
|
both, and the way to make it the same is to have one copy.
|
|
|
|
Why the walk is at compile time at all: a Flan value carries no header, so
|
|
nothing at run time could say what it is. The compiler knows the type and
|
|
renders it there. And why it emits piecewise rather than building a string:
|
|
a struct is its fields with punctuation between them, and concatenating
|
|
that would need an allocator the language does not have.
|
|
|
|
The emitter is five functions rather than five names because the two sides
|
|
are not both extern calls. The REPL's are ([flan_dev_emit_i64] takes an
|
|
i64); stdout's compose a conversion with a write — [(write-stdout
|
|
(i64->bytes x))] — and a name alone cannot say that. *)
|
|
|
|
(* Each takes a value of the type its field is named for and returns a Unit
|
|
expression that prints it. [estr] is handed a [u8] slice and is expected to
|
|
quote and escape it: it is the *nested* string case, the one inside a struct
|
|
or an array, where an unquoted run of bytes could not be told from the
|
|
punctuation around it. A caller that wants a string printed raw does not go
|
|
through the walk at all. *)
|
|
type emitter = {
|
|
ebytes : Tast.expr -> Tast.expr; (* [u8], verbatim: punctuation and literals *)
|
|
estr : Tast.expr -> Tast.expr; (* [u8], quoted and escaped *)
|
|
ei64 : Tast.expr -> Tast.expr;
|
|
eu64 : Tast.expr -> Tast.expr;
|
|
ef64 : Tast.expr -> Tast.expr;
|
|
}
|
|
|
|
(* What a walk is allowed to do with a pointer, and it is exactly two
|
|
questions. Both are asked of the allocation registry (runtime/flan_dev.c),
|
|
which is the only thing in the program that can answer either: a Flan value
|
|
carries no header, so the *type* at the far end is known here and statically
|
|
— (Ptr Enemy) says Enemy — while whether the storage is still there is not
|
|
knowable at compile time at all.
|
|
|
|
A record of functions rather than two names, for the reason the emitter is
|
|
one: only the REPL's side has these. [println] passes [None] and keeps
|
|
printing [<ptr>], which is what spec-memory.md says it prints and what the
|
|
acceptance table reads back. Following a pointer in a printed line would
|
|
also cost every release build the two calls, and a release build has no
|
|
registry to call. *)
|
|
type pointers = {
|
|
live : Tast.expr -> Tast.expr; (* a (Ptr a) -> bool: may it be read *)
|
|
(* Emits what the registry remembers about a dead address, and emits nothing
|
|
at all for one it never saw — a stack local is not in it by design, and
|
|
inventing a sentence about one would be worse than the silence [<ptr>]
|
|
already is. *)
|
|
epitaph : Tast.expr -> Tast.expr; (* a (Ptr a) -> unit *)
|
|
}
|
|
|
|
type ctx = {
|
|
structs : Tast.structure list;
|
|
(* The declared unions. [Types.Named] covers a struct and a union alike, so
|
|
which list the name is in is what says which this is — the same
|
|
arrangement the checker and the emitter use. *)
|
|
unions : Tast.union list;
|
|
enums : (string * (string * int64) list) list;
|
|
emit : emitter;
|
|
(* [None] in a build with no registry to ask, which is every release build
|
|
and every [println]. See [pointers]. *)
|
|
ptrs : pointers option;
|
|
(* A slot in the *caller's* frame. Only the slice arm needs one, and it needs
|
|
two: the slice itself, so the expression it came from is evaluated once
|
|
rather than once per element, and the loop counter. Who owns the frame
|
|
differs — the REPL's is a thunk it is building, [println]'s is the user
|
|
function being checked — so allocating one is the caller's to do. *)
|
|
alloc : Types.t -> int;
|
|
}
|
|
|
|
(* Two separate limits, easily conflated. [depth] and [span] bound the *walk*,
|
|
so a big fixed array or a self-containing struct cannot turn one expression
|
|
into a module with ten thousand render sites in it. How much text actually
|
|
comes out is bounded in the runtime instead, once, for every renderer. *)
|
|
let max_depth = 4
|
|
let max_span = 8
|
|
|
|
let fail = Loc.fail
|
|
|
|
let rec render c depth (e : Tast.expr) : Tast.expr list =
|
|
let loc = e.Tast.loc in
|
|
let unit_ e = { Tast.e; ty = Types.Unit; loc } in
|
|
let cast t x = { Tast.e = Tast.Prim (Tast.Cast t, [ x ]); ty = t; loc } in
|
|
let bytes_of s =
|
|
{ Tast.e = Tast.Prim (Tast.Bytes, [ { Tast.e = Tast.Str s; ty = Types.String; loc } ]);
|
|
ty = Types.Slice (Types.Int Types.U8); loc }
|
|
in
|
|
let lit s = c.emit.ebytes (bytes_of s) in
|
|
let int64 n = { Tast.e = Tast.Int (n, Types.I64); ty = Types.Int Types.I64; loc } in
|
|
let i32 n =
|
|
{ Tast.e = Tast.Int (Int64.of_int n, Types.I32); ty = Types.Int Types.I32; loc }
|
|
in
|
|
let do_ xs = unit_ (Tast.Do xs) in
|
|
if depth > max_depth then [ lit "..." ]
|
|
else
|
|
match e.Tast.ty with
|
|
| Types.Int Types.U64 -> [ c.emit.eu64 e ]
|
|
| Types.Int _ -> [ c.emit.ei64 (cast (Types.Int Types.I64) e) ]
|
|
| Types.Float _ -> [ c.emit.ef64 (cast (Types.Float Types.F64) e) ]
|
|
| Types.Bool ->
|
|
[ unit_ (Tast.If (e, lit "true", lit "false")) ]
|
|
(* Evaluated *and then* reported. A Unit expression is almost always a call
|
|
made for its effect — (println "x") is the REPL's most ordinary
|
|
input — so emitting the literal without running it would make the prompt
|
|
answer () while nothing happened. *)
|
|
| Types.Unit -> [ e; lit "()" ]
|
|
| Types.String ->
|
|
[ c.emit.estr
|
|
{ Tast.e = Tast.Prim (Tast.Bytes, [ e ]);
|
|
ty = Types.Slice (Types.Int Types.U8); loc } ]
|
|
(* Bytes are almost always text, and escaping makes the case where they are
|
|
not readable rather than a mess. *)
|
|
| Types.Slice (Types.Int Types.U8) -> [ c.emit.estr e ]
|
|
(* An enum's members are erased to i32 before the backend sees them, so the
|
|
name has to be recovered here, from the checker's table, as a chain of
|
|
comparisons. Falling through to the number is not a failure: a value
|
|
outside the declared members is exactly what you would want to see. *)
|
|
| Types.Enum n ->
|
|
let members = try List.assoc n c.enums with Not_found -> [] in
|
|
let number = c.emit.ei64 (cast (Types.Int Types.I64) e) in
|
|
List.fold_left
|
|
(fun otherwise (name, v) ->
|
|
let is =
|
|
{ Tast.e =
|
|
Tast.Prim (Tast.Eq,
|
|
[ cast (Types.Int Types.I64) e; int64 v ]);
|
|
ty = Types.Bool; loc }
|
|
in
|
|
unit_ (Tast.If (is, lit (":" ^ name), otherwise)))
|
|
number members
|
|
|> fun x -> [ x ]
|
|
(* A pointer with nobody to ask is rendered as its shape and never
|
|
followed: it is the only thing that could make this walk cycle, and
|
|
dereferencing one a REPL was handed is not a safe thing to do on
|
|
someone's behalf.
|
|
|
|
The registry is the somebody to ask, and it changes only the second half
|
|
of that sentence. The type at the far end was never the difficulty —
|
|
(Ptr Enemy) says Enemy, here, at compile time. What was missing is
|
|
*permission*, and an allocation registry is exactly a record of which
|
|
addresses it is still true to read. So a live pointer is followed and
|
|
its pointee rendered by the same walk as anything else, one level
|
|
deeper, which the depth cap bounds the way it bounds a self-containing
|
|
struct. A dead one names what died instead of showing bytes that are no
|
|
longer what they say, which is the whole difference between an
|
|
inspector and a hex dump.
|
|
|
|
An address the registry never saw is neither: it prints [<ptr>]. That
|
|
is a stack local, a global, or a pointer from C, and the shadow stack
|
|
and the static type table already answer for the first two by name. *)
|
|
| Types.Ptr t ->
|
|
(match c.ptrs with
|
|
| None -> [ lit "<ptr>" ]
|
|
| Some pt ->
|
|
(* Into a slot first, the slice arm's rule and for its reason: this
|
|
arm names the pointer three times — asked about, followed, and
|
|
mourned — and the expression it came from may be a call. An
|
|
[inspect] with a path reaches a leaf through [flan_vec_at], which
|
|
is a bounds check and a transfer guard; three of those to render
|
|
one pointer would be the walk paying for its own shape. *)
|
|
let pv = c.alloc e.Tast.ty in
|
|
let p () = { Tast.e = Tast.Local pv; ty = e.Tast.ty; loc } in
|
|
let inner =
|
|
do_ ([ lit "<ptr " ]
|
|
@ render c (depth + 1) { Tast.e = Tast.Deref (p ()); ty = t; loc }
|
|
@ [ lit ">" ])
|
|
in
|
|
let gone = do_ [ lit "<ptr"; pt.epitaph (p ()); lit ">" ] in
|
|
[ unit_
|
|
(Tast.Let ([ (pv, e) ],
|
|
[ unit_ (Tast.If (pt.live (p ()), inner, gone)) ])) ])
|
|
(* Opaque on purpose, and for the same reason: its contents are the
|
|
runtime's, its address is not stable across runs, and printing either
|
|
would make an acceptance test's output depend on the heap. *)
|
|
| Types.Alloc -> [ lit "<allocator>" ]
|
|
(* Printing a Vec structurally would be a walk over storage this function
|
|
does not own, and the walk is what [as-slice] is for: (print (as-slice
|
|
v)) prints the elements and says at the call site that it borrowed. *)
|
|
| Types.Vec _ -> [ lit "<vec>" ]
|
|
(* Opaque for the reason a Vec is: the slots are storage this function does
|
|
not own, and a walk over them would print the dead ones too — there is
|
|
no way to say "dead" inside a rendered element. (pool-handle p i) and
|
|
(resolve p h) are how a program looks, and they say it. *)
|
|
| Types.Pool _ -> [ lit "<pool>" ]
|
|
(* Its identity, which is what spec-memory.md says a handle prints —
|
|
"Ptr and Handle print their address or identity rather than recursively
|
|
dereferencing". Shown as index:generation rather than as the packed
|
|
number, because those are the two things a reader is trying to tell
|
|
apart when two handles disagree. *)
|
|
| Types.Handle _ ->
|
|
let h = cast (Types.Int Types.U64) e in
|
|
let u64 v = { Tast.e = v; ty = Types.Int Types.U64; loc } in
|
|
let idx =
|
|
u64 (Tast.Prim (Tast.BitAnd,
|
|
[ h; u64 (Tast.Int (0xFFFFFFFFL, Types.U64)) ]))
|
|
in
|
|
let gen =
|
|
u64 (Tast.Prim (Tast.Shr, [ h; u64 (Tast.Int (32L, Types.U64)) ]))
|
|
in
|
|
[ do_ [ lit "<handle "; c.emit.eu64 idx; lit ":"; c.emit.eu64 gen;
|
|
lit ">" ] ]
|
|
(* A function value is a code address, and printing the address would make
|
|
an inspection depend on where the image loaded. The signature is what a
|
|
reader can act on, so that is what is shown — and the inspector reaches
|
|
every local of a stopped frame, so a frame holding one has to render
|
|
rather than refuse. *)
|
|
| Types.Fn _ as ft -> [ lit ("<" ^ Types.to_string ft ^ ">") ]
|
|
| Types.Option t ->
|
|
let tag = { Tast.e = Tast.Field (e, 0); ty = Types.Int Types.I8; loc } in
|
|
let some = { Tast.e = Tast.Field (e, 1); ty = t; loc } in
|
|
let is_some =
|
|
{ Tast.e =
|
|
Tast.Prim (Tast.Ne,
|
|
[ tag; { Tast.e = Tast.Int (0L, Types.I8);
|
|
ty = Types.Int Types.I8; loc } ]);
|
|
ty = Types.Bool; loc }
|
|
in
|
|
[ unit_
|
|
(Tast.If (is_some,
|
|
do_ ((lit "(some " :: render c (depth + 1) some) @ [ lit ")" ]),
|
|
lit "none")) ]
|
|
(* A union, printed as the source would write it: the case is recovered
|
|
from the tag by a chain of comparisons, exactly as an enum's member name
|
|
is, and only the case in hand has its fields read. Reading the others
|
|
would be reading a payload that is not there. *)
|
|
| Types.Named n
|
|
when List.exists (fun (u : Tast.union) -> String.equal u.Tast.uname n)
|
|
c.unions ->
|
|
let u =
|
|
List.find (fun (u : Tast.union) -> String.equal u.Tast.uname n) c.unions
|
|
in
|
|
let tag = { Tast.e = Tast.Field (e, 0); ty = Types.Int Types.I32; loc } in
|
|
let one i (v : Tast.variant) otherwise =
|
|
let is =
|
|
{ Tast.e =
|
|
Tast.Prim (Tast.Eq,
|
|
[ tag; { Tast.e = Tast.Int (Int64.of_int i, Types.I32);
|
|
ty = Types.Int Types.I32; loc } ]);
|
|
ty = Types.Bool; loc }
|
|
in
|
|
let full = n ^ "." ^ v.Tast.vname in
|
|
let body =
|
|
if v.Tast.vfields = [] then lit full
|
|
else
|
|
let shown = List.filteri (fun i _ -> i < max_span) v.Tast.vfields in
|
|
let parts =
|
|
List.concat
|
|
(List.mapi
|
|
(fun i (f : Tast.field) ->
|
|
let fv =
|
|
{ Tast.e = Tast.CaseField (e, v.Tast.vname, i);
|
|
ty = f.Tast.fty; loc }
|
|
in
|
|
(if i = 0 then [] else [ lit " " ])
|
|
@ [ lit ("." ^ f.Tast.fname ^ " ") ]
|
|
@ render c (depth + 1) fv)
|
|
shown)
|
|
in
|
|
do_ ((lit ("(" ^ full ^ " {") :: parts)
|
|
@ (if List.length v.Tast.vfields > max_span then [ lit " ..." ]
|
|
else [])
|
|
@ [ lit "})" ])
|
|
in
|
|
unit_ (Tast.If (is, body, otherwise))
|
|
in
|
|
(* The fallback is a tag no case names, which only a scribbled-over union
|
|
could hold. Showing the number is more use than showing a case it is
|
|
not. *)
|
|
let base =
|
|
do_ [ lit ("<" ^ n ^ " tag ");
|
|
c.emit.ei64 (cast (Types.Int Types.I64) tag); lit ">" ]
|
|
in
|
|
[ List.fold_left (fun acc x -> x acc) base
|
|
(List.rev (List.mapi one u.Tast.cases)) ]
|
|
| Types.Named n ->
|
|
(match
|
|
List.find_opt (fun (s : Tast.structure) -> String.equal s.Tast.sname n)
|
|
c.structs
|
|
with
|
|
| None -> [ lit ("<" ^ n ^ ">") ]
|
|
| Some st ->
|
|
let fields = st.Tast.fields in
|
|
let shown = List.filteri (fun i _ -> i < max_span) fields in
|
|
let parts =
|
|
List.concat
|
|
(List.mapi
|
|
(fun i (f : Tast.field) ->
|
|
let v = { Tast.e = Tast.Field (e, i); ty = f.Tast.fty; loc } in
|
|
(if i = 0 then [] else [ lit " " ])
|
|
(* A dot, matching the source spelling a struct literal
|
|
is written in. This printed form is a wire format --
|
|
emacs/flan-inspect.el parses it back to build the field
|
|
list -- so the two moved together; see that file's
|
|
[flan-inspect--read-struct]. *)
|
|
@ [ lit ("." ^ f.Tast.fname ^ " ") ]
|
|
@ render c (depth + 1) v)
|
|
shown)
|
|
in
|
|
[ do_ ((lit ("(" ^ n ^ " {") :: parts)
|
|
@ (if List.length fields > max_span then [ lit " ..." ] else [])
|
|
@ [ lit "})" ]) ])
|
|
(* A fixed array's length is in its type, so it unrolls — capped, because
|
|
sand's grid is [100 [100 u32]] and unrolling that is ten thousand render
|
|
sites in one module. *)
|
|
| Types.Array (n, t) ->
|
|
let shown = min (Int64.to_int n) max_span in
|
|
let parts =
|
|
List.concat
|
|
(List.init shown (fun i ->
|
|
let v =
|
|
{ Tast.e = Tast.Prim (Tast.At, [ e; i32 i ]); ty = t; loc }
|
|
in
|
|
lit " " :: render c (depth + 1) v))
|
|
in
|
|
[ do_ ((lit "[" :: parts)
|
|
@ (if Int64.to_int n > shown then [ lit " ..." ] else [])
|
|
@ [ lit "]" ]) ]
|
|
(* A slice's length is not known until it runs, so this is the one case
|
|
that needs a loop. The slice goes into a slot first: the expression it
|
|
came from must not be evaluated once per element. *)
|
|
| Types.Slice t ->
|
|
let sv = c.alloc e.Tast.ty and iv = c.alloc (Types.Int Types.I32) in
|
|
let local i ty = { Tast.e = Tast.Local i; ty; loc } in
|
|
let len =
|
|
{ Tast.e = Tast.Prim (Tast.Len, [ local sv e.Tast.ty ]);
|
|
ty = Types.Int Types.I32; loc }
|
|
in
|
|
let cond =
|
|
{ Tast.e = Tast.Prim (Tast.Lt, [ local iv (Types.Int Types.I32); len ]);
|
|
ty = Types.Bool; loc }
|
|
in
|
|
let elem =
|
|
{ Tast.e =
|
|
Tast.Prim (Tast.At, [ local sv e.Tast.ty; local iv (Types.Int Types.I32) ]);
|
|
ty = t; loc }
|
|
in
|
|
let step =
|
|
unit_
|
|
(Tast.Set
|
|
(Tast.Plocal iv,
|
|
{ Tast.e =
|
|
Tast.Prim (Tast.Add, [ local iv (Types.Int Types.I32); i32 1 ]);
|
|
ty = Types.Int Types.I32; loc }))
|
|
in
|
|
[ unit_
|
|
(Tast.Let
|
|
([ (sv, e); (iv, i32 0) ],
|
|
[ lit "[";
|
|
unit_
|
|
(Tast.While
|
|
(cond, lit " " :: render c (depth + 1) elem, [ step ]));
|
|
lit "]" ])) ]
|
|
| t ->
|
|
fail loc "no printer for %s" (Types.to_string t)
|