Joseph Ferano
5791faee4e
Finishes DISCUSS.md §9's `pause` marking: the daemon half was already built, this is the editor half plus the one daemon path it was missing. `C-u C-c C-c` marks the form point is inside, `C-u C-u C-c C-c` the top-level form (stop on entry), `C-u C-x C-e` the expression before point. The buffer is never edited — the position rides beside the code and the `(pause)` call goes into the tree after parsing, so no source location moves. `C-x C-e`'s path needed the daemon: its 5s `wait` answered "the program did not reach a frame boundary", which is exactly what a thunk parked at a breakpoint looks like from out here. `wait` is now three-way and asks `state t = Stopped` only when a pause was requested, so the no-pause shape `test_dev.ml` pins is unchanged. The overlay is an annotation and not feedback, so unlike an error marker it survives `pre-command-hook`; what takes it down is an accepted evaluation with no `:pause` on it, which is the same thing that takes the mark itself down. Tests: a `test_dev.ml` block over the new `dev-pause.flan` that marks, stops, re-evaluates plainly and then polls half a second confirming it does not stop again — one sample after `continue` proves nothing, the resumed frame is still in the old body — and an `emacs/test-flan-dev.el` block for which form a prefix picks, the byte column, the overlay's lifetime, and one live round trip.
1062 lines
47 KiB
OCaml
1062 lines
47 KiB
OCaml
(** A live program: the declarations a running process was built from, plus
|
|
every change accepted since.
|
|
|
|
This is what makes an editor possible. [Check.program] builds a fresh
|
|
environment from a declaration list on every call, which is exactly the
|
|
property a session needs and the reason there is no scratch-environment
|
|
machinery here: a form that fails to check leaves nothing behind, because
|
|
nothing was mutated. The list is only replaced once the check has
|
|
succeeded. Re-checking the whole program each time costs the whole frontend,
|
|
which is under 10ms — less than the [llc] that follows it.
|
|
|
|
Two things the session knows that no single evaluation could:
|
|
|
|
- **which names the running process was built with.** A name it has is a
|
|
symbol the loaded module binds to; a name it lacks goes through the
|
|
by-name registry in runtime/flan_dev.c. Getting this wrong is silent:
|
|
treating [rand-seed] as new gives it a registry cell nobody publishes,
|
|
and the first call jumps to null. It has to come from the *checked*
|
|
program, because [Check.program] prepends the prelude and no accumulated
|
|
AST contains it.
|
|
- **what the memory of that process looks like.** A cell is a bare pointer
|
|
and carries no signature, so a redefined function whose parameters
|
|
changed is called by every existing call site with the old ones — no link
|
|
error, no trap, a wrong number. Struct fields and global types are the
|
|
same class. Those are refused here, with the reason, rather than loaded.
|
|
|
|
Not here, and deliberately: evaluating an expression. That is a separate
|
|
primitive — synthesize a function around the form, call it, render the
|
|
value — and it is not what redefining a name is. *)
|
|
|
|
type t = {
|
|
file : string; (* resolves an import's relative path *)
|
|
mutable decls : Ast.decl list; (* post-Load: flat, one namespace *)
|
|
mutable program : Tast.program; (* the last thing that checked *)
|
|
mutable env : Check.env; (* the same, as the checker sees it *)
|
|
host : Tast.program; (* what the process was built from *)
|
|
pkgs : Load.pkg list; (* alias, directory, names owned *)
|
|
mutable thunks : int; (* expression evaluations so far *)
|
|
(* Whether the modules this session emits carry DWARF. It belongs to the
|
|
session rather than to each call because it has to match the process the
|
|
modules are loaded into: a redefinition with debug info, dlopened into a
|
|
host built without it, gives a debugger a second module to resolve names
|
|
against and nothing to line up the host's own frames with. Both ends are
|
|
set from one flag — see [Dev.start]. *)
|
|
debug : bool;
|
|
}
|
|
|
|
let fail = Loc.fail
|
|
|
|
(* Structural, and conservative: anything this does not recognise counts as
|
|
changed. Comparing emitted text instead would be wrong — [Emit.const] on a
|
|
string allocates a name off a per-module counter, so two different strings
|
|
in two throwaway modules both come out as [@".str.0"] and compare equal. *)
|
|
let rec same_const (a : Tast.expr) (b : Tast.expr) =
|
|
match (a.Tast.e, b.Tast.e) with
|
|
| Tast.Int (x, k), Tast.Int (y, l) -> Int64.equal x y && k = l
|
|
| Tast.Float (x, k), Tast.Float (y, l) -> Float.equal x y && k = l
|
|
| Tast.Bool x, Tast.Bool y -> x = y
|
|
| Tast.Str x, Tast.Str y -> String.equal x y
|
|
| Tast.Unit, Tast.Unit -> true
|
|
| Tast.Zero x, Tast.Zero y -> Types.equal x y
|
|
| Tast.Arr xs, Tast.Arr ys ->
|
|
List.length xs = List.length ys && List.for_all2 same_const xs ys
|
|
| Tast.Make (x, xs), Tast.Make (y, ys) ->
|
|
String.equal x y && List.length xs = List.length ys
|
|
&& List.for_all2 same_const xs ys
|
|
| _ -> false
|
|
|
|
let create ?(debug = false) ~file () =
|
|
let l = Load.program ~file (Parse.program (Reader.read_file file)) in
|
|
let p, env = Check.program_with_env l.Load.decls in
|
|
({ file; decls = l.Load.decls; program = p; env; host = p; pkgs = l.Load.pkgs;
|
|
thunks = 0; debug }, l)
|
|
|
|
(* Which package a file being edited belongs to, if any.
|
|
|
|
A form typed into vendor/agent/agent.flan declares [poll], but the running
|
|
program only ever knew it as [agent/poll]: the alias is chosen by whatever
|
|
imported the directory, and is written nowhere in the file itself. Without
|
|
this the form splices as a brand-new unrelated name, the evaluation reports
|
|
success, and nothing changes — the exact failure this whole design is meant
|
|
to make impossible.
|
|
|
|
Derived from the path rather than sent by the editor for that same reason:
|
|
the editor cannot know an alias the file does not mention. *)
|
|
let package_of t origin =
|
|
match origin with
|
|
| "" -> None
|
|
| origin ->
|
|
let here =
|
|
try Unix.realpath origin with Unix.Unix_error _ -> origin
|
|
in
|
|
let dir = Filename.dirname here in
|
|
(* A package is a directory, or a single .flan file named outright — so the
|
|
file being edited belongs to it if the package *is* that file, or if it
|
|
sits in the package's directory. Comparing only the directory would miss
|
|
the file case entirely and answer [None], which is the silent failure
|
|
above rather than a loud one: the form splices unqualified and the
|
|
running program keeps calling the name it already had. *)
|
|
let same p =
|
|
let d =
|
|
try Unix.realpath p.Load.dir with Unix.Unix_error _ -> p.Load.dir
|
|
in
|
|
String.equal d here || String.equal d dir
|
|
in
|
|
(match List.filter same t.pkgs with
|
|
| [] -> None
|
|
| [ p ] -> Some p
|
|
(* One directory under two aliases: both are live in the program and a
|
|
form cannot mean both. Say so rather than picking one. *)
|
|
| ps ->
|
|
Loc.fail Loc.unknown
|
|
"%s is imported under more than one alias (%s); a form here would \
|
|
have to mean all of them"
|
|
dir
|
|
(String.concat ", " (List.map (fun p -> p.Load.alias) ps)))
|
|
|
|
(* A name the running process exports. Everything else is looked up by name at
|
|
install time — see [Emit.redefinition]'s [known]. *)
|
|
let known t n =
|
|
List.exists (fun (f : Tast.fn) -> String.equal f.Tast.name n) t.host.Tast.fns
|
|
|| List.exists
|
|
(fun (g : Tast.global) -> String.equal g.Tast.gname n)
|
|
t.host.Tast.globals
|
|
|
|
(* ── What a running process cannot be told ─────────────────────────── *)
|
|
|
|
(* Everything here is a change that would load cleanly and then be wrong. The
|
|
house rule (NEXT.md, Watch for) says recognise it and refuse with the
|
|
reason, so each one names what it would have broken. *)
|
|
let compatible ~loc (old_ : Tast.program) (new_ : Tast.program) =
|
|
let find_fn p n =
|
|
List.find_opt (fun (f : Tast.fn) -> String.equal f.Tast.name n) p.Tast.fns
|
|
in
|
|
List.iter
|
|
(fun (f : Tast.fn) ->
|
|
match find_fn old_ f.Tast.name with
|
|
| None -> ()
|
|
| Some g ->
|
|
let same =
|
|
List.length f.Tast.params = List.length g.Tast.params
|
|
&& List.for_all2 Types.equal f.Tast.params g.Tast.params
|
|
&& Types.equal f.Tast.ret g.Tast.ret
|
|
in
|
|
(* A cell holds a bare pointer. Every call site compiled before this
|
|
change still passes the old arguments through it.
|
|
|
|
This refusal is correct for what is built and is *not* the design
|
|
plan.org now describes: a signature change should make a new
|
|
internal function version with its own trampoline, leave existing
|
|
callers and stored [Fn] values safely on the old one, and warn at
|
|
each tracked stale caller site. That needs versions, trampolines
|
|
and caller tracking, none of which exist — so this stays a refusal
|
|
until they do, rather than becoming a silent mismatch. See
|
|
plan.org, Hot reload, and open decision #6. *)
|
|
if not same then
|
|
fail loc
|
|
"%s changes signature, from (Fn [%s] %s) to (Fn [%s] %s); \
|
|
the calls already compiled into the running program pass the old \
|
|
one. Restart to change it."
|
|
f.Tast.name
|
|
(String.concat " " (List.map Types.to_string g.Tast.params))
|
|
(Types.to_string g.Tast.ret)
|
|
(String.concat " " (List.map Types.to_string f.Tast.params))
|
|
(Types.to_string f.Tast.ret))
|
|
new_.Tast.fns;
|
|
List.iter
|
|
(fun (g : Tast.global) ->
|
|
match
|
|
List.find_opt
|
|
(fun (h : Tast.global) -> String.equal h.Tast.gname g.Tast.gname)
|
|
old_.Tast.globals
|
|
with
|
|
(* A [defconst] is folded into its call sites — into an array length, at
|
|
worst, which is decided before any type resolves — so its value is in
|
|
the running program's code and not only in its storage. A [defvar]'s
|
|
initial value is the opposite case and must *not* be refused: the
|
|
storage holds live state the program has long since moved past, which
|
|
is the whole of "edit the code, keep the sand". Same record, opposite
|
|
answers, told apart by [gconst]. *)
|
|
(* Only a constant the *checker* consumed. Its value is in the shape of
|
|
the running program — [(defconst rows (/ h c))] decides the type of
|
|
[grid] before anything else resolves — so no store can reach it. A
|
|
constant that is only ever read at run time is just bytes in memory:
|
|
a dev build emits it as a mutable global and a redefinition stores
|
|
the new value, which is how a colour table is tuned live. *)
|
|
| Some h
|
|
when h.Tast.gconst && g.Tast.gconst && h.Tast.gfolded
|
|
&& Types.equal g.Tast.gty h.Tast.gty
|
|
&& not (same_const g.Tast.ginit h.Tast.ginit) ->
|
|
fail loc
|
|
"%s is used at compile time — an array length or a type — so the \
|
|
running program has its old value in its shape, where a reload \
|
|
cannot reach it. Restart to change it."
|
|
g.Tast.gname
|
|
| Some h when not (Types.equal g.Tast.gty h.Tast.gty) ->
|
|
(* The storage exists and has a shape. Reusing it for another one
|
|
reads fields at the wrong offsets; allocating fresh storage would
|
|
silently discard the state the reload exists to preserve. *)
|
|
fail loc
|
|
"%s changes type, from %s to %s; the running program already laid \
|
|
that storage out. Restart to change it."
|
|
g.Tast.gname (Types.to_string h.Tast.gty) (Types.to_string g.Tast.gty)
|
|
| _ -> ())
|
|
new_.Tast.globals;
|
|
List.iter
|
|
(fun (s : Tast.structure) ->
|
|
match
|
|
List.find_opt
|
|
(fun (r : Tast.structure) -> String.equal r.Tast.sname s.Tast.sname)
|
|
old_.Tast.structs
|
|
with
|
|
| Some r ->
|
|
let fields (x : Tast.structure) =
|
|
List.map (fun (f : Tast.field) -> (f.Tast.fname, f.Tast.fty))
|
|
x.Tast.fields
|
|
in
|
|
let same =
|
|
List.length s.Tast.fields = List.length r.Tast.fields
|
|
&& List.for_all2
|
|
(fun (an, at) (bn, bt) -> String.equal an bn && Types.equal at bt)
|
|
(fields s) (fields r)
|
|
in
|
|
(* Every value of this type in the running program has the old layout,
|
|
including ones held in globals that the reload is preserving. *)
|
|
if not same then
|
|
fail loc
|
|
"%s changes layout; the values the running program is holding have \
|
|
the old one. Restart to change it."
|
|
s.Tast.sname
|
|
| None -> ())
|
|
new_.Tast.structs
|
|
|
|
(* An enum member is erased to an [i32] literal in the caller — [:space] at a
|
|
call site resolves to a number and is folded there — so changing one cannot
|
|
reach code that is already compiled, exactly like a [defconst]. It has to be
|
|
compared over declarations rather than over [Tast.program], which carries no
|
|
enums at all for that same reason. *)
|
|
let compatible_enums ~loc old_ new_ =
|
|
let members (ds : Ast.decl list) =
|
|
List.filter_map
|
|
(fun (d : Ast.decl) ->
|
|
match d.Ast.d with Ast.Defenum (n, ms) -> Some (n, ms) | _ -> None)
|
|
ds
|
|
in
|
|
let before = members old_ in
|
|
List.iter
|
|
(fun (n, ms) ->
|
|
match List.assoc_opt n before with
|
|
| Some old_ms when old_ms <> ms ->
|
|
fail loc
|
|
"%s changes its members; the running program folded the old values \
|
|
into every call site that names one. Restart to change it."
|
|
n
|
|
| _ -> ())
|
|
(members new_)
|
|
|
|
(* ── Accepting a change ────────────────────────────────────────────── *)
|
|
|
|
(* The redefinition unit is a list of top-level forms, so this is one path for
|
|
both editor commands: C-c C-c sends one form, C-c C-k sends a file. *)
|
|
type change = {
|
|
ir : string; (* the module to build and send *)
|
|
names : string list; (* everything the forms declared *)
|
|
fns : string list; (* the subset that has a body to install *)
|
|
(* False when the module would define nothing: no body to publish and no
|
|
storage to allocate. Building and delivering one anyway reports success
|
|
for a change that cannot have had an effect, and costs the program a
|
|
frame's worth of reload it did not need. *)
|
|
installs : bool;
|
|
}
|
|
|
|
(* [pause] is [C-u C-c C-c]: the position, in the source just sent, of the form
|
|
the program should stop at — DISCUSS.md §9. It arrives as a separate field
|
|
rather than spliced into [src], because splicing text would move every
|
|
location after it, and it is applied below to the *declarations*, once
|
|
parsing has attached those locations and [Load] has qualified the names.
|
|
|
|
Nothing here makes it stick and nothing has to: the marked declaration is
|
|
what goes into [t.decls], so it stays marked until an evaluation replaces
|
|
it — which is an ordinary [C-c C-c] over the same form, with no [:pause].
|
|
That is §9's settled behaviour, and it is the same one statement that
|
|
accepts every other change. *)
|
|
let eval ?(origin = "<eval>") ?pause t src : change =
|
|
let forms = Reader.read_all ~file:origin src in
|
|
(* Through [Load] like any other source, so an evaluated (import ...) means
|
|
what it means in a file. Its expansion is what gets spliced, which is also
|
|
why the accumulated list is the post-Load one: re-evaluating a file that
|
|
imports something would otherwise append a second copy of the import and
|
|
the duplicate-name pass would reject it. *)
|
|
let incoming =
|
|
let ds = (Load.program ~file:t.file (Parse.program forms)).Load.decls in
|
|
match package_of t origin with
|
|
| None -> ds
|
|
| Some p ->
|
|
(* Qualified exactly as the import qualified them, so a redefined
|
|
[settle] lands on [sim/settle] and its call to [move-grain] lands on
|
|
[sim/move-grain]. A name the package does not own — the prelude's, or
|
|
another package's — is left alone, which is the same rule [Load] uses
|
|
at import time and the reason both go through [qualify_decl]. *)
|
|
let owns =
|
|
p.Load.owns
|
|
@ List.filter_map Ast.declared_name ds
|
|
in
|
|
List.map (Load.qualify_decl owns p.Load.alias) ds
|
|
in
|
|
let loc =
|
|
match incoming with d :: _ -> d.Ast.dloc | [] -> Loc.unknown
|
|
in
|
|
(* After [qualify_decl], so a package that defines a [pause] of its own does
|
|
not capture the call this splices in. Refused when the position matches
|
|
nothing: installing an unmarked body and answering "ok" would report a
|
|
breakpoint that is not there. *)
|
|
let incoming =
|
|
match pause with
|
|
| None -> incoming
|
|
| Some (line, col) ->
|
|
(match Ast.mark_pause ~line ~col incoming with
|
|
| Some ds -> ds
|
|
| None ->
|
|
fail loc "nothing to pause at line %d, column %d of the form sent"
|
|
line col)
|
|
in
|
|
let names = List.filter_map Ast.declared_name incoming in
|
|
let replacement n =
|
|
List.find_opt
|
|
(fun (d : Ast.decl) -> Ast.declared_name d = Some n)
|
|
incoming
|
|
in
|
|
(* Replaced in place and appended only when genuinely new, so declaration
|
|
order — which is emission order for globals — does not shuffle on every
|
|
evaluation. *)
|
|
let replaced = ref [] in
|
|
let kept =
|
|
List.map
|
|
(fun (d : Ast.decl) ->
|
|
match Ast.declared_name d with
|
|
| Some n ->
|
|
(match replacement n with
|
|
| Some nd -> replaced := n :: !replaced; nd
|
|
| None -> d)
|
|
| None -> d)
|
|
t.decls
|
|
in
|
|
let added =
|
|
List.filter
|
|
(fun (d : Ast.decl) ->
|
|
match Ast.declared_name d with
|
|
| Some n -> not (List.exists (String.equal n) !replaced)
|
|
| None -> false)
|
|
incoming
|
|
in
|
|
let decls = kept @ added in
|
|
(* Nothing above this line has changed the session. A [Loc.Error] from here
|
|
leaves it exactly as it was. *)
|
|
let program, env = Check.program_with_env decls in
|
|
compatible ~loc t.program program;
|
|
compatible_enums ~loc t.decls decls;
|
|
let fns =
|
|
List.filter
|
|
(fun n ->
|
|
List.exists
|
|
(fun (f : Tast.fn) -> String.equal f.Tast.name n)
|
|
program.Tast.fns)
|
|
names
|
|
in
|
|
(* A constant that changed and can be published: known to the host, not
|
|
consumed by the checker. The module stores its new value at the frame
|
|
boundary, exactly as it stores a new function body. *)
|
|
let consts =
|
|
List.filter
|
|
(fun n ->
|
|
known t n
|
|
&& List.exists
|
|
(fun (g : Tast.global) ->
|
|
String.equal g.Tast.gname n && g.Tast.gconst
|
|
&& not g.Tast.gfolded)
|
|
program.Tast.globals)
|
|
names
|
|
in
|
|
let ir =
|
|
Emit.redefinition ~dev:true ~debug:t.debug ~known:(known t) ~consts program
|
|
~fns
|
|
in
|
|
let allocates =
|
|
List.exists
|
|
(fun (g : Tast.global) -> not (known t g.Tast.gname))
|
|
program.Tast.globals
|
|
in
|
|
t.decls <- decls;
|
|
t.program <- program;
|
|
t.env <- env;
|
|
{ ir; names; fns; installs = fns <> [] || allocates || consts <> [] }
|
|
|
|
(* ── Evaluating an expression ──────────────────────────────────────── *)
|
|
|
|
(* [C-x C-e] is a different primitive from redefining a name, and this is where
|
|
the difference lives: there is no name to install a body into, so the
|
|
expression is wrapped in a function that has nowhere to be called from, and
|
|
the module says "run this once". The agent does, at a frame boundary.
|
|
|
|
Getting the value back does not marshal anything. 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*, in the thunk. That is the layout decision's
|
|
bill, paid here — and it is why the renderer is a compile-time walk over the
|
|
type rather than a function in the runtime.
|
|
|
|
The rendering goes to [flan_dev_emit], a piece at a time, not to stdout.
|
|
Piecewise because a struct is its fields with punctuation between them and
|
|
concatenating that in generated IR would need an allocator the language does
|
|
not have; not stdout because stdout belongs to the program, is in the hot
|
|
path for anything that prints, and a dev-only feature must not put a branch
|
|
in it. *)
|
|
|
|
type emitter = { ename : string; ety : Types.t }
|
|
|
|
let emit_bytes = { ename = "flan/dev-emit"; ety = Types.Slice (Types.Int Types.U8) }
|
|
let emit_str = { ename = "flan/dev-emit-str"; ety = Types.Slice (Types.Int Types.U8) }
|
|
let emit_i64 = { ename = "flan/dev-emit-i64"; ety = Types.Int Types.I64 }
|
|
let emit_u64 = { ename = "flan/dev-emit-u64"; ety = Types.Int Types.U64 }
|
|
let emit_f64 = { ename = "flan/dev-emit-f64"; ety = Types.Float Types.F64 }
|
|
|
|
let externs : Tast.extern list =
|
|
let one e sym = { Tast.ename = e.ename; esym = sym; eparams = [ e.ety ];
|
|
eret = Types.Unit } in
|
|
[ one emit_bytes "flan_dev_emit";
|
|
one emit_str "flan_dev_emit_str";
|
|
one emit_i64 "flan_dev_emit_i64";
|
|
one emit_u64 "flan_dev_emit_u64";
|
|
one emit_f64 "flan_dev_emit_f64";
|
|
(* The address of a slot in a *stopped* frame, resolved by the agent
|
|
against the snapshot that break took. It is the one piece a locals
|
|
thunk cannot work out for itself: the compiler knows every slot's type
|
|
and name, and nothing but the running program knows where the frame
|
|
is. See [render_locals]. *)
|
|
{ Tast.ename = "flan/dev-slot"; esym = "flan_agent_frame_slot";
|
|
eparams = [ Types.Int Types.I64; Types.Int Types.I64 ];
|
|
eret = Types.Ptr (Types.Int Types.U8) };
|
|
{ Tast.ename = "flan/dev-begin"; esym = "flan_dev_result_begin";
|
|
eparams = []; eret = Types.Unit };
|
|
{ Tast.ename = "flan/dev-end"; esym = "flan_dev_result_end";
|
|
eparams = []; eret = Types.Unit };
|
|
(* The allocation registry's two questions about an address. Both take a
|
|
[(Ptr u8)] and every pointer is cast to it: the registry is asked
|
|
whether a *byte* is inside a block it knows, and the type at the far
|
|
end is the renderer's business and already known there.
|
|
|
|
[reg-live] returns i32 rather than bool because that is what the C
|
|
returns, and a Flan bool is one bit wide; the comparison to zero is
|
|
made below, where the type is spelled once.
|
|
|
|
[reg-emit] writes into the same result buffer every other piece of a
|
|
rendering goes to. It answers whether it wrote anything, which this
|
|
side ignores — the renderer needs the *emission*, and "nothing was
|
|
written" is already the right rendering for an address the registry
|
|
never saw. *)
|
|
{ Tast.ename = "flan/reg-live"; esym = "flan_dev_reg_live";
|
|
eparams = [ Types.Ptr (Types.Int Types.U8) ];
|
|
eret = Types.Int Types.I32 };
|
|
{ Tast.ename = "flan/reg-emit"; esym = "flan_dev_reg_emit";
|
|
eparams = [ Types.Ptr (Types.Int Types.U8) ];
|
|
eret = Types.Int Types.I32 } ]
|
|
|
|
(* The REPL's emitter. Each piece is one extern call: the dev runtime already
|
|
has a renderer per scalar, and [flan_dev_emit_str] already quotes and
|
|
escapes. See render.ml for what the five are and why they are functions. *)
|
|
let dev_emitter : Render.emitter =
|
|
let call em (x : Tast.expr) : Tast.expr =
|
|
{ Tast.e = Tast.Call (em.ename, [ x ]); ty = Types.Unit; loc = x.Tast.loc }
|
|
in
|
|
{ Render.ebytes = call emit_bytes;
|
|
estr = call emit_str;
|
|
ei64 = call emit_i64;
|
|
eu64 = call emit_u64;
|
|
ef64 = call emit_f64 }
|
|
|
|
(* And what the REPL may do with a pointer, which [println] may not. See
|
|
render.ml's [pointers] for why the two sides differ. *)
|
|
let dev_pointers : Render.pointers =
|
|
let i32 = Types.Int Types.I32 in
|
|
let ask name (p : Tast.expr) : Tast.expr =
|
|
let loc = p.Tast.loc in
|
|
let byte =
|
|
{ Tast.e = Tast.Prim (Tast.Cast (Types.Ptr (Types.Int Types.U8)), [ p ]);
|
|
ty = Types.Ptr (Types.Int Types.U8); loc }
|
|
in
|
|
{ Tast.e = Tast.Call (name, [ byte ]); ty = i32; loc }
|
|
in
|
|
{ Render.live =
|
|
(fun p ->
|
|
let loc = p.Tast.loc in
|
|
let zero = { Tast.e = Tast.Int (0L, Types.I32); ty = i32; loc } in
|
|
{ Tast.e = Tast.Prim (Tast.Ne, [ ask "flan/reg-live" p; zero ]);
|
|
ty = Types.Bool; loc });
|
|
(* Called for the emission and not for the answer, so the i32 is discarded
|
|
here rather than in render.ml: a [Do] whose last element is the unit is
|
|
the honest way to say "run this and forget what it said", and it keeps
|
|
the walk's node types true. *)
|
|
epitaph =
|
|
(fun p ->
|
|
let loc = p.Tast.loc in
|
|
{ Tast.e =
|
|
Tast.Do [ ask "flan/reg-emit" p;
|
|
{ Tast.e = Tast.Unit; ty = Types.Unit; loc } ];
|
|
ty = Types.Unit; loc }) }
|
|
|
|
(* ── The locals of a stopped frame ─────────────────────────────────── *)
|
|
|
|
(* The second half of what a break loop can show, and it is the same primitive
|
|
as [C-x C-e] pointed somewhere else.
|
|
|
|
Nothing marshals and nothing is read across the process boundary. A Flan
|
|
value carries no header, so the daemon could not make sense of bytes it
|
|
copied out even if it had them; what it has instead is the *type*, from
|
|
[Tast.fn.slots], and a name for it, from [snames] beside it. So it compiles
|
|
a thunk that renders those types at those addresses, in the program, and
|
|
reads back the text — exactly what an evaluated expression does, except
|
|
that the root is an address rather than an expression. That address is the
|
|
only thing that comes from the running program.
|
|
|
|
[bound] is which slots the program says have been reached. It is not an
|
|
optimisation: an unbound slot's entry is null, and a thunk that rendered
|
|
one would dereference null on the game thread of a program that is already
|
|
stopped. So the refusal happens here, before any code is emitted for it.
|
|
|
|
What comes back is one line per slot — name, type, value, tab separated.
|
|
Tab and newline are safe separators because every string the renderer emits
|
|
goes through [flan_dev_emit_str], which escapes both.
|
|
|
|
Each slot is rendered from its address rather than copied into the thunk
|
|
first. A copy would be one [alloca] the size of the slot — 40KB for sand's
|
|
grid — and the walk only ever shows eight elements of it. The cost is one
|
|
call to [flan/dev-slot] per leaf the walk reaches instead of one per slot,
|
|
which the depth and span caps already bound. *)
|
|
let render_locals ?(origin = "<locals>") t ~frame ~(fn : Tast.fn) ~bound
|
|
: change * (string * string) list =
|
|
let loc = fn.Tast.floc in
|
|
let extra = ref [] and nslots = ref 0 in
|
|
let c =
|
|
{ Render.structs = t.program.Tast.structs;
|
|
unions = t.program.Tast.unions;
|
|
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums [];
|
|
emit = dev_emitter;
|
|
ptrs = Some dev_pointers;
|
|
alloc = (fun ty ->
|
|
let i = !nslots in
|
|
incr nslots;
|
|
extra := ty :: !extra;
|
|
i) }
|
|
in
|
|
let nullary n = { Tast.e = Tast.Call (n, []); ty = Types.Unit; loc } in
|
|
let bytes_of str =
|
|
{ Tast.e =
|
|
Tast.Prim (Tast.Bytes, [ { Tast.e = Tast.Str str; ty = Types.String; loc } ]);
|
|
ty = Types.Slice (Types.Int Types.U8); loc }
|
|
in
|
|
let lit str = c.Render.emit.Render.ebytes (bytes_of str) in
|
|
let refused = ref [] in
|
|
let refuse name why = refused := (name, why) :: !refused in
|
|
let one i ty name =
|
|
let idx n =
|
|
{ Tast.e = Tast.Int (Int64.of_int n, Types.I64); ty = Types.Int Types.I64; loc }
|
|
in
|
|
let address =
|
|
{ Tast.e = Tast.Call ("flan/dev-slot", [ idx frame; idx i ]);
|
|
ty = Types.Ptr (Types.Int Types.U8); loc }
|
|
in
|
|
let typed =
|
|
{ Tast.e = Tast.Prim (Tast.Cast (Types.Ptr ty), [ address ]);
|
|
ty = Types.Ptr ty; loc }
|
|
in
|
|
let v = { Tast.e = Tast.Deref typed; ty; loc } in
|
|
match Render.render c 0 v with
|
|
| parts ->
|
|
(* The slot *index* travels with the line, last, and it is what makes
|
|
[i] in the break buffer able to name this exact slot back to the
|
|
daemon. The name cannot: [check.ml]'s [fresh_slot] only ever
|
|
allocates, so (let [v 22] …) inside (let [v 11] …) is two slots both
|
|
called [v] and both listed here. Nor can the position in the list,
|
|
because a refused slot is not in it. See [render_slot]. *)
|
|
Some
|
|
((lit (name ^ "\t" ^ Types.to_string ty ^ "\t") :: parts)
|
|
@ [ lit ("\t" ^ string_of_int i ^ "\n") ])
|
|
| exception Loc.Error { Loc.dmsg = why; _ } ->
|
|
(* A type the structural printer has no arm for — a map, a function
|
|
value, a type variable. Named, with the reason, rather than left out
|
|
of the list: a local that is missing and a local that could not be
|
|
printed are different facts. *)
|
|
refuse name why;
|
|
None
|
|
in
|
|
let body =
|
|
List.concat
|
|
((List.filter_map
|
|
(fun i ->
|
|
let ty = fn.Tast.slots.(i) in
|
|
let name =
|
|
if i < Array.length fn.Tast.snames then fn.Tast.snames.(i)
|
|
else None
|
|
in
|
|
match name with
|
|
| None ->
|
|
(* A slot the compiler made up: [dotimes]'s hidden bound, the
|
|
temporary a (min) evaluates an operand into. There is no
|
|
name to show and inventing one would put a variable in the
|
|
list that nobody can find in the file. *)
|
|
refuse (Printf.sprintf "s%d" i)
|
|
"a slot the compiler made up; no name was written for it";
|
|
None
|
|
| Some name when not (List.mem i bound) ->
|
|
refuse name
|
|
"not bound yet at the point the program stopped";
|
|
None
|
|
| Some name -> one i ty name)
|
|
(List.init (Array.length fn.Tast.slots) (fun i -> i))))
|
|
in
|
|
t.thunks <- t.thunks + 1;
|
|
let name = Printf.sprintf "locals/%d" t.thunks in
|
|
let thunk : Tast.fn =
|
|
{ Tast.name; params = []; ret = Types.Unit;
|
|
body = (nullary "flan/dev-begin" :: body) @ [ nullary "flan/dev-end" ];
|
|
fdefers = []; fparent = None; floc = loc;
|
|
slots = Array.of_list (List.rev !extra);
|
|
(* Every slot in here is the walk's own scratch: the locals being shown
|
|
are the *other* frame's, and this thunk reaches them by address. *)
|
|
snames = Array.make (List.length !extra) None }
|
|
in
|
|
let program =
|
|
{ t.program with
|
|
Tast.fns = t.program.Tast.fns @ [ thunk ];
|
|
externs = t.program.Tast.externs @ externs }
|
|
in
|
|
let ir =
|
|
Emit.redefinition ~dev:true ~debug:t.debug ~known:(known t) ~call:name
|
|
program ~fns:[ name ]
|
|
in
|
|
ignore origin;
|
|
({ ir; names = []; fns = []; installs = true }, List.rev !refused)
|
|
|
|
(* ── One slot of a stopped frame, walked ───────────────────────────── *)
|
|
|
|
(* The inspector's second rooting mode, and the whole of what it needed.
|
|
|
|
The inspector navigates by rewriting *expressions* — `(.pos b)' where the
|
|
last one was `b' — because a Flan value has no header and the thunk that
|
|
rendered it is [dlclose]d as soon as it returns, so nothing can be held on
|
|
this side the way CIDER holds a JVM object. The cost of that is the bug it
|
|
had: a name sent back to be evaluated is evaluated wherever the evaluator
|
|
stands, which on any frame but the innermost may resolve to a global, to a
|
|
different binding, or to nothing, with the listing above it still showing
|
|
the frame's own storage.
|
|
|
|
Rooting at the slot's address alone does not fix it — an address is not an
|
|
expression, so the first step has nothing to build from. What makes this
|
|
work is that the step does not have to be an expression either. A frame's
|
|
address comes from the shadow stack and every slot's type comes from
|
|
[Tast.fn.slots], so a step into a field is an address plus an offset with
|
|
that field's type, which is *exactly* the arithmetic [Render.render] does
|
|
for the locals listing. So this is [render_locals] with a path applied to
|
|
the root before the walk, and not a second walk.
|
|
|
|
What the path cannot do is the honest half. Every step is refused by name
|
|
with its reason rather than guessed at: a field the type does not have, an
|
|
index past the end of a fixed array, an option's payload on something that
|
|
is not an option. A pointer is still never followed — that is the
|
|
renderer's rule and not this mode's. *)
|
|
|
|
(* A step, as the editor sends it. [Sfield] on a union carries the case as
|
|
well, because a union's payload is at an offset that depends on which case
|
|
it is, and the renderer is what told the editor which case this value
|
|
currently holds. Guessing the case from a field name that two cases share
|
|
would read one case's layout over another's payload. *)
|
|
type step = Sfield of string | Sindex of int | Ssome
|
|
|
|
let step_text = function
|
|
| Sfield f -> "." ^ f
|
|
| Sindex i -> Printf.sprintf "[%d]" i
|
|
| Ssome -> ".some"
|
|
|
|
let path_text path = String.concat "" (List.map step_text path)
|
|
|
|
let step_into t (v : Tast.expr) (s : step) : (Tast.expr, string) result =
|
|
let loc = v.Tast.loc in
|
|
let ty = v.Tast.ty in
|
|
let no why = Error why in
|
|
match s with
|
|
| Ssome ->
|
|
(match ty with
|
|
| Types.Option pay -> Ok { Tast.e = Tast.Field (v, 1); ty = pay; loc }
|
|
| _ ->
|
|
no
|
|
(Printf.sprintf "%s is not an option, so it has no payload to go into"
|
|
(Types.to_string ty)))
|
|
| Sindex i ->
|
|
(match ty with
|
|
| Types.Array (n, el) ->
|
|
if i < 0 || Int64.compare (Int64.of_int i) n >= 0 then
|
|
no
|
|
(Printf.sprintf "%d is past the end of %s, which has %Ld elements" i
|
|
(Types.to_string ty) n)
|
|
else
|
|
Ok
|
|
{ Tast.e =
|
|
Tast.Prim
|
|
(Tast.At,
|
|
[ v;
|
|
{ Tast.e = Tast.Int (Int64.of_int i, Types.I32);
|
|
ty = Types.Int Types.I32; loc } ]);
|
|
ty = el; loc }
|
|
| Types.Slice el ->
|
|
(* A slice's length is not in its type, so this is the one step whose
|
|
range cannot be settled here. It is checked in the program, like
|
|
every other index in a dev build. *)
|
|
if i < 0 then no (Printf.sprintf "%d is not an index" i)
|
|
else
|
|
Ok
|
|
{ Tast.e =
|
|
Tast.Prim
|
|
(Tast.At,
|
|
[ v;
|
|
{ Tast.e = Tast.Int (Int64.of_int i, Types.I32);
|
|
ty = Types.Int Types.I32; loc } ]);
|
|
ty = el; loc }
|
|
| _ ->
|
|
no
|
|
(Printf.sprintf "%s is not an array or a slice, so it has no element %d"
|
|
(Types.to_string ty) i))
|
|
| Sfield spec ->
|
|
(match ty with
|
|
| Types.Named n
|
|
when List.exists (fun (u : Tast.union) -> String.equal u.Tast.uname n)
|
|
t.program.Tast.unions ->
|
|
let u =
|
|
List.find (fun (u : Tast.union) -> String.equal u.Tast.uname n)
|
|
t.program.Tast.unions
|
|
in
|
|
(* The editor spells this `Union.case.field', which is the head the
|
|
renderer wrote — `(Union.case {.field …})' — with the field appended.
|
|
A bare `case.field' is taken too, since that is the same fact said
|
|
shorter. *)
|
|
(match String.rindex_opt spec '.' with
|
|
| None ->
|
|
no
|
|
(Printf.sprintf
|
|
"%s is a union: a field of it has to name the case that holds \
|
|
it, because the payload's offset depends on which case the \
|
|
value is in"
|
|
n)
|
|
| Some k ->
|
|
let case = String.sub spec 0 k
|
|
and fname = String.sub spec (k + 1) (String.length spec - k - 1) in
|
|
let case =
|
|
let pre = n ^ "." in
|
|
let lp = String.length pre in
|
|
if String.length case > lp && String.equal (String.sub case 0 lp) pre
|
|
then String.sub case lp (String.length case - lp)
|
|
else case
|
|
in
|
|
(match
|
|
List.find_opt
|
|
(fun (vr : Tast.variant) -> String.equal vr.Tast.vname case)
|
|
u.Tast.cases
|
|
with
|
|
| None ->
|
|
no (Printf.sprintf "%s has no case called %s" n case)
|
|
| Some vr ->
|
|
let rec idx i = function
|
|
| [] -> None
|
|
| (f : Tast.field) :: rest ->
|
|
if String.equal f.Tast.fname fname then Some (i, f.Tast.fty)
|
|
else idx (i + 1) rest
|
|
in
|
|
(match idx 0 vr.Tast.vfields with
|
|
| None ->
|
|
no
|
|
(Printf.sprintf "%s.%s has no field called %s" n case fname)
|
|
| Some (i, fty) ->
|
|
Ok
|
|
{ Tast.e = Tast.CaseField (v, vr.Tast.vname, i); ty = fty; loc })))
|
|
| Types.Named n ->
|
|
(match
|
|
List.find_opt
|
|
(fun (s : Tast.structure) -> String.equal s.Tast.sname n)
|
|
t.program.Tast.structs
|
|
with
|
|
| None ->
|
|
no
|
|
(Printf.sprintf
|
|
"%s is a type this session has no layout for, so there is no \
|
|
field to step to"
|
|
n)
|
|
| Some st ->
|
|
let rec idx i = function
|
|
| [] -> None
|
|
| (f : Tast.field) :: rest ->
|
|
if String.equal f.Tast.fname spec then Some (i, f.Tast.fty)
|
|
else idx (i + 1) rest
|
|
in
|
|
(match idx 0 st.Tast.fields with
|
|
| None ->
|
|
no (Printf.sprintf "%s has no field called %s" n spec)
|
|
| Some (i, fty) -> Ok { Tast.e = Tast.Field (v, i); ty = fty; loc }))
|
|
| _ ->
|
|
no
|
|
(Printf.sprintf "%s has no fields, so there is no .%s in it"
|
|
(Types.to_string ty) spec))
|
|
|
|
(* Renders slot [slot] of frame [frame], after walking [path] into it. The
|
|
thunk is [render_locals]'s, minus the loop over every slot: one root, one
|
|
line, and the reply carries the type the path ended at so the editor can
|
|
say what it is looking at.
|
|
|
|
The caller has already established that the frame is the body this session
|
|
holds — the slot fingerprint — and that the slot is bound. This function
|
|
does not re-derive either; it is handed the [fn] that check passed. *)
|
|
let render_slot ?(origin = "<inspect>") t ~frame ~(fn : Tast.fn) ~slot ~path
|
|
: (change * string * string, string) result =
|
|
let loc = fn.Tast.floc in
|
|
let nslots_of_fn = Array.length fn.Tast.slots in
|
|
if slot < 0 || slot >= nslots_of_fn then
|
|
Error
|
|
(Printf.sprintf "there is no slot %d in %s; it has %d" slot fn.Tast.name
|
|
nslots_of_fn)
|
|
else
|
|
let sname =
|
|
if slot < Array.length fn.Tast.snames then fn.Tast.snames.(slot) else None
|
|
in
|
|
match sname with
|
|
| None ->
|
|
Error
|
|
(Printf.sprintf
|
|
"slot %d of %s is one the compiler made up; no name was written for \
|
|
it, and it is not something the listing offers"
|
|
slot fn.Tast.name)
|
|
| Some name ->
|
|
let extra = ref [] and nslots = ref 0 in
|
|
let c =
|
|
{ Render.structs = t.program.Tast.structs;
|
|
unions = t.program.Tast.unions;
|
|
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums [];
|
|
emit = dev_emitter;
|
|
ptrs = Some dev_pointers;
|
|
alloc = (fun ty ->
|
|
let i = !nslots in
|
|
incr nslots;
|
|
extra := ty :: !extra;
|
|
i) }
|
|
in
|
|
let idx n =
|
|
{ Tast.e = Tast.Int (Int64.of_int n, Types.I64); ty = Types.Int Types.I64;
|
|
loc }
|
|
in
|
|
let ty = fn.Tast.slots.(slot) in
|
|
let address =
|
|
{ Tast.e = Tast.Call ("flan/dev-slot", [ idx frame; idx slot ]);
|
|
ty = Types.Ptr (Types.Int Types.U8); loc }
|
|
in
|
|
let typed =
|
|
{ Tast.e = Tast.Prim (Tast.Cast (Types.Ptr ty), [ address ]);
|
|
ty = Types.Ptr ty; loc }
|
|
in
|
|
let root = { Tast.e = Tast.Deref typed; ty; loc } in
|
|
let rec walk v = function
|
|
| [] -> Ok v
|
|
| s :: rest ->
|
|
(match step_into t v s with
|
|
| Error why -> Error why
|
|
| Ok v' -> walk v' rest)
|
|
in
|
|
(match walk root path with
|
|
| Error why -> Error (name ^ path_text path ^ ": " ^ why)
|
|
| Ok v ->
|
|
(match Render.render c 0 v with
|
|
| exception Loc.Error { Loc.dmsg = why; _ } -> Error (name ^ path_text path ^ ": " ^ why)
|
|
| parts ->
|
|
let nullary n = { Tast.e = Tast.Call (n, []); ty = Types.Unit; loc } in
|
|
t.thunks <- t.thunks + 1;
|
|
let tname = Printf.sprintf "inspect/%d" t.thunks in
|
|
let thunk : Tast.fn =
|
|
{ Tast.name = tname; params = []; ret = Types.Unit;
|
|
body =
|
|
(nullary "flan/dev-begin" :: parts) @ [ nullary "flan/dev-end" ];
|
|
fdefers = []; fparent = None; floc = loc;
|
|
slots = Array.of_list (List.rev !extra);
|
|
snames = Array.make (List.length !extra) None }
|
|
in
|
|
let program =
|
|
{ t.program with
|
|
Tast.fns = t.program.Tast.fns @ [ thunk ];
|
|
externs = t.program.Tast.externs @ externs }
|
|
in
|
|
let ir =
|
|
Emit.redefinition ~dev:true ~debug:t.debug ~known:(known t)
|
|
~call:tname program ~fns:[ tname ]
|
|
in
|
|
ignore origin;
|
|
Ok
|
|
({ ir; names = []; fns = []; installs = true },
|
|
name ^ path_text path,
|
|
Types.to_string v.Tast.ty)))
|
|
|
|
(* ── The globals a stopped stack reaches ───────────────────────────── *)
|
|
|
|
(* The other half of what a break loop can show, and in this language arguably
|
|
the more useful one: a game keeps most of its state in top-level [defvar]s,
|
|
and sand.flan holds its entire grid that way.
|
|
|
|
Almost the same thunk as [render_locals] with a different root, and the
|
|
difference is the whole reason this is a second function rather than a
|
|
parameter. A local is reached by *address* — [flan/dev-slot] hands back
|
|
where the frame is, and only the stopped program knows that. A global is
|
|
reached by *name*: [Emit.redefinition] writes a global the host already has
|
|
as [external], so the loaded module binds to the program's own storage and
|
|
the dynamic linker does the work. Nothing has to be asked of the stopped
|
|
thread at all, which is also why there is no [bound] list here — a global's
|
|
storage exists from the moment the process started, so there is no
|
|
not-yet-bound case to refuse.
|
|
|
|
[globals] is chosen by the caller and not here, because the choice is about
|
|
the *stack* and this function is about rendering. See [Dev.globals_op].
|
|
|
|
One line per global — name, type, value, tab separated — the same framing
|
|
[render_locals] uses, and safe for the same reason: every string the
|
|
renderer emits goes through [flan_dev_emit_str], which escapes both. *)
|
|
let render_globals ?(origin = "<globals>") t ~(globals : Tast.global list)
|
|
: change * (string * string) list =
|
|
let loc = Loc.unknown in
|
|
let extra = ref [] and nslots = ref 0 in
|
|
let c =
|
|
{ Render.structs = t.program.Tast.structs;
|
|
unions = t.program.Tast.unions;
|
|
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums [];
|
|
emit = dev_emitter;
|
|
ptrs = Some dev_pointers;
|
|
alloc = (fun ty ->
|
|
let i = !nslots in
|
|
incr nslots;
|
|
extra := ty :: !extra;
|
|
i) }
|
|
in
|
|
let bytes_of str =
|
|
{ Tast.e =
|
|
Tast.Prim (Tast.Bytes, [ { Tast.e = Tast.Str str; ty = Types.String; loc } ]);
|
|
ty = Types.Slice (Types.Int Types.U8); loc }
|
|
in
|
|
let lit str = c.Render.emit.Render.ebytes (bytes_of str) in
|
|
let nullary n = { Tast.e = Tast.Call (n, []); ty = Types.Unit; loc } in
|
|
let refused = ref [] in
|
|
let one (g : Tast.global) =
|
|
let v = { Tast.e = Tast.Global g.Tast.gname; ty = g.Tast.gty; loc } in
|
|
match Render.render c 0 v with
|
|
| parts ->
|
|
Some
|
|
((lit (g.Tast.gname ^ "\t" ^ Types.to_string g.Tast.gty ^ "\t") :: parts)
|
|
@ [ lit "\n" ])
|
|
| exception Loc.Error { Loc.dmsg = why; _ } ->
|
|
(* A type the structural printer has no arm for. Named with its reason
|
|
rather than left out, for [render_locals]'s reason: a global that is
|
|
missing and a global that could not be printed are different facts,
|
|
and a list that showed neither would be the same lie twice. *)
|
|
refused := (g.Tast.gname, why) :: !refused;
|
|
None
|
|
in
|
|
let body = List.concat (List.filter_map one globals) in
|
|
t.thunks <- t.thunks + 1;
|
|
let name = Printf.sprintf "globals/%d" t.thunks in
|
|
let thunk : Tast.fn =
|
|
{ Tast.name; params = []; ret = Types.Unit;
|
|
body = (nullary "flan/dev-begin" :: body) @ [ nullary "flan/dev-end" ];
|
|
fdefers = []; fparent = None; floc = loc;
|
|
slots = Array.of_list (List.rev !extra);
|
|
(* Every slot in here is the walk's own scratch: what is being shown is
|
|
the program's storage, which this thunk reaches by name. *)
|
|
snames = Array.make (List.length !extra) None }
|
|
in
|
|
let program =
|
|
{ t.program with
|
|
Tast.fns = t.program.Tast.fns @ [ thunk ];
|
|
externs = t.program.Tast.externs @ externs }
|
|
in
|
|
let ir =
|
|
Emit.redefinition ~dev:true ~debug:t.debug ~known:(known t) ~call:name
|
|
program ~fns:[ name ]
|
|
in
|
|
ignore origin;
|
|
({ ir; names = []; fns = []; installs = true }, List.rev !refused)
|
|
|
|
(* [pause] is [C-u C-x C-e] — §9's "last expression" target. It is a flag and
|
|
not a position, because there is only one form here and it is the whole of
|
|
what was sent: the expression *is* the target. It is also why nothing here
|
|
sticks — a thunk is built and thrown away, so the mark lasts exactly one
|
|
evaluation, which is the truthful thing for an expression that has no
|
|
declaration to live in. *)
|
|
let eval_expr ?(origin = "<eval>") ?(pause = false) t src : change =
|
|
let form =
|
|
match Reader.read_all ~file:origin src with
|
|
| [ f ] -> f
|
|
| [] -> fail Loc.unknown "nothing to evaluate"
|
|
| _ :: f :: _ -> fail f.Form.loc "one expression at a time"
|
|
in
|
|
let parsed = Parse.expr form in
|
|
(* Wrapped before the checker, so the call is checked like any other and a
|
|
prelude that stopped offering [pause] would be an ordinary unknown name
|
|
rather than a thunk that silently did not stop. The [Do] takes the
|
|
expression's own location for the reason [Ast.mark_pause] does: the frame
|
|
the break loop reports reads it. *)
|
|
let parsed =
|
|
if pause then
|
|
{ Ast.e = Ast.Do [ Ast.pause_call parsed.Ast.loc; parsed ];
|
|
Ast.loc = parsed.Ast.loc }
|
|
else parsed
|
|
in
|
|
let checked, base, bnames = Check.expression t.env parsed in
|
|
(* The thunk's frame starts at whatever [Check.expression] needed and grows
|
|
as the walk finds slices in it, so the slots the renderer asks for are
|
|
appended past [base] and collected here to size the frame below. *)
|
|
let extra = ref [] and nslots = ref (Array.length base) in
|
|
let c =
|
|
{ Render.structs = t.program.Tast.structs;
|
|
unions = t.program.Tast.unions;
|
|
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums [];
|
|
emit = dev_emitter;
|
|
ptrs = Some dev_pointers;
|
|
alloc = (fun ty ->
|
|
let i = !nslots in
|
|
incr nslots;
|
|
extra := ty :: !extra;
|
|
i) }
|
|
in
|
|
let loc = checked.Tast.loc in
|
|
let nullary n = { Tast.e = Tast.Call (n, []); ty = Types.Unit; loc } in
|
|
let body =
|
|
(nullary "flan/dev-begin" :: Render.render c 0 checked)
|
|
@ [ nullary "flan/dev-end" ]
|
|
in
|
|
t.thunks <- t.thunks + 1;
|
|
let name = Printf.sprintf "eval/%d" t.thunks in
|
|
let thunk : Tast.fn =
|
|
{ Tast.name; params = []; ret = Types.Unit; body; fdefers = []; fparent = None; floc = loc;
|
|
slots = Array.append base (Array.of_list (List.rev !extra));
|
|
(* The expression's own [let]s keep their names; the slots [render] added
|
|
behind them are the walk's own scratch and have none to keep. *)
|
|
snames = Array.append bnames (Array.make (List.length !extra) None) }
|
|
in
|
|
(* Built against the program but never spliced into it: an evaluation is not
|
|
a declaration, and adding one would leave the session carrying an eval/N
|
|
for every expression ever typed. *)
|
|
let program =
|
|
{ t.program with
|
|
Tast.fns = t.program.Tast.fns @ [ thunk ];
|
|
externs = t.program.Tast.externs @ externs }
|
|
in
|
|
let ir =
|
|
(* The thunk gets debug info on the same flag as everything else. It is a
|
|
function nobody sets a breakpoint on by name, but it is a frame on the
|
|
stack when the expression signals, and a frame the debugger cannot name
|
|
is the thing the conditions buffer is trying to stop showing. *)
|
|
Emit.redefinition ~dev:true ~debug:t.debug ~known:(known t) ~call:name
|
|
program ~fns:[ name ]
|
|
in
|
|
{ ir; names = []; fns = []; installs = true }
|