Joseph Ferano
008165335d
return is refused inside handler-bind and restart-case blanketly, and rightly: a return always crosses the frames they pushed. A break does not. A loop written wholly inside a restart-case body has a perfectly good local break, so the rule is a barrier on the loop stack rather than a flag — a jump is refused exactly when a barrier stands between it and the loop it names, and the message says which construct. handler-bind and restart-case bodies are barriers, so is a restart clause, so are a defer's forms; a handler clause is lifted into its own function and needs no rule at all. in_frames is untouched: a return is the special case where the target is always outside every barrier. continue wanted the other blocker. check_dotimes folded its step onto the end of the body, which a continue would jump past, so the counter would never advance and the loop would hang. Tast.While carries a latch now — condition, body, latch — the step goes there, and emit_while emits four blocks. A while's latch is empty and folds away. Labels are Odin's, in the head position: (while :outer c ...) and (break :outer). A keyword there is unambiguous because a loop condition is never one, so one label function serves while, until, dotimes, break and continue. It is not a goto — the checker resolves a label against the loops the form is lexically inside, so control can only leave a loop it is already in. Break and Continue carry a relative depth rather than a name, because that is what a backend already has: emit keeps one entry per While the way it keeps one pad per frame, and indexes it. Nothing in the prelude wants either. Every early exit there is a return from the function, which break cannot replace; the sentinel-flag loop break exists to remove does not appear in it. The two the compiler emits are that shape and are the one place it cannot help — their sentinel is set inside a restart-case. reach.ml and render.ml take the While arity change and nothing else.
272 lines
12 KiB
OCaml
272 lines
12 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;
|
|
}
|
|
|
|
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;
|
|
(* 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 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. *)
|
|
| Types.Ptr _ -> [ lit "<ptr>" ]
|
|
(* 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>" ]
|
|
| 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)
|