2571 lines
120 KiB
OCaml
2571 lines
120 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.** Struct fields and
|
|
global types are storage the process already has in a shape, so a change
|
|
to either is refused here, with the reason, rather than loaded.
|
|
- **what every function in the process was compiled against.** A dev cell
|
|
carries its body's signature word (see [Emit.sig_text]), so a function
|
|
whose parameters or return changed installs anyway and a caller compiled
|
|
before the change stops on [StaleCall] at the call rather than passing
|
|
the old arguments. [built] is how the session names those callers
|
|
before anyone runs them: the call sites of every body the process has,
|
|
each with the signature it was compiled for. See [stale_sites].
|
|
|
|
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. *)
|
|
|
|
(* One call site in a body the process is running: the function it calls,
|
|
the signature that function had when this body was compiled, and where the
|
|
call is written. A function value taken by name is a site too — the dev
|
|
build checks the signature where the address is taken. *)
|
|
type site = { callee : string; csig : string; cret : Types.t; sloc : Loc.t }
|
|
|
|
(* What the session knows about one compiled body: the declaration it belongs
|
|
to — itself, the function a clause was lifted out of, or the generic a copy
|
|
was made from — and its call sites. *)
|
|
type built = { owner : string; sites : site list }
|
|
|
|
module SM = Map.Make (String)
|
|
|
|
(* A call site compiled against a signature its callee no longer has. *)
|
|
type stale = {
|
|
caller : string; (* the compiled body the site is in *)
|
|
target : string; (* the function it calls *)
|
|
compiled : string; (* the signature it was compiled for *)
|
|
current : string; (* the signature the function has now *)
|
|
at : Loc.t;
|
|
(* True when the call is in [main] and the program is running: the
|
|
activation it is in is [main]'s loop, which never returns to be called
|
|
again, so compiling [main] again cannot reach it. Changing the callee
|
|
back or re-running the program does. *)
|
|
running : bool;
|
|
(* When [target]'s return type is read off its body and that is what
|
|
changed: which way, and the line that decided it. *)
|
|
cause : string option;
|
|
}
|
|
|
|
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 *)
|
|
mutable host : Tast.program; (* what the process was built from *)
|
|
pkgs : Load.pkg list; (* alias, directory, names owned *)
|
|
(* Every [defmacro] this session can expand a call to: the imports', under
|
|
their aliases, and the buffer's own, under the names the buffer writes.
|
|
Held rather than re-derived because an evaluation parses one form with no
|
|
import and no [defmacro] in sight, and a macro that works on the first
|
|
build and not on the reload is worse than one that never existed.
|
|
|
|
It is exactly this record's own rule applied to macros — what the program
|
|
was built from, plus every change accepted since. The file's own set is
|
|
seeded in [create] from the forms [Load] was handed, which is the same
|
|
read that produced [decls]; nothing here ever goes back to disk, so a
|
|
macro cannot arrive from a version of the file the session was never
|
|
told about. *)
|
|
mutable macros : Form.t list;
|
|
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;
|
|
(* Which backend compiles the modules this session emits, and it belongs to
|
|
the session for exactly the reason [debug] does: it has to match the
|
|
process they are loaded into. The two backends agree on every scalar and
|
|
disagree on every aggregate, so a module from one dlopened into a host
|
|
from the other is correct until the first redefined function takes or
|
|
returns a struct. Both ends are set from one flag -- see [Dev.start] --
|
|
and [flan.abi.x86] is the backstop if they ever come apart. *)
|
|
x86 : bool;
|
|
(* Every body the running process has, by symbol, with the call sites it
|
|
was compiled with. Seeded from [host] and replaced, body by body, as
|
|
modules are accepted — so it is what was *compiled*, which after a
|
|
signature change is not what [program] would check to. *)
|
|
mutable built : built SM.t;
|
|
(* The bodies of [main], and of the clauses lifted out of it, as the
|
|
running activation was compiled — kept when [main] is compiled again
|
|
while the program runs, because the loop the program is in is still the
|
|
old one and nothing re-enters it until a re-run. Emptied by [rerun]. *)
|
|
mutable live : built SM.t;
|
|
}
|
|
|
|
let fail = Loc.fail
|
|
|
|
(* ── What each compiled body calls ──────────────────────────────────── *)
|
|
|
|
(* The call sites of one body, each with the signature its callee has in
|
|
[p] — the program the body is being compiled from, which is the signature
|
|
both backends compare the cell's word against at that site. *)
|
|
let sites_of (p : Tast.program) (fn : Tast.fn) =
|
|
let sigs = Hashtbl.create 64 in
|
|
List.iter
|
|
(fun (f : Tast.fn) ->
|
|
Hashtbl.replace sigs f.Tast.name
|
|
(Emit.sig_text f.Tast.params f.Tast.ret, f.Tast.ret))
|
|
p.Tast.fns;
|
|
let found = ref [] in
|
|
let see (e : Tast.expr) =
|
|
let at m =
|
|
match Hashtbl.find_opt sigs m with
|
|
| Some (csig, cret) ->
|
|
found := { callee = m; csig; cret; sloc = e.Tast.loc } :: !found
|
|
| None -> ()
|
|
in
|
|
match e.Tast.e with
|
|
| Tast.Call (m, _) -> at m
|
|
| Tast.FnAddr (Tast.Fnval m) | Tast.Closure (Tast.Fnval m, _) -> at m
|
|
| _ -> ()
|
|
in
|
|
List.iter (Tast.walk see) fn.Tast.body;
|
|
List.iter (Tast.walk see) fn.Tast.fdefers;
|
|
List.rev !found
|
|
|
|
(* The declaration a compiled body belongs to, which is what the checker
|
|
names when that body's source no longer checks. A widening thunk belongs
|
|
to nobody and is left out: each module carries its own copy, so a name
|
|
says nothing about which copy the process reaches. *)
|
|
let owner_of env (fn : Tast.fn) =
|
|
match fn.Tast.fparent with
|
|
| Some "<thick>" -> None
|
|
| Some p -> Some p
|
|
| None ->
|
|
(match Check.instantiation_origin env fn.Tast.name with
|
|
| Some (g, _) -> Some g
|
|
| None -> Some fn.Tast.name)
|
|
|
|
let record_built env (p : Tast.program) (fns : Tast.fn list) m =
|
|
List.fold_left
|
|
(fun m (fn : Tast.fn) ->
|
|
match owner_of env fn with
|
|
| None -> m
|
|
| Some owner -> SM.add fn.Tast.name { owner; sites = sites_of p fn } m)
|
|
m fns
|
|
|
|
(* Every compiled call site whose callee's signature in [p] is not the one
|
|
it was compiled for, in source order. A callee [p] does not have is
|
|
skipped rather than reported: nothing could have been installed under it
|
|
since, so the cell still holds what the site was compiled against. *)
|
|
let stale_sites ?(live = SM.empty) ?(running = false)
|
|
?(inferred = fun _ -> None) built (p : Tast.program) : stale list =
|
|
let sigs = Hashtbl.create 64 and rets = Hashtbl.create 64 in
|
|
List.iter
|
|
(fun (f : Tast.fn) ->
|
|
Hashtbl.replace sigs f.Tast.name (Emit.sig_text f.Tast.params f.Tast.ret);
|
|
Hashtbl.replace rets f.Tast.name f.Tast.ret)
|
|
p.Tast.fns;
|
|
(* Nobody wrote an inferred return type, so a change to one is said in
|
|
terms of the line that made it. *)
|
|
let cause (st : site) =
|
|
match inferred st.callee, Hashtbl.find_opt rets st.callee with
|
|
| Some (l : Loc.t), Some now when not (Types.equal now st.cret) ->
|
|
Some
|
|
(Printf.sprintf "%s now returns %s, not %s, because of line %d%s"
|
|
st.callee (Types.to_string now) (Types.to_string st.cret) l.Loc.line
|
|
(if String.equal l.Loc.file st.sloc.Loc.file then ""
|
|
else " of " ^ Filename.basename l.Loc.file))
|
|
| _ -> None
|
|
in
|
|
(* Named by the declaration a body belongs to: a clause lifted out of
|
|
[step] is [step]'s call, and a generic's copy is the generic's. *)
|
|
let from ~kept m acc =
|
|
SM.fold
|
|
(fun _ b acc ->
|
|
let running = kept || (running && String.equal b.owner "main") in
|
|
List.fold_left
|
|
(fun acc (st : site) ->
|
|
match Hashtbl.find_opt sigs st.callee with
|
|
| Some now when not (String.equal now st.csig) ->
|
|
{ caller = b.owner; target = st.callee; compiled = st.csig;
|
|
current = now; at = st.sloc; running; cause = cause st }
|
|
:: acc
|
|
| _ -> acc)
|
|
acc b.sites)
|
|
m acc
|
|
in
|
|
from ~kept:true live (from ~kept:false built [])
|
|
(* A caller or callee the prelude-shadowing rename made is not the
|
|
program's, and there is nothing in the program to recompile for it. *)
|
|
|> List.filter (fun s ->
|
|
not (Check.internal_name s.caller || Check.internal_name s.target))
|
|
|> List.sort (fun a b ->
|
|
match String.compare a.at.Loc.file b.at.Loc.file with
|
|
| 0 -> Loc.before a.at b.at
|
|
| c -> c)
|
|
|
|
(* 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
|
|
|
|
(* The [defmacro]s among a set of top-level forms, as [t.macros] has to hold
|
|
them.
|
|
|
|
[Expand.quasiquote] is not decoration. [Parse.parse_forms] desugars every
|
|
form it is handed before the expander sees it, and [Load.qualify_macro]
|
|
desugars a package's macro on its way out for the same reason — but
|
|
[Parse.imported_macros] is read by [Macro.program] directly, past that map.
|
|
An undesugared body still has its quasiquote in it, which makes a
|
|
quasiquoted call look like a real one: the false ring docs/BUILT.md records the
|
|
first cycle test walking into.
|
|
|
|
Unqualified, and that is the point: a buffer writes its own macro's bare
|
|
name, so that is the name the session has to answer to. A file inside a
|
|
package that the program also imports has both — the bare one from here and
|
|
[alias/name] from [Load] — which is what the two call sites each need. *)
|
|
let own_macros (forms : Form.t list) : Form.t list =
|
|
List.filter_map
|
|
(fun f ->
|
|
match f.Form.v with
|
|
| Form.List ({ Form.v = Form.Sym "defmacro"; _ } :: _) ->
|
|
Some (Expand.quasiquote f)
|
|
| _ -> None)
|
|
forms
|
|
|
|
(* The macros [load] defined by expanding [forms], beside the ones written in
|
|
them: [(defsq sq)] defines [sq] without a [defmacro] in sight, and the next
|
|
evaluation has to be able to call it. Only those expanded from these forms'
|
|
own file — [Load.program] also parses the packages they import, and a macro
|
|
a package's expansion defined belongs to the package. Written first, so an
|
|
expansion's newer body wins as a [defmacro]'s does. *)
|
|
let with_expansion_macros (forms : Form.t list) (load : unit -> 'a) : 'a * Form.t list =
|
|
Parse.expansion_macros := [];
|
|
let r = load () in
|
|
let files = List.map (fun (f : Form.t) -> f.Form.loc.Loc.file) forms in
|
|
let defined =
|
|
List.filter
|
|
(fun (f : Form.t) -> List.mem (Loc.call_site f.Form.loc).Loc.file files)
|
|
!Parse.expansion_macros
|
|
in
|
|
Parse.expansion_macros := [];
|
|
(r, Load.macro_union (own_macros forms) defined)
|
|
|
|
let of_forms ~debug ~x86 ~file forms =
|
|
let l, mine = with_expansion_macros forms (fun () -> Load.program ~file forms) 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;
|
|
(* The file's own first, so that if the file being edited is itself a
|
|
package the program imports, the bare name wins for a form typed into
|
|
that buffer. [macro_union] keeps the left. *)
|
|
macros = Load.macro_union mine l.Load.macros;
|
|
thunks = 0; debug; x86;
|
|
built = record_built env p p.Tast.fns SM.empty; live = SM.empty }, l)
|
|
|
|
let create ?(debug = false) ?(x86 = false) ~file () =
|
|
of_forms ~debug ~x86 ~file (Source.read_file file)
|
|
|
|
(* ── A file loaded a form at a time, keeping what compiles ─────────── *)
|
|
|
|
(* The form a diagnostic is about: the last one in [forms] that starts at or
|
|
before the position it was reported at — the call, for an error inside a
|
|
macro's expansion. [None] when the position is in no file these forms came
|
|
from, which is an error nothing here can drop a form to avoid. *)
|
|
let blame (forms : Form.t list) (d : Loc.diag) : Form.t option =
|
|
let at = Loc.call_site d.Loc.dloc in
|
|
List.fold_left
|
|
(fun acc (f : Form.t) ->
|
|
if String.equal f.Form.loc.Loc.file at.Loc.file
|
|
&& Loc.before f.Form.loc at <= 0
|
|
then Some f
|
|
else acc)
|
|
None forms
|
|
|
|
(* SBCL's [load] and CIDER's load-file: a file whose third form does not
|
|
compile still defines the other two. [attempt] is run over [forms]; each
|
|
refusal drops the form it is about and runs it again over the rest, so a
|
|
form that only failed because it called one that was dropped is dropped
|
|
with its own error on the next round. Each round drops at least one form,
|
|
so this ends. Answers what [attempt] returned, the forms it was given, and
|
|
every error in the order found. An error no form can be blamed for is
|
|
raised as it came. *)
|
|
let pruned (attempt : Form.t list -> 'a) (forms : Form.t list) :
|
|
'a * Form.t list * Loc.diag list =
|
|
let rec go forms errs =
|
|
let drop ds e =
|
|
let bad = List.map (blame forms) ds in
|
|
if List.exists Option.is_none bad then raise e
|
|
else
|
|
let bad = List.filter_map Fun.id bad in
|
|
go (List.filter (fun f -> not (List.memq f bad)) forms)
|
|
(List.rev_append ds errs)
|
|
in
|
|
match attempt forms with
|
|
| r -> (r, forms, List.rev errs)
|
|
| exception (Loc.Error d as e) -> drop [ d ] e
|
|
| exception (Loc.Errors ds as e) -> drop ds e
|
|
in
|
|
go forms []
|
|
|
|
(* Where [flan dev] writes the [main] a file without one is given. Not a path:
|
|
nothing reads it back, and a location here is how the session tells that
|
|
[main] apart from one somebody wrote. *)
|
|
let stub_file = "<flan dev>"
|
|
|
|
let stub_main () = Reader.read_all ~file:stub_file "(defn main [] i32 0)"
|
|
|
|
let declares_main (forms : Form.t list) =
|
|
List.exists
|
|
(fun (f : Form.t) ->
|
|
match f.Form.v with
|
|
| Form.List
|
|
({ Form.v = Form.Sym "defn"; _ } :: { Form.v = Form.Sym "main"; _ } :: _)
|
|
-> true
|
|
| _ -> false)
|
|
forms
|
|
|
|
(* Whether the [main] this session would run is one somebody wrote. *)
|
|
let has_main t =
|
|
List.exists
|
|
(fun (d : Ast.decl) ->
|
|
Ast.declared_name d = Some "main"
|
|
&& not (String.equal d.Ast.dloc.Loc.file stub_file))
|
|
t.decls
|
|
|
|
(* The session [flan dev] starts: the file's forms loaded as [pruned] loads
|
|
them, so what compiles is in the host and what does not is answered beside
|
|
the session rather than instead of it. A file with no [main] — or whose
|
|
[main] is one of the forms left out — is the empty image of SBCL's order: a
|
|
[main] that returns at once is added so there is a process to park, and a
|
|
[main] loaded later replaces the stub like any other redefinition. *)
|
|
let create_dev ?(debug = false) ?(x86 = false) ~file () =
|
|
let build forms =
|
|
of_forms ~debug ~x86 ~file
|
|
(if declares_main forms then forms else forms @ stub_main ())
|
|
in
|
|
let (t, l), _, errs = pruned build (Source.read_file file) in
|
|
(t, l, errs)
|
|
|
|
(* What a macro may call, for the same reason [macros] is held: an evaluation
|
|
parses one form with no import in sight, and a package macro whose body
|
|
calls its own package's functions has to find them. [Load.program] hands
|
|
this to [Parse.with_imported] from the import it just read; a session has to
|
|
answer it from what it already holds.
|
|
|
|
Filtered out of [decls] by ownership rather than kept as a second list,
|
|
because [decls] is the one thing every redefinition already maintains and a
|
|
parallel copy would be a second thing to remember to update. A package's
|
|
names are qualified in there — that is what "post-Load: flat, one namespace"
|
|
means — so the prefix is the whole test.
|
|
|
|
The buffer's own declarations are deliberately not here. A macro module is
|
|
built from the prelude with no part of the file in it (see [Macro.reduce]'s
|
|
header, and the cycle it is about), and a session's [decls] is the file. *)
|
|
let package_decls t =
|
|
List.filter
|
|
(fun (d : Ast.decl) ->
|
|
match Ast.declared_name d with
|
|
| Some n ->
|
|
List.exists
|
|
(fun (p : Load.pkg) -> String.starts_with ~prefix:(p.Load.alias ^ "/") n)
|
|
t.pkgs
|
|
| None -> false)
|
|
t.decls
|
|
|
|
(* Which package a file being edited belongs to, if any.
|
|
|
|
A form typed into vendor/agent/agent.fln 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]. *)
|
|
(* The macros a form sent from [origin] can call. From a package's file that
|
|
is the package's own under the bare names the file writes, in front of the
|
|
rest: the session holds them qualified, as the importer calls them, and a
|
|
bare call parsed without these is a call to an unknown function that the
|
|
qualification afterwards turns into a call to the macro's own name. *)
|
|
let macros_for t origin =
|
|
match package_of t origin with
|
|
| None -> t.macros
|
|
| Some p ->
|
|
let pre = p.Load.alias ^ "/" in
|
|
let bare =
|
|
List.filter_map
|
|
(fun (f : Form.t) ->
|
|
match f.Form.v with
|
|
| Form.List (hd :: ({ Form.v = Form.Sym n; _ } as nf) :: rest)
|
|
when String.starts_with ~prefix:pre n ->
|
|
let b = String.sub n (String.length pre) (String.length n - String.length pre) in
|
|
Some { f with Form.v = Form.List (hd :: { nf with Form.v = Form.Sym b } :: rest) }
|
|
| _ -> None)
|
|
t.macros
|
|
in
|
|
Load.macro_union bare t.macros
|
|
|
|
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 (docs/BUILT.md, "The session") 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) =
|
|
(* A function's signature is not in this list. A dev cell carries its
|
|
body's signature word, so a function whose parameters or return changed
|
|
installs and every caller compiled before the change stops at the call
|
|
with [StaleCall] — see [Emit.sig_text] and [stale_sites].
|
|
|
|
[main] is the one exception, because its caller is not a call site a
|
|
cell can check. The startup code calls it, and that code was compiled
|
|
into the program when it started; a re-run calls it again the same
|
|
way. *)
|
|
let find_fn p n =
|
|
List.find_opt (fun (f : Tast.fn) -> String.equal f.Tast.name n) p.Tast.fns
|
|
in
|
|
(match find_fn old_ "main", find_fn new_ "main" with
|
|
| Some g, Some f
|
|
when not
|
|
(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) ->
|
|
fail loc
|
|
"main changes signature, from %s to %s. The program's startup code \
|
|
calls main, and it was built for the first one. Restart the program \
|
|
to change it."
|
|
(Emit.sig_text g.Tast.params g.Tast.ret)
|
|
(Emit.sig_text f.Tast.params f.Tast.ret)
|
|
| _ -> ());
|
|
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 [defonce]'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, in an array length or a type. \
|
|
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. Restart to change it."
|
|
g.Tast.gname (Types.to_string h.Tast.gty) (Types.to_string g.Tast.gty)
|
|
(* Which form declared a global is not in the storage, it is in the
|
|
code the process was *built* with: [Emit.startup_plan] wrote the
|
|
[.init~once.] guard around a defonce's store, left a def's bare,
|
|
and gave a defconst no store at all, and that startup function was
|
|
compiled into the host when the process started. A redefinition
|
|
republishes the initialiser and cannot republish the thing that
|
|
decides how often — or whether — it is called. So every swap of the
|
|
keyword would load cleanly and then go on doing what the *old*
|
|
keyword said, with nothing anywhere saying so:
|
|
|
|
- defonce → def keeps the guard and never re-runs; def → defonce
|
|
keeps re-running.
|
|
- anything → defconst is worse than ineffective. A constant the
|
|
checker did not fold is republished by value, at the frame
|
|
boundary, by the [consts] list below — so the store lands on
|
|
storage holding live state the program has long since moved past,
|
|
which is "edit the code, keep the sand" broken by a keyword.
|
|
- defconst → anything gets no store at all, because the host's
|
|
startup has none to run for a name that was an image when it was
|
|
compiled.
|
|
|
|
One refusal over all of it, because it is one fact: the defining
|
|
form is fixed at build time. Told by [gconst] and [grerun]
|
|
together, which is exactly how every other pass tells the three
|
|
apart. The arms above get first say and are the better message
|
|
where they apply — a folded constant whose value changed, and any
|
|
retype — and neither is about the keyword. *)
|
|
| Some h
|
|
when h.Tast.gconst <> g.Tast.gconst
|
|
|| h.Tast.grerun <> g.Tast.grerun ->
|
|
let word (x : Tast.global) =
|
|
if x.Tast.gconst then "defconst"
|
|
else if x.Tast.grerun then "def"
|
|
else "defonce"
|
|
in
|
|
fail loc
|
|
"%s changes from %s to %s. The running program was built with the \
|
|
first one — when an initialiser runs, or whether it runs at all, \
|
|
is decided in its startup code, and a reload can replace the \
|
|
initialiser but not that. Restart to change it, or keep %s and \
|
|
edit the value."
|
|
g.Tast.gname (word h) (word g) (word h)
|
|
| _ -> ())
|
|
new_.Tast.globals;
|
|
List.iter
|
|
(fun (s : Tast.structure) ->
|
|
(* An environment the checker synthesised for a capturing fn is not
|
|
subject to this rule, and that is not a loophole. The layout rule is
|
|
about values the running program reads with code newer than the code
|
|
that wrote them. An environment is only ever read by the lifted body
|
|
that was compiled beside the literal that made it: a function value
|
|
carries that body's own symbol, not a cell, and a redefinition module
|
|
carries its own copy of every lifted body it replaces. A value made
|
|
before the reload keeps calling the old body over the old layout —
|
|
and each environment carries the descriptor it was allocated with —
|
|
so editing which locals an fn names is an ordinary body change, and
|
|
demanding a restart for it would take the dev loop away from the
|
|
feature it was built for. *)
|
|
if Check.is_env_struct s.Tast.sname then () else
|
|
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. Restart to change it."
|
|
(Types.to_string (Types.Named 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. 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 *)
|
|
(* Which backend wrote [ir], and therefore which builder and which file
|
|
extension it wants: LLVM IR through [Build.shared], or x86-64 assembly
|
|
through [Build.shared_x86]. It rides on the change rather than being
|
|
looked up again at the build, so the text and the choice of builder can
|
|
never come from two different answers to the same question. *)
|
|
x86 : bool;
|
|
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;
|
|
(* Every call site in the running program compiled against a signature its
|
|
callee no longer has, once this change is in: the callers a signature
|
|
change leaves behind, and the ones earlier changes left that this one
|
|
did not recompile. Empty for anything that builds no module. *)
|
|
stale : stale list;
|
|
}
|
|
|
|
(* [pause] is [C-u C-c C-c]: the position, in the source just sent, of the form
|
|
the program should stop at — TODO.org, "A breakpoint is marked from the
|
|
editor, without editing the buffer". 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 that entry's settled behaviour, and it is the same one statement
|
|
that accepts every other change. *)
|
|
(* The one place the backend choice is made, so that the six callers below
|
|
cannot disagree about it and the refusal has one home.
|
|
|
|
There is no fallback and there must not be one. If [X86.redefinition]
|
|
refuses a form, the daemon reports the refusal; quietly building an LLVM
|
|
module instead would hand an [--x86] host a module from the other backend,
|
|
which is the crossed pair [flan.abi.x86] exists to refuse at [dlopen]. A
|
|
refusal a user can read is the right answer; a segfault three frames later
|
|
is not. *)
|
|
let redefinition (t : t) ?retains ?call ?(consts = []) program ~fns =
|
|
if not t.x86 then
|
|
Emit.redefinition ~dev:true ~debug:t.debug ~known:(known t) ?retains
|
|
~consts ?call ~annotate:true program ~fns
|
|
else
|
|
match
|
|
X86.redefinition ~checks:true ~dev:true ~known:(known t) ?retains ~consts
|
|
?call ~annotate:true program ~fns
|
|
with
|
|
| asm -> asm
|
|
(* The dev backend covers a subset of the IR and refuses the rest by name,
|
|
which is what makes a build that succeeds one it really compiled. A
|
|
refusal has to reach the editor as a diagnostic like every other, so it
|
|
is re-raised at the form it is about -- the first name being redefined,
|
|
which is where a reader would look. Every caller already handles
|
|
[Loc.Error]; none of them handles [X86.Unsupported], and a session that
|
|
died on the first unsupported form would be worse than one that says so
|
|
and stays up. *)
|
|
| exception X86.Unsupported m ->
|
|
let loc =
|
|
match
|
|
List.find_opt
|
|
(fun (f : Tast.fn) -> List.mem f.Tast.name fns)
|
|
program.Tast.fns
|
|
with
|
|
| Some f -> f.Tast.floc
|
|
| None -> Loc.unknown
|
|
in
|
|
(* The flag is named because the backend is no longer something anybody
|
|
asked for: [flan dev] takes it by default, so the person reading this
|
|
chose a program and not a code generator. "unsupported" on its own
|
|
tells them their form is wrong, which it is not — it compiles, on the
|
|
other backend, and the whole of the fix is one flag on the daemon.
|
|
Naming it here rather than in the editor keeps the sentence with the
|
|
refusal it belongs to, and reaches [flan reload] too. *)
|
|
fail loc
|
|
"the x86 dev backend cannot compile this: %s. Restart the daemon with \
|
|
flan dev --llvm" m
|
|
|
|
(* ── Undoing an acceptance ─────────────────────────────────────────── *)
|
|
|
|
(* Checking is not the last thing that can fail, and until this existed the
|
|
session behaved as though it were. [eval] assigns the four mutable fields
|
|
the moment a form checks; the *build* and the *delivery* happen afterwards,
|
|
in the daemon, and either can refuse — llc can fail, and the agent's reload
|
|
ring can be full, which a parked program guarantees after enough queued
|
|
installs, since nothing drains the ring while the main thread waits. The
|
|
editor saw an error either way, so the evaluation looked refused; the
|
|
session went on holding the declaration anyway.
|
|
|
|
That leftover is not untidiness, it is a segfault. A declaration the session
|
|
holds and the host does not export is a name every later module lists in its
|
|
install prologue, and the prologue interns a cell for it. A cell nothing
|
|
ever stored a body into is NULL, and a dev build's call through a cell is a
|
|
load and an indirect call with no test in front of it — so the next
|
|
[C-x C-e], the next locals render, the next globals refresh jumps the game
|
|
thread to address 0. One failed build, and the next thing anybody types
|
|
kills the program.
|
|
|
|
So the four fields are one unit that can be put back. [held] is what the
|
|
session was before the evaluation and [restore] is the session being that
|
|
again — all four together, because they are four views of one answer: the
|
|
declarations, the checked program, the checker's environment, and the macros
|
|
a later form expands against. Putting back three of them would leave the
|
|
checker willing to accept a call to a name the program does not have, which
|
|
is the same crash by a longer road.
|
|
|
|
What a restored session can claim is the honest sentence rather than the one
|
|
anyone would rather have: it holds no declaration that no module was
|
|
*accepted* for. Accepted is not installed — the agent queues a module and
|
|
the game thread installs it at a frame boundary — but a queued module is one
|
|
the process has and will run, and that is as far as this side can see.
|
|
|
|
A [defmacro] evaluated in the same breath as a [defn] that fails to build
|
|
goes back with it, and that is right: they arrived as one form and were
|
|
accepted as one. A [defmacro] on its own never reaches a restore, because a
|
|
change with no body to install and no storage to allocate is answered before
|
|
anything is built.
|
|
|
|
[thunks] is not in here. It is a counter that keeps two evaluations from
|
|
naming their thunks alike, not something the session believes about the
|
|
program, and the agent refuses a full ring *before* it dlopens — so a
|
|
rolled-back number would be reused for a module nothing ever mapped, and
|
|
reusing it is the one way to make two live modules share a symbol. *)
|
|
type held = {
|
|
hdecls : Ast.decl list;
|
|
hprogram : Tast.program;
|
|
henv : Check.env;
|
|
hmacros : Form.t list;
|
|
(* And what the process was compiled with, which an acceptance moves too:
|
|
a module that never arrived compiled nothing. *)
|
|
hbuilt : built SM.t;
|
|
hlive : built SM.t;
|
|
}
|
|
|
|
let held t =
|
|
{ hdecls = t.decls; hprogram = t.program; henv = t.env; hmacros = t.macros;
|
|
hbuilt = t.built; hlive = t.live }
|
|
|
|
let restore t h =
|
|
t.decls <- h.hdecls;
|
|
t.program <- h.hprogram;
|
|
t.env <- h.henv;
|
|
t.macros <- h.hmacros;
|
|
t.built <- h.hbuilt;
|
|
t.live <- h.hlive
|
|
|
|
(* A re-run calls [main] through its cell, so the body it enters is the
|
|
newest one and no older activation is left running. *)
|
|
let rerun t = t.live <- SM.empty
|
|
|
|
(* The process is about to be built again from what the session holds now
|
|
(a --two-process re-run), so that becomes what it was built from. Checked
|
|
whole rather than taken from [program], which can hold a caller's old body
|
|
beside a callee whose signature changed (see [eval]); a fresh build of that
|
|
pair would be wrong, so it raises the checker's error instead. *)
|
|
let rehost t =
|
|
let p, env =
|
|
let was = !Check.print_warnings in
|
|
Check.print_warnings := false;
|
|
Fun.protect ~finally:(fun () -> Check.print_warnings := was)
|
|
(fun () -> Check.program_with_env t.decls)
|
|
in
|
|
t.program <- p;
|
|
t.env <- env;
|
|
t.host <- p;
|
|
t.built <- record_built env p p.Tast.fns SM.empty;
|
|
t.live <- SM.empty
|
|
|
|
(* The session's own functions whose names a macro also has — see
|
|
[Parse.shadowing_fns]. A [defmacro] is a [defn] once parsed, so the
|
|
session's macros are taken back out. *)
|
|
let shadowing_fns t origin =
|
|
let macros = List.filter_map Macro.macro_name (macros_for t origin) in
|
|
List.filter_map
|
|
(fun (d : Ast.decl) ->
|
|
match d.Ast.d with
|
|
| Ast.Defn fn when not (List.mem fn.Ast.name macros) -> Some fn.Ast.name
|
|
| _ -> None)
|
|
t.decls
|
|
|
|
(* The name a prelude function the session splices a call to — [pause] for a
|
|
mark, [step-point] for the stepper — answers to in [decls]. A program's own
|
|
function or global of that name takes the name over and the prelude's is
|
|
renamed (see [Check.shadow_prelude]), and the spliced call is the
|
|
prelude's, not the program's. *)
|
|
let prelude_fn (decls : Ast.decl list) n =
|
|
let takes (d : Ast.decl) =
|
|
match d.Ast.d with
|
|
| Ast.Defn fn | Ast.Declare (fn, _) | Ast.DeclareC (fn, _) ->
|
|
String.equal fn.Ast.name n
|
|
| Ast.Defvar (m, _, _, _) | Ast.Defconst (m, _, _) -> String.equal m n
|
|
| _ -> false
|
|
in
|
|
if List.exists takes decls then Check.prelude_alias ^ "/" ^ n else n
|
|
|
|
(* [forms], when given, are [src] already read — [pruned] runs this over a
|
|
file a form fewer each round and has no text for the subset. [base] is the
|
|
file an [(import ...)] in them is resolved against, the session's own when
|
|
absent: a file loaded from another directory names its packages from
|
|
there. *)
|
|
let eval ?(origin = "<eval>") ?base ?forms ?pause ?(step = false) ?(running = true) t src : change =
|
|
let forms =
|
|
match forms with Some f -> f | None -> Source.read_code ~file:origin src
|
|
in
|
|
(* What an annotated listing quotes for this form is what was sent, not what
|
|
the file on disk said when it was last read. *)
|
|
Loc.remember ~file:origin src;
|
|
Parse.with_imported ~decls:(package_decls t) ~fns:(shadowing_fns t origin) (macros_for t origin) @@ fun () ->
|
|
(* 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 macros = ref t.macros in
|
|
let incoming =
|
|
let l, mine =
|
|
with_expansion_macros forms (fun () ->
|
|
Load.program ~file:(Option.value base ~default:t.file) forms)
|
|
in
|
|
(* An evaluated import *adds* to the session's set, so a macro brought in
|
|
by C-c C-k is there for the C-c C-c after it. A union and not an
|
|
assignment: [Load.program] answers the macros of the imports it was
|
|
handed, and the one form C-c C-c sends has no import in it, so
|
|
replacing would empty the set on the first re-evaluation of a defn —
|
|
the macro would work on the build and be an unknown name on the
|
|
reload.
|
|
|
|
The incoming set comes first because [macro_union] keeps the left on a
|
|
name collision, and what [Load] just read off disk is newer than what
|
|
the session has been holding: editing a macro in a package and
|
|
reloading the file that imports it has to expand the new body. The
|
|
other order would keep the stale one and say nothing.
|
|
|
|
Held here and committed at the bottom with everything else, rather than
|
|
assigned on the spot: this is above the checker, and the session's rule
|
|
is that a form which does not check leaves it exactly as it was —
|
|
macros included. Nothing between here and there reads [t.macros]:
|
|
[Load.program] puts the imported set in front of the parse it drives
|
|
itself, and the checker below is handed declarations that are already
|
|
parsed.
|
|
|
|
And the forms just sent come in front of both, which is the half that
|
|
makes a [defmacro] typed at the editor mean anything. A [defmacro] is
|
|
an ordinary declaration on this path already — it parses to a [Defn]
|
|
and installs a body like any other — so the only thing missing was the
|
|
session remembering that the name is a macro. It does now, and the
|
|
shape that follows is the one [defn] already has: the declaration
|
|
joins the session, and the *next* evaluation can call it. Not a re-read
|
|
of the file, which would also pick up macros the session was never told
|
|
about and would put unsaved-versus-saved skew into expansion.
|
|
|
|
Left-wins again, and here it is what lets a macro be edited: the
|
|
incoming body replaces the one the session was holding under that
|
|
name. [Macro.program] dedupes the same way on the same rule, because
|
|
while this parse runs the old copy is still ambient. *)
|
|
macros :=
|
|
Load.macro_union mine (Load.macro_union l.Load.macros t.macros);
|
|
let ds = l.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
|
|
let ds = List.map (Load.qualify_decl owns p.Load.alias) ds in
|
|
if Load.is_package_file p.Load.dir then Load.file_scoped ds else 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 ~fn:(prelude_fn (t.decls @ incoming) "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
|
|
(* [step]: every defn sent stops before each form of its body — see
|
|
[Ast.instrument_step]. After [qualify_decl] for the reason [pause] is. *)
|
|
let incoming =
|
|
if not step then incoming
|
|
else
|
|
match
|
|
Ast.instrument_step ~fn:(prelude_fn (t.decls @ incoming) "step-point")
|
|
incoming
|
|
with
|
|
| Some ds -> ds
|
|
| None -> fail loc "there is no defn in the form sent to step through"
|
|
in
|
|
(* A method declares a name of its own — that is what makes evaluating one
|
|
twice a replacement and evaluating a new one an append, through the same
|
|
kept/added logic every other declaration goes through. But no function is
|
|
emitted under that name: a method's body is inlined into its generic's
|
|
dispatch by [Classes.expand], so the body that has to be installed is the
|
|
*generic's*. Naming it here is what makes [C-c C-c] on a defmethod reach
|
|
a call site compiled before the method existed, which is the whole of why
|
|
this feature is usable in the loop the project exists for. *)
|
|
let names =
|
|
List.filter_map Ast.declared_name incoming
|
|
@ List.filter_map
|
|
(fun (d : Ast.decl) ->
|
|
match d.Ast.d with Ast.Defmethod m -> Some m.Ast.mgen | _ -> None)
|
|
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. *)
|
|
(* ── Callers compiled against a signature that changed ─────────────
|
|
A redefinition may change a function's parameters or return, and it
|
|
installs: every caller compiled before the change stops at the call on
|
|
[StaleCall] rather than passing the old arguments (see [Emit.sig_text]).
|
|
Those callers are still in [decls], unchanged, and their source may no
|
|
longer check against the new signature — [(helper 1)] after [helper]
|
|
gained a parameter. They are not being recompiled, so that is not a
|
|
reason to refuse the form that changed [helper]; it is the thing the
|
|
reply reports.
|
|
|
|
So a body whose check fails is tolerated exactly when it is a stale
|
|
caller: not in this form, and compiled with a call site whose callee's
|
|
signature, as the new check collected it, is not the one it was compiled
|
|
for. A failure at the line of such a site is tolerated too, which is
|
|
what lets a generic's copy through — the error then lands in whichever
|
|
function asked for the copy, and the stale site is in the generic's
|
|
body. Anything else fails as it always did, and a body that still
|
|
checks is simply checked; either way it is not recompiled, and the
|
|
report below names it.
|
|
|
|
What stands in for a tolerated body is the checked body the session
|
|
already had, which is the body the process is running. *)
|
|
let stale_owner (env : Check.env) name (d : Loc.diag) =
|
|
let now callee =
|
|
match Hashtbl.find_opt env.Check.fns callee with
|
|
| Some (ps, r) -> Some (Emit.sig_text ps r)
|
|
| None -> None
|
|
in
|
|
let stale_site (st : site) =
|
|
match now st.callee with
|
|
| Some n -> not (String.equal n st.csig)
|
|
| None -> false
|
|
in
|
|
(not (List.mem name names))
|
|
&& SM.exists
|
|
(fun fname b ->
|
|
(String.equal b.owner name || String.equal fname name
|
|
|| List.exists
|
|
(fun (st : site) ->
|
|
String.equal st.sloc.Loc.file d.Loc.dloc.Loc.file
|
|
&& st.sloc.Loc.line = d.Loc.dloc.Loc.line)
|
|
b.sites)
|
|
&& List.exists stale_site b.sites)
|
|
t.built
|
|
in
|
|
(* Every error in the form sent, not the first: [keep_going] checks past a
|
|
refused subexpression (see [Check.check]). One error is still raised as
|
|
[Loc.Error], which is what every caller of one form expects. *)
|
|
let program, env, tolerated =
|
|
(* A tolerated body whose return type is read off it keeps the
|
|
signature the process has for it. *)
|
|
let previous n =
|
|
List.find_map
|
|
(fun (f : Tast.fn) ->
|
|
if String.equal f.Tast.name n then Some (f.Tast.params, f.Tast.ret)
|
|
else None)
|
|
t.program.Tast.fns
|
|
in
|
|
match
|
|
Check.program_tolerant ~keep_going:true ~tolerate:stale_owner ~previous
|
|
decls
|
|
with
|
|
| r -> r
|
|
| exception Loc.Errors [ d ] -> raise (Loc.Error d)
|
|
in
|
|
let program =
|
|
if tolerated = [] then program
|
|
else
|
|
let kept_fns =
|
|
List.filter
|
|
(fun (f : Tast.fn) ->
|
|
List.mem f.Tast.name tolerated
|
|
|| (match f.Tast.fparent with
|
|
| Some p -> List.mem p tolerated
|
|
| None -> false))
|
|
t.program.Tast.fns
|
|
and kept_globals =
|
|
List.filter
|
|
(fun (g : Tast.global) -> List.mem g.Tast.gname tolerated)
|
|
t.program.Tast.globals
|
|
in
|
|
{ program with
|
|
Tast.fns = program.Tast.fns @ kept_fns;
|
|
globals = program.Tast.globals @ kept_globals }
|
|
in
|
|
(* A (defclass ...) whose slot list changed is a constructor whose
|
|
signature changed, and it takes the same road: it installs, and a
|
|
compiled caller of the old constructor is a stale caller like any
|
|
other. *)
|
|
let incoming_classes =
|
|
List.filter_map
|
|
(fun (d : Ast.decl) ->
|
|
match d.Ast.d with
|
|
| Ast.Defclass (n, _) ->
|
|
Some (n, Option.value ~default:[] (Check.class_slots env n))
|
|
| _ -> None)
|
|
incoming
|
|
in
|
|
compatible ~loc t.program program;
|
|
compatible_enums ~loc t.decls decls;
|
|
(* ── The bodies to install ────────────────────────────────────────────
|
|
The names the form declared that have a body in the checked program —
|
|
and, for a generic, the bodies its *copies* have, because a generic
|
|
[defn] never reaches [Tast.fns] at all. Without the second clause
|
|
[C-c C-c] on a generic reports [installs=false, fns=[]]: it installs
|
|
nothing and says nothing went wrong, which is the feature being unusable
|
|
in the loop the project exists for.
|
|
|
|
Transitivity is free. The check above was a whole-program check, so
|
|
[env.insts] already holds every copy every call site asked for, including
|
|
the ones a redefined generic pulled in by calling another generic at its
|
|
own variable.
|
|
|
|
The third clause is the one that makes a redefinition reach a type the
|
|
process was never built with. Redefining a *caller* so that it uses a
|
|
generic at a new element type generates a brand-new symbol the host has
|
|
never had — it is not [known t] and no name in [names] mentions it — so
|
|
it has to be found by being an instantiation that the running process
|
|
lacks. [Emit.redefinition] then writes it as a new by-name cell, which is
|
|
the same path a [defn] the process was never built with already takes. *)
|
|
let declared_fns =
|
|
List.filter
|
|
(fun n ->
|
|
List.exists
|
|
(fun (f : Tast.fn) -> String.equal f.Tast.name n)
|
|
program.Tast.fns)
|
|
names
|
|
in
|
|
(* ── What evaluating a [def] does to the value ────────────────────────
|
|
[def] is Common Lisp's [defparameter], and evaluating a defparameter
|
|
assigns. That is the whole difference from [defvar] — [defonce] here —
|
|
which leaves an existing binding alone. So a [def] sent from the editor
|
|
has two effects and needs both:
|
|
|
|
- the storage takes the new value *now*, so code already compiled against
|
|
the global reads it at the next frame; and
|
|
- the initialiser is the one that runs at the next re-run, and at every
|
|
one after it.
|
|
|
|
The second is the lifted [global/<n>] — [Check.check_global] lifts every
|
|
[def] initialiser, constants included, for exactly this — published
|
|
through its cell, which the host's startup function calls. Republishing
|
|
it is the whole of the re-run half.
|
|
|
|
The first is the store below: the same [Set] the startup function makes,
|
|
run once, at a frame boundary, by the thunk this module carries. It is
|
|
not a second delivery path — it is the one [C-x C-e] already uses, which
|
|
is what makes "at a frame boundary, on the game thread" true of it.
|
|
|
|
A [def] the process has never seen is in here too. Its storage comes
|
|
from [flan_dev_global] like any new global's and no startup call names
|
|
it, so without the store a brand-new [(def n i64 (count-them))] would
|
|
come up as calloc's zeroes and stay there for the life of the process.
|
|
[Emit.initial_image] answers that for a constant initialiser and cannot
|
|
for a computed one; the store answers both.
|
|
|
|
[defonce] is not in here, and that is its contract: a value the program
|
|
already holds is not touched. A [defconst] is not either — a constant
|
|
the checker never consumed is republished by value, in [consts] below,
|
|
which is the same frame-boundary store by a shorter road.
|
|
|
|
The filter is the lifted function's existence rather than the shape of
|
|
the initialiser: [uninit] is the one [def] with nothing to run, and it
|
|
is the one with nothing lifted. *)
|
|
let def_globals =
|
|
List.filter_map
|
|
(fun (d : Ast.decl) ->
|
|
match d.Ast.d with
|
|
| Ast.Defvar (n, _, _, Ast.Every)
|
|
when List.exists
|
|
(fun (f : Tast.fn) ->
|
|
String.equal f.Tast.name ("global/" ^ n))
|
|
program.Tast.fns ->
|
|
List.find_opt
|
|
(fun (g : Tast.global) -> String.equal g.Tast.gname n)
|
|
program.Tast.globals
|
|
| _ -> None)
|
|
incoming
|
|
in
|
|
let def_inits =
|
|
List.map (fun (g : Tast.global) -> "global/" ^ g.Tast.gname) def_globals
|
|
in
|
|
(* Filtered by what the program holds: a copy a tolerated caller asked for
|
|
on its way to failing is in the tables and not in the program, and there
|
|
is nothing of it to install. *)
|
|
let from_generics =
|
|
List.concat_map
|
|
(fun n ->
|
|
if Check.is_generic env n then
|
|
List.filter
|
|
(fun c ->
|
|
List.exists
|
|
(fun (f : Tast.fn) -> String.equal f.Tast.name c)
|
|
program.Tast.fns)
|
|
(Check.instantiations env n)
|
|
else [])
|
|
names
|
|
in
|
|
let new_instances =
|
|
List.filter_map
|
|
(fun (f : Tast.fn) ->
|
|
if known t f.Tast.name then None
|
|
else
|
|
match Check.instantiation_origin env f.Tast.name with
|
|
| Some _ -> Some f.Tast.name
|
|
| None -> None)
|
|
program.Tast.fns
|
|
in
|
|
(* A name that takes over a prelude function's moves the prelude's body to
|
|
[Check.prelude_alias] and the prelude's own calls with it (see
|
|
[Check.shadow_prelude]). The process was built with those calls going
|
|
through the name's cell, which the new body is about to be installed
|
|
into, so the prelude's body is installed under its new name and every
|
|
body whose calls moved is compiled again: the prelude keeps its own
|
|
function, as a rebuild would give it. *)
|
|
let prelude_moved =
|
|
if not (List.exists (fun (f : Tast.fn) -> Check.internal_name f.Tast.name)
|
|
program.Tast.fns)
|
|
then []
|
|
else
|
|
let calls_moved (f : Tast.fn) (b : built) =
|
|
let hit = ref false in
|
|
let see (e : Tast.expr) =
|
|
match e.Tast.e with
|
|
| Tast.Call (m, _)
|
|
| Tast.FnAddr (Tast.Fnval m) | Tast.Closure (Tast.Fnval m, _)
|
|
when Check.internal_name m
|
|
&& not (List.exists
|
|
(fun (s : site) -> String.equal s.callee m) b.sites) ->
|
|
hit := true
|
|
| _ -> ()
|
|
in
|
|
List.iter (Tast.walk see) f.Tast.body;
|
|
List.iter (Tast.walk see) f.Tast.fdefers;
|
|
!hit
|
|
in
|
|
List.filter_map
|
|
(fun (f : Tast.fn) ->
|
|
(* A moved body not yet in the process is installed; one that is
|
|
— moved by an earlier shadowing — is compiled again like any
|
|
other when a later shadowing moves a call inside it. *)
|
|
if Check.internal_name f.Tast.name
|
|
&& not (known t f.Tast.name || SM.mem f.Tast.name t.built)
|
|
then Some f.Tast.name
|
|
else
|
|
match SM.find_opt f.Tast.name t.built with
|
|
| Some b when calls_moved f b ->
|
|
(* A lifted clause is compiled with the body it came from. *)
|
|
(match f.Tast.fparent with
|
|
| Some p when p <> "<thick>" -> Some p
|
|
| _ -> Some f.Tast.name)
|
|
| _ -> None)
|
|
program.Tast.fns
|
|
in
|
|
let fns =
|
|
List.sort_uniq String.compare
|
|
(declared_fns @ def_inits @ from_generics @ new_instances @ prelude_moved)
|
|
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
|
|
(* ── What the program has to run, and not merely load ─────────────────
|
|
Two things now, and one thunk for both, because a module carries one
|
|
[flan_reload_call] and the agent runs it once — after the bodies are
|
|
published, at a frame boundary, on the game thread.
|
|
|
|
The first is the class registrations.
|
|
|
|
A (defclass ...) is compile-time sugar for a constructor [defn], so
|
|
nothing about it reaches the running process except a function body —
|
|
which is why redefining one used to be silent, and why the instances
|
|
already in the program kept their old slots for ever.
|
|
|
|
What closes that is one call per class into
|
|
[runtime/flan_dyn.c]'s registry, carried by a thunk the agent runs after
|
|
the module's bodies are published and on the game thread, which is the
|
|
mechanism [C-x C-e] already uses. It has to be a thunk and not something
|
|
in the constructor: the case this exists for is a class redefined and
|
|
*not* constructed — old instances touched after the edit — and a
|
|
registration that only ran at construction would never fire.
|
|
|
|
Every class in the form, not only the ones whose slots changed. The
|
|
registry ignores a re-registration of the same list, so a C-c C-k costs
|
|
a comparison per class and migrates nothing; and a class whose
|
|
definition the registry has never seen has to arrive somehow. *)
|
|
let class_body =
|
|
let str s : Tast.expr = { Tast.e = Tast.Str s; ty = Types.String; loc } in
|
|
(* And the hook a migration calls, re-registered by every module that
|
|
could have changed what it should be: one carrying a class, since
|
|
that is what makes migrations happen, and one carrying a method of
|
|
the generic, since that is what changes the body. The address is the
|
|
cell's contents at the time the thunk runs — after this module's
|
|
bodies are published — so it is the body just installed. *)
|
|
let hook =
|
|
let n = Classes.migrate_generic in
|
|
if incoming_classes <> [] || List.mem n names then
|
|
let ty =
|
|
Types.CFn ([ Types.Dyn; Types.Dyn; Types.Dyn ], Types.Dyn)
|
|
in
|
|
[ { Tast.e =
|
|
Tast.Prim (Tast.Rt "flan_dyn_class_hook",
|
|
[ { Tast.e = Tast.FnAddr (Tast.Fnval n); ty; loc } ]);
|
|
ty = Types.Unit; loc } ]
|
|
else []
|
|
in
|
|
hook @ List.map
|
|
(fun (n, slots) : Tast.expr ->
|
|
let kw : Tast.expr =
|
|
{ Tast.e = Tast.Prim (Tast.Rt "flan_dyn_kw", [ str n ]);
|
|
ty = Types.Dyn; loc }
|
|
in
|
|
(* The slots in one string, a line each with the slot's type
|
|
after its name: the runtime splits them. A dyn vector would
|
|
have been the obvious shape and is the wrong one — it is a
|
|
collector object, so the registry would hold something the
|
|
marker has to reach, where a packed string reaches interned
|
|
keywords that are immortal already. The constructor carries
|
|
the same string, from the same function. *)
|
|
{ Tast.e =
|
|
Tast.Prim (Tast.Rt "flan_dyn_class_def",
|
|
[ kw; str (Check.class_spec_of slots) ]);
|
|
ty = Types.Unit; loc })
|
|
incoming_classes
|
|
in
|
|
(* And the second: the [def] stores. One [Set] per re-evaluated [def], the
|
|
same one [Emit.startup_plan] writes for the same global and without the
|
|
guard flag a [defonce]'s carries. See the note at [def_globals] for why
|
|
this happens at all.
|
|
|
|
What an initialiser that transfers out leaves behind is the backend's
|
|
answer and not this line's, and the two do not agree: a scalar comes
|
|
back in a register and is stored after the transfer guard on both, and
|
|
an aggregate is a temporary and one store on LLVM but is written into
|
|
the global in place on x86, which has no [Set] arm of its own. So an
|
|
x86 aggregate initialiser that signals half-way is a global half
|
|
written — the same thing [(set g (wreck))] has always done there, and
|
|
recorded in TODO.org, "A global initialiser still builds an aggregate
|
|
straight into its destination on x86", rather than promised away here.
|
|
|
|
After the registrations, not before: a [def] whose initialiser
|
|
constructs an instance of a class the same form redefined has to see the
|
|
slot list the registry now holds. *)
|
|
let store_body =
|
|
List.map
|
|
(fun (g : Tast.global) : Tast.expr ->
|
|
{ Tast.e = Tast.Set (Tast.Pglobal g.Tast.gname, g.Tast.ginit);
|
|
ty = Types.Unit; loc = g.Tast.ginit.Tast.loc })
|
|
def_globals
|
|
in
|
|
let run_thunk =
|
|
match class_body @ store_body with
|
|
| [] -> None
|
|
| body ->
|
|
t.thunks <- t.thunks + 1;
|
|
Some
|
|
{ Tast.name = Printf.sprintf "install/%d" t.thunks;
|
|
params = []; ret = Types.Unit; body;
|
|
fdefers = []; fenv = None; fparent = None; floc = loc;
|
|
slots = [||]; snames = [||]; as_slots = [] }
|
|
in
|
|
let ir =
|
|
match run_thunk with
|
|
| None -> redefinition t ~consts program ~fns
|
|
| Some th ->
|
|
redefinition t ~consts ~call:th.Tast.name
|
|
{ program with Tast.fns = program.Tast.fns @ [ th ] }
|
|
~fns:(fns @ [ th.Tast.name ])
|
|
in
|
|
let allocates =
|
|
List.exists
|
|
(fun (g : Tast.global) -> not (known t g.Tast.gname))
|
|
program.Tast.globals
|
|
in
|
|
(* Every one of these together, and after the last thing *here* that can
|
|
raise: until this line the session is still the one the evaluation started
|
|
against, which is what makes a refusal cost nothing.
|
|
|
|
It is not the last thing that can fail, though, and this line used to be
|
|
written as if it were. The build and the delivery come after it, in the
|
|
daemon, and both can refuse — so the caller takes a [held] first and puts
|
|
it back when they do. See [restore] above for what a session that kept the
|
|
declaration anyway does to the program. *)
|
|
(* The bodies this module compiles, and what each of them now calls: the
|
|
ones it installs by name and the clauses lifted out of them, which is
|
|
[Emit.redefinition]'s own list. Every stale caller the report names
|
|
afterwards is one this left alone. *)
|
|
let rebuilt =
|
|
List.filter
|
|
(fun (f : Tast.fn) ->
|
|
List.mem f.Tast.name fns
|
|
|| (match f.Tast.fparent with
|
|
| Some "<thick>" -> false
|
|
| Some p -> List.mem p fns
|
|
| None -> false))
|
|
program.Tast.fns
|
|
in
|
|
let built = record_built env program rebuilt t.built in
|
|
(* [main]'s running activation is the body the program started with, and
|
|
compiling [main] again does not reach it: the loop it is in never
|
|
returns to be called again. So while the program runs, the body it was
|
|
started with is kept, and its stale sites stay on the list. *)
|
|
let live =
|
|
if not running then t.live
|
|
else
|
|
List.fold_left
|
|
(fun live (f : Tast.fn) ->
|
|
match SM.find_opt f.Tast.name t.built with
|
|
| Some b when String.equal b.owner "main"
|
|
&& not (SM.mem f.Tast.name live) ->
|
|
SM.add f.Tast.name b live
|
|
| _ -> live)
|
|
t.live rebuilt
|
|
in
|
|
t.macros <- !macros;
|
|
t.decls <- decls;
|
|
t.program <- program;
|
|
t.env <- env;
|
|
t.built <- built;
|
|
t.live <- live;
|
|
(* [run_thunk] counts: a form that is only a (defclass ...) already
|
|
installs its constructor, but a module carrying nothing but the
|
|
registration still has something for the program to run. *)
|
|
{ ir; x86 = t.x86; names; fns;
|
|
installs =
|
|
fns <> [] || allocates || consts <> [] || run_thunk <> None;
|
|
stale =
|
|
stale_sites ~live ~running ~inferred:(Check.inferred_cause env) built
|
|
program }
|
|
|
|
(* ── 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. *)
|
|
|
|
(* The functions checking an expression lifted out of it — a handler clause,
|
|
a condition's printer — which the checker hangs on a function it calls
|
|
[<none>], since an expression has no enclosing one. They belong to the
|
|
thunk the expression becomes, and a redefinition module brings a lifted
|
|
function along only with its parent, so each is handed to [thunk]. *)
|
|
let lifted_mark t = Check.lifted_mark t.env
|
|
|
|
let claim_lifted t mark thunk =
|
|
List.filter_map
|
|
(fun (f : Tast.fn) ->
|
|
if f.Tast.fparent = Some "<none>" then
|
|
Some { f with Tast.fparent = Some thunk }
|
|
else None)
|
|
(Check.lifted_since t.env mark)
|
|
|
|
type emitter = { ename : string; ety : Types.t }
|
|
|
|
let emit_bytes = { ename = "flan/dev-emit"; ety = Types.Slice (Types.Mut, (Types.Int Types.U8)) }
|
|
let emit_str = { ename = "flan/dev-emit-str"; ety = Types.Slice (Types.Mut, (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 =
|
|
(* [Loc.unknown]: these are the session's own, built here and never written
|
|
in a source file, so there is no [declare] for a refusal to point at. *)
|
|
let one e sym = { Tast.ename = e.ename; esym = sym; eparams = [ e.ety ];
|
|
eret = Types.Unit; eloc = Loc.unknown } 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 write
|
|
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 [write_slot]. *)
|
|
{ Tast.ename = "flan/dev-slot"; esym = "flan_agent_frame_slot";
|
|
eparams = [ Types.Int Types.I64; Types.Int Types.I64 ];
|
|
eret = Types.Ptr (Types.Mut, (Types.Int Types.U8)); eloc = Loc.unknown };
|
|
(* A typed restart's parameter, by the restart's index in the snapshot on
|
|
top and a byte offset into its buffer, and the flag that says the
|
|
buffer was written. See [arm_restart]. *)
|
|
{ Tast.ename = "flan/dev-restart-arg"; esym = "flan_agent_restart_arg";
|
|
eparams = [ Types.Int Types.I64; Types.Int Types.I64 ];
|
|
eret = Types.Ptr (Types.Mut, Types.Int Types.U8); eloc = Loc.unknown };
|
|
{ Tast.ename = "flan/dev-restart-arm"; esym = "flan_agent_restart_arm";
|
|
eparams = [ Types.Int Types.I64 ]; eret = Types.Unit;
|
|
eloc = Loc.unknown };
|
|
(* The character beside a rendered byte. See [Render.pointers]. *)
|
|
{ Tast.ename = "flan/dev-emit-u8-char"; esym = "flan_dev_emit_u8_char";
|
|
eparams = [ Types.Int Types.I64 ]; eret = Types.Unit;
|
|
eloc = Loc.unknown };
|
|
{ Tast.ename = "flan/dev-begin"; esym = "flan_dev_result_begin";
|
|
eparams = []; eret = Types.Unit; eloc = Loc.unknown };
|
|
{ Tast.ename = "flan/dev-end"; esym = "flan_dev_result_end";
|
|
eparams = []; eret = Types.Unit; eloc = Loc.unknown };
|
|
(* 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.Mut, (Types.Int Types.U8)) ];
|
|
eret = Types.Int Types.I32; eloc = Loc.unknown };
|
|
{ Tast.ename = "flan/reg-emit"; esym = "flan_dev_reg_emit";
|
|
eparams = [ Types.Ptr (Types.Mut, (Types.Int Types.U8)) ];
|
|
eret = Types.Int Types.I32; eloc = Loc.unknown } ]
|
|
|
|
(* 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;
|
|
(* Into the value buffer, not stdout: a dyn expression's value belongs in
|
|
the reply's value like any other. *)
|
|
edyn =
|
|
(fun x ->
|
|
{ Tast.e = Tast.Prim (Tast.Rt "flan_dyn_emit_dev", [ x ]);
|
|
ty = Types.Unit; loc = x.Tast.loc });
|
|
enested =
|
|
(fun x ->
|
|
{ Tast.e = Tast.Prim (Tast.Rt "flan_dyn_emit_dev", [ x ]);
|
|
ty = Types.Unit; loc = x.Tast.loc }) }
|
|
|
|
(* 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.Mut, (Types.Int Types.U8))), [ p ]);
|
|
ty = Types.Ptr (Types.Mut, (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 });
|
|
(* Widened to i64 at the call, because every extern this file declares
|
|
that takes a number takes one, and the C reads the byte back out of
|
|
it. The spelling table is in flan_dev.c and answers to
|
|
lib/reader.ml's [read_byte]. *)
|
|
bytechar =
|
|
(fun b ->
|
|
let loc = b.Tast.loc in
|
|
let wide =
|
|
{ Tast.e = Tast.Prim (Tast.Cast (Types.Int Types.I64), [ b ]);
|
|
ty = Types.Int Types.I64; loc }
|
|
in
|
|
{ Tast.e = Tast.Call ("flan/dev-emit-u8-char", [ wide ]);
|
|
ty = Types.Unit; loc }) }
|
|
|
|
(* ── The locals of a stopped frame ─────────────────────────────────── *)
|
|
|
|
(* What a slot is *shown as*. Two departures from the raw [snames] entry,
|
|
both about keeping the listing in the words the person wrote.
|
|
|
|
A compiler temp — [dotimes]'s hidden bound, the slot a (min) evaluates an
|
|
operand into — has no name at all, and it is hidden rather than refused:
|
|
[s4] is not a variable anyone can find in the file, and a row explaining
|
|
its absence was noise on every frame that had one. [None] here means
|
|
"not shown".
|
|
|
|
A shadowing rebind — [check.ml]'s [bind] suffixes the repeat as [v~2] so
|
|
the debug info never claims one binding is the other — is shown under the
|
|
written name, because the depth is the compiler's bookkeeping. Only a
|
|
trailing [~N] is stripped: [~] is the reader's delimiter and a synthesized
|
|
name like [destructure~nth] carries it for a different reason. And when
|
|
stripping would put one name on two slots of this frame, both keep their
|
|
raw spelling — two rows called [v] with nothing to tell them apart is the
|
|
lie the suffix existed to prevent. *)
|
|
let strip_rebind name =
|
|
match String.rindex_opt name '~' with
|
|
| Some k when k > 0 && k < String.length name - 1 ->
|
|
let suffix = String.sub name (k + 1) (String.length name - k - 1) in
|
|
if String.for_all (fun c -> c >= '0' && c <= '9') suffix
|
|
then String.sub name 0 k
|
|
else name
|
|
| _ -> name
|
|
|
|
let shown_names (fn : Tast.fn) : string option array =
|
|
let n = Array.length fn.Tast.slots in
|
|
let raw =
|
|
Array.init n (fun i ->
|
|
if i < Array.length fn.Tast.snames then fn.Tast.snames.(i) else None)
|
|
in
|
|
(* A name the compiler gave a local of its own, such as the stepper's
|
|
[flan~step], is hidden like an unnamed slot: [~] cannot be typed. *)
|
|
let raw =
|
|
Array.map
|
|
(function
|
|
| Some n when String.starts_with ~prefix:"flan~" n -> None
|
|
| x -> x)
|
|
raw
|
|
in
|
|
let stripped = Array.map (Option.map strip_rebind) raw in
|
|
let count name =
|
|
Array.fold_left
|
|
(fun acc s -> if s = Some name then acc + 1 else acc)
|
|
0 stripped
|
|
in
|
|
Array.mapi
|
|
(fun i s ->
|
|
match s with
|
|
| None -> None
|
|
| Some d -> if count d > 1 then raw.(i) else Some d)
|
|
stripped
|
|
|
|
(* ── One slot of a stopped frame, walked ───────────────────────────── *)
|
|
|
|
(* The inspector's second rooting mode, and the whole of what it needed.
|
|
|
|
The inspector used to navigate by rewriting *expressions* — `(.pos b)'
|
|
where the last one was `b' — and 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. [slot_path] builds that as an expression over the
|
|
slot's value and [Inspect.place] works out where it lives, so the steps
|
|
and their refusals are stated once, here.
|
|
|
|
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 data type carries the case as
|
|
well, because a data type'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.data) -> String.equal u.Tast.dname n)
|
|
t.program.Tast.datas ->
|
|
let u =
|
|
List.find (fun (u : Tast.data) -> String.equal u.Tast.dname n)
|
|
t.program.Tast.datas
|
|
in
|
|
(* The editor spells this `Type.case.field', which is the head the
|
|
renderer wrote — `(Type.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 data type: 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))
|
|
|
|
(* Where slot [slot] of [fn] ends up after walking [path] into it, as an
|
|
expression over [root] — the value at the slot's address — together with
|
|
the label the reply names it by. [Dev.inspect] reads the value there
|
|
through [Inspect]; nothing is compiled.
|
|
|
|
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 slot_path t ~(fn : Tast.fn) ~slot ~path ~(root : Types.t -> Tast.expr)
|
|
: (Tast.expr * string, string) result =
|
|
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
|
|
match (shown_names fn).(slot) with
|
|
| None ->
|
|
Error
|
|
(Printf.sprintf
|
|
"slot %d of %s has no name in the source; the listing does not \
|
|
show it and there is nothing here to inspect"
|
|
slot fn.Tast.name)
|
|
| Some name ->
|
|
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 fn.Tast.slots.(slot)) path with
|
|
| Error why -> Error (name ^ path_text path ^ ": " ^ why)
|
|
| Ok v -> Ok (v, name ^ path_text path))
|
|
|
|
(* ── Writing one of them back ──────────────────────────────────────── *)
|
|
|
|
(* The inspector's other direction. SLY sets a value from the inspector and
|
|
the reason it is worth having here is the same one the read half has: a
|
|
game keeps its state in a struct somewhere, and the loop between "that
|
|
field is wrong" and "is it this value that fixes it" is the loop the whole
|
|
dev story is about. Changing it in the source and reloading answers a
|
|
different question — it answers what the *next* run does.
|
|
|
|
Everything about the addressing is the read half's, deliberately and not
|
|
for economy: the same root, the same [step_into], the same refusals for a
|
|
field a type does not have. A write that addressed values its own way would
|
|
be free to land somewhere the render above it never showed, which is the
|
|
whole class of bug [slot_path] exists to have closed.
|
|
|
|
What is new is two things. The walk has to end at a *place* and not at a
|
|
value, and the value being stored is an expression somebody typed, so it
|
|
goes through the checker against the type the walk ended at. Both of those
|
|
refuse, and both refuse with a sentence rather than by doing something
|
|
smaller than was asked. *)
|
|
|
|
(* The walk's last expression, as somewhere to store.
|
|
|
|
[step_into] builds exactly four shapes and three of them are places. That
|
|
is not a coincidence to be relied on quietly, so the fourth is named here
|
|
rather than left to fall through to a backend: [emit]'s [place] would
|
|
[failwith] on it and [x86]'s would not, and two backends disagreeing about
|
|
what is writable is worse than either answer.
|
|
|
|
Refused with the reason, not the layout. "A data type has no place form" is
|
|
a fact about this compiler; "the tag is what says which case the bytes are"
|
|
is the fact about the program, and it is the one that says why writing the
|
|
field alone would be wrong even if the offset were right. *)
|
|
let place_of (v : Tast.expr) : (Tast.place, string) result =
|
|
match v.Tast.e with
|
|
| Tast.Deref p -> Ok (Tast.Pderef p)
|
|
| Tast.Prim (Tast.At, target :: idx) when idx <> [] ->
|
|
Ok (Tast.Pindex (target, idx))
|
|
(* [Ssome] builds this too, and it is the one [Field] that is not writable:
|
|
an option is a tag and a payload, and storing the payload on its own
|
|
leaves a [None] holding a value — a value nothing will ever read, because
|
|
every reader asks the tag first. Set the option itself. *)
|
|
| Tast.Field (target, _) when (match target.Tast.ty with
|
|
| Types.Option _ -> true | _ -> false) ->
|
|
Error
|
|
"an option's payload is not a place on its own: the tag is what says \
|
|
whether there is one, and storing past it would leave a None holding a \
|
|
value nothing will ever look at. Set the option itself"
|
|
| Tast.Field (target, i) -> Ok (Tast.Pfield (target, i))
|
|
| Tast.CaseField (_, case, _) ->
|
|
Error
|
|
(Printf.sprintf
|
|
"%s is a field of a data type's case, and which case the bytes are in \
|
|
is what the tag says — so there is no address to store to that does \
|
|
not also have to settle the tag. Set the whole value instead"
|
|
case)
|
|
| _ ->
|
|
Error
|
|
(Printf.sprintf "%s is not somewhere a value can be stored"
|
|
(Types.to_string v.Tast.ty))
|
|
|
|
(* And the types that are places but must not be written through the editor.
|
|
|
|
A [Ptr] is the one that matters. Every other refusal here is about a shape;
|
|
this one is about where the number would come from. A pointer value typed
|
|
into a prompt is an address this end made up, and the registry's whole
|
|
argument is that an address is only worth anything with a blessing beside
|
|
it. Storing one would hand the program a pointer nothing ever blessed, to
|
|
be dereferenced at a moment nobody chose. The read half refuses to *follow*
|
|
a pointer for the same reason it is refused here. *)
|
|
let writable_type (ty : Types.t) : (unit, string) result =
|
|
match ty with
|
|
| Types.Ptr _ ->
|
|
Error
|
|
(Printf.sprintf
|
|
"%s is a pointer, and an address typed in here is one this end made \
|
|
up: nothing blessed it, and the program would dereference it at a \
|
|
moment nobody chose. The inspector does not follow pointers either"
|
|
(Types.to_string ty))
|
|
| _ -> Ok ()
|
|
|
|
(* Stores into slot [slot] of frame [frame], one store per [edits] entry,
|
|
after walking [path].
|
|
|
|
A list and not one store, because the buffer this exists for hands back a
|
|
whole value with several fields changed in it. N modules would be N builds
|
|
of a third of a second each and N trips past the agent's gate — so a
|
|
five-field edit would feel broken, and, worse, would be five separate
|
|
moments for a resume to land between. One module is one job: either every
|
|
store in it happened at this stop or none of them did.
|
|
|
|
Each edit's steps are relative to [path], which is what the buffer is
|
|
showing. A single field set from a line of the inspector is one edit with
|
|
one step; a whole value committed is one edit per changed leaf, with the
|
|
steps that reach it.
|
|
|
|
The thunk stores and then *renders*, between the same [dev-begin] and
|
|
[dev-end] the read half uses, and what comes back is therefore not the
|
|
editor's idea of what it asked for: it is what is actually there
|
|
afterwards, read out of the program's own storage by the printer that drew
|
|
the buffer in the first place.
|
|
|
|
[retains] is left at its default on purpose. A module that stores a string
|
|
literal leaves the program pointing into that module's image, and the
|
|
default is what keeps the mapping alive for it; claiming otherwise here to
|
|
save a page would be [(set msg "tuned")] left pointing at unmapped memory,
|
|
which [emit.ml] spells out where it writes [flan_reload_transient].
|
|
|
|
The caller has established the frame, as it has for [slot_path]. *)
|
|
let write_slot ?(origin = "<set>") t ~frame ~(fn : Tast.fn) ~slot ~path
|
|
~(edits : (step list * string) list)
|
|
: (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 if edits = [] then
|
|
(* Not a no-op quietly performed. A commit that found nothing to write is
|
|
a fact worth saying, and a module built to store nothing would cost a
|
|
third of a second to say it. *)
|
|
Error "there is nothing to store: nothing in this was changed"
|
|
else
|
|
let sname = (shown_names fn).(slot) in
|
|
match sname with
|
|
| None ->
|
|
Error
|
|
(Printf.sprintf
|
|
"slot %d of %s has no name in the source; the listing does not \
|
|
show it and there is nothing here to inspect"
|
|
slot fn.Tast.name)
|
|
| Some name ->
|
|
let where = name ^ path_text path 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.Mut, (Types.Int Types.U8)); loc }
|
|
in
|
|
let typed =
|
|
{ Tast.e = Tast.Prim (Tast.Cast (Types.Ptr (Types.Mut, ty)), [ address ]);
|
|
ty = Types.Ptr (Types.Mut, 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 (where ^ ": " ^ why)
|
|
| Ok shown ->
|
|
(* Two passes over the edits, and the split is the point. This one
|
|
settles every *place* and refuses the whole commit if any of them
|
|
is not one, before a single expression has been read — so a buffer
|
|
with one impossible field in it stores nothing rather than storing
|
|
the fields that happened to sort first. The module's
|
|
all-or-nothing property would be an empty promise if this end had
|
|
already half-decided. *)
|
|
let rec places acc = function
|
|
| [] -> Ok (List.rev acc)
|
|
| (steps, code) :: rest ->
|
|
let at = where ^ path_text steps in
|
|
(match walk shown steps with
|
|
| Error why -> Error (at ^ ": " ^ why)
|
|
| Ok target ->
|
|
(match writable_type target.Tast.ty with
|
|
| Error why -> Error (at ^ ": " ^ why)
|
|
| Ok () ->
|
|
(match place_of target with
|
|
| Error why -> Error (at ^ ": " ^ why)
|
|
| Ok dest ->
|
|
places ((at, dest, target.Tast.ty, code) :: acc) rest)))
|
|
in
|
|
(match places [] edits with
|
|
| Error why -> Error why
|
|
| Ok targets ->
|
|
(* And this one reads and checks the values. Every expression is
|
|
checked against one [ctx] — [Check.expressions], not one
|
|
[Check.expression] each — because two expressions checked apart
|
|
both number their slots from zero, and splicing them into one
|
|
thunk would have the second one's [let] reading and writing the
|
|
first one's storage. *)
|
|
let mark = Check.instance_mark t.env in
|
|
let lmark = lifted_mark t in
|
|
let wanted =
|
|
List.map
|
|
(fun (at, _, tty, code) ->
|
|
let form =
|
|
match Source.read_code ~expr:true ~file:origin code with
|
|
| [ f ] -> f
|
|
| [] -> fail loc "nothing to store into %s" at
|
|
| _ :: f :: _ -> fail f.Form.loc "one value at a time"
|
|
in
|
|
(* Expanded with the session's imported macros in front of
|
|
it, for the reason [eval_expr] gives: the prompt sends
|
|
one expression with no import in sight, and the session
|
|
is the only thing holding what the imports brought in. *)
|
|
(Some tty, Parse.with_imported t.macros (fun () -> Parse.expr form)))
|
|
targets
|
|
in
|
|
(* Checked *against the place's type*, which is the whole reason
|
|
[Check.expression] grew a [want]. Without it, [7] into an [f32]
|
|
field arrives as an [i32] and is refused for a mismatch the
|
|
reader never wrote; with it, it arrives as an [f32], and what
|
|
stays refused is what really does not fit — in the checker's
|
|
own words, which is the only place that sentence should ever be
|
|
written down. *)
|
|
let values, base, bnames = Check.expressions t.env wanted in
|
|
let fresh = Check.instances_since t.env mark in
|
|
let stores =
|
|
List.map2
|
|
(fun (_, dest, _, _) value ->
|
|
{ Tast.e = Tast.Set (dest, value); ty = Types.Unit; loc })
|
|
targets values
|
|
in
|
|
let extra = ref [] and nslots = ref (Array.length base) in
|
|
let c =
|
|
{ Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs;
|
|
datas = t.program.Tast.datas;
|
|
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
|
|
(match Render.render c 0 shown with
|
|
| exception Loc.Error { Loc.dmsg = why; _ } ->
|
|
Error (where ^ ": " ^ why)
|
|
| parts ->
|
|
let nullary n =
|
|
{ Tast.e = Tast.Call (n, []); ty = Types.Unit; loc }
|
|
in
|
|
t.thunks <- t.thunks + 1;
|
|
let tname = Printf.sprintf "set/%d" t.thunks in
|
|
let thunk : Tast.fn =
|
|
{ Tast.name = tname; params = []; ret = Types.Unit;
|
|
body =
|
|
stores
|
|
@ (nullary "flan/dev-begin" :: parts)
|
|
@ [ nullary "flan/dev-end" ];
|
|
fdefers = []; fenv = None; fparent = None; floc = loc;
|
|
slots = Array.append base (Array.of_list (List.rev !extra));
|
|
(* The stored expressions' 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);
|
|
as_slots = [] }
|
|
in
|
|
(* A struct copy the values named first, laid out in this
|
|
module and kept, as [eval_expr] keeps one. *)
|
|
let copies = Check.fresh_copies t.env t.program.Tast.structs in
|
|
let program =
|
|
{ t.program with
|
|
Tast.fns =
|
|
t.program.Tast.fns @ fresh @ claim_lifted t lmark tname
|
|
@ [ thunk ];
|
|
structs = t.program.Tast.structs @ copies;
|
|
externs = t.program.Tast.externs @ externs }
|
|
in
|
|
let ir =
|
|
redefinition t ~call:tname program
|
|
~fns:
|
|
(List.map (fun (f : Tast.fn) -> f.Tast.name) fresh
|
|
@ [ tname ])
|
|
in
|
|
(* The instances the values forced stay, the thunk does not —
|
|
[eval_expr] says why, and the caller takes the same [held]
|
|
around this that it takes around one. *)
|
|
t.program <-
|
|
{ t.program with
|
|
Tast.fns = t.program.Tast.fns @ fresh;
|
|
structs = t.program.Tast.structs @ copies };
|
|
Ok
|
|
({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] },
|
|
where, Types.to_string shown.Tast.ty))))
|
|
|
|
(* ── A typed restart, taken from the break loop ──────────────────────── *)
|
|
|
|
(* The types a restart takes, read back from how its frame spells them —
|
|
[Check.restart_sig], a parenthesised list of [Types.to_string]s, which the
|
|
reader reads as one list of type forms. *)
|
|
let restart_params t sg =
|
|
match Reader.read_all ~file:"<restart>" sg with
|
|
| [ { Form.v = Form.List forms; _ } ] ->
|
|
(match List.map (fun f -> Check.resolve t.env (Parse.texpr f)) forms with
|
|
| tys -> Ok tys
|
|
| exception Loc.Error { Loc.dmsg = why; _ } ->
|
|
Error ("the restart takes " ^ sg ^ ", and " ^ why))
|
|
| _ -> Error ("the restart's parameters are spelled " ^ sg ^ ", which is not a list of types")
|
|
|
|
(* What [invoke-restart] does to a frame before it aims the channel, done by a
|
|
thunk instead: each value, checked against the parameter's own type, stored
|
|
at its offset in the buffer the frame owns, and the flag set that says the
|
|
buffer was written. The offsets are [Emit.lay_fields] over the parameter
|
|
types, which is how both backends lay out that buffer and how the invoker
|
|
and the clause agree on it.
|
|
|
|
The values are expressions, checked in the session like any evaluated one,
|
|
so the refusal for a value that does not fit is the checker's own sentence.
|
|
The thunk renders the stored values back, which is what the program holds
|
|
now rather than what was asked for. *)
|
|
let arm_restart ?(origin = "<restart>") t ~index ~(params : Types.t list)
|
|
~(codes : string list) : (change * string list, string) result =
|
|
let loc = Loc.unknown in
|
|
let md = X86.layout_ctx ~checks:false ~dev:true t.program in
|
|
let _, _, offs = Emit.lay_fields md params in
|
|
let mark = Check.instance_mark t.env in
|
|
let lmark = lifted_mark t in
|
|
let wanted =
|
|
List.map2
|
|
(fun ty code ->
|
|
let form =
|
|
match Source.read_code ~expr:true ~file:origin code with
|
|
| [ f ] -> f
|
|
| [] -> fail loc "a value for a %s is empty" (Types.to_string ty)
|
|
| _ :: f :: _ -> fail f.Form.loc "one value for each parameter"
|
|
in
|
|
(Some ty, Parse.with_imported t.macros (fun () -> Parse.expr form)))
|
|
params codes
|
|
in
|
|
let values, base, bnames = Check.expressions t.env wanted in
|
|
let fresh = Check.instances_since t.env mark in
|
|
let i64 n =
|
|
{ Tast.e = Tast.Int (Int64.of_int n, Types.I64); ty = Types.Int Types.I64; loc }
|
|
in
|
|
let at ty off =
|
|
let raw =
|
|
{ Tast.e = Tast.Call ("flan/dev-restart-arg", [ i64 index; i64 off ]);
|
|
ty = Types.Ptr (Types.Mut, Types.Int Types.U8); loc }
|
|
in
|
|
{ Tast.e = Tast.Prim (Tast.Cast (Types.Ptr (Types.Mut, ty)), [ raw ]); ty = Types.Ptr (Types.Mut, ty); loc }
|
|
in
|
|
let stores =
|
|
List.map2
|
|
(fun (ty, off) (v : Tast.expr) ->
|
|
{ Tast.e = Tast.Set (Tast.Pderef (at ty off), v); ty = Types.Unit; loc })
|
|
(List.combine params offs) values
|
|
in
|
|
let arm =
|
|
{ Tast.e = Tast.Call ("flan/dev-restart-arm", [ i64 index ]); ty = Types.Unit; loc }
|
|
in
|
|
let extra = ref [] and nslots = ref (Array.length base) in
|
|
let c =
|
|
{ Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs;
|
|
datas = t.program.Tast.datas;
|
|
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.Mut, Types.Int Types.U8); loc }
|
|
in
|
|
let lit str = c.Render.emit.Render.ebytes (bytes_of str) in
|
|
match
|
|
List.concat
|
|
(List.map2
|
|
(fun (ty, off) k ->
|
|
(if k > 0 then [ lit "\n" ] else [])
|
|
@ Render.render c 0 { Tast.e = Tast.Deref (at ty off); ty; loc })
|
|
(List.combine params offs)
|
|
(List.init (List.length params) Fun.id))
|
|
with
|
|
| exception Loc.Error { Loc.dmsg = why; _ } -> Error why
|
|
| shown ->
|
|
let nullary n = { Tast.e = Tast.Call (n, []); ty = Types.Unit; loc } in
|
|
t.thunks <- t.thunks + 1;
|
|
let tname = Printf.sprintf "restart/%d" t.thunks in
|
|
let thunk : Tast.fn =
|
|
{ Tast.name = tname; params = []; ret = Types.Unit;
|
|
body =
|
|
stores @ [ arm ] @ (nullary "flan/dev-begin" :: shown)
|
|
@ [ nullary "flan/dev-end" ];
|
|
fdefers = []; fenv = None; fparent = None; floc = loc;
|
|
slots = Array.append base (Array.of_list (List.rev !extra));
|
|
snames = Array.append bnames (Array.make (List.length !extra) None);
|
|
as_slots = [] }
|
|
in
|
|
let copies = Check.fresh_copies t.env t.program.Tast.structs in
|
|
let program =
|
|
{ t.program with
|
|
Tast.fns =
|
|
t.program.Tast.fns @ fresh @ claim_lifted t lmark tname @ [ thunk ];
|
|
structs = t.program.Tast.structs @ copies;
|
|
externs = t.program.Tast.externs @ externs }
|
|
in
|
|
let ir =
|
|
redefinition t ~call:tname program
|
|
~fns:(List.map (fun (f : Tast.fn) -> f.Tast.name) fresh @ [ tname ])
|
|
in
|
|
t.program <-
|
|
{ t.program with
|
|
Tast.fns = t.program.Tast.fns @ fresh;
|
|
structs = t.program.Tast.structs @ copies };
|
|
Ok
|
|
({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] },
|
|
List.map Types.to_string params)
|
|
|
|
(* [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. *)
|
|
(* [frame] is SLIME's eval-in-frame: a stopped frame's index, the function it
|
|
is running and which of its slots were bound when it stopped. The
|
|
expression is then checked with that frame's named locals in scope — the
|
|
innermost of two of one name winning, as it does in the source — and every
|
|
use of one reads or writes the frame's own storage through [flan/dev-slot],
|
|
so a [set] changes the frame and a vec is not copied. A local not bound
|
|
yet is refused where it is named: its address is null. *)
|
|
let in_frame t ~frame:(index, (fn : Tast.fn), bound) (parsed : Ast.expr) =
|
|
let n = Array.length fn.Tast.slots in
|
|
let nparams = List.length fn.Tast.params in
|
|
let named =
|
|
List.filter_map
|
|
(fun i ->
|
|
match if i < Array.length fn.Tast.snames then fn.Tast.snames.(i) else None with
|
|
| Some raw -> Some (i, strip_rebind raw)
|
|
| None -> None)
|
|
(List.init n Fun.id)
|
|
in
|
|
(* Unbound first, so that of two slots one name the bound one shadows. *)
|
|
let order =
|
|
List.filter (fun (i, _) -> not (List.mem i bound)) named
|
|
@ List.filter (fun (i, _) -> List.mem i bound) named
|
|
in
|
|
let scope =
|
|
List.map
|
|
(fun (i, name) ->
|
|
(name, fn.Tast.slots.(i), i >= nparams, List.mem i fn.Tast.as_slots))
|
|
order
|
|
in
|
|
let checked, base, bnames, syn = Check.expression_in_scope t.env ~scope parsed in
|
|
let table = List.map2 (fun (i, name) (_, j) -> (j, (i, name))) order syn in
|
|
let idx loc k =
|
|
{ Tast.e = Tast.Int (Int64.of_int k, Types.I64); ty = Types.Int Types.I64; loc }
|
|
in
|
|
let pointer i loc =
|
|
let ty = fn.Tast.slots.(i) in
|
|
{ Tast.e =
|
|
Tast.Prim
|
|
(Tast.Cast (Types.Ptr (Types.Mut, ty)),
|
|
[ { Tast.e = Tast.Call ("flan/dev-slot", [ idx loc index; idx loc i ]);
|
|
ty = Types.Ptr (Types.Mut, Types.Int Types.U8); loc } ]);
|
|
ty = Types.Ptr (Types.Mut, ty); loc }
|
|
in
|
|
let checked =
|
|
Tast.rewrite_locals
|
|
(fun j loc ->
|
|
match List.assoc_opt j table with
|
|
| None -> None
|
|
| Some (i, name) when not (List.mem i bound) ->
|
|
fail loc
|
|
"%s is not bound yet where the program stopped, so there is no \
|
|
value to read" name
|
|
| Some (i, _) -> Some (pointer i loc))
|
|
checked
|
|
in
|
|
(* The slots the frame's names were bound to are read through the pointer
|
|
now, never directly; a byte keeps each from costing its type's size. *)
|
|
let base =
|
|
Array.mapi (fun j ty -> if List.mem_assoc j table then Types.Int Types.U8 else ty) base
|
|
and bnames =
|
|
Array.mapi (fun j nm -> if List.mem_assoc j table then None else nm) bnames
|
|
in
|
|
(checked, base, bnames)
|
|
|
|
let eval_expr ?(origin = "<eval>") ?(pause = false) ?frame t src : change =
|
|
let form =
|
|
match Source.read_code ~expr:true ~file:origin src with
|
|
| [ f ] -> f
|
|
| [] -> fail Loc.unknown "nothing to evaluate"
|
|
| _ :: f :: _ -> fail f.Form.loc "one expression at a time"
|
|
in
|
|
Loc.remember ~file:origin src;
|
|
(* [Parse.expr] expands, so the imported set has to be in front of it here
|
|
exactly as [eval] puts it in front of a declaration: C-x C-e sends one
|
|
expression with no import in sight, and the session is the only thing
|
|
holding what the imports brought in. Without this the prelude's macros
|
|
would work and a package's would be an unknown name.
|
|
|
|
Expansion happens here, before the thunk is built and long before the
|
|
agent is asked for anything, so the wait in [Dev.eval_expr] is untouched:
|
|
a cold macro module costs its ~300ms before that clock starts,
|
|
and the non-termination refusals raise [Loc.Error] out of this call, which
|
|
the daemon already answers as an error rather than a silence. *)
|
|
let parsed = Parse.with_imported ~decls:(package_decls t) ~fns:(shadowing_fns t origin) (macros_for t origin) (fun () -> Parse.expr form) in
|
|
(* CIDER's rule: an expression sent from a package's file means what it
|
|
would mean written in that file, so [(integrate 1.0)] in physics/step.flan
|
|
reaches [physics/integrate]. The qualification [eval] gives a declaration
|
|
from the same buffer. A [defn-] is reachable too, because the location
|
|
[private_ref] compares is the buffer's own path. *)
|
|
let parsed =
|
|
match package_of t origin with
|
|
| None -> parsed
|
|
| Some p -> Load.rename_expr p.Load.owns p.Load.alias [] parsed
|
|
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 ~fn:(prelude_fn t.decls "pause") parsed.Ast.loc;
|
|
parsed ];
|
|
Ast.loc = parsed.Ast.loc }
|
|
else parsed
|
|
in
|
|
(* Checking against the live environment can *generate* code: the first
|
|
[C-x C-e] of a call to a generic at a type nothing has used yet
|
|
instantiates it here, and the copy lands in [t.env] and in no program
|
|
anywhere. Marked before and collected after, and spliced into the module
|
|
below — without this the thunk calls a symbol the module never defines
|
|
and the host has no cell for. *)
|
|
let mark = Check.instance_mark t.env in
|
|
let lmark = Check.lifted_mark t.env in
|
|
let checked, base, bnames =
|
|
match frame with
|
|
| None -> Check.expression t.env parsed
|
|
| Some frame -> in_frame t ~frame parsed
|
|
in
|
|
let fresh = Check.instances_since t.env mark in
|
|
let lifted = Check.lifted_since t.env lmark 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 @ Check.fresh_copies t.env t.program.Tast.structs;
|
|
datas = t.program.Tast.datas;
|
|
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 = []; fenv = None; 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);
|
|
as_slots = [] }
|
|
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. *)
|
|
(* A body the expression lifted — an [fn] literal, a handler clause — is
|
|
reached by address from the thunk, so it goes into the module with it:
|
|
parented on the thunk, which is what makes [redefinition] carry it, and
|
|
with the environment struct it captured into, which is what lays it out.
|
|
Placed like any other capturing fn, against the whole program, so a
|
|
closure the expression keeps gets an environment the collector owns. *)
|
|
let lifted =
|
|
List.map (fun (f : Tast.fn) -> { f with Tast.fparent = Some name }) lifted
|
|
in
|
|
let placed =
|
|
Check.place_closures (t.program.Tast.fns @ fresh @ lifted @ [ thunk ])
|
|
in
|
|
let own = List.map (fun (f : Tast.fn) -> f.Tast.name) (lifted @ [ thunk ]) in
|
|
let placed =
|
|
List.filter (fun (f : Tast.fn) -> List.mem f.Tast.name own) placed
|
|
in
|
|
let copies = Check.fresh_copies t.env t.program.Tast.structs in
|
|
let program =
|
|
{ t.program with
|
|
Tast.fns = t.program.Tast.fns @ fresh @ placed;
|
|
structs =
|
|
t.program.Tast.structs @ copies @ Check.env_structs t.env lifted;
|
|
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. *)
|
|
redefinition t ~call:name program
|
|
~fns:(List.map (fun (f : Tast.fn) -> f.Tast.name) fresh @ [ name ])
|
|
in
|
|
(* The copies stay in the session's program, unlike the thunk: the thunk is
|
|
not a declaration and there is nothing to keep, but a copy that has been
|
|
built and loaded *is* part of the running process from here on, and
|
|
forgetting it would generate a second one under the same name at the next
|
|
evaluation.
|
|
|
|
After [Emit], not before it: the session must not come to believe it holds
|
|
a body that no module was ever written for. A daemon that answers and has
|
|
lost track of what the program contains is worse than one that died.
|
|
|
|
Written for is as far as this line can get, and it is not far enough on
|
|
its own: the module still has to build and still has to be taken. The
|
|
caller closes that half by taking a [held] before this and restoring it
|
|
when either fails — a copy the session holds and no module defines is a
|
|
null cell exactly as a stranded declaration is. *)
|
|
t.program <-
|
|
{ t.program with
|
|
Tast.fns = t.program.Tast.fns @ fresh;
|
|
structs = t.program.Tast.structs @ copies };
|
|
{ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] }
|
|
|
|
(* ── What a macro call expands to ──────────────────────────────────── *)
|
|
|
|
(* [C-c C-m]. The one thing the editor can ask that compiles nothing, sends
|
|
nothing to the program, and leaves the session exactly as it found it.
|
|
|
|
It is a session operation rather than a [Reader] plus a [Macro] call for the
|
|
reason the whole of this file exists: what a call expands to is decided by
|
|
*which macros this session holds* — the prelude's, the ones its imports
|
|
brought in, and the [defmacro]s the buffer has evaluated since it started —
|
|
and that set lives in [t.macros] and nowhere else. Expanding against a fresh
|
|
read of the file would answer with macros the session was never told about
|
|
and with a version of the ones it was told about that is whatever happens to
|
|
be *saved*. An expansion that disagreed with what an evaluation does would
|
|
be worse than no expansion at all: a macro decides what the code is.
|
|
|
|
Nothing here is assigned. [eval] commits [t.macros] and [eval_expr] bumps
|
|
[t.thunks] and [t.program]; this reads and writes nothing, so a form that
|
|
only *looks* like a declaration — a [defmacro] handed to [C-c C-m] — does
|
|
not join the session by having been looked at. [test_session] pins that. *)
|
|
|
|
type expansion = {
|
|
xbefore : Form.t; (* what was sent, quasiquote already desugared *)
|
|
xafter : Form.t; (* what it expands to *)
|
|
xmacro : string option; (* the macro at the head, when the head is one *)
|
|
(* False when the expansion is the form itself. Reported rather than left for
|
|
the editor to diff, because the two ways of being unchanged are different
|
|
facts: a head that names no macro, and a macro whose answer is its own
|
|
call. Only [xmacro] tells them apart. *)
|
|
xchanged : bool;
|
|
}
|
|
|
|
(* [all] is the difference between CIDER's two commands, and it is real here
|
|
rather than inherited: a macro may quasiquote a call to another macro, so
|
|
[(mac/quad 3)] one-stepped is [(mac/twice (mac/twice 3))] and all the way is
|
|
[(+ (+ 3 3) (+ 3 3))].
|
|
|
|
The refusals both live on the [all] path and both are [Loc.Error], which the
|
|
daemon answers as a reply: a macro that never settles is stopped by
|
|
[Macro.fuel] and named, and a ring of macros was refused while the package
|
|
holding it was parsed, which is before any session over it could exist. One
|
|
step cannot reach either — it makes exactly one call and does not look at
|
|
the answer — so [(s/spin)] one-stepped is a fact about the macro and only
|
|
[C-u] refuses. *)
|
|
let macroexpand ?(origin = "<eval>") ~(all : bool) t (src : string) : expansion =
|
|
let form =
|
|
match Source.read_code ~file:origin src with
|
|
| [ f ] -> f
|
|
| [] -> fail Loc.unknown "nothing to expand"
|
|
| _ :: f :: _ -> fail f.Form.loc "one form at a time"
|
|
in
|
|
(* Desugared first, exactly as [Parse.parse_forms] does it and for its
|
|
reason: a quasiquote that has not been rewritten still looks like a call
|
|
to something named [quasiquote], and the [Form.Sym] inside it looks like a
|
|
head anything could mistake for one. *)
|
|
let before = Expand.quasiquote form in
|
|
(* And the session's macros in front of it, as [eval] and [eval_expr] both
|
|
put them: [Macro.program] reads [Parse.imported_macros] directly. *)
|
|
Parse.with_imported ~decls:(package_decls t) ~fns:(shadowing_fns t origin) (macros_for t origin) @@ fun () ->
|
|
let after, name =
|
|
if all then Macro.expand_all before else Macro.expand_step before
|
|
in
|
|
{ xbefore = before; xafter = after; xmacro = name;
|
|
(* Structural, through the printer both halves are shown with, so "changed"
|
|
means "would print differently" — which is the claim the buffer makes.
|
|
There is no equality on [Form.t] to use instead: it carries a [Loc.t],
|
|
and [Loc.from_macro] stamps a name onto every node a macro answers, so
|
|
even an identity expansion compares unequal. *)
|
|
xchanged = Form.to_source after <> Form.to_source before }
|