Merge master into the generics lane
This commit is contained in:
commit
2f321fd061
@ -262,9 +262,9 @@ driver at all — it goes `llc` + `ld -shared` + `dlopen`, which is what makes
|
||||
is a confusing shape of failure to meet without warning.
|
||||
|
||||
Variables beginning `FLAN_DEV_` other than `FLAN_DEV_LEAKS`, plus
|
||||
`FLAN_AGENT_SOCKET` and `FLAN_COMPILER_STAMP`, are internal: `flan dev` sets
|
||||
them across its own `exec` to hand the merged binary what it needs. Setting
|
||||
them by hand is not supported.
|
||||
`FLAN_AGENT_SOCKET`, `FLAN_AGENT_OWNER` and `FLAN_COMPILER_STAMP`, are
|
||||
internal: `flan dev` sets them across its own `exec` to hand the merged binary
|
||||
what it needs. Setting them by hand is not supported.
|
||||
|
||||
## Checking it
|
||||
|
||||
|
||||
89
TODO.org
89
TODO.org
@ -1464,10 +1464,6 @@ out the first element typing the rest.
|
||||
|
||||
* Dev loop
|
||||
|
||||
** TODO Every evaluated expression leaves its module mapped
|
||||
Each C-x C-e loads its own =.so= and never unloads it, so a session's mapping count
|
||||
grows by about four per evaluation; the kernel's limit (65530) ends a long session.
|
||||
|
||||
** TODO A prelude function shadowed live is reached by the prelude's own calls
|
||||
A defn of a prelude function's name sent to a running =flan dev= installs into the
|
||||
host's cell for that name, so the prelude's calls compiled into the host follow it;
|
||||
@ -1509,12 +1505,6 @@ A finished program parks instead of dying, and a daemon op wakes it and re-enter
|
||||
Globals are not reset between runs — the process never died. Rules out a fresh
|
||||
process per run.
|
||||
|
||||
** NEXT Re-run does not work under --two-process
|
||||
Decided 2026-09-25: re-run under =--two-process= starts a fresh child, installed redefinitions included, and says that globals start over because the process is new.
|
||||
A finished child process is genuinely gone, so there is nothing to wake. Re-run is
|
||||
merged-build only, and since the default backend runs merged it is no longer the
|
||||
blocked case.
|
||||
|
||||
** DONE An accepted re-run reads as running
|
||||
CLOSED: [2026-09-21]
|
||||
A caller that asked for a re-run and then waited for the program to park was
|
||||
@ -1550,14 +1540,6 @@ was delivered" is a generation number rather than a name, so evaluating from
|
||||
inside a break into a thunk that stops on the same condition class is settled by
|
||||
comparing two integers.
|
||||
|
||||
** NEXT Whose break it is, which no counter answers
|
||||
Decided 2026-09-25: fix it. A stop records whether the thread that stopped was running the evaluation's thunk or the program's own code, so the sentence is decided by the frame and not by the generation counter.
|
||||
A game loop that signals during the build or the wait bumps the generation exactly
|
||||
as a thunk would. The machine-readable fields stay right; what is wrong is the
|
||||
sentence. The per-frame program-or-eval label is computed by the daemon from
|
||||
ownership, not from anything in the frame, so this is not the shadow-stack gap it
|
||||
was once written down as. Not queued — the window is narrow.
|
||||
|
||||
** DONE The first evaluation no longer stalls behind the agent socket
|
||||
The accept loop used to sit behind a ten-second wait for the agent socket, so a
|
||||
program that binds its socket late — or not at all — looked ready and answered
|
||||
@ -1603,13 +1585,6 @@ prunes a package nothing calls into in a release build. =flan dev= links the
|
||||
agent's C into every program it builds whether or not the source imports it; a
|
||||
release build links it only when the program calls into it.
|
||||
|
||||
** NEXT FLAN_AGENT_SOCKET in a shell's environment steals the socket
|
||||
Decided 2026-09-25: narrow the gate. The daemon also exports its own pid, and the constructor binds the socket only when that pid is the program's parent (or the program itself, in a merged build).
|
||||
Binding unlinks the path first, and before the constructor that unlink was reached
|
||||
only by an explicit call. A sentence about the shape of the gate rather than an
|
||||
observed problem: only the daemon sets the variable and it never runs release
|
||||
builds. The fix, if it is ever felt, is a narrower gate.
|
||||
|
||||
** DONE The daemon's "has not called (agent/start ...)" note is unreachable
|
||||
CLOSED: [2026-09-25]
|
||||
Retired, with the matching arm of an evaluation's timeout, because it named the
|
||||
@ -1709,10 +1684,11 @@ out versioned bodies and trampolines, and redirecting a value taken before the
|
||||
change. =main= stays refused: its caller is startup code no cell reaches.
|
||||
docs/BUILT.md, "A signature change installs".
|
||||
|
||||
** DONE A module carrying a string literal is never unloaded
|
||||
The transient rule is that a module retaining nothing may go, and a string literal
|
||||
counts as something retained — which silently stopped every module carrying one
|
||||
from ever being unloaded. That is why frame descriptors got their own counter.
|
||||
** DONE An expression's module is unloaded unless it hands out a constant
|
||||
CLOSED: [2026-09-25]
|
||||
A thunk's string literal is a copy the process keeps, and registry names and initial
|
||||
images are copied by the runtime, so none of them pins the module; a condition's
|
||||
name or a restart's text still does. Rules out unloading on a guess about a literal.
|
||||
|
||||
** DONE A redefinition delivered while parked installs on the next re-run
|
||||
The park used to drain the agent ring only when something had asked it to poll,
|
||||
@ -1758,13 +1734,6 @@ nothing orders the two. The read raised on a closed socket and the test binary
|
||||
exited 1 with no failure line, which is the worst shape a failure can have when
|
||||
a lane is judged on the exit status.
|
||||
|
||||
** NEXT A program driven by a real flan dev daemon under a sanitizer
|
||||
Decided 2026-09-25: =flan dev --sanitize= builds the host under ASan/UBSan on the LLVM backend (refused by name with =--x86=), and the @sanitize alias gains a case driving a real session through reloads and a break.
|
||||
The daemon builds its host through its own path and the CLI has no way to pass a
|
||||
sanitizer flag to it. Named as the check worth adding next; a day rather than an
|
||||
hour. The x86 backend is not a gap here — that pair is refused by name, because
|
||||
there is no sanitizer pass over hand-written assembly.
|
||||
|
||||
** DONE A transient signal 11 on a globals daemon
|
||||
CLOSED: [2026-09-25]
|
||||
Not a segfault. The report was OCaml's signal number, and in OCaml's numbering
|
||||
@ -1816,11 +1785,12 @@ line and every later row unrun.
|
||||
gone. The dev daemon now removes its own on a clean end; the one-shot commands do
|
||||
not.
|
||||
|
||||
** TODO An x86 dev session's dyn global sometimes reads wrong after an allocating thunk
|
||||
test_dev's =--x86: after a thunk that allocates (cycle 1) the parked program's dyn
|
||||
global reads "kept"= failed once in a full =dune test= on 2026-09-25 and passed three
|
||||
direct reruns. Intermittent and GC-shaped: a dyn global read after a collection a
|
||||
C-x C-e thunk triggered. Needs reproducing under load and fixing.
|
||||
** WAIT An x86 dev session's read of a dyn global after an allocating thunk failed once
|
||||
WAIT on a recurrence; the test now prints the failing read's own reply.
|
||||
The one failure's message came from a second read, which said "kept"; the failing
|
||||
reply itself was not recorded. Not reproduced in 350 churn-and-read cycles under
|
||||
8-way load, three concurrent test_dev runs, or a valgrind run of the cycle, which
|
||||
was clean.
|
||||
|
||||
* Editor
|
||||
|
||||
@ -1987,15 +1957,6 @@ maps bind =q=, and the diagnostics map binds =RET= and =q=, so those keys are
|
||||
the mode's own and behave the same under Evil. Every key a mode does not bind
|
||||
itself, including the rest of =special-mode-map=, stays Evil's.
|
||||
|
||||
** NEXT Eval in the frame, from the break loop
|
||||
Decided 2026-09-25: SLIME's eval-in-frame, as described.
|
||||
An expression is evaluated at a frame boundary, so it sees globals and not the
|
||||
stopped frame's locals — which are the values anyone stopped there wants. Wants
|
||||
SLIME's eval-in-frame: pick a frame, and the expression is checked and run with
|
||||
its slots in scope. The slots are already on the frame and already readable
|
||||
(=flan_dev_frame_slot=); what is missing is checking an expression against that
|
||||
frame's names and types.
|
||||
|
||||
** DONE The stack lists prelude frames
|
||||
CLOSED: [2026-09-25]
|
||||
A frame whose location is =<prelude>= is hidden by default, and a line in its
|
||||
@ -2004,14 +1965,15 @@ because =locals= and the inspector are asked by it. The innermost frame is
|
||||
shown even when it is the prelude's, unless the stop is =(pause)=, because it
|
||||
is where the program stopped. Rules out renumbering the visible frames.
|
||||
|
||||
** NEXT There is no stepper
|
||||
Decided 2026-09-25: stepping happens inside a stopped frame, so the game loop and its clock are frozen, as under =(pause)=.
|
||||
=(pause)= stops and offers restarts, frames, locals and the inspector, but
|
||||
nothing advances a form at a time. CIDER instruments a form and steps the
|
||||
instrumented copy; the equivalent here is a dev-build-only instrumented
|
||||
redefinition, which the cell indirection already makes deliverable. Open:
|
||||
whether stepping suspends the frame loop, and what it does to a game's clock.
|
||||
** DONE C-c C-c reports one error, not every error in the form
|
||||
CLOSED: [2026-09-25]
|
||||
Every error at any depth: a refused subexpression stands as a Never that fits
|
||||
any want, and what it causes is left unsaid. Rules out stopping at a statement boundary.
|
||||
|
||||
** DONE There is no stepper
|
||||
CLOSED: [2026-09-25]
|
||||
C-c C-s instruments a defn with a step point before each body form; no step
|
||||
into a callee, no argument positions, and no value shown after a form.
|
||||
** DONE A NaN cast says "does not fit", which reads as too big
|
||||
CLOSED: [2026-09-25]
|
||||
Two more =ArithError= codes: 5 for a cast of NaN and 6 for a cast of an infinity,
|
||||
@ -2034,23 +1996,10 @@ rebinds all at once. No other form had the gap: =let= was already sequential,
|
||||
=dotimes= binds one name, and =fn=, =defn=, =match= and the handler and restart
|
||||
clauses bind parameters with no initialisers.
|
||||
|
||||
** NEXT C-c C-c reports one error, not every error in the form
|
||||
Decided 2026-09-25: every error in the form, at any depth. A failed subexpression takes an error type that fits any want, so checking continues around it and the errors it would cause are not reported — Rust's, TypeScript's and Elm's shape. Rules out stopping at a statement boundary.
|
||||
Whole-file paths use =Check.program_all= and report every bad declaration. The
|
||||
daemon asks for the sink off (=lib/loc.ml:185=) and gets one exception, so a
|
||||
function with three bad expressions takes three round trips. The sink is
|
||||
per-phase; making it per-form would need a resync point inside a body.
|
||||
|
||||
** DONE A session should start before a program compiles
|
||||
CLOSED: [2026-09-25]
|
||||
A file with no =main= starts on a stub =main= that returns and parks; =load-file= (=C-c C-k=, already its key — the inspector stays on =C-c C-i=) keeps what compiles and lists the rest. Rules out =flan dev= with no file at all, and =--two-process= on a file with no =main=.
|
||||
|
||||
** NEXT The daemon buffer is navigable but not coloured
|
||||
Decided 2026-09-25: errors, warnings and notes take compilation-mode's faces, and the program's own output takes a face of its own so it reads apart from the compiler's.
|
||||
=*flan*= is all plain text. =compilation-minor-mode= is on (=emacs/flan.el:822=)
|
||||
so =next-error= works, but a minor mode installs no font-lock. Open: whether the
|
||||
program's output should look different from the compiler's.
|
||||
|
||||
** DONE compilation-mode steps over the notes
|
||||
CLOSED: [2026-09-25]
|
||||
The daemon buffer and the diagnostics buffer set =compilation-skip-threshold= to
|
||||
|
||||
12
bin/main.ml
12
bin/main.ml
@ -799,7 +799,11 @@ let () =
|
||||
which is the point of leaving it readable here — the combination stays
|
||||
refused by name, it is just no longer somewhere you arrive by typing one
|
||||
flag. *)
|
||||
let x86 = backend_x86 ~default:(not debug) rest in
|
||||
(* --sanitize takes [--llvm]'s side for the reason [--debug] does: the
|
||||
sanitizers are LLVM passes. [--x86] written as well is refused by name
|
||||
in [Dev.start]. *)
|
||||
let sanitize = List.mem sanitize_flag rest in
|
||||
let x86 = backend_x86 ~default:(not (debug || sanitize)) rest in
|
||||
let asked_x86 = List.mem x86_flag rest in
|
||||
let merged = not (List.mem two_process_flag rest) in
|
||||
let rest = List.filter (fun a -> not (is_flag a)) rest in
|
||||
@ -809,8 +813,8 @@ let () =
|
||||
| [] -> Filename.concat (Filename.dirname path) ".flan-dev.sock"
|
||||
| _ ->
|
||||
prerr_endline
|
||||
"usage: flan dev <program.flan> [-s socket] [--debug] [--llvm] \
|
||||
[--two-process]";
|
||||
"usage: flan dev <program.flan> [-s socket] [--debug] [--sanitize] \
|
||||
[--llvm] [--two-process]";
|
||||
exit 2
|
||||
in
|
||||
(* Only this command hands one over, and only when it chose the backend
|
||||
@ -826,7 +830,7 @@ let () =
|
||||
else None
|
||||
in
|
||||
with_errors ?x86_hint path (fun () ->
|
||||
Flan.Dev.start ~debug ~merged ~x86 ~file:path ~sock ())
|
||||
Flan.Dev.start ~debug ~sanitize ~merged ~x86 ~file:path ~sock ())
|
||||
|
||||
(* One redefinition, built the way an editor will ask for it: a session over
|
||||
the program the process was built from, and a file of the forms that
|
||||
|
||||
@ -1045,8 +1045,9 @@ the two builds are *supposed* to differ, since `flan_dev_crash_enable` checks a
|
||||
install the handler when ASan is in the process. So the case asserts ASan's report and the absence of the handler's
|
||||
line, built at `-O0` because at `-O2` a store through a zeroed `(Ptr u8)` is undefined and need not fault. That yield had
|
||||
never run in any build anywhere: it was behind a link that did not happen. Twenty-six seconds of the alias's 2m30 warm.
|
||||
What it still does not reach is a program driven by a real daemon under ASan: `flan dev` builds its host through its own
|
||||
path and has no `--sanitize` to pass it.
|
||||
`dev_session` drives a real `flan dev --sanitize` session — merged, LLVM, the compiler's OCaml in the same process as
|
||||
the sanitized host — through a break, three reloads and a second break; the modules it sends are still not
|
||||
instrumented.
|
||||
|
||||
**Two aliases were green only because `dune test` runs first, and that is the same disease in a different place.**
|
||||
`@sanitize` never listed the package directories `pkg-diamond.flan` imports and `@page` never listed `sand.flan`, which
|
||||
@ -1821,7 +1822,9 @@ shape TODO.org's "The compiler is a thread inside the program" landed on: **the
|
||||
program's process. It is SLIME's model — you start the image, it serves, the editor connects.
|
||||
|
||||
`--two-process` is the escape hatch, for a machine where the compiler object cannot be built (no `ocamlfind`, no
|
||||
`flan.cmxa` beside the binary). It has its own test and it stays.
|
||||
`flan.cmxa` beside the binary). It has its own test and it stays. A re-run there is a new child built from the session
|
||||
as it stands, so the redefinitions are in it and the globals start over; the daemon outlives a finished child to take
|
||||
that request.
|
||||
|
||||
**The editor socket and its wire protocol did not move.** Emacs cannot tell the difference, which is what made the merge
|
||||
testable: the whole existing suite is the check.
|
||||
|
||||
@ -236,6 +236,12 @@ breakpoint is just a condition nobody handled.
|
||||
hit it as many times as you like; an ordinary `C-c C-c` over the same form (or
|
||||
`C-c C-k` over the buffer) takes it off.
|
||||
|
||||
**Stepping.** `C-c C-s` installs the `defn` at point so that a call stops
|
||||
before each form of its body. Each stop is a break like `(pause)`, and the
|
||||
source of the form about to run is shown beside it. `s` goes to the next form,
|
||||
`c` runs the rest of the call, and the next call steps again. `C-c C-c` over the
|
||||
same form installs it plain.
|
||||
|
||||
`C-u C-x C-e` does the same for the expression before point: it stops *at* the
|
||||
expression instead of printing its value. That one does not stick, because there
|
||||
is no definition for it to stick to. `C-u C-c C-c` on a top-level form that is
|
||||
@ -375,6 +381,9 @@ Keys in that buffer:
|
||||
| `v` | visit the source of the frame at point |
|
||||
| `P` | show or hide the prelude's frames |
|
||||
| `i` | inspect the local or global at point |
|
||||
| `e` | evaluate an expression in the frame at point; it sees that frame's locals |
|
||||
| `s` | at a step, go to the next form |
|
||||
| `c` | take `continue`: at a step, run the rest of the call |
|
||||
| `a` | abort |
|
||||
| `g` | read the program again |
|
||||
| `q` | close the buffer |
|
||||
@ -1186,6 +1195,7 @@ Use `C-c C-g` if you need frames.
|
||||
| `C-u C-c C-c` | ...and stop at the form point is inside (`C-u C-u`: on entry) |
|
||||
| `C-M-x` | the same as `C-c C-c`, on the binding SLIME and CIDER use |
|
||||
| `C-c C-k` | load the whole buffer, as one module; what does not compile is listed |
|
||||
| `C-c C-s` | install the defn at point to stop before each form of its body |
|
||||
| `C-x C-e` | the form before point, evaluated — or installed, if it is a declaration |
|
||||
| `C-u C-x C-e` | ...and stop at it instead of showing its value |
|
||||
| `C-c C-z` | connect (finds `.flan-dev.sock` upward) |
|
||||
|
||||
@ -63,6 +63,7 @@
|
||||
;;; Code:
|
||||
|
||||
(require 'seq)
|
||||
(require 'pulse)
|
||||
(require 'subr-x)
|
||||
(require 'flan-mode)
|
||||
|
||||
@ -170,6 +171,15 @@ nothing in the compiler knows a breakpoint from an error and this buffer is the
|
||||
first place that can tell the difference. Named here rather than spelled at
|
||||
its use, because it is a fact about the prelude.")
|
||||
|
||||
(defconst flan-cnr-step "StepPoint"
|
||||
"The condition the stepper's `(step-point)' signals, before each form of a
|
||||
defn sent with `C-c C-s'. A stop like `(pause)', with `next' and `continue'
|
||||
restarts: `s' takes the first and `c' the second.")
|
||||
|
||||
(defun flan-cnr--stepping-p (state)
|
||||
"Whether STATE is a stop of the stepper."
|
||||
(equal (plist-get state :condition) flan-cnr-step))
|
||||
|
||||
(defun flan-cnr--headline-fields (fields)
|
||||
"The condition's own numbers, folded into the headline.
|
||||
FIELDS is the fields list; the result is \"low 9, high 9, length 4\" over the
|
||||
@ -229,7 +239,7 @@ indexing or the division itself, so it sits directly under the headline."
|
||||
;; only thing that can be wrong here is the word for it. Calling a
|
||||
;; breakpoint unhandled would be a small lie told at the top of the
|
||||
;; one buffer that exists to say what happened.
|
||||
(paused (equal name flan-cnr-breakpoint))
|
||||
(paused (member name (list flan-cnr-breakpoint flan-cnr-step)))
|
||||
(numbers (flan-cnr--headline-fields (plist-get state :fields))))
|
||||
(insert (propertize name 'face (if paused 'warning 'error)))
|
||||
(when numbers (insert " — " numbers))
|
||||
@ -240,9 +250,11 @@ indexing or the division itself, so it sits directly under the headline."
|
||||
(let ((sentence (plist-get state :sentence)))
|
||||
(when sentence (insert sentence "\n")))
|
||||
(insert (propertize
|
||||
(if paused
|
||||
"stopped at (pause); nothing has been unwound\n"
|
||||
"unhandled; stopped where it erred, nothing unwound\n")
|
||||
(cond
|
||||
((flan-cnr--stepping-p state)
|
||||
"stepping: stopped before the form below; s steps to the next, c runs the rest of the call\n")
|
||||
(paused "stopped at (pause); nothing has been unwound\n")
|
||||
(t "unhandled; stopped where it erred, nothing unwound\n"))
|
||||
'face 'shadow))
|
||||
(flan-cnr--insert-site state))
|
||||
(insert "\n")
|
||||
@ -439,7 +451,8 @@ breakpoint the program's author wrote, not a step of the program."
|
||||
(if (and (not flan-cnr--show-prelude)
|
||||
(flan-cnr--prelude-frame-p fr)
|
||||
(or (> i 0)
|
||||
(equal (plist-get state :condition) flan-cnr-breakpoint)))
|
||||
(equal (plist-get state :condition) flan-cnr-breakpoint)
|
||||
(flan-cnr--stepping-p state)))
|
||||
(setq hidden (1+ hidden))
|
||||
(when (> hidden 0)
|
||||
(flan-cnr--insert-hidden hidden)
|
||||
@ -574,7 +587,7 @@ puts the likely culprit on top."
|
||||
;; an entry is annotated with have to be on screen above it to read.
|
||||
(flan-cnr--insert-globals state)
|
||||
(insert (propertize
|
||||
"RET/0-9 take RET on a frame visits it TAB fold P prelude frames i inspect a abort g refresh q quit\n"
|
||||
"RET/0-9 take RET on a frame visits it TAB fold P prelude frames i inspect e eval in frame s step c continue a abort g refresh q quit\n"
|
||||
'face 'shadow))
|
||||
(goto-char (point-min))
|
||||
;; Point starts on the restart that abandons the evaluation, when there is
|
||||
@ -833,6 +846,69 @@ drawn from."
|
||||
(`(:expr ,expr) (flan-inspect expr))
|
||||
(_ (user-error "flan: this line carries no root the inspector knows")))))
|
||||
|
||||
(defun flan-cnr--frame-at-point ()
|
||||
"The index of the frame point is on, or on a local of, or nil."
|
||||
(or (get-text-property (point) 'flan-cnr-frame)
|
||||
(pcase (get-text-property (point) 'flan-cnr-inspect)
|
||||
(`(:slot ,frame . ,_) frame))))
|
||||
|
||||
(defun flan-cnr-eval-in-frame (frame code)
|
||||
"Evaluate CODE in stopped FRAME, SLIME's eval-in-frame, and show the value.
|
||||
CODE sees FRAME's locals as well as the globals, and a `set' of a local
|
||||
changes the frame. Interactively FRAME is the one point is on, or on a
|
||||
local of, and CODE is read from the minibuffer."
|
||||
(interactive
|
||||
(let ((frame (flan-cnr--frame-at-point)))
|
||||
(unless frame
|
||||
(user-error "flan: point is not on a frame — e evaluates in the frame point is on"))
|
||||
(list frame (read-string (format "Eval in frame %d: " frame)))))
|
||||
(let ((r (funcall flan-cnr-request-function
|
||||
(list :op "eval-expr" :frame frame :code code))))
|
||||
(if (equal (plist-get r :status) "ok")
|
||||
(let ((v (or (plist-get r :value) (plist-get r :note) "")))
|
||||
;; A set may have changed what an open frame shows, so each is
|
||||
;; asked again the next time it is opened.
|
||||
(dolist (fr (plist-get flan-cnr--state :stack))
|
||||
(when (consp fr) (plist-put fr :fetched nil)))
|
||||
(message "=> %s" v)
|
||||
v)
|
||||
(user-error "flan: %s" (or (plist-get r :message) "refused")))))
|
||||
|
||||
(defun flan-cnr--take-named (name)
|
||||
"Take the innermost restart called NAME, or refuse by name."
|
||||
(let ((i (seq-position (plist-get flan-cnr--state :restarts) name)))
|
||||
(unless i (user-error "flan: there is no %s restart at this stop" name))
|
||||
(flan-cnr--invoke i name)))
|
||||
|
||||
(defun flan-cnr-step ()
|
||||
"Step to the next form: take the stepper's `next' restart."
|
||||
(interactive)
|
||||
(flan-cnr--take-named "next"))
|
||||
|
||||
(defun flan-cnr-continue ()
|
||||
"Take the innermost `continue' restart.
|
||||
At a stepper's stop it runs the rest of the call; at a `(pause)' it resumes."
|
||||
(interactive)
|
||||
(flan-cnr--take-named "continue"))
|
||||
|
||||
(defun flan-cnr--step-site (state)
|
||||
"Where a stepper's STATE stopped: the first frame that is not the prelude's."
|
||||
(seq-some (lambda (fr)
|
||||
(and (not (flan-cnr--prelude-frame-p fr))
|
||||
(plist-get fr :loc)))
|
||||
(plist-get state :stack)))
|
||||
|
||||
(defun flan-cnr--show-step-site (state)
|
||||
"At a stepper's stop, show the form about to run in its source, highlighted.
|
||||
The break buffer keeps the selection; the source is shown beside it."
|
||||
(let ((loc (and (flan-cnr--stepping-p state) (flan-cnr--step-site state))))
|
||||
(when loc
|
||||
(ignore-errors
|
||||
(save-selected-window
|
||||
(with-current-buffer (flan-visit-loc loc "the step")
|
||||
(pulse-momentary-highlight-region
|
||||
(point) (save-excursion (ignore-errors (forward-sexp)) (point)))))))))
|
||||
|
||||
(defun flan-cnr-refresh ()
|
||||
"Ask the program again what it is offering."
|
||||
(interactive)
|
||||
@ -889,7 +965,12 @@ anyone who would rather TAB always moved."
|
||||
(define-key map "v" #'flan-cnr-visit)
|
||||
(define-key map "P" #'flan-cnr-toggle-prelude)
|
||||
(define-key map "i" #'flan-cnr-inspect)
|
||||
;; SLIME's `e': evaluate in the frame at point.
|
||||
(define-key map "e" #'flan-cnr-eval-in-frame)
|
||||
(define-key map "a" #'flan-cnr-abort)
|
||||
;; The stepper's two, CIDER's `c' and SLIME's `s' (`n' moves).
|
||||
(define-key map "s" #'flan-cnr-step)
|
||||
(define-key map "c" #'flan-cnr-continue)
|
||||
(define-key map "g" #'flan-cnr-refresh)
|
||||
(define-key map "q" #'quit-window)
|
||||
;; Numbered, as SBCL's are, and for SBCL's reason: the names are not
|
||||
@ -1132,6 +1213,7 @@ walk from a running program."
|
||||
;; the program running again: see `flan--forget-break-stack'.
|
||||
(setq next-error-last-buffer buf))
|
||||
(pop-to-buffer buf)
|
||||
(flan-cnr--show-step-site (buffer-local-value 'flan-cnr--state buf))
|
||||
buf)))
|
||||
|
||||
(provide 'flan-cnr)
|
||||
|
||||
@ -87,6 +87,7 @@
|
||||
;; wiring they need.
|
||||
(autoload 'flan-inspect "flan-inspect" nil t)
|
||||
(autoload 'flan-cnr-show "flan-cnr" nil t)
|
||||
(autoload 'flan-step-defun "flan" nil t)
|
||||
(autoload 'flan-doc "flan" nil t)
|
||||
(autoload 'flan "flan" nil t)
|
||||
(autoload 'flan-quit "flan" nil t)
|
||||
@ -448,6 +449,8 @@ For `syntax-propertize-function'."
|
||||
;; reads as the client being broken rather than as the key being free.
|
||||
(define-key map (kbd "C-M-x") #'flan-eval-defun)
|
||||
(define-key map (kbd "C-c C-k") #'flan-eval-buffer)
|
||||
;; The stepper: the defn at point, installed to stop before each form.
|
||||
(define-key map (kbd "C-c C-s") #'flan-step-defun)
|
||||
(define-key map (kbd "C-x C-e") #'flan-eval-last-sexp)
|
||||
(define-key map (kbd "C-c C-z") #'flan-connect)
|
||||
(define-key map (kbd "C-c C-q") #'flan-disconnect)
|
||||
|
||||
@ -412,6 +412,34 @@ nil keeps everything."
|
||||
(let ((inhibit-read-only t))
|
||||
(delete-region (point-min) (line-beginning-position)))))))
|
||||
|
||||
(defface flan-output-face '((t :inherit font-lock-string-face))
|
||||
"Face for the running program's own output in the daemon's buffer.
|
||||
It sets that output apart from what the compiler and the daemon say, whose
|
||||
errors, warnings and notes take `compilation-mode''s faces."
|
||||
:group 'flan)
|
||||
|
||||
(defun flan--daemon-buffer-setup ()
|
||||
"Make the current buffer the daemon's log: navigable and coloured.
|
||||
The daemon writes a diagnostic as `file:line:col: message', the shape
|
||||
`compilation-minor-mode' already reads, so it only has to be switched on.
|
||||
The minor mode adds its font-lock rules but turns nothing on, and a process
|
||||
buffer is in `fundamental-mode', which global font-lock skips; so font-lock
|
||||
is switched on here, first, or the rules would never be drawn."
|
||||
(font-lock-mode 1)
|
||||
;; A log, not source: a quote the program printed opens no string.
|
||||
(setq-local font-lock-keywords-only t)
|
||||
;; Only the compiler's own shape, `file:line:col:', is a diagnostic here.
|
||||
;; compile.el's other rules are for a build log: one of them draws any
|
||||
;; line starting `word:' as a program name, which is every `score: 10'
|
||||
;; the program prints.
|
||||
(setq-local compilation-mode-font-lock-keywords nil)
|
||||
(setq-local compilation-error-regexp-alist
|
||||
'(("^\\([^ \t\n:][^\t\n:]*\\):\\([0-9]+\\):\\([0-9]+\\): \
|
||||
\\(?:\\(warning\\)\\|\\(note\\|info\\)\\)?"
|
||||
1 2 3 (4 . 5))))
|
||||
(compilation-minor-mode 1)
|
||||
(flan--navigable-notes))
|
||||
|
||||
(defun flan--append-output (text)
|
||||
"Append TEXT, the running program's own output, where it can be read.
|
||||
Two places. The daemon's log always gets it, so output lands somewhere
|
||||
@ -423,7 +451,13 @@ open, above its prompt, which is where whoever is typing there is looking."
|
||||
(inhibit-read-only t))
|
||||
(save-excursion
|
||||
(goto-char (point-max))
|
||||
(insert text))
|
||||
;; Marked as it is inserted, because nothing in the text says whose
|
||||
;; it is. A line the program prints in the diagnostic shape is
|
||||
;; still read as one by `compilation-minor-mode', and takes its
|
||||
;; face. `face' for a buffer with font-lock off, `font-lock-face'
|
||||
;; so fontification does not strip it.
|
||||
(insert (propertize text 'face 'flan-output-face
|
||||
'font-lock-face 'flan-output-face)))
|
||||
(flan--trim-lines)
|
||||
;; Follow the tail only for someone who was already at it; a reader
|
||||
;; scrolled back is reading something.
|
||||
@ -893,8 +927,7 @@ It builds the program first, which for a cold project is most of this."
|
||||
;; program runs, and `compilation-mode' would claim it as the output of
|
||||
;; one finished command — killing the process on a `recompile', among
|
||||
;; other things it has no business doing to a live session.
|
||||
(compilation-minor-mode 1)
|
||||
(flan--navigable-notes))
|
||||
(flan--daemon-buffer-setup))
|
||||
(make-process
|
||||
:name "flan-daemon" :buffer buf
|
||||
:command args
|
||||
@ -2566,7 +2599,7 @@ signature, listed in %s"
|
||||
(user-error "flan: %s%s" (or msg "rejected")
|
||||
(if loc (format " (%s)" loc) "")))))
|
||||
|
||||
(defun flan--eval (code what &optional start end pause)
|
||||
(defun flan--eval (code what &optional start end pause step)
|
||||
"Send CODE to the running program. WHAT names it for the echo area.
|
||||
START and END, when given, are the region it came from, flashed on success.
|
||||
PAUSE, when given, is (BEG . END): the bounds of the form inside CODE the
|
||||
@ -2582,11 +2615,20 @@ breakpoint is marked from the editor, without editing the buffer\"."
|
||||
(list :op "eval" :code code :file (or buffer-file-name "<buffer>")
|
||||
:syntax (flan--syntax))
|
||||
(when pause
|
||||
(list :pause (flan--wire-position (car pause))))))))
|
||||
(list :pause (flan--wire-position (car pause))))
|
||||
(when step (list :step t))))))
|
||||
;; END as the place a value could go. Every caller of this sends a
|
||||
;; declaration and declarations have no value, so this is the path that
|
||||
;; stays open rather than one anybody takes today.
|
||||
(flan--report reply what end)
|
||||
;;
|
||||
;; A form with several errors is refused with all of them under
|
||||
;; `:errors'; `flan--report' marks and signals the first, and the rest
|
||||
;; are marked beside it before the signal leaves, as `C-c C-k' does.
|
||||
(condition-case err
|
||||
(flan--report reply what end)
|
||||
(user-error
|
||||
(flan--report-load-errors (cdr (plist-get reply :errors)) t)
|
||||
(signal (car err) (cdr err))))
|
||||
;; `flan--report' signals on a rejection, so reaching here means it
|
||||
;; landed. Flashing the text that was sent answers "which form did that
|
||||
;; take?" — the question the echo area cannot, because point may be nowhere
|
||||
@ -2601,6 +2643,10 @@ breakpoint is marked from the editor, without editing the buffer\"."
|
||||
(cond
|
||||
((and pause (plist-get reply :pause))
|
||||
(flan--show-pause (car pause) (cdr pause)))
|
||||
;; An instrumented defn is marked whole, as a pause mark is, and an
|
||||
;; ordinary C-c C-c of it takes the mark down with the instrumentation.
|
||||
((and step start end (plist-get reply :step))
|
||||
(flan--show-pause start end))
|
||||
((and start end) (flan-clear-pause start end)))
|
||||
reply))
|
||||
|
||||
@ -2893,6 +2939,20 @@ declaration for it to live in."
|
||||
;; `flan--report' signals on a rejection.
|
||||
(pulse-momentary-highlight-region (car b) end))))))
|
||||
|
||||
;;;###autoload
|
||||
(defun flan-step-defun ()
|
||||
"Install the defn at point so that a call stops before each form of its body.
|
||||
A stepper, CIDER's `C-u C-M-x': each stop is a break like `(pause)', with the
|
||||
program and its clock frozen, and the break buffer shows the form about to
|
||||
run. There `s' steps to the next form and `c' runs the rest of the call; the
|
||||
next call steps again. `C-c C-c' on the defn installs it plain."
|
||||
(interactive)
|
||||
(let* ((b (flan--defun-bounds))
|
||||
(head (and (< (car b) (cdr b))
|
||||
(flan--declaration-head-at (car b) flan--defun-heads))))
|
||||
(unless head (user-error "flan: no defn at point to step through"))
|
||||
(flan--eval (flan--text (car b) (cdr b)) "form" (car b) (cdr b) nil t)))
|
||||
|
||||
;;;###autoload
|
||||
(defun flan-eval-buffer ()
|
||||
"Load this buffer into the running program, as `C-c C-k' does in SLIME and CIDER.
|
||||
|
||||
@ -1477,6 +1477,114 @@ would be overwritten. Look again and re-do the edit")
|
||||
(test-flan--check "nothing is evaluated as an expression"
|
||||
(null (plist-get (car asked) :code))))))
|
||||
|
||||
;; `e' evaluates in the frame point is on, or on a local of: the request
|
||||
;; names that frame, and the value comes back to the echo area.
|
||||
(let* ((asked nil)
|
||||
(flan-cnr-request-function
|
||||
(lambda (form) (push form asked) '(:status "ok" :value "8"))))
|
||||
(with-current-buffer (test-flan--cnr
|
||||
(list :condition "Missing" :restarts '("retry")
|
||||
:stack (list (list :fn "g" :fetched t
|
||||
:locals '(("b" "i64" "1" 4)))
|
||||
(list :fn "f" :fetched t
|
||||
:locals '(("n" "i64" "7" 0))))))
|
||||
(goto-char (point-min))
|
||||
(search-forward " 1: > f")
|
||||
(flan-cnr-toggle-frame)
|
||||
(goto-char (point-min))
|
||||
(search-forward " 1: v f")
|
||||
(search-forward "i64 n")
|
||||
(let ((said (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "(+ n 1)"))
|
||||
((symbol-function 'message)
|
||||
(lambda (fmt &rest args) (apply #'format fmt args))))
|
||||
(call-interactively #'flan-cnr-eval-in-frame))))
|
||||
(test-flan--check "`e' on a local evaluates in that local's frame"
|
||||
(and (equal (plist-get (car asked) :op) "eval-expr")
|
||||
(= 1 (plist-get (car asked) :frame))
|
||||
(equal (plist-get (car asked) :code) "(+ n 1)")))
|
||||
(test-flan--check "and answers the value"
|
||||
(equal said "8")))
|
||||
(test-flan--check "`e' is the break buffer's own key"
|
||||
(eq (lookup-key flan-cnr-mode-map "e") #'flan-cnr-eval-in-frame))))
|
||||
|
||||
;; The stepper's stop: said as a step, the prelude's own frame hidden, and
|
||||
;; `s' and `c' take its `next' and `continue' by index.
|
||||
(let* ((asked nil)
|
||||
(flan-cnr-request-function
|
||||
(lambda (form) (push form asked) '(:status "ok"))))
|
||||
(with-current-buffer (test-flan--cnr
|
||||
(list :condition "StepPoint"
|
||||
:restarts '("next" "continue" "continue")
|
||||
:stack (list (list :fn "step-point" :loc "<prelude>:250:3")
|
||||
(list :fn "step" :loc "/s.flan:1:19"))))
|
||||
(let ((text (buffer-string)))
|
||||
(test-flan--check "a step's headline says it is stepping"
|
||||
(string-match-p "stepping: stopped before the form" text))
|
||||
(test-flan--check "and the prelude's step-point frame is hidden"
|
||||
(not (string-match-p "step-point" text))))
|
||||
(test-flan--check "the step site is the stepped frame's location"
|
||||
(equal (flan-cnr--step-site flan-cnr--state) "/s.flan:1:19"))
|
||||
(save-window-excursion (flan-cnr-step))
|
||||
(test-flan--check "`s' takes next"
|
||||
(and (equal (plist-get (car asked) :op) "restart-at")
|
||||
(equal (plist-get (car asked) :name) "next")
|
||||
(= 0 (plist-get (car asked) :index)))))
|
||||
(with-current-buffer (test-flan--cnr
|
||||
(list :condition "StepPoint"
|
||||
:restarts '("next" "continue" "continue")))
|
||||
(save-window-excursion (flan-cnr-continue))
|
||||
(test-flan--check "`c' takes the innermost continue"
|
||||
(and (equal (plist-get (car asked) :name) "continue")
|
||||
(= 1 (plist-get (car asked) :index)))))
|
||||
(test-flan--check "`s' and `c' are the break buffer's own keys"
|
||||
(and (eq (lookup-key flan-cnr-mode-map "s") #'flan-cnr-step)
|
||||
(eq (lookup-key flan-cnr-mode-map "c") #'flan-cnr-continue))))
|
||||
|
||||
;; Every key flan-mode binds has a row in the manual's key reference.
|
||||
(let ((text (with-temp-buffer
|
||||
(insert-file-contents
|
||||
(expand-file-name "MANUAL.md"
|
||||
(file-name-directory (locate-library "flan-mode"))))
|
||||
(buffer-string)))
|
||||
(missing nil))
|
||||
(map-keymap
|
||||
(lambda (k d)
|
||||
(when (and (eq k ?\C-c) (keymapp d))
|
||||
(map-keymap
|
||||
(lambda (k2 d2)
|
||||
(when (commandp d2)
|
||||
(let ((desc (replace-regexp-in-string
|
||||
"RET" "C-m"
|
||||
(replace-regexp-in-string
|
||||
"TAB" "C-i" (key-description (vector k k2))))))
|
||||
(unless (string-match-p (regexp-quote (format "| `%s` |" desc)) text)
|
||||
(push desc missing)))))
|
||||
d)))
|
||||
flan-mode-map)
|
||||
(test-flan--check (format "every C-c key has a row in the manual (missing %s)" missing)
|
||||
(null missing)))
|
||||
|
||||
;; C-c C-s sends the defn at point for stepping and marks it.
|
||||
(let ((sent nil))
|
||||
(with-temp-buffer
|
||||
(flan-mode)
|
||||
(insert "(defn step [] i64\n (set ticks 1)\n ticks)\n")
|
||||
(goto-char (point-min))
|
||||
(forward-line 1)
|
||||
(cl-letf (((symbol-function 'flan--request)
|
||||
(lambda (form) (setq sent form)
|
||||
'(:status "ok" :fns ("step") :names ("step") :step t)))
|
||||
((symbol-function 'flan-refresh-defs) #'ignore))
|
||||
(flan-step-defun))
|
||||
(test-flan--check "C-c C-s sends the defn with :step"
|
||||
(and (equal (plist-get sent :op) "eval")
|
||||
(plist-get sent :step)
|
||||
(string-prefix-p "(defn step" (plist-get sent :code))))
|
||||
(test-flan--check "and marks it as instrumented"
|
||||
(flan--pause-overlays))
|
||||
(test-flan--check "C-c C-s is flan-mode's key for it"
|
||||
(eq (lookup-key flan-mode-map (kbd "C-c C-s")) #'flan-step-defun))))
|
||||
|
||||
;; `flan-cnr-show' refuses a running program by name rather than opening an
|
||||
;; empty buffer.
|
||||
;; The layout without the values: what a `layout' op alone would buy. The
|
||||
|
||||
@ -533,6 +533,43 @@ already rely on it — so nothing here is a stand-in for the real thing."
|
||||
;; The session is not poisoned by that: a good form still lands.
|
||||
(flan--eval "(defn step [] i64 (set ticks (+ ticks 100)) ticks)" "form")
|
||||
|
||||
;; The daemon's buffer is coloured: the compiler's errors, warnings and
|
||||
;; notes take compilation's faces and the program's own output takes
|
||||
;; `flan-output-face'. Checked on `font-lock-face', which is what
|
||||
;; fontification writes; batch Emacs cannot turn `font-lock-mode' on, so
|
||||
;; nothing here aliases it to `face'.
|
||||
(let ((flan-daemon-buffer " *flan-colour-test*"))
|
||||
(with-current-buffer (get-buffer-create flan-daemon-buffer)
|
||||
(insert "flan dev: built x.flan in 3ms\n"
|
||||
"/tmp/a.flan:2:8: expected i32, found string\n"
|
||||
"/tmp/a.flan:3:1: warning: w\n"
|
||||
"/tmp/a.flan:4:1: note: n\n")
|
||||
(flan--daemon-buffer-setup)
|
||||
(flan--append-output "said hi\nscore: 10\n")
|
||||
(font-lock-ensure)
|
||||
(let ((face-on (lambda (text)
|
||||
(goto-char (point-min))
|
||||
(search-forward text)
|
||||
(get-text-property (match-beginning 0) 'font-lock-face))))
|
||||
(test-flan--check
|
||||
"the daemon's buffer draws an error, a warning and a note in compilation's faces"
|
||||
(and (memq 'compilation-error (ensure-list (funcall face-on "a.flan:2")))
|
||||
(memq 'compilation-warning (ensure-list (funcall face-on "a.flan:3")))
|
||||
(memq 'compilation-info (ensure-list (funcall face-on "a.flan:4")))))
|
||||
(test-flan--check
|
||||
"the program's output takes its own face"
|
||||
(eq (funcall face-on "said") 'flan-output-face))
|
||||
(test-flan--check
|
||||
"a line of output shaped `word:' is not drawn as a program name"
|
||||
(progn (goto-char (point-min)) (search-forward "score")
|
||||
(and (null (get-text-property (match-beginning 0) 'face))
|
||||
(eq (get-text-property (match-beginning 0) 'font-lock-face)
|
||||
'flan-output-face))))
|
||||
(test-flan--check
|
||||
"the daemon's own line is left plain"
|
||||
(null (funcall face-on "flan dev:")))))
|
||||
(kill-buffer flan-daemon-buffer))
|
||||
|
||||
;; The program's own output arrives on replies and lands in the daemon's
|
||||
;; buffer — no REPL is open yet, and the log is the fallback that makes a
|
||||
;; println never depend on one.
|
||||
|
||||
65
lib/ast.ml
65
lib/ast.ml
@ -484,6 +484,71 @@ let map_children f (e : expr) : expr =
|
||||
|
||||
let pause_call loc = { e = Call ({ e = Var "pause"; loc }, []); loc }
|
||||
|
||||
(* The stepper. [instrument_step ds] is [ds] with every [defn] rebuilt so a
|
||||
call stops before each form of its body, at any depth of body: the forms of
|
||||
a [do], a [let], a loop, a [match] arm and each branch of an [if]. Not
|
||||
inside an argument, an [fn] or a handler clause, which are not forms a
|
||||
person reads as steps, and the last two are functions of their own. [None]
|
||||
when there is no [defn] to instrument.
|
||||
|
||||
A step is [(step-point)] from the prelude — [error] of a [StepPoint] under a
|
||||
[restart-case], so the break loop takes it as it takes [(pause)], with the
|
||||
game loop and its clock frozen. It answers whether to go on stepping: its
|
||||
[next] restart says yes and its [continue] says no, and the answer is kept
|
||||
in a local of the call, [flan~step], so [continue] runs the rest of this
|
||||
call and the next call steps again. [~] cannot occur in a source symbol, so
|
||||
the local is visibly the compiler's and hidden from the locals listing. *)
|
||||
let step_flag = "flan~step"
|
||||
|
||||
let step_point loc =
|
||||
let v = { e = Var step_flag; loc } in
|
||||
{ e =
|
||||
If (v,
|
||||
{ e = Set (Pvar step_flag, { e = Call ({ e = Var "step-point"; loc }, []); loc });
|
||||
loc },
|
||||
None);
|
||||
loc }
|
||||
|
||||
let rec step_body (es : expr list) : expr list =
|
||||
List.concat_map (fun (e : expr) -> [ step_point e.loc; step_expr e ]) es
|
||||
|
||||
and step_expr (e : expr) : expr =
|
||||
let branch (x : expr) =
|
||||
match x.e with
|
||||
| Do _ -> step_expr x
|
||||
| _ -> { e = Do [ step_point x.loc; step_expr x ]; loc = x.loc }
|
||||
in
|
||||
match e.e with
|
||||
| Do es -> { e with e = Do (step_body es) }
|
||||
| Let (bs, es) -> { e with e = Let (bs, step_body es) }
|
||||
| If (c, a, b) -> { e with e = If (c, branch a, Option.map branch b) }
|
||||
| While (l, c, es) -> { e with e = While (l, c, step_body es) }
|
||||
| Loop (bs, es) -> { e with e = Loop (bs, step_body es) }
|
||||
| Dotimes (l, n, b, es) -> { e with e = Dotimes (l, n, b, step_body es) }
|
||||
| Match (sc, arms) ->
|
||||
{ e with e = Match (sc, List.map (fun a -> { a with body = step_body a.body }) arms) }
|
||||
| _ -> e
|
||||
|
||||
let instrument_step (ds : decl list) : decl list option =
|
||||
let hit = ref false in
|
||||
let ds =
|
||||
List.map
|
||||
(fun (d : decl) ->
|
||||
match d.d with
|
||||
| Defn f ->
|
||||
hit := true;
|
||||
let on =
|
||||
{ bname = step_flag; bty = None;
|
||||
bval = { e = Var "true"; loc = d.dloc }; bloc = d.dloc }
|
||||
in
|
||||
{ d with
|
||||
d = Defn { f with fbody = [ { e = Let ([ on ], step_body f.fbody);
|
||||
loc = d.dloc } ] } }
|
||||
| _ -> d)
|
||||
ds
|
||||
in
|
||||
if !hit then Some ds else None
|
||||
|
||||
(* [mark_pause ~line ~col ds] is [ds] with a [(pause)] put in front of whatever
|
||||
starts at that position, or [None] when nothing does.
|
||||
|
||||
|
||||
266
lib/check.ml
266
lib/check.ml
@ -284,6 +284,19 @@ type env = {
|
||||
the declare-c forms before [Shim.expand] rewrites them. Keyed by the Flan
|
||||
name a program calls. *)
|
||||
tracks : (string, Shim.track) Hashtbl.t;
|
||||
(* Recovery: checking goes on past a refused subexpression. See [check].
|
||||
[recovering] is on only while a whole-file or session check is collecting
|
||||
every error; [recovered] is what it found, newest first; [poison] counts
|
||||
failed subexpressions and reads of what they were bound to, which is how
|
||||
an error caused by an earlier one is told apart and left unsaid.
|
||||
[speculating] turns recovery off inside a trial, whose refusal is an
|
||||
answer the caller acts on; [guard_next] turns it off for the one next
|
||||
[check], whose own refusal a caller re-words. *)
|
||||
mutable recovering : bool;
|
||||
mutable recovered : Loc.diag list;
|
||||
mutable poison : int;
|
||||
mutable speculating : int;
|
||||
mutable guard_next : bool;
|
||||
}
|
||||
|
||||
let new_env () = {
|
||||
@ -323,6 +336,11 @@ let new_env () = {
|
||||
in_field = false;
|
||||
classes = Hashtbl.create 8;
|
||||
tracks = Hashtbl.create 16;
|
||||
recovering = false;
|
||||
recovered = [];
|
||||
poison = 0;
|
||||
speculating = 0;
|
||||
guard_next = false;
|
||||
}
|
||||
|
||||
(* Where a named type was declared, and what it has, as a note.
|
||||
@ -3975,6 +3993,63 @@ let hash_ty = Types.Int Types.U64
|
||||
Each caller calls it again rather than sharing one value: [slots] and
|
||||
[slot_tys] are counted up per frame, and two frames that shared a context
|
||||
would share a slot counter. *)
|
||||
(* What a refused subexpression stands as while recovering. [Zero] of [Never]
|
||||
is a value nothing else builds, so it is recognisable; see [check]. *)
|
||||
let poison loc = { Tast.e = Tast.Zero Types.Never; ty = Types.Never; loc }
|
||||
|
||||
(* A poison, or a read of a local one was bound to. *)
|
||||
let is_poison (r : Tast.expr) =
|
||||
Types.equal r.Tast.ty Types.Never
|
||||
&& (match r.Tast.e with Tast.Zero Types.Never | Tast.Local _ -> true | _ -> false)
|
||||
|
||||
let record_recovered env (d : Loc.diag) =
|
||||
let same (x : Loc.diag) = x.Loc.dloc = d.Loc.dloc && String.equal x.Loc.dmsg d.Loc.dmsg in
|
||||
if not (List.exists same env.recovered) then env.recovered <- d :: env.recovered
|
||||
|
||||
(* [f] with recovery off, for a check whose refusal is an answer: a trial, a
|
||||
probe, a fallback that re-checks. *)
|
||||
let speculate env f =
|
||||
env.speculating <- env.speculating + 1;
|
||||
Fun.protect ~finally:(fun () -> env.speculating <- env.speculating - 1) f
|
||||
|
||||
(* A refusal a caller has re-worded: recorded and stood in for while
|
||||
recovering, raised otherwise. The [check] it re-words was [guarded], so its
|
||||
own refusal came here rather than being recorded in its first wording. *)
|
||||
let refuse_or_poison env loc (d : Loc.diag) =
|
||||
if env.recovering && env.speculating = 0 then begin
|
||||
record_recovered env d;
|
||||
env.poison <- env.poison + 1;
|
||||
poison loc
|
||||
end
|
||||
else raise (Loc.Error d)
|
||||
|
||||
(* [f], a declaration's body, with recovery on when [on]. Everything it
|
||||
recorded is raised as [Loc.Errors] at the end, together with whatever
|
||||
refusal ended it, so nothing checked with a poison in it is ever returned. *)
|
||||
let with_recovery env ~on f =
|
||||
if not on then f ()
|
||||
else begin
|
||||
let saved = (env.recovering, env.recovered, env.poison) in
|
||||
let restore () =
|
||||
let r, d, p = saved in
|
||||
env.recovering <- r; env.recovered <- d; env.poison <- p
|
||||
in
|
||||
env.recovering <- true; env.recovered <- []; env.poison <- 0;
|
||||
match f () with
|
||||
| x ->
|
||||
let found = List.rev env.recovered in
|
||||
restore ();
|
||||
if found = [] then x else raise (Loc.Errors found)
|
||||
| exception Loc.Error d ->
|
||||
let found = List.rev env.recovered in
|
||||
restore ();
|
||||
(* Raised past the end of the body after something in it already
|
||||
failed: a return that does not fit, a value that is missing, both of
|
||||
them what the failure left behind. *)
|
||||
if found = [] then raise (Loc.Error d) else raise (Loc.Errors found)
|
||||
| exception e -> restore (); raise e
|
||||
end
|
||||
|
||||
let invented_ctx env ret =
|
||||
{ env; ret; slots = 0; slot_tys = []; slot_names = []; scope = [];
|
||||
defers = []; defer_slot = None; outer = []; outer_what = None; caught = []; place_ok = false; envslot = None; parent = None; in_frames = None; loops = []; tail = false;
|
||||
@ -4600,7 +4675,67 @@ let tracked_call loc env name (tr : Shim.track) ret (args : Tast.expr list) =
|
||||
(* Every expression goes through here, and [check_value] is the one that
|
||||
knows the forms. What this adds is [refuse_owned_copy], asked of whatever
|
||||
came back unless the form was checked as the target of a place. *)
|
||||
(* Recovery, when [env.recovering] is on: a subexpression that is refused is
|
||||
recorded and stands as a [poison] of type [Never], which fits any want, so
|
||||
checking carries on around it and every error in a body is reported. What
|
||||
an earlier failure causes is not reported: an error raised by a node one of
|
||||
whose subexpressions failed, or with [Never] wanted, is dropped, as long as
|
||||
something has been recorded. That last condition keeps a poison from ever
|
||||
reaching a backend unreported — a scope with a poison in it always ends in
|
||||
a raise (see [with_recovery]). *)
|
||||
let rec check ctx ?want (e : Ast.expr) : Tast.expr =
|
||||
let env = ctx.env in
|
||||
let guarded = env.guard_next in
|
||||
env.guard_next <- false;
|
||||
if (not env.recovering) || env.speculating > 0 || guarded then
|
||||
check_plain ctx ?want e
|
||||
else begin
|
||||
let seen = env.poison in
|
||||
let caused () =
|
||||
env.recovered <> []
|
||||
&& (env.poison > seen || want = Some Types.Never)
|
||||
in
|
||||
match check_plain ctx ?want e with
|
||||
| r ->
|
||||
if is_poison r then env.poison <- env.poison + 1;
|
||||
r
|
||||
| exception Loc.Error d ->
|
||||
if not (caused ()) then begin
|
||||
record_recovered env d;
|
||||
(* A call refused as a whole — the wrong number of arguments, say —
|
||||
never checked its arguments, and a mistake inside one is still a
|
||||
mistake. They are checked on their own, with no expectation, so
|
||||
only what no expectation could change is kept: a name that is not
|
||||
there. *)
|
||||
match e.Ast.e with
|
||||
| Ast.Call (_, args) -> recheck_args ctx args
|
||||
| _ -> ()
|
||||
end;
|
||||
env.poison <- env.poison + 1;
|
||||
poison e.Ast.loc
|
||||
(* A checker arm that was never written for a [Never] operand may fail
|
||||
some other way over one. Only then, and only as a consequence. *)
|
||||
| exception (Not_found | Invalid_argument _ | Failure _ | Assert_failure _
|
||||
| Match_failure _) when caused () ->
|
||||
env.poison <- env.poison + 1;
|
||||
poison e.Ast.loc
|
||||
end
|
||||
|
||||
and recheck_args ctx (args : Ast.expr list) =
|
||||
let env = ctx.env in
|
||||
let before = env.recovered in
|
||||
List.iter (fun a -> ignore (check ctx a)) args;
|
||||
let rec fresh l = if l == before then [] else match l with [] -> [] | d :: r -> d :: fresh r in
|
||||
let kept =
|
||||
List.filter
|
||||
(fun (d : Loc.diag) ->
|
||||
String.starts_with ~prefix:"check/unknown-" d.Loc.kind
|
||||
|| String.equal d.Loc.kind "check/private")
|
||||
(fresh env.recovered)
|
||||
in
|
||||
env.recovered <- kept @ before
|
||||
|
||||
and check_plain ctx ?want (e : Ast.expr) : Tast.expr =
|
||||
let place = ctx.place_ok in
|
||||
ctx.place_ok <- false;
|
||||
let r = check_value ctx ?want e in
|
||||
@ -6031,6 +6166,9 @@ and check_let ctx ?(tail = false) ?want ?(defer_ok = false) loc bs body =
|
||||
let want = Option.map (resolve ctx.env) b.Ast.bty in
|
||||
let v = check ctx ?want b.Ast.bval in
|
||||
(match v.Tast.ty with
|
||||
(* A refused initialiser, already reported: the name is bound to
|
||||
the poison so that what follows is still checked. *)
|
||||
| Types.Never when is_poison v -> ()
|
||||
| Types.Unit | Types.Never ->
|
||||
fail b.Ast.bloc "%s would be bound to %s, which is not a value"
|
||||
b.Ast.bname (Types.to_string v.Tast.ty)
|
||||
@ -6261,6 +6399,9 @@ and check_loop ctx ?want loc bs body =
|
||||
(fun (n, v) ->
|
||||
let v = check ctx v in
|
||||
(match v.Tast.ty with
|
||||
(* A refused initialiser, already reported: the name is bound to
|
||||
the poison so that what follows is still checked. *)
|
||||
| Types.Never when is_poison v -> ()
|
||||
| Types.Unit | Types.Never ->
|
||||
fail v.Tast.loc "%s would be bound to %s, which is not a value" n
|
||||
(Types.to_string v.Tast.ty)
|
||||
@ -6434,7 +6575,10 @@ and check_recur ctx ~tail loc args =
|
||||
accident. *)
|
||||
and check_truthy ctx c =
|
||||
let loc = c.Ast.loc in
|
||||
match check ctx c with
|
||||
(* Speculative, because a refusal here is answered by asking again at
|
||||
[bool]; and that second ask is guarded, because its refusal is re-worded
|
||||
below. Recovery sees each refusal once, in its final words. *)
|
||||
match speculate ctx.env (fun () -> check ctx c) with
|
||||
| c0 when c0.Tast.ty = Types.Dyn ->
|
||||
widen loc Types.Bool (rt loc (Types.Int Types.I32) "flan_dyn_truthy" [ c0 ])
|
||||
| c0 when Types.fits ~expected:Types.Bool ~actual:c0.Tast.ty -> c0
|
||||
@ -6460,10 +6604,11 @@ and check_truthy ctx c =
|
||||
Anything more complicated than a name gets the operator and no
|
||||
template: a reconstructed expression would be a guess at code the
|
||||
reader can see for themselves. *)
|
||||
(match check ctx ~want:Types.Bool c with
|
||||
(ctx.env.guard_next <- true;
|
||||
match check ctx ~want:Types.Bool c with
|
||||
| c1 -> c1
|
||||
| exception Loc.Error d when not (String.equal d.Loc.kind "check/type-mismatch") ->
|
||||
raise (Loc.Error d)
|
||||
refuse_or_poison ctx.env loc d
|
||||
| exception Loc.Error _ ->
|
||||
let how =
|
||||
let zero = match c0.Tast.ty with Types.Float _ -> "0.0" | _ -> "0" in
|
||||
@ -6475,9 +6620,11 @@ and check_truthy ctx c =
|
||||
| _, true -> Printf.sprintf " — test it against %s with !=" zero
|
||||
| _ -> ""
|
||||
in
|
||||
Loc.failk "check/condition-not-bool" loc
|
||||
"a condition is a bool or a dyn, and this is %s%s"
|
||||
(Types.to_string c0.Tast.ty) how)
|
||||
(try
|
||||
Loc.failk "check/condition-not-bool" loc
|
||||
"a condition is a bool or a dyn, and this is %s%s"
|
||||
(Types.to_string c0.Tast.ty) how
|
||||
with Loc.Error d -> refuse_or_poison ctx.env loc d))
|
||||
| exception Loc.Error _ -> check ctx ~want:Types.Bool c
|
||||
|
||||
and check_if ctx ?(tail = false) ?want loc c t e =
|
||||
@ -6545,15 +6692,23 @@ and check_if ctx ?(tail = false) ?want loc c t e =
|
||||
location; and with an expectation in hand both arms are checked against
|
||||
it rather than against each other, so nothing here runs. *)
|
||||
let e =
|
||||
match branch ctx (fun () -> in_tail (fun () -> check ctx ?want:ewant e)) with
|
||||
let reworded = want = None && and_sentinel e in
|
||||
match
|
||||
branch ctx (fun () ->
|
||||
in_tail (fun () ->
|
||||
if reworded then ctx.env.guard_next <- true;
|
||||
check ctx ?want:ewant e))
|
||||
with
|
||||
| v -> v
|
||||
| exception Loc.Error d
|
||||
when want = None && and_sentinel e
|
||||
&& String.equal d.Loc.kind "check/type-mismatch" ->
|
||||
Loc.failk "check/shortcircuit-operand" t.Tast.loc
|
||||
"an and answers false or its last operand, so the two have to be \
|
||||
one type — this operand is %s, and false is a bool"
|
||||
(Types.to_string t.Tast.ty)
|
||||
when reworded && String.equal d.Loc.kind "check/type-mismatch" ->
|
||||
(try
|
||||
Loc.failk "check/shortcircuit-operand" t.Tast.loc
|
||||
"an and answers false or its last operand, so the two have to be \
|
||||
one type — this operand is %s, and false is a bool"
|
||||
(Types.to_string t.Tast.ty)
|
||||
with Loc.Error d -> refuse_or_poison ctx.env e.Ast.loc d)
|
||||
| exception Loc.Error d when reworded -> refuse_or_poison ctx.env e.Ast.loc d
|
||||
in
|
||||
let t, e =
|
||||
match free_join, Types.const_join t.Tast.ty e.Tast.ty with
|
||||
@ -6789,16 +6944,19 @@ and positional_struct ctx ~want loc name args =
|
||||
let fields =
|
||||
map2_lr
|
||||
(fun (f : Tast.field) (a : Ast.expr) ->
|
||||
ctx.env.guard_next <- true;
|
||||
try check ctx ~want:f.Tast.fty a with
|
||||
| Loc.Error d when d.Loc.dloc = a.Ast.loc ->
|
||||
Loc.raise_diag
|
||||
{ d with
|
||||
Loc.notes =
|
||||
d.Loc.notes
|
||||
@ [ Loc.note a.Ast.loc
|
||||
(Printf.sprintf "this is %s's field .%s" shown
|
||||
f.Tast.fname) ]
|
||||
@ note })
|
||||
refuse_or_poison ctx.env a.Ast.loc
|
||||
(Loc.sort_notes
|
||||
{ d with
|
||||
Loc.notes =
|
||||
d.Loc.notes
|
||||
@ [ Loc.note a.Ast.loc
|
||||
(Printf.sprintf "this is %s's field .%s" shown
|
||||
f.Tast.fname) ]
|
||||
@ note })
|
||||
| Loc.Error d -> refuse_or_poison ctx.env a.Ast.loc d)
|
||||
fields args
|
||||
in
|
||||
expect ctx loc ~want (mk loc (Types.Named name) (Tast.Make (name, fields)))
|
||||
@ -7244,6 +7402,8 @@ and numbers_disagree : 'a. ctx -> (Ast.expr * Types.t) list -> 'a =
|
||||
that finds nothing. *)
|
||||
and mixed_refusal : 'a. ctx -> Ast.expr list -> Loc.diag -> 'a =
|
||||
fun ctx items d ->
|
||||
(* Every check here only looks for a better sentence for [d]. *)
|
||||
speculate ctx.env @@ fun () ->
|
||||
match items with
|
||||
| [] -> raise (Loc.Error d)
|
||||
| first :: rest ->
|
||||
@ -7441,7 +7601,7 @@ and check_the ctx ~want loc (t : Ast.texpr) (v : Ast.expr) =
|
||||
dyn — a dyn becomes a %s where a %s is passed, returned or stored"
|
||||
tn tn tn
|
||||
| None ->
|
||||
(match check ctx ~want:ty v with
|
||||
(match speculate ctx.env (fun () -> check ctx ~want:ty v) with
|
||||
| _ ->
|
||||
fail v.Ast.loc
|
||||
"the checks a value as %s and does not convert one, and this is \
|
||||
@ -7967,6 +8127,7 @@ and ordinal n =
|
||||
points at the wrong form. The rekind is what stops a nested call from being
|
||||
named twice: once enriched, it is no longer the kind this looks for. *)
|
||||
and check_arg ctx name i (want : Types.t) (a : Ast.expr) =
|
||||
ctx.env.guard_next <- true;
|
||||
match check ctx ~want a with
|
||||
| e -> e
|
||||
| exception Loc.Error d
|
||||
@ -7982,9 +8143,10 @@ and check_arg ctx name i (want : Types.t) (a : Ast.expr) =
|
||||
name which p.Ast.fname (Types.to_string want)) ]
|
||||
| _ -> []
|
||||
in
|
||||
Loc.raise_diag
|
||||
refuse_or_poison ctx.env a.Ast.loc
|
||||
(Loc.diag ~kind:"check/argument-type" ~notes a.Ast.loc
|
||||
(Printf.sprintf "%s — this is the %s argument of %s" d.Loc.dmsg which name))
|
||||
| exception Loc.Error d -> refuse_or_poison ctx.env a.Ast.loc d
|
||||
|
||||
and fields_named env n : Tast.structure option =
|
||||
match Hashtbl.find_opt env.structs n with
|
||||
@ -11351,6 +11513,16 @@ and ordinary_call ctx ~want loc name args =
|
||||
lifted body captures it by value and then calls the copy. [peek_outer]
|
||||
rather than [capture] in the guard, because a guard must not take a copy
|
||||
on its way to deciding what a form means. *)
|
||||
(* A local bound to a refused initialiser's stand-in, called: the refusal
|
||||
is already reported, so the call stands in too, its arguments still
|
||||
checked. *)
|
||||
| _ when ctx.env.recovering
|
||||
&& (match lookup ctx name with
|
||||
| Some b -> Types.equal b.bty Types.Never
|
||||
| None -> false) ->
|
||||
List.iter (fun a -> ignore (check ctx a)) args;
|
||||
ctx.env.poison <- ctx.env.poison + 1;
|
||||
poison loc
|
||||
| _ when (match lookup ctx name with
|
||||
| Some b -> callable_ty b.bty
|
||||
| None ->
|
||||
@ -12100,7 +12272,9 @@ and instantiate env loc gname vars subst cparams cret =
|
||||
sym
|
||||
end else
|
||||
let tfn =
|
||||
match !check_fn_ref env { fn with Ast.name = sym } with
|
||||
(* Without recovery: a copy that does not check is refused whole, at
|
||||
the call that asked for it, as it always was. *)
|
||||
match speculate env (fun () -> !check_fn_ref env { fn with Ast.name = sym }) with
|
||||
| tfn -> restore (); tfn
|
||||
| exception e ->
|
||||
restore ();
|
||||
@ -12277,7 +12451,7 @@ and trial ctx f =
|
||||
outer_what; caught; place_ok; envslot; parent = _;
|
||||
in_frames; loops; tail; in_defer;
|
||||
owner = _ } = ctx in
|
||||
match f () with
|
||||
match speculate ctx.env f with
|
||||
| r -> Ok r
|
||||
| exception Loc.Error d ->
|
||||
ctx.slots <- slots; ctx.slot_tys <- slot_tys;
|
||||
@ -13424,7 +13598,7 @@ let collect env (decls : Ast.decl list) =
|
||||
let left =
|
||||
List.filter
|
||||
(fun ((n, _) as c) ->
|
||||
match infer c with
|
||||
match speculate env (fun () -> infer c) with
|
||||
| ty -> Hashtbl.replace env.globals n (ty, true); false
|
||||
| exception Loc.Error _ -> true)
|
||||
!pending
|
||||
@ -14743,7 +14917,7 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) :
|
||||
in
|
||||
(match f () with
|
||||
| x -> x
|
||||
| exception (Loc.Error d as e) ->
|
||||
| exception ((Loc.Error d | Loc.Errors (d :: _)) as e) ->
|
||||
if ok env name d then begin
|
||||
Hashtbl.filter_map_inplace
|
||||
(fun g r ->
|
||||
@ -14824,7 +14998,9 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) :
|
||||
| Ast.Defn fn when Hashtbl.mem env.gsigs fn.Ast.name ->
|
||||
(match
|
||||
Loc.caught s (fun () ->
|
||||
tolerant fn.Ast.name (fun () -> Some (check_generic env fn)))
|
||||
tolerant fn.Ast.name (fun () ->
|
||||
with_recovery env ~on:keep_going (fun () ->
|
||||
Some (check_generic env fn))))
|
||||
with
|
||||
| None -> Hashtbl.replace env.refused_generics fn.Ast.name ()
|
||||
| Some _ -> ())
|
||||
@ -14835,9 +15011,12 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) :
|
||||
(fun (d : Ast.decl) ->
|
||||
Option.join
|
||||
(Loc.caught s (fun () ->
|
||||
let checked () =
|
||||
with_recovery env ~on:keep_going (fun () -> check_global env d)
|
||||
in
|
||||
match Ast.declared_name d with
|
||||
| Some n -> tolerant n (fun () -> check_global env d)
|
||||
| None -> check_global env d)))
|
||||
| Some n -> tolerant n checked
|
||||
| None -> checked ())))
|
||||
decls
|
||||
in
|
||||
let fns =
|
||||
@ -14850,7 +15029,9 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) :
|
||||
| Ast.Defn fn ->
|
||||
Option.join
|
||||
(Loc.caught s (fun () ->
|
||||
tolerant fn.Ast.name (fun () -> Some (check_fn env fn))))
|
||||
tolerant fn.Ast.name (fun () ->
|
||||
with_recovery env ~on:keep_going (fun () ->
|
||||
Some (check_fn env fn)))))
|
||||
| _ -> None)
|
||||
decls
|
||||
in
|
||||
@ -14914,8 +15095,8 @@ let program_with_env (decls : Ast.decl list) : Tast.program * env =
|
||||
(** The same, with [tolerate] deciding which body failures leave a
|
||||
declaration out rather than refuse it — see [build_program]. The names
|
||||
left out come back beside the program; nothing else about it changes. *)
|
||||
let program_tolerant ~tolerate (decls : Ast.decl list) =
|
||||
build_program ~keep_going:false ~tolerate decls
|
||||
let program_tolerant ?(keep_going = false) ~tolerate (decls : Ast.decl list) =
|
||||
build_program ~keep_going ~tolerate decls
|
||||
|
||||
let program (decls : Ast.decl list) : Tast.program =
|
||||
let p, _, _ = build_program ~keep_going:false decls in
|
||||
@ -15051,6 +15232,25 @@ let expressions env (es : (Types.t option * Ast.expr) list) :
|
||||
(ts, Array.of_list (List.rev ctx.slot_tys),
|
||||
Array.of_list (List.rev ctx.slot_names))
|
||||
|
||||
(* One expression checked with [scope]'s names already bound, in order, so a
|
||||
later entry shadows an earlier one of the same name: evaluating in a stopped
|
||||
frame, whose locals the expression may name. Each is bound to a slot of the
|
||||
expression's own frame, and which slot is answered beside the name, so the
|
||||
caller can point every use of it at the stopped frame's storage instead
|
||||
([Tast.rewrite_locals]). *)
|
||||
let expression_in_scope env ~(scope : (string * Types.t * bool) list)
|
||||
(e : Ast.expr) :
|
||||
Tast.expr * Types.t array * string option array * (string * int) list =
|
||||
let ctx = invented_ctx env Types.Unit in
|
||||
let bound =
|
||||
List.map
|
||||
(fun (name, ty, assignable) -> (name, bind ctx name ty ~assignable))
|
||||
scope
|
||||
in
|
||||
let t = expect ctx e.Ast.loc ~want:None (check ctx e) in
|
||||
(t, Array.of_list (List.rev ctx.slot_tys),
|
||||
Array.of_list (List.rev ctx.slot_names), bound)
|
||||
|
||||
(* The one-expression case, which is every caller but the write verb. *)
|
||||
let expression env ?want (e : Ast.expr) :
|
||||
Tast.expr * Types.t array * string option array =
|
||||
|
||||
429
lib/dev.ml
429
lib/dev.ml
@ -28,11 +28,15 @@ type t = {
|
||||
(* The running program. [Some pid] is the two-process daemon, which launched
|
||||
it; [None] is the merged build, where the program is *this* process and
|
||||
the compiler is a thread inside it. That is the whole of the difference at
|
||||
this layer — see [merged_setup] for why there is no third case. *)
|
||||
child : int option;
|
||||
this layer — see [merged_setup] for why there is no third case. A re-run
|
||||
under --two-process replaces the child with a new one. *)
|
||||
mutable child : int option;
|
||||
agent : string; (* where it listens for modules *)
|
||||
dir : string; (* modules are built here, one per eval *)
|
||||
stdout : Unix.file_descr; (* the program's output, on its way to here *)
|
||||
mutable stdout : Unix.file_descr; (* the program's output, on its way here *)
|
||||
(* --two-process only: build the program again from the session as it is
|
||||
now and start it, answering the new child and its stdout. *)
|
||||
relaunch : (unit -> int * Unix.file_descr) option;
|
||||
out : Buffer.t; (* ...buffered until an editor asks for it *)
|
||||
mutable n : int; (* dlopen caches by path: never reuse one *)
|
||||
(* Bookkeeping for disassembly, and the reason it can exist at all: the
|
||||
@ -268,10 +272,41 @@ let deliver_at_stop t ~gen path =
|
||||
[None] where the program cannot be reached or answers something else, and
|
||||
the caller treats that the way it treats a missing refusal count: as no
|
||||
evidence, not as zero. Zero is a fact — it means running. *)
|
||||
let stop_gen t : int option =
|
||||
let stop_reply t =
|
||||
match request t "stop" with
|
||||
| exception Unix.Unix_error _ -> None
|
||||
| text -> int_of_string_opt (String.trim text)
|
||||
| text ->
|
||||
(match String.split_on_char ' ' (String.trim text) with
|
||||
| g :: rest ->
|
||||
Option.map (fun g -> (g, rest)) (int_of_string_opt g)
|
||||
| [] -> None)
|
||||
|
||||
let stop_gen t : int option = Option.map fst (stop_reply t)
|
||||
|
||||
(* How many evaluated expressions the agent has queued, and the highest one
|
||||
that has returned a value; [None] from an agent without the verb. *)
|
||||
let calls t : (int * int) option =
|
||||
match request t "calls" with
|
||||
| exception Unix.Unix_error _ -> None
|
||||
| text ->
|
||||
(match String.split_on_char ' ' (String.trim text) with
|
||||
| [ q; v ] ->
|
||||
(match int_of_string_opt q, int_of_string_opt v with
|
||||
| Some q, Some v -> Some (q, v)
|
||||
| _ -> None)
|
||||
| _ -> None)
|
||||
|
||||
(* The same stop with whose code it stopped in: [Some true] when the thread
|
||||
was running an evaluated thunk, [Some false] when it was in the program's
|
||||
own code, [None] from an agent that does not say. *)
|
||||
let stop_owner t : (int * bool option) option =
|
||||
Option.map
|
||||
(fun (g, rest) ->
|
||||
(g, match rest with
|
||||
| [ "eval" ] -> Some true
|
||||
| [ "program" ] -> Some false
|
||||
| _ -> None))
|
||||
(stop_reply t)
|
||||
|
||||
(* How many stopped-only modules the program has thrown away for reaching the
|
||||
game thread while it was running, and the sentence the agent says about it.
|
||||
@ -802,7 +837,8 @@ let build_module (c : Session.change) ~debug ~out =
|
||||
spelled once so that every op tells the same story.
|
||||
|
||||
[gone] is what all of them used to say and is now said only where it is
|
||||
true: there is no process left and nothing short of a new one will help.
|
||||
true: there is no process left and nothing short of a new one will help —
|
||||
which, under --two-process, a re-run is.
|
||||
|
||||
[parked] is the new half, and the sentence it appends is the whole point of
|
||||
the distinction. Somebody reading it has a program that is *there* — its
|
||||
@ -813,7 +849,7 @@ let build_module (c : Session.change) ~debug ~out =
|
||||
refused for want of a frame boundary and an op refused for want of a stopped
|
||||
stack are refused by the same state for different causes, and a reader who
|
||||
cannot tell them apart cannot tell what to do instead. *)
|
||||
let gone = "the program exited; restart flan dev"
|
||||
let gone = "the program exited; M-x flan-rerun starts it again"
|
||||
|
||||
let parked_msg why =
|
||||
why
|
||||
@ -995,7 +1031,32 @@ let stale_field (ss : Session.stale list) =
|
||||
(if x.Session.running then " :running t" else ""))
|
||||
ss) ]
|
||||
|
||||
let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause =
|
||||
(* Every refusal a check found, one plist each: beside what a load installed,
|
||||
or beside the first of them when a form sent had several. *)
|
||||
let errors_field (ds : Loc.diag list) =
|
||||
match ds with
|
||||
| [] -> []
|
||||
| ds ->
|
||||
[ ":errors "
|
||||
^ Wire.list
|
||||
(List.map
|
||||
(fun (d : Loc.diag) ->
|
||||
Printf.sprintf "(:loc %s :message %s)"
|
||||
(Wire.quote (Loc.to_string d.Loc.dloc))
|
||||
(Wire.quote d.Loc.dmsg))
|
||||
ds) ]
|
||||
|
||||
(* A refusal with several diagnostics: the first where every refusal puts its
|
||||
message, all of them under [:errors]. *)
|
||||
let errors_reply (ds : Loc.diag list) =
|
||||
match ds with
|
||||
| [] -> error "nothing was refused"
|
||||
| d :: _ ->
|
||||
let e = error ~loc:(Loc.to_string d.Loc.dloc) d.Loc.dmsg in
|
||||
String.sub e 0 (String.length e - 1)
|
||||
^ " " ^ String.concat " " (errors_field ds) ^ ")"
|
||||
|
||||
let eval ?forms ?base ?(extra = []) ?(step = false) t ~code ~origin ~pause =
|
||||
let now = liveness t in
|
||||
let parked_now = now = Parked in
|
||||
(* A park that is over takes its note with it: the long sentence below is
|
||||
@ -1016,10 +1077,28 @@ let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause =
|
||||
nothing that can go wrong after it. *)
|
||||
let before = Session.held t.session in
|
||||
let refused msg = Session.restore t.session before; error msg in
|
||||
if now = Gone then error gone
|
||||
if now = Gone && t.relaunch <> None then
|
||||
(* --two-process, the child ended: the form is checked into the session
|
||||
and nothing is sent, because the next process is built from the
|
||||
session whole ([rerun]). *)
|
||||
match
|
||||
Session.eval ~origin ?base ?forms ?pause ~running:false t.session code
|
||||
with
|
||||
| c ->
|
||||
ok
|
||||
([ ":names " ^ Wire.strings c.Session.names; ":fns ()";
|
||||
":note "
|
||||
^ Wire.quote
|
||||
"loaded; the program has ended, so this is in it when M-x \
|
||||
flan-rerun starts it again" ]
|
||||
@ extra)
|
||||
| exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } ->
|
||||
Session.restore t.session before;
|
||||
error ~loc:(Loc.to_string l) msg
|
||||
else if now = Gone then error gone
|
||||
else
|
||||
match
|
||||
Session.eval ~origin ?base ?forms ?pause ~running:(not parked_now)
|
||||
Session.eval ~origin ?base ?forms ?pause ~step ~running:(not parked_now)
|
||||
t.session code
|
||||
with
|
||||
| c when not c.Session.installs ->
|
||||
@ -1082,6 +1161,7 @@ let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause =
|
||||
| Some (l, c) ->
|
||||
[ ":pause " ^ Wire.quote (Printf.sprintf "%d:%d" l c) ]
|
||||
| None -> [])
|
||||
@ (if step then [ ":step t" ] else [])
|
||||
@ install_note t ~parked:parked_now
|
||||
@ unpolled_note t ~parked:parked_now
|
||||
@ extra)
|
||||
@ -1100,20 +1180,9 @@ let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause =
|
||||
| exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } ->
|
||||
Session.restore t.session before;
|
||||
error ~loc:(Loc.to_string l) msg
|
||||
|
||||
(* The refusals a load answered beside what it installed, one plist each. *)
|
||||
let errors_field (ds : Loc.diag list) =
|
||||
match ds with
|
||||
| [] -> []
|
||||
| ds ->
|
||||
[ ":errors "
|
||||
^ Wire.list
|
||||
(List.map
|
||||
(fun (d : Loc.diag) ->
|
||||
Printf.sprintf "(:loc %s :message %s)"
|
||||
(Wire.quote (Loc.to_string d.Loc.dloc))
|
||||
(Wire.quote d.Loc.dmsg))
|
||||
ds) ]
|
||||
| exception Loc.Errors ds ->
|
||||
Session.restore t.session before;
|
||||
errors_reply ds
|
||||
|
||||
(* C-c C-k: a whole file into the running session, SBCL's [load]. [eval] with
|
||||
one difference — a form that does not compile is left out and listed
|
||||
@ -1141,16 +1210,9 @@ let load_file t ~code ~origin =
|
||||
(match Session.pruned check forms with
|
||||
| exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } ->
|
||||
error ~loc:(Loc.to_string l) msg
|
||||
| exception Loc.Errors ({ Loc.dloc = l; dmsg = msg; _ } :: _ as ds) ->
|
||||
let e = error ~loc:(Loc.to_string l) msg in
|
||||
String.sub e 0 (String.length e - 1)
|
||||
^ " " ^ String.concat " " (errors_field ds) ^ ")"
|
||||
| exception Loc.Errors ds -> errors_reply ds
|
||||
| (), kept, errs ->
|
||||
if errs <> [] && kept = [] then
|
||||
let d = List.hd errs in
|
||||
let e = error ~loc:(Loc.to_string d.Loc.dloc) d.Loc.dmsg in
|
||||
String.sub e 0 (String.length e - 1)
|
||||
^ " " ^ String.concat " " (errors_field errs) ^ ")"
|
||||
if errs <> [] && kept = [] then errors_reply errs
|
||||
else
|
||||
eval ~forms:kept ?base ~extra:(errors_field errs) t ~code ~origin
|
||||
~pause:None)
|
||||
@ -1191,7 +1253,7 @@ let load_file t ~code ~origin =
|
||||
state to spawn it beside; the price is that eval races the application and
|
||||
the race is documented as the programmer's problem. There is no race to
|
||||
document here, because there is nothing running to race. *)
|
||||
let eval_expr t ~code ~origin ~pause =
|
||||
let eval_expr_at t ~code ~origin ~pause ~at =
|
||||
match liveness t with
|
||||
| Gone -> error gone
|
||||
| Live | Parked ->
|
||||
@ -1207,9 +1269,13 @@ let eval_expr t ~code ~origin ~pause =
|
||||
let had =
|
||||
List.map (fun (f : Tast.fn) -> f.Tast.name) t.session.Session.program.Tast.fns
|
||||
in
|
||||
match Session.eval_expr ~origin ~pause t.session code with
|
||||
match Session.eval_expr ~origin ~pause ?frame:(Option.map snd at) t.session code with
|
||||
| c ->
|
||||
let before = match result t with Some (g, _) -> g | None -> 0L in
|
||||
(* This expression's number among those the agent has queued: an
|
||||
earlier one resumed by a restart can publish after this one is sent,
|
||||
and the result counter alone would take its value for this one's. *)
|
||||
let mine = Option.map (fun (q, _) -> q + 1) (calls t) in
|
||||
(* Read here, beside [before], and for the same kind of reason: all
|
||||
three are the "how things stood" half of a difference the wait below
|
||||
measures. A program already sitting in a break when the request
|
||||
@ -1223,19 +1289,23 @@ let eval_expr t ~code ~origin ~pause =
|
||||
the reason [stop_gen]'s note gives at its definition. The name is kept
|
||||
beside it as the fallback for an agent that cannot answer the verb.
|
||||
|
||||
As early as it usefully can be, and still not early enough to be
|
||||
exact: [build_module] below takes a couple of hundred milliseconds,
|
||||
and a game loop that signals *on its own* during them — or mid-wait,
|
||||
while the thunk is still perfectly fine — bumps the generation too.
|
||||
The reply then says "the expression stopped on X" about an expression
|
||||
that had not run. Its machine-readable half stays right, so the editor
|
||||
opens the break the program is actually in; only the sentence is
|
||||
wrong, and no counter closes this one, because the program's break and
|
||||
the thunk's are the same kind of event. Separating them wants the
|
||||
per-frame origin the backtrace carries, which is LLVM-only.
|
||||
TODO.org, "Whose break it is, which no counter answers" has it. *)
|
||||
A game loop that signals *on its own* while this is in flight bumps
|
||||
the generation too, so a fresh stop is not yet the thunk's. The stop
|
||||
itself says whose it is — see [settled] below. *)
|
||||
let entered = state t in
|
||||
let entered_gen = stop_gen t in
|
||||
(* In a frame the thunk is addressed to one stop, and the agent drops it,
|
||||
and counts the drop, if that stop has ended by the time it is
|
||||
claimed. Read before the build, which is when that usually happens. *)
|
||||
let refused_before = if at = None then None else refusals t in
|
||||
let dropped () =
|
||||
match refused_before with
|
||||
| None -> None
|
||||
| Some (before, _) ->
|
||||
(match refusals t with
|
||||
| Some (now, why) when now > before -> Some why
|
||||
| _ -> None)
|
||||
in
|
||||
t.n <- t.n + 1;
|
||||
let out = Filename.concat t.dir (Printf.sprintf "e%d.so" t.n) in
|
||||
(* A generic called at a new type makes a copy that is defined in this
|
||||
@ -1254,7 +1324,14 @@ let eval_expr t ~code ~origin ~pause =
|
||||
in
|
||||
(match build_module c ~debug:t.session.Session.debug ~out with
|
||||
| _ ->
|
||||
(match deliver t out with
|
||||
(match
|
||||
(* In a frame, only at the stop the frame was read at: the thunk
|
||||
reads that frame's slots by address, and after a resume they
|
||||
are somebody else's storage. *)
|
||||
match at with
|
||||
| Some (gen, _) -> deliver_at_stop t ~gen out
|
||||
| None -> deliver t out
|
||||
with
|
||||
| "ok" ->
|
||||
if copies <> [] then begin
|
||||
t.gen <- t.gen + 1;
|
||||
@ -1321,12 +1398,17 @@ let eval_expr t ~code ~origin ~pause =
|
||||
re-stop between them could pair a stale name with a fresh
|
||||
generation; it cannot manufacture one, since the generation only
|
||||
climbs when a break really was entered. *)
|
||||
(* A fresh stop in the program's own code is not an answer: the
|
||||
thunk has not run, and the break loop that stop entered polls
|
||||
the ring, so the thunk runs inside it and its value arrives on
|
||||
a later tick. *)
|
||||
let settled now =
|
||||
match now with
|
||||
| Stopped c ->
|
||||
let fresh =
|
||||
match stop_gen t, entered_gen with
|
||||
| Some g, Some g0 -> g > g0
|
||||
match stop_owner t, entered_gen with
|
||||
| Some (_, Some false), _ -> false
|
||||
| Some (g, _), Some g0 -> g > g0
|
||||
| _ ->
|
||||
(match entered with Stopped c0 -> c0 <> c | _ -> true)
|
||||
in
|
||||
@ -1366,9 +1448,16 @@ let eval_expr t ~code ~origin ~pause =
|
||||
the sleep has to stay a sleep. *)
|
||||
drain t;
|
||||
let value () =
|
||||
match result t with
|
||||
| Some (g, v) when Int64.compare g before > 0 -> Some v
|
||||
| _ -> None
|
||||
let returned =
|
||||
match mine, calls t with
|
||||
| Some m, Some (_, v) -> v >= m
|
||||
| _ -> true
|
||||
in
|
||||
if not returned then None
|
||||
else
|
||||
match result t with
|
||||
| Some (g, v) when Int64.compare g before > 0 -> Some v
|
||||
| _ -> None
|
||||
in
|
||||
match value () with
|
||||
| Some v -> `Value v
|
||||
@ -1400,6 +1489,9 @@ let eval_expr t ~code ~origin ~pause =
|
||||
| Some answer ->
|
||||
(match value () with Some v -> `Value v | None -> answer)
|
||||
| None ->
|
||||
match dropped () with
|
||||
| Some why -> `Dropped why
|
||||
| None ->
|
||||
if ms <= 0 then `Timeout
|
||||
else begin
|
||||
ignore (Unix.select [] [] [] 0.005);
|
||||
@ -1464,6 +1556,7 @@ let eval_expr t ~code ~origin ~pause =
|
||||
left over, which is the shape it was always about: a program
|
||||
that is running, is not parked, and produced nothing in five
|
||||
seconds. *)
|
||||
| `Dropped why -> error why
|
||||
| `Timeout ->
|
||||
if liveness t = Parked then
|
||||
error
|
||||
@ -2429,6 +2522,40 @@ let stopped_frame t ~frame ~what : (string * Tast.fn, string) result =
|
||||
name name)
|
||||
else Ok (name, fn)))
|
||||
|
||||
(* [:frame N] on [eval-expr] is SLIME's eval-in-frame: the expression sees
|
||||
that stopped frame's locals — see [Session.in_frame]. The frame is checked
|
||||
the way [locals] and [inspect] check it, and the thunk is delivered at this
|
||||
stop only. *)
|
||||
let eval_expr ?frame ?at_stop t ~code ~origin ~pause =
|
||||
match frame with
|
||||
| None -> eval_expr_at t ~code ~origin ~pause ~at:None
|
||||
| Some index ->
|
||||
(match stopped_frame t ~frame:index ~what:"an expression in a frame" with
|
||||
| Error m -> error m
|
||||
| Ok (_, fn) ->
|
||||
(match stop_gen t with
|
||||
| None | Some 0 ->
|
||||
error
|
||||
"the program resumed while this was being asked; there is no frame \
|
||||
to evaluate in any more"
|
||||
| Some gen ->
|
||||
(* A frame with no slots has no locals to bind, and the program
|
||||
has no table to answer for it: the expression sees globals. *)
|
||||
let bound =
|
||||
if Array.length fn.Tast.slots = 0 then Ok []
|
||||
else bound_slots t ~frame:index
|
||||
in
|
||||
(* [at_stop] is the stop the editor drew the frame at. It is not
|
||||
checked here: the agent refuses a thunk addressed to a stop that
|
||||
is over, and says so. *)
|
||||
let gen = Option.value ~default:gen at_stop in
|
||||
(match bound with
|
||||
| Error m ->
|
||||
error ("the program refused to say which slots are bound: " ^ m)
|
||||
| Ok bound ->
|
||||
eval_expr_at t ~code ~origin ~pause
|
||||
~at:(Some (gen, (index, fn, bound))))))
|
||||
|
||||
(* [(:op "locals" :frame N)] — what a stopped frame's named locals hold.
|
||||
|
||||
The half of a break loop that the author actually wanted, and the reason
|
||||
@ -3666,7 +3793,54 @@ let abort t =
|
||||
park, the next request went out while the first run had not started, and the
|
||||
pair of them produced one run — or, a moment later, a refusal saying the
|
||||
program was already running. Both faces are gone with the lag. *)
|
||||
(* Under --two-process a finished child is gone and there is no thread to
|
||||
wake, so a re-run is a new process: the program is built again from the
|
||||
session as it stands, which puts every accepted redefinition in it from
|
||||
the start, and its globals start over. *)
|
||||
let relaunch_child t relaunch =
|
||||
match liveness t with
|
||||
| Live | Parked ->
|
||||
error
|
||||
(if parked_break t then
|
||||
"the program is stopped at a break, so it cannot be started again \
|
||||
until that ends: resume it or abort it"
|
||||
else
|
||||
"the program is still running; a re-run starts it again in a new \
|
||||
process once this one has finished. Close its window, or let it \
|
||||
finish, and ask again")
|
||||
| Gone ->
|
||||
(* The whole program is checked again first ([Session.rehost]); a caller
|
||||
left compiled against a signature that has since changed is where
|
||||
that fails. *)
|
||||
let refused (d : Loc.diag) =
|
||||
error ~loc:(Loc.to_string d.Loc.dloc)
|
||||
("a re-run builds the whole program again, and it does not compile: "
|
||||
^ d.Loc.dmsg ^ ". Fix this and load it with C-c C-c, then ask again")
|
||||
in
|
||||
(match relaunch () with
|
||||
| child, rd ->
|
||||
drain t;
|
||||
(try Unix.close t.stdout with Unix.Unix_error _ -> ());
|
||||
t.stdout <- rd;
|
||||
t.child <- Some child;
|
||||
t.finished <- false;
|
||||
t.died <- None;
|
||||
(* Every body is in the new host now, so no module owns one. *)
|
||||
Hashtbl.reset t.owners;
|
||||
ok
|
||||
[ ":note "
|
||||
^ Wire.quote
|
||||
"started the program again in a new process, built with every \
|
||||
change loaded so far; its globals start over, because the \
|
||||
process is new" ]
|
||||
| exception Failure m -> error m
|
||||
| exception Loc.Error d -> refused d
|
||||
| exception Loc.Errors (d :: _) -> refused d)
|
||||
|
||||
let rerun t =
|
||||
match t.relaunch with
|
||||
| Some relaunch -> relaunch_child t relaunch
|
||||
| None ->
|
||||
match liveness t with
|
||||
| Gone -> error gone
|
||||
(* A file started with no [main] runs a stub that returns at once; running
|
||||
@ -4404,7 +4578,13 @@ and handle_op t req =
|
||||
let origin =
|
||||
match Wire.string_field req "file" with Some f -> f | None -> "<editor>"
|
||||
in
|
||||
eval t ~code ~origin ~pause:(Wire.pos_field req "pause")
|
||||
(* [:step t] instruments every defn sent for the stepper. *)
|
||||
let step =
|
||||
match Wire.field req "step" with
|
||||
| Some { Form.v = Form.Sym "nil"; _ } | None -> false
|
||||
| Some _ -> true
|
||||
in
|
||||
eval t ~code ~origin ~pause:(Wire.pos_field req "pause") ~step
|
||||
| None -> error "eval needs :code")
|
||||
| Some "eval-expr" ->
|
||||
(match Wire.string_field req "code" with
|
||||
@ -4422,7 +4602,8 @@ and handle_op t req =
|
||||
| Some { Form.v = Form.Sym "nil"; _ } | None -> false
|
||||
| Some _ -> true
|
||||
in
|
||||
eval_expr t ~code ~origin ~pause
|
||||
eval_expr ?frame:(Wire.int_field req "frame")
|
||||
?at_stop:(Wire.int_field req "at-stop") t ~code ~origin ~pause
|
||||
| None -> error "eval-expr needs :code")
|
||||
(* [:all], absent or [nil] being false and anything else true — the spelling
|
||||
[:pause], [:on] and [:reset] already use. One step is the default because
|
||||
@ -5085,8 +5266,11 @@ let accept_loop ?grace t ls =
|
||||
where a session with no editor attached spends its time. *)
|
||||
agent_check t;
|
||||
match liveness t with
|
||||
| Gone -> ()
|
||||
| (Live | Parked) as live ->
|
||||
| Gone when t.relaunch = None -> ()
|
||||
| live ->
|
||||
(* A --two-process child that has ended can be started again, so the
|
||||
session waits as a parked one does, on the parked grace. *)
|
||||
let live = if live = Gone then Parked else live in
|
||||
let idle = Unix.gettimeofday () -. !since in
|
||||
if orphaned ~grace ~served:!served ~idle live then
|
||||
(* The measured gap and not the threshold it crossed: the threshold is
|
||||
@ -5099,7 +5283,10 @@ let accept_loop ?grace t ls =
|
||||
else
|
||||
(* The program's pipe is in the same select as the listening socket: it
|
||||
has to be drained whether or not an editor is asking for anything. *)
|
||||
match Unix.select [ ls; t.stdout ] [] [] 0.2 with
|
||||
(* Not once it has read EOF: an ended child's pipe is readable for
|
||||
ever, and the loop would spin on it. *)
|
||||
let fds = if t.finished then [ ls ] else [ ls; t.stdout ] in
|
||||
match Unix.select fds [] [] 0.2 with
|
||||
| [], _, _ -> go ()
|
||||
| ready, _, _ when not (List.mem ls ready) -> drain t; go ()
|
||||
| _ ->
|
||||
@ -5207,19 +5394,21 @@ let need_main ~file (session : Session.t) =
|
||||
|
||||
(* The agent's C, in every program [flan dev] builds, whether or not the source
|
||||
imports the package: its constructor binds the socket before [main], so a
|
||||
file that never mentions the agent can still be reached from the editor. A
|
||||
program that imports it already has it, and is left alone — two copies
|
||||
would collide at the link. A release build is not built here and is not
|
||||
affected. *)
|
||||
file that never mentions the agent can still be reached from the editor.
|
||||
|
||||
Always this compiler's own copy, in place of any the program vendors. The
|
||||
agent is the daemon's other half — the stack it snapshots and the verbs it
|
||||
answers are what this file reads — and a program outside this repository
|
||||
carries whatever copy of vendor/agent it was given, however old. An old one
|
||||
builds and answers, and then puts every frame at its function's own line,
|
||||
because it predates the call-site record, so the stepper never moves. One
|
||||
copy and not two: two would collide at the link. A release build is not
|
||||
built here. *)
|
||||
let with_agent ~dir csrcs lflags =
|
||||
let c = Filename.concat dir "flan_agent.c" in
|
||||
write_file c Runtime_src.agent_source;
|
||||
let csrcs =
|
||||
if List.exists (fun c -> Filename.basename c = "flan_agent.c") csrcs then
|
||||
csrcs
|
||||
else begin
|
||||
let c = Filename.concat dir "flan_agent.c" in
|
||||
write_file c Runtime_src.agent_source;
|
||||
csrcs @ [ c ]
|
||||
end
|
||||
List.filter (fun x -> Filename.basename x <> "flan_agent.c") csrcs @ [ c ]
|
||||
in
|
||||
let lflags =
|
||||
lflags
|
||||
@ -5247,7 +5436,7 @@ let report_dropped ~file = function
|
||||
deletes it — and silently making every reloaded body -O0 would change the
|
||||
frame time of the one function you are iterating on, in the loop whose whole
|
||||
point is watching that number. *)
|
||||
let two_process ?(debug = false) ?(x86 = true) ~file ~sock () =
|
||||
let two_process ?(debug = false) ?(sanitize = false) ?(x86 = true) ~file ~sock () =
|
||||
let t0 = Unix.gettimeofday () in
|
||||
(* Absolute, because every location this daemon ever reports is derived from
|
||||
it and an editor is not in this process's working directory. [flan dev
|
||||
@ -5274,19 +5463,22 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () =
|
||||
against each module as it loads either way, but a breakpoint set on a line
|
||||
in the .flan buffer needs a line table on both sides — the host's to fire
|
||||
before the first C-c C-c, the module's to follow the reload. *)
|
||||
let _, kept =
|
||||
Build.executable
|
||||
~opts:{ Build.default with Build.dev = true; Build.keep = true;
|
||||
Build.debug; Build.x86 }
|
||||
~csrcs ~lflags session.Session.host ~out:exe
|
||||
in
|
||||
(* Host and modules are chosen together, which is the whole licence: an
|
||||
[--x86] host gets [--x86] modules because one flag set both, and the
|
||||
source [Build.executable] kept is assembly rather than IR. *)
|
||||
let host_ll = Filename.concat dir (if x86 then "host.s" else "host.ll") in
|
||||
(match kept with
|
||||
| Some src -> (try Sys.rename src host_ll with Sys_error _ -> ())
|
||||
| None -> ());
|
||||
let build_host () =
|
||||
let _, kept =
|
||||
Build.executable
|
||||
~opts:{ Build.default with Build.dev = true; Build.keep = true;
|
||||
Build.debug; Build.sanitize; Build.x86 }
|
||||
~csrcs ~lflags session.Session.host ~out:exe
|
||||
in
|
||||
match kept with
|
||||
| Some src -> (try Sys.rename src host_ll with Sys_error _ -> ())
|
||||
| None -> ()
|
||||
in
|
||||
build_host ();
|
||||
let agent = Filename.concat dir "agent.sock" in
|
||||
|
||||
(* The program's source names some socket path; the daemon is the one that
|
||||
@ -5294,6 +5486,10 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () =
|
||||
environment. Guessing instead would fail silently — everything compiles,
|
||||
the module is built, and nothing ever receives it. *)
|
||||
Unix.putenv "FLAN_AGENT_SOCKET" agent;
|
||||
(* The child binds that path only if this pid is its parent, so a process
|
||||
that merely inherited the variable leaves the socket alone
|
||||
(flan_agent.c, [daemon_socket]). *)
|
||||
Unix.putenv "FLAN_AGENT_OWNER" (string_of_int (Unix.getpid ()));
|
||||
(* And who its parent is, which is the child's licence to end itself.
|
||||
vendor/agent/flan_agent.c carries the argument at length; the half that
|
||||
belongs here is that this daemon is the only thing that ever kills its
|
||||
@ -5318,23 +5514,39 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () =
|
||||
the pipe it was writing to; that also meant the pipe could never reach
|
||||
EOF while the child lived, so "wait for EOF on the daemon's end" was never
|
||||
the mechanism it looked like it could be. *)
|
||||
let rd, wr = Unix.pipe ~cloexec:true () in
|
||||
let child = Unix.create_process exe [| exe |] Unix.stdin wr Unix.stderr in
|
||||
Unix.close wr;
|
||||
Unix.set_nonblock rd;
|
||||
|
||||
(* Wait for it to bind before accepting an evaluation. One that arrives first
|
||||
would fail for a reason that reads like a compiler bug. *)
|
||||
if not (await (fun () -> Sys.file_exists agent)) then begin
|
||||
(try Unix.kill child Sys.sigterm with Unix.Unix_error _ -> ());
|
||||
failwith
|
||||
("the program did not open its agent socket at " ^ agent
|
||||
^ ". Under --two-process every edit reaches the program through that \
|
||||
socket.")
|
||||
end;
|
||||
let spawn () =
|
||||
(* A socket file a previous child left behind would answer the wait below
|
||||
before this child has bound anything. *)
|
||||
(try Unix.unlink agent with Unix.Unix_error _ -> ());
|
||||
let rd, wr = Unix.pipe ~cloexec:true () in
|
||||
let child = Unix.create_process exe [| exe |] Unix.stdin wr Unix.stderr in
|
||||
Unix.close wr;
|
||||
Unix.set_nonblock rd;
|
||||
(* Wait for it to bind before accepting an evaluation. One that arrives
|
||||
first would fail for a reason that reads like a compiler bug. *)
|
||||
if not (await (fun () -> Sys.file_exists agent)) then begin
|
||||
(try Unix.kill child Sys.sigterm with Unix.Unix_error _ -> ());
|
||||
(try Unix.close rd with Unix.Unix_error _ -> ());
|
||||
failwith
|
||||
("the program did not open its agent socket at " ^ agent
|
||||
^ ". Under --two-process every edit reaches the program through that \
|
||||
socket.")
|
||||
end;
|
||||
(child, rd)
|
||||
in
|
||||
let child, rd = spawn () in
|
||||
(* A re-run: the host is built again from the session as it stands, so
|
||||
every redefinition accepted so far is in the new process from its first
|
||||
instruction rather than delivered to it later. *)
|
||||
let relaunch () =
|
||||
Session.rehost session;
|
||||
build_host ();
|
||||
spawn ()
|
||||
in
|
||||
|
||||
let t =
|
||||
{ session; child = Some child; agent; dir; stdout = rd;
|
||||
relaunch = Some relaunch;
|
||||
out = Buffer.create 4096; n = 0; gen = 0; owners = Hashtbl.create 32;
|
||||
host_ll; host_exe = exe; finished = false; agent_watch = None;
|
||||
park_noted = false; died = None; dropped = 0 }
|
||||
@ -5348,9 +5560,12 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () =
|
||||
((Unix.gettimeofday () -. t0) *. 1000.);
|
||||
Fun.protect
|
||||
~finally:(fun () ->
|
||||
(try Unix.kill child Sys.sigterm with Unix.Unix_error _ -> ());
|
||||
(match t.child with
|
||||
| Some child ->
|
||||
(try Unix.kill child Sys.sigterm with Unix.Unix_error _ -> ())
|
||||
| None -> ());
|
||||
(try Unix.close ls with Unix.Unix_error _ -> ());
|
||||
(try Unix.close rd with Unix.Unix_error _ -> ());
|
||||
(try Unix.close t.stdout with Unix.Unix_error _ -> ());
|
||||
(try Unix.unlink sock with Unix.Unix_error _ -> ()))
|
||||
(fun () -> accept_loop t ls);
|
||||
(* Here only when the loop returned: an exception out of it has already
|
||||
@ -6193,7 +6408,7 @@ let merged_setup () =
|
||||
with Unix.Unix_error _ -> Sys.executable_name
|
||||
in
|
||||
let t =
|
||||
{ session; child = None; agent; dir; stdout = rd;
|
||||
{ session; child = None; agent; dir; stdout = rd; relaunch = None;
|
||||
out = Buffer.create 4096; n = 0; gen = 0; owners = Hashtbl.create 32;
|
||||
host_ll; host_exe = exe; finished = false; agent_watch = None;
|
||||
park_noted = false; died = None; dropped = 0 }
|
||||
@ -6276,7 +6491,7 @@ let merged_serve () =
|
||||
(* The merged build is made here and then [exec]'d, so what an editor talks to
|
||||
is the program itself rather than something that launched it. The launcher
|
||||
does not survive: there is one process from the first reply onwards. *)
|
||||
let start_merged ?(debug = false) ?(x86 = true) ~file ~sock () =
|
||||
let start_merged ?(debug = false) ?(sanitize = false) ?(x86 = true) ~file ~sock () =
|
||||
let t0 = Unix.gettimeofday () in
|
||||
let dir = session_dir ~file ~sock in
|
||||
let given = file in
|
||||
@ -6294,7 +6509,8 @@ let start_merged ?(debug = false) ?(x86 = true) ~file ~sock () =
|
||||
let host_ll = Filename.concat dir (if x86 then "host.s" else "host.ll") in
|
||||
ignore
|
||||
(merged_executable
|
||||
~opts:{ Build.default with Build.dev = true; Build.debug; Build.x86 }
|
||||
~opts:{ Build.default with Build.dev = true; Build.debug;
|
||||
Build.sanitize; Build.x86 }
|
||||
~csrcs ~lflags ~pnames:[]
|
||||
session.Session.host ~out:exe ~ll:host_ll);
|
||||
(* Read by the park, so the first one says the session is waiting rather
|
||||
@ -6307,6 +6523,9 @@ let start_merged ?(debug = false) ?(x86 = true) ~file ~sock () =
|
||||
that the game thread's [getenv] cannot race the compiler thread's
|
||||
[putenv]: there is no ordering left to get wrong. *)
|
||||
Unix.putenv "FLAN_AGENT_SOCKET" agent;
|
||||
(* This pid, because the exec below keeps it: the program is the owner
|
||||
flan_agent.c's [daemon_socket] looks for. *)
|
||||
Unix.putenv "FLAN_AGENT_OWNER" (string_of_int (Unix.getpid ()));
|
||||
Unix.putenv "FLAN_DEV_SOURCE" file;
|
||||
Unix.putenv "FLAN_DEV_SOCK" sock;
|
||||
Unix.putenv "FLAN_DEV_DIR" dir;
|
||||
@ -6332,7 +6551,17 @@ let start_merged ?(debug = false) ?(x86 = true) ~file ~sock () =
|
||||
flan.cmxa beside the binary — and it is what every behaviour in this file
|
||||
was written against, so it stays until the transport it exists to drive is
|
||||
actually deleted. *)
|
||||
let start ?(debug = false) ?(merged = true) ?(x86 = true) ~file ~sock () =
|
||||
let start ?(debug = false) ?(sanitize = false) ?(merged = true) ?(x86 = true)
|
||||
~file ~sock () =
|
||||
(* The sanitizers are LLVM passes, and the x86 backend's host is written
|
||||
by hand with no pass run over it. The modules a session sends are not
|
||||
instrumented on either backend; what is checked is the host and the
|
||||
runtime, which is where a dev session's own bookkeeping lives. *)
|
||||
if x86 && sanitize then
|
||||
failwith
|
||||
"flan dev --x86 --sanitize: the sanitizers instrument LLVM's output, and \
|
||||
the x86 backend writes its code by hand, so the program's own code \
|
||||
would not be checked. Drop --x86 to build this session with LLVM.";
|
||||
(* x86 unless told otherwise, and the default is here rather than only in
|
||||
[bin/main.ml] so that there is one answer to "what backend is a dev
|
||||
session". A library caller that starts a daemon starts the same daemon the
|
||||
@ -6382,5 +6611,5 @@ let start ?(debug = false) ?(merged = true) ?(x86 = true) ~file ~sock () =
|
||||
|
||||
[--x86 --debug] above is still refused, and for a reason that has nothing
|
||||
to do with this one. *)
|
||||
if merged then start_merged ~debug ~x86 ~file ~sock ()
|
||||
else two_process ~debug ~x86 ~file ~sock ()
|
||||
if merged then start_merged ~debug ~sanitize ~x86 ~file ~sock ()
|
||||
else two_process ~debug ~sanitize ~x86 ~file ~sock ()
|
||||
|
||||
81
lib/emit.ml
81
lib/emit.ml
@ -539,6 +539,12 @@ type m = {
|
||||
[annot]. *)
|
||||
ann : bool;
|
||||
mutable nstr : int;
|
||||
(* Set while an expression thunk's module is emitted: a string literal's
|
||||
value is then a copy [flan_dev_literal] keeps for the life of the
|
||||
process, so storing it anywhere leaves nothing pointing into the module,
|
||||
and the literal is not counted in [nstr]. Without it every C-x C-e that
|
||||
wrote a string or a keyword kept its mapping. *)
|
||||
mutable pool : bool;
|
||||
(* The frame descriptors a dev build's shadow stack points at, counted apart
|
||||
from [nstr] deliberately. [nstr] is the test [redefinition] uses to decide
|
||||
whether an expression thunk's module may be unloaded — a string literal in
|
||||
@ -2592,6 +2598,16 @@ and value_at f (e : Tast.expr) : string =
|
||||
| Tast.Int (n, _) -> Int64.to_string n
|
||||
| Tast.Float (x, k) -> float_const k x
|
||||
| Tast.Bool b -> if b then "true" else "false"
|
||||
| Tast.Str s when f.md.pool ->
|
||||
(* See [pool]: the bytes are still this module's, but only the copy
|
||||
leaves it, so they are [fi_bytes]' kind of constant and not
|
||||
[string_bytes']. The copy carries the NUL. *)
|
||||
let id, n = fi_bytes f.md s in
|
||||
let p = fresh f in
|
||||
ins f "%s = call ptr @flan_dev_literal(ptr %s, i64 %d)" p id n;
|
||||
let v = fresh f in
|
||||
ins f "%s = insertvalue %%slice { ptr poison, i64 %d }, ptr %s, 0" v n p;
|
||||
v
|
||||
| Tast.Str s -> string_const f.md s
|
||||
| Tast.Unit | Tast.Zero _ | Tast.None_ -> "zeroinitializer"
|
||||
| Tast.Uninit _ -> "poison"
|
||||
@ -4993,6 +5009,8 @@ declare void @flan_dev_watch_emit_i64(i64)
|
||||
declare void @flan_dev_watch_emit_u64(i64)
|
||||
declare void @flan_dev_watch_emit_f64(double)
|
||||
declare void @flan_dev_watch_end()
|
||||
; An expression thunk's string literals, copied to storage the process keeps.
|
||||
declare ptr @flan_dev_literal(ptr, i64)
|
||||
declare i64 @flan_dyn_need_i64(i64)
|
||||
declare double @flan_dyn_need_f64(i64)
|
||||
declare i32 @flan_dyn_need_bool(i64)
|
||||
@ -5310,7 +5328,7 @@ let new_module ~checks ~dev ~known ?(debug = false) ?(sanitize = false)
|
||||
globals = Hashtbl.create 16;
|
||||
externs = Hashtbl.create 32;
|
||||
checks; dev; gcfn = dev || makes_closures p;
|
||||
known; nstr = 0; nfi = 0; sanitize; ann = annotate;
|
||||
known; nstr = 0; pool = false; nfi = 0; sanitize; ann = annotate;
|
||||
descs = Hashtbl.create 8;
|
||||
dbg = (if debug then Some (new_dbg p) else None);
|
||||
fsigs = fsigs_of p;
|
||||
@ -5753,6 +5771,43 @@ let program ?(checks = true) ?(dev = false) ?(debug = false) ?(pnames = [])
|
||||
|
||||
String literals still have to come along: they are this module's own
|
||||
constants, and omitting them is an undefined [@.str.N] at link time. *)
|
||||
|
||||
(* Whether an expression thunk makes a function value anywhere in its body or
|
||||
in the clauses lifted out of it. Such a value's code address is in this
|
||||
module — a lambda's body, or the thick wrapper a named function is handed
|
||||
out through — and it may be stored anywhere, so the module must stay
|
||||
mapped. Both backends ask this before marking a thunk's module
|
||||
unloadable. *)
|
||||
let thunk_makes_fn_values (p : Tast.program) name =
|
||||
let mine = Hashtbl.create 8 in
|
||||
Hashtbl.replace mine name ();
|
||||
(* Lifted clauses nest: a lambda inside a lambda is lifted out of the
|
||||
outer one's body, so the set grows until nothing new joins it. *)
|
||||
let rec close () =
|
||||
let grew = ref false in
|
||||
List.iter
|
||||
(fun (f : Tast.fn) ->
|
||||
match f.Tast.fparent with
|
||||
| Some q when Hashtbl.mem mine q && not (Hashtbl.mem mine f.Tast.name) ->
|
||||
Hashtbl.replace mine f.Tast.name (); grew := true
|
||||
| _ -> ())
|
||||
p.Tast.fns;
|
||||
if !grew then close ()
|
||||
in
|
||||
close ();
|
||||
let found = ref false in
|
||||
List.iter
|
||||
(fun (f : Tast.fn) ->
|
||||
if Hashtbl.mem mine f.Tast.name then
|
||||
List.iter
|
||||
(Tast.walk (fun (e : Tast.expr) ->
|
||||
match e.Tast.e with
|
||||
| Tast.FnAddr _ | Tast.Closure _ | Tast.Thicken _ -> found := true
|
||||
| _ -> ()))
|
||||
f.Tast.body)
|
||||
p.Tast.fns;
|
||||
!found
|
||||
|
||||
let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
|
||||
?(known = fun _ -> true) ?(retains = true)
|
||||
?call ?(consts = []) ?(annotate = false) (p : Tast.program) ~fns
|
||||
@ -5792,6 +5847,7 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
|
||||
List.filter (fun (f : Tast.fn) -> f.Tast.fparent = None) p.Tast.fns
|
||||
in
|
||||
let m = new_module ~checks ~dev ~known ~debug ~annotate p in
|
||||
m.pool <- call <> None && retains;
|
||||
(* A thunk the module runs itself is excluded from all of this: it is called
|
||||
directly by [flan_reload_call], so it needs no cell, must not be published
|
||||
into one, and must not take a registry slot — there are 4096 of those and
|
||||
@ -5911,7 +5967,7 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
|
||||
let t = fresh () in
|
||||
Buffer.add_string b
|
||||
(Printf.sprintf " %s = call ptr @flan_dev_cell(ptr %s)\n store ptr %s, ptr %s\n"
|
||||
t (cstring m (Mangle.sym f.Tast.name)) t (cellptr f.Tast.name)))
|
||||
t (fi_cstring m (Mangle.sym f.Tast.name)) t (cellptr f.Tast.name)))
|
||||
new_fns;
|
||||
List.iter
|
||||
(fun (g : Tast.global) ->
|
||||
@ -5930,8 +5986,10 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
|
||||
match initial_image p g with
|
||||
| None -> "null"
|
||||
| Some v ->
|
||||
let init = Printf.sprintf "@\".init.%d\"" m.nstr in
|
||||
m.nstr <- m.nstr + 1;
|
||||
(* Copied by the runtime and not kept, so not counted in
|
||||
[nstr]; a string inside it is, through [const]. *)
|
||||
let init = Printf.sprintf "@\".init.%d\"" m.nfi in
|
||||
m.nfi <- m.nfi + 1;
|
||||
Buffer.add_string m.strs
|
||||
(Printf.sprintf "%s = private constant %s %s\n" init
|
||||
(ll g.Tast.gty) (const m v));
|
||||
@ -5941,7 +5999,7 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
|
||||
(Printf.sprintf
|
||||
" %s = call ptr @flan_dev_global(ptr %s, i64 ptrtoint (ptr getelementptr (%s, ptr null, i32 1) to i64), ptr %s)\n \
|
||||
store ptr %s, ptr %s\n"
|
||||
t (cstring m (Mangle.sym g.Tast.gname)) (ll g.Tast.gty) init t
|
||||
t (fi_cstring m (Mangle.sym g.Tast.gname)) (ll g.Tast.gty) init t
|
||||
(globalptr g.Tast.gname)))
|
||||
new_globals;
|
||||
(* A constant whose value the checker never consumed is just bytes in the
|
||||
@ -6010,10 +6068,12 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
|
||||
expression may store one anywhere it likes — [(set msg "tuned")] on a
|
||||
string global leaves that global pointing into the mapping the agent
|
||||
is about to drop. The next thunk can be mapped at the same address, so
|
||||
the result is silent garbage rather than a fault. A module with no
|
||||
string constants has nothing in its image anyone could still be
|
||||
pointing at; one with any keeps its mapping, which costs a page and is
|
||||
the same bargain every redefinition already makes. *)
|
||||
the result is silent garbage rather than a fault. So a thunk's
|
||||
literal is a copy the process keeps (see [pool]) and is not counted;
|
||||
what [nstr] still counts is a constant something may go on pointing
|
||||
at, such as a condition's name, and a module with one keeps its
|
||||
mapping. The registry names above are not counted: flan_dev.c copies
|
||||
a name it keeps, and an initial image is copied on allocation. *)
|
||||
(* [retains = false] is a caller saying it knows where every literal in
|
||||
this module goes. The [m.nstr] test below is a conservative stand-in
|
||||
for that — an expression may store a string literal anywhere it likes,
|
||||
@ -6023,7 +6083,8 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
|
||||
into the result buffer, so nothing outside the module holds an address
|
||||
inside it once the call has returned. Without this, clicking through
|
||||
the frames of a break loop costs a permanent mapping per click. *)
|
||||
if fns = [ fn ] && consts = [] && ((not retains) || m.nstr = 0) then
|
||||
if fns = [ fn ] && consts = [] && ((not retains) || m.nstr = 0)
|
||||
&& not (thunk_makes_fn_values p fn) then
|
||||
Buffer.add_string m.out "\n@flan_reload_transient = global i8 1\n"
|
||||
| None -> ()
|
||||
end;
|
||||
|
||||
@ -205,6 +205,7 @@ let caught s f =
|
||||
match f () with
|
||||
| x -> Some x
|
||||
| exception Error d -> s.found <- d :: s.found; None
|
||||
| exception Errors ds -> s.found <- List.rev_append ds s.found; None
|
||||
|
||||
(** Raise everything found, in the order it was found, or return if the pass
|
||||
was clean. *)
|
||||
|
||||
@ -240,6 +240,18 @@ let source = {flan|
|
||||
(defn pause [] ()
|
||||
(restart-case (error (Pause {}))
|
||||
(continue [] (do))))
|
||||
;; The stepper's stop, which C-c C-s puts before each form of a defn's body
|
||||
;; (Ast.instrument_step). It is (pause) with an answer: next goes on stepping
|
||||
;; and continue runs the rest of the call, and the instrumented body keeps
|
||||
;; that answer in a local of its own. Like Pause it is not under Error.
|
||||
;; Named so a program's own step or Step is not what the instrumented body
|
||||
;; calls.
|
||||
(defstruct StepPoint [])
|
||||
|
||||
(defn step-point [] bool
|
||||
(restart-case (error (StepPoint {}))
|
||||
(next [] :report "stop at the next form" true)
|
||||
(continue [] :report "run the rest of this call" false)))
|
||||
|
||||
;; A seeded PRNG in Flan rather than libc's, because a grid hash is only a
|
||||
;; regression test if the sequence is byte-identical on native and wasm32
|
||||
|
||||
@ -98,6 +98,5 @@ let rerun ?(stopped = false) () =
|
||||
its window, or let it finish, and ask again"
|
||||
| _ ->
|
||||
Error
|
||||
"this session's program is a process of its own, so there is no parked \
|
||||
thread here to send round again; it is the merged build that can re-run \
|
||||
a program, not --two-process"
|
||||
"this process has no program thread of its own, so there is nothing \
|
||||
here to run again"
|
||||
|
||||
116
lib/session.ml
116
lib/session.ml
@ -65,7 +65,7 @@ type t = {
|
||||
mutable decls : Ast.decl list; (* post-Load: flat, one namespace *)
|
||||
mutable program : Tast.program; (* the last thing that checked *)
|
||||
mutable env : Check.env; (* the same, as the checker sees it *)
|
||||
host : Tast.program; (* what the process was built from *)
|
||||
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.
|
||||
@ -782,12 +782,30 @@ let restore t h =
|
||||
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
|
||||
|
||||
(* [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 ?(running = true) t src : change =
|
||||
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
|
||||
@ -877,6 +895,15 @@ let eval ?(origin = "<eval>") ?base ?forms ?pause ?(running = true) t src : chan
|
||||
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 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
|
||||
@ -968,8 +995,13 @@ let eval ?(origin = "<eval>") ?base ?forms ?pause ?(running = true) t src : chan
|
||||
&& 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 =
|
||||
Check.program_tolerant ~tolerate:stale_owner decls
|
||||
match Check.program_tolerant ~keep_going:true ~tolerate:stale_owner decls with
|
||||
| r -> r
|
||||
| exception Loc.Errors [ d ] -> raise (Loc.Error d)
|
||||
in
|
||||
let program =
|
||||
if tolerated = [] then program
|
||||
@ -1499,6 +1531,15 @@ let shown_names (fn : Tast.fn) : string option array =
|
||||
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
|
||||
@ -2518,7 +2559,68 @@ let render_globals ?(origin = "<globals>") t ~(globals : Tast.global list)
|
||||
sticks — a thunk is built and thrown away, so the mark lasts exactly one
|
||||
evaluation, which is the truthful thing for an expression that has no
|
||||
declaration to live in. *)
|
||||
let eval_expr ?(origin = "<eval>") ?(pause = false) t src : change =
|
||||
(* [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)) 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
|
||||
@ -2567,7 +2669,11 @@ let eval_expr ?(origin = "<eval>") ?(pause = false) t src : change =
|
||||
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 = Check.expression t.env parsed 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
|
||||
|
||||
59
lib/tast.ml
59
lib/tast.ml
@ -506,6 +506,65 @@ and walk_place f (p : place) =
|
||||
| Pfield (t, _) | Pderef t -> walk f t
|
||||
| Pindex (t, idx) -> walk f t; List.iter (walk f) idx
|
||||
|
||||
(* [e] with every read, store and address of a local slot [f] answers for
|
||||
replaced: a read of slot [i] by [Deref p], its place by [Pderef p], where
|
||||
[f i loc] is [Some p], a pointer to where the value really lives. The one
|
||||
caller is evaluating in a stopped frame, whose locals are the other frame's
|
||||
slots reached by address. Slots [f] answers [None] for are left alone, and
|
||||
so is every binder: only the slots [f] names are replaced, and none of them
|
||||
is bound inside [e]. *)
|
||||
let rec rewrite_locals (f : int -> Loc.t -> expr option) (e : expr) : expr =
|
||||
let go = rewrite_locals f in
|
||||
let gos = List.map go in
|
||||
let kind =
|
||||
match e.e with
|
||||
| Local i ->
|
||||
(match f i e.loc with Some p -> Deref p | None -> e.e)
|
||||
| Int _ | Float _ | Bool _ | Str _ | Unit | Zero _ | Uninit _ | Global _
|
||||
| None_ | FnAddr _ | Break _ | Continue _ -> e.e
|
||||
| Fill (t, b) -> Fill (t, go b)
|
||||
| DeadBeef (t, b) -> DeadBeef (t, go b)
|
||||
| Prim (p, es) -> Prim (p, gos es)
|
||||
| Call (n, es) -> Call (n, gos es)
|
||||
| Do es -> Do (gos es)
|
||||
| Make (n, es) -> Make (n, gos es)
|
||||
| MakeCase (d, c, es) -> MakeCase (d, c, gos es)
|
||||
| Arr es -> Arr (gos es)
|
||||
| InvokeRestart (a, b, es, c, d, l) -> InvokeRestart (a, b, gos es, c, d, l)
|
||||
| CallPtr (c, es) -> CallPtr (go c, gos es)
|
||||
| Let (bs, body) -> Let (List.map (fun (s, v) -> (s, go v)) bs, gos body)
|
||||
| If (a, b, c) -> If (go a, go b, go c)
|
||||
| While (c, body, latch) -> While (go c, gos body, gos latch)
|
||||
| Return v -> Return (Option.map go v)
|
||||
| Set (p, v) -> Set (rewrite_place f e.loc p, go v)
|
||||
| Addr p -> Addr (rewrite_place f e.loc p)
|
||||
| Field (t, i) -> Field (go t, i)
|
||||
| Deref t -> Deref (go t)
|
||||
| CaseField (t, c, i) -> CaseField (go t, c, i)
|
||||
| Some_ t -> Some_ (go t)
|
||||
| UnwrapSome t -> UnwrapSome (go t)
|
||||
| Signal (k, d, t) -> Signal (k, d, go t)
|
||||
| Closure (r, t) -> Closure (r, go t)
|
||||
| Thicken (n, t) -> Thicken (n, go t)
|
||||
| Match (sc, arms) ->
|
||||
Match (go sc, List.map (fun a -> { a with abody = gos a.abody }) arms)
|
||||
| Handled (hs, body) ->
|
||||
Handled
|
||||
(List.map (fun h -> { h with henv = Option.map go h.henv }) hs, gos body)
|
||||
| RestartCase (cs, body) ->
|
||||
RestartCase (List.map (fun c -> { c with rbody = gos c.rbody }) cs, go body)
|
||||
| WithAlloc (a, body) -> WithAlloc (go a, gos body)
|
||||
in
|
||||
{ e with e = kind }
|
||||
|
||||
and rewrite_place f loc (p : place) : place =
|
||||
match p with
|
||||
| Plocal i -> (match f i loc with Some ptr -> Pderef ptr | None -> p)
|
||||
| Pglobal _ -> p
|
||||
| Pfield (t, i) -> Pfield (rewrite_locals f t, i)
|
||||
| Pderef t -> Pderef (rewrite_locals f t)
|
||||
| Pindex (t, idx) -> Pindex (rewrite_locals f t, List.map (rewrite_locals f) idx)
|
||||
|
||||
(* ── What the object image can hold ─────────────────────────────────── *)
|
||||
|
||||
(* Whether an initialiser is a value a linker can write into the program's
|
||||
|
||||
33
lib/x86.ml
33
lib/x86.ml
@ -491,7 +491,8 @@ let layout_ctx ~checks ~dev (p : Tast.program) : Emit.m =
|
||||
globals; externs = Hashtbl.create 1; checks;
|
||||
dev; gcfn = dev || Emit.makes_closures p;
|
||||
known = (fun _ -> true); dbg = None; sanitize = false; ann = false;
|
||||
nstr = 0; nfi = 0; descs = Hashtbl.create 8; fsigs = Emit.fsigs_of p }
|
||||
nstr = 0; pool = false; nfi = 0; descs = Hashtbl.create 8;
|
||||
fsigs = Emit.fsigs_of p }
|
||||
|
||||
let sizeof md t = fst (Emit.lay md t)
|
||||
|
||||
@ -1813,6 +1814,16 @@ and lower_at f (e : Tast.expr) (dst : loc) : unit =
|
||||
let l = float_const f x ~f64 in
|
||||
fload f.b ~dst:xmm0 ~mm:(Sym (l, 0)) ~f64;
|
||||
fstore f.b ~src:xmm0 ~mm:(lmem f dst ~scratch:r11) ~f64
|
||||
| Tast.Str s when f.md.Emit.pool ->
|
||||
(* [Emit]'s [pool]: an expression thunk's literal is a copy the process
|
||||
keeps, so nothing is left pointing into the module. *)
|
||||
let l, n = fi_bytes f s in
|
||||
lea f.b ~dst:rdi ~mm:(Sym (l, 0));
|
||||
imm_into f ~reg:rsi (Int64.of_int n);
|
||||
call_sym f.b "flan_dev_literal";
|
||||
store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8;
|
||||
imm_into f ~reg:rax (Int64.of_int n);
|
||||
store_int f.b ~src:rax ~mm:(lmem f (shift dst 8) ~scratch:r11) ~size:8
|
||||
| Tast.Str s ->
|
||||
(* A string and a [u8] slice are the same two words, which is why [Bytes]
|
||||
below is a non-instruction. *)
|
||||
@ -5317,6 +5328,7 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true)
|
||||
p.Tast.globals
|
||||
in
|
||||
let md = layout_ctx ~checks ~dev p in
|
||||
md.Emit.pool <- call <> None && retains;
|
||||
let externs = Hashtbl.create 16 in
|
||||
List.iter
|
||||
(fun (e : Tast.extern) -> Hashtbl.replace externs e.Tast.ename e.Tast.esym)
|
||||
@ -5421,7 +5433,10 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true)
|
||||
the same and [test_reload.ml] checks it there by grepping the IR text;
|
||||
there is no text to grep on this side, so the guarantee is this loop
|
||||
order and this comment. *)
|
||||
let cstr sym = let l = string_const f sym in lea f.b ~dst:rdi ~mm:(Sym (l, 0)) in
|
||||
(* Not counted in [nstr]: flan_dev.c's registry copies a name it keeps, so
|
||||
nothing is left pointing at these once the lookup returns. Counted, every
|
||||
module after the session's first new name would keep its mapping. *)
|
||||
let cstr sym = let l = fi_cstring f sym in lea f.b ~dst:rdi ~mm:(Sym (l, 0)) in
|
||||
List.iter
|
||||
(fun (fn : Tast.fn) ->
|
||||
cstr (Mangle.sym fn.Tast.name);
|
||||
@ -5600,16 +5615,14 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true)
|
||||
store one anywhere it likes -- [(set msg "tuned")] on a string global
|
||||
leaves that global pointing into the mapping the agent is about to drop.
|
||||
The next thunk can be mapped at the same address, so the result is silent
|
||||
garbage rather than a fault. A module with no string constants has nothing
|
||||
in its image anyone could still be pointing at; one with any keeps its
|
||||
mapping, which costs a page and is the same bargain every redefinition
|
||||
already makes. [string_const] is where the count is kept, and the install
|
||||
function's own registry names go through it too -- which is right rather
|
||||
than incidental, since a module that interned a name left something
|
||||
behind. *)
|
||||
garbage rather than a fault. So a thunk's literal is a copy the process
|
||||
keeps ([Emit]'s [pool]) and is not counted; what [string_const] still
|
||||
counts is a constant something may go on pointing at, such as a
|
||||
condition's name, and a module with one keeps its mapping. The install
|
||||
function's registry names are not counted: the registry copies them. *)
|
||||
(match call with
|
||||
| Some fn
|
||||
when fns = [ fn ] && consts = []
|
||||
when fns = [ fn ] && consts = [] && not (Emit.thunk_makes_fn_values p fn)
|
||||
&& ((not retains) || md.Emit.nstr = 0) ->
|
||||
Buffer.add_string out
|
||||
"\n\t.data\n\t.globl\tflan_reload_transient\n\
|
||||
|
||||
@ -436,6 +436,56 @@ void flan_dev_result_end(void) {
|
||||
* when it was sizing something to send through a socket. */
|
||||
uint64_t flan_dev_result_cap(void) { return RESULT_MAX; }
|
||||
|
||||
/* ── An expression thunk's string literals ──────────────────────────── */
|
||||
|
||||
/* A literal in an evaluated expression is a copy made here and kept for the
|
||||
* life of the process, one per distinct text, NUL after the bytes as the
|
||||
* module's own constants have. The expression may store it anywhere, so
|
||||
* pointing it into the thunk's module would keep that module mapped for ever
|
||||
* (Emit's [pool]); pointing it here lets the agent unload the module once the
|
||||
* thunk returns. Game thread only: thunks run there. */
|
||||
typedef struct lit { struct lit *next; int64_t len; uint8_t bytes[]; } lit;
|
||||
|
||||
static lit **lits;
|
||||
static size_t lits_cap, lits_n;
|
||||
|
||||
static uint64_t lit_hash(const uint8_t *p, int64_t n) {
|
||||
uint64_t h = 1469598103934665603ULL; /* FNV-1a */
|
||||
for (int64_t i = 0; i < n; i++) { h ^= p[i]; h *= 1099511628211ULL; }
|
||||
return h;
|
||||
}
|
||||
|
||||
const uint8_t *flan_dev_literal(const uint8_t *p, int64_t n) {
|
||||
if (n < 0) n = 0;
|
||||
if (lits_n >= lits_cap / 2) {
|
||||
size_t cap = lits_cap ? lits_cap * 2 : 64;
|
||||
lit **t = calloc(cap, sizeof *t);
|
||||
if (t == NULL) die("out of memory", "a string literal");
|
||||
for (size_t i = 0; i < lits_cap; i++)
|
||||
for (lit *e = lits[i], *nx; e != NULL; e = nx) {
|
||||
nx = e->next;
|
||||
size_t b = lit_hash(e->bytes, e->len) & (cap - 1);
|
||||
e->next = t[b];
|
||||
t[b] = e;
|
||||
}
|
||||
free(lits);
|
||||
lits = t;
|
||||
lits_cap = cap;
|
||||
}
|
||||
size_t b = lit_hash(p, n) & (lits_cap - 1);
|
||||
for (lit *e = lits[b]; e != NULL; e = e->next)
|
||||
if (e->len == n && memcmp(e->bytes, p, (size_t)n) == 0) return e->bytes;
|
||||
lit *e = malloc(sizeof *e + (size_t)n + 1);
|
||||
if (e == NULL) die("out of memory", "a string literal");
|
||||
e->len = n;
|
||||
if (n > 0) memcpy(e->bytes, p, (size_t)n);
|
||||
e->bytes[n] = 0;
|
||||
e->next = lits[b];
|
||||
lits[b] = e;
|
||||
lits_n++;
|
||||
return e->bytes;
|
||||
}
|
||||
|
||||
/* Called between the copy and the second read of the counter, when set. It
|
||||
* exists for test/dev_limits.c and nothing else sets it: the losing side of
|
||||
* the race is a write landing inside that window, and a second thread cannot
|
||||
|
||||
@ -140,7 +140,9 @@
|
||||
; a Flan program: flan_dyn.c has no Flan spelling yet. It is also the one
|
||||
; translation unit here that frees the most, which is what makes it worth a
|
||||
; sanitized run at all. See [dyn_sweep].
|
||||
(file dyn_ops.c))
|
||||
(file dyn_ops.c)
|
||||
; [dev_session] drives a real flan dev --sanitize.
|
||||
(file %{workspace_root}/bin/main.exe))
|
||||
(action (run ./test_sanitize.exe)))
|
||||
|
||||
; The corpus a third time, under Valgrind's memcheck. Its own alias for the
|
||||
|
||||
22
test/programs/dev-own-break.flan
Normal file
22
test/programs/dev-own-break.flan
Normal file
@ -0,0 +1,22 @@
|
||||
;;;; A program that stops on its own while an evaluation is in flight.
|
||||
;;;;
|
||||
;;;; Setting [go] from the editor starts it: the loop sees it, sleeps without
|
||||
;;;; polling for longer than a module takes to build, and then signals. An
|
||||
;;;; expression evaluated just after [go] is therefore waiting in the ring
|
||||
;;;; when the program's own break is entered, and runs inside that break's
|
||||
;;;; loop. The stop is the program's and the value is the expression's.
|
||||
(import agent "vendor:agent")
|
||||
|
||||
(declare-c usleep [us i32] i32 "usleep")
|
||||
|
||||
(defstruct Late [])
|
||||
|
||||
(defonce go i64)
|
||||
|
||||
(defn main [] i32
|
||||
(while (= go 0)
|
||||
(agent/wait 5))
|
||||
(usleep 1500000)
|
||||
(restart-case
|
||||
(do (error (Late {})) 0)
|
||||
(carry-on [] 0)))
|
||||
@ -61,6 +61,14 @@ let send path line =
|
||||
Unix.close s;
|
||||
Buffer.contents b
|
||||
|
||||
(* The pair the daemon sets: the path, and the pid it is meant for. This test
|
||||
binary is the parent of every program it starts, which is the
|
||||
--two-process shape. *)
|
||||
let daemon_env path =
|
||||
let me = string_of_int (Unix.getpid ()) in
|
||||
[| "FLAN_AGENT_SOCKET=" ^ path; "FLAN_AGENT_OWNER=" ^ me;
|
||||
"FLAN_DEV_PARENT=" ^ me |]
|
||||
|
||||
let () =
|
||||
match Sys.command "command -v clang > /dev/null 2>&1 && command -v llc > /dev/null 2>&1" with
|
||||
| 0 ->
|
||||
@ -298,7 +306,7 @@ let () =
|
||||
let bad = tmp "bad.out" in
|
||||
let bfd' = ofd bad in
|
||||
let benv =
|
||||
Array.append aenv [| "FLAN_AGENT_SOCKET=/nonexistent-dir/agent.sock" |]
|
||||
Array.append aenv (daemon_env "/nonexistent-dir/agent.sock")
|
||||
in
|
||||
let bpid' = Unix.create_process_env aexe [| aexe |] benv Unix.stdin bfd' bfd' in
|
||||
Unix.close bfd';
|
||||
@ -325,6 +333,79 @@ let () =
|
||||
"cannot listen\n"
|
||||
end;
|
||||
|
||||
(* ── The variable inherited by a process the daemon did not start ── *)
|
||||
|
||||
(* A shell opened from inside a [flan dev] program carries its
|
||||
FLAN_AGENT_SOCKET, and so does anything run from that shell. Binding
|
||||
unlinks the path first, so honouring it there would take the session's
|
||||
socket from its program. FLAN_AGENT_OWNER names the process the daemon
|
||||
launched; pid 1 is neither this program nor its parent, so the variable
|
||||
is not this program's, and it picks and announces a path of its own as
|
||||
if nothing were set. The file standing in for the session's socket has
|
||||
to still be the same file afterwards. *)
|
||||
let inherited ~shape ~owner =
|
||||
let stolen = tmp "stolen.sock" and serr = tmp "stolen.err" in
|
||||
Out_channel.with_open_bin stolen (fun oc ->
|
||||
output_string oc "the session's");
|
||||
let senv =
|
||||
Array.append aenv
|
||||
[| "FLAN_AGENT_SOCKET=" ^ stolen; "FLAN_AGENT_OWNER=" ^ owner |]
|
||||
in
|
||||
let s1 = ofd (tmp "stolen.out") and s2 = ofd serr in
|
||||
let spid = Unix.create_process_env aexe [| aexe |] senv Unix.stdin s1 s2 in
|
||||
Unix.close s1;
|
||||
Unix.close s2;
|
||||
let prefix = "flan agent: listening on " in
|
||||
let sannounced () =
|
||||
let text = In_channel.with_open_bin serr In_channel.input_all in
|
||||
List.find_map
|
||||
(fun l ->
|
||||
if String.length l > String.length prefix
|
||||
&& String.sub l 0 (String.length prefix) = prefix
|
||||
then Some (String.sub l (String.length prefix)
|
||||
(String.length l - String.length prefix))
|
||||
else None)
|
||||
(String.split_on_char '\n' text)
|
||||
in
|
||||
(match
|
||||
if await (fun () -> sannounced () <> None) then sannounced () else None
|
||||
with
|
||||
| None ->
|
||||
fail "%s: a program with someone else's FLAN_AGENT_SOCKET announced no \
|
||||
socket of its own" shape;
|
||||
(try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ())
|
||||
| Some p ->
|
||||
if p = stolen then fail "%s: the inherited path was bound: %S" shape p;
|
||||
if not (await (fun () -> Sys.file_exists p)) then
|
||||
fail "%s: nothing was bound at the announced %S" shape p
|
||||
else ignore (send p aso);
|
||||
let reaped =
|
||||
await ~ms:5000 (fun () ->
|
||||
match Unix.waitpid [ Unix.WNOHANG ] spid with
|
||||
| 0, _ -> false
|
||||
| _ -> true)
|
||||
in
|
||||
if not reaped then begin
|
||||
(try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ());
|
||||
fail "%s: the program with an inherited variable never finished" shape
|
||||
end);
|
||||
(match In_channel.with_open_bin stolen In_channel.input_all with
|
||||
| "the session's" -> ()
|
||||
| _ -> fail "%s: the inherited FLAN_AGENT_SOCKET's file was replaced" shape
|
||||
| exception Sys_error _ ->
|
||||
fail "%s: the inherited FLAN_AGENT_SOCKET's file was removed" shape);
|
||||
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
|
||||
[ stolen; serr; tmp "stolen.out" ]
|
||||
in
|
||||
(* Nobody's pid. *)
|
||||
inherited ~shape:"an owner that is not this process" ~owner:"1";
|
||||
(* A merged build's owner is the program itself, so a process the program
|
||||
starts has the owner as its parent; with no FLAN_DEV_PARENT naming it,
|
||||
that is not the --two-process shape and the socket is not its. Here the
|
||||
test binary stands in for the program. *)
|
||||
inherited ~shape:"a child of a merged program"
|
||||
~owner:(string_of_int (Unix.getpid ()));
|
||||
|
||||
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
|
||||
[ aexe; aso; aout; aerr; bad ];
|
||||
|
||||
@ -359,7 +440,7 @@ let () =
|
||||
let nc = Session.eval nt "(defn tick [] i64 1000)" in
|
||||
ignore (Build.shared ~opts:dev ~ir:nc.Session.ir ~out:nso ());
|
||||
let nenv =
|
||||
Array.append (Unix.environment ()) [| "FLAN_AGENT_SOCKET=" ^ nsock |]
|
||||
Array.append (Unix.environment ()) (daemon_env nsock)
|
||||
in
|
||||
let nfd =
|
||||
Unix.openfile nout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
|
||||
@ -412,7 +493,7 @@ let () =
|
||||
bt.Session.host ~out:bexe);
|
||||
let bfd = Unix.openfile bout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
|
||||
let env =
|
||||
Array.append (Unix.environment ()) [| "FLAN_AGENT_SOCKET=" ^ bsock |]
|
||||
Array.append (Unix.environment ()) (daemon_env bsock)
|
||||
in
|
||||
let bpid =
|
||||
Unix.create_process_env bexe [| bexe |] env Unix.stdin bfd bfd
|
||||
@ -753,7 +834,7 @@ let () =
|
||||
lt.Session.host ~out:lexe);
|
||||
let lfd = Unix.openfile lout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
|
||||
let lenv =
|
||||
Array.append (Unix.environment ()) [| "FLAN_AGENT_SOCKET=" ^ lsock |]
|
||||
Array.append (Unix.environment ()) (daemon_env lsock)
|
||||
in
|
||||
let lpid = Unix.create_process_env lexe [| lexe |] lenv Unix.stdin lfd lfd in
|
||||
Unix.close lfd;
|
||||
|
||||
519
test/test_dev.ml
519
test/test_dev.ml
@ -127,6 +127,166 @@ let status r =
|
||||
|
||||
let contains_sub = Test_support.contains
|
||||
|
||||
(* The stepper, against a running program whose [step] is dev-pause.flan's
|
||||
and dev-repl.flan's: sent with [:step t], a call stops before each form of
|
||||
its body — the (set ...), then after [next] the [ticks] it answers.
|
||||
[continue] runs the rest of the call and the next call steps again, and a
|
||||
plain evaluation takes it out. Run in a daemon of each backend that another
|
||||
block already started, so it costs no build of its own. *)
|
||||
let stepper_checks ~what ask =
|
||||
let stopped r =
|
||||
match Wire.field r "stopped" with
|
||||
| Some { Form.v = Form.Sym "t"; _ } -> true
|
||||
| _ -> false
|
||||
in
|
||||
let body = "(defn step [] i64 (set ticks (+ ticks 1)) ticks)" in
|
||||
let col sub =
|
||||
let n = String.length sub in
|
||||
let rec find i =
|
||||
if String.equal (String.sub body i n) sub then i + 1 else find (i + 1)
|
||||
in
|
||||
find 0
|
||||
in
|
||||
(* Where the stepped frame is: the frame of [step], whose location is
|
||||
the step point's, which is the form about to run. *)
|
||||
let at () =
|
||||
match Wire.field (ask "(:op \"backtrace\")") "frames" with
|
||||
| Some { Form.v = Form.List l; _ } ->
|
||||
List.find_map
|
||||
(fun (f : Form.t) ->
|
||||
match f.Form.v with
|
||||
| Form.List ({ Form.v = Form.Str "step"; _ }
|
||||
:: { Form.v = Form.Str loc; _ } :: _) -> Some loc
|
||||
| _ -> None)
|
||||
l
|
||||
| _ -> None
|
||||
in
|
||||
let stops_at sub =
|
||||
let want = Printf.sprintf ":1:%d" (col sub) in
|
||||
await (fun () ->
|
||||
stopped (ask "(:op \"describe\")")
|
||||
&& (match at () with Some l -> contains_sub l want | None -> false))
|
||||
in
|
||||
let r =
|
||||
ask
|
||||
(Printf.sprintf "(:op \"eval\" :code %s :file \"/tmp/step.flan\" :step t)"
|
||||
(Wire.quote body))
|
||||
in
|
||||
if status r <> "ok" then
|
||||
fail "%sinstrumenting for the stepper: %s" what
|
||||
(Option.value ~default:"" (Wire.string_field r "message"))
|
||||
else begin
|
||||
if Wire.field r "step" = None then
|
||||
fail "%san instrumented defn did not echo :step" what;
|
||||
if not (stops_at "(set ticks") then
|
||||
fail "%sthe stepper did not stop before the first form (at %s)" what
|
||||
(Option.value ~default:"<none>" (at ()))
|
||||
else begin
|
||||
(match Wire.string_field (ask "(:op \"describe\")") "condition" with
|
||||
| Some "StepPoint" -> ()
|
||||
| c -> fail "%sa step stopped on %s" what (Option.value ~default:"<none>" c));
|
||||
(* The stepper's own local is not one of the frame's. *)
|
||||
let fr = ask "(:op \"locals\" :frame 1)" in
|
||||
(match Wire.string_field fr "frame" with
|
||||
| Some "step" ->
|
||||
(match Wire.field fr "locals" with
|
||||
| Some { Form.v = Form.List []; _ } | None -> ()
|
||||
| _ -> fail "%sthe stepper's flag is listed as a local" what)
|
||||
| f -> fail "%sframe 1 at a step is %s" what (Option.value ~default:"<none>" f));
|
||||
let r = ask "(:op \"restart\" :name \"next\")" in
|
||||
if status r <> "ok" then
|
||||
fail "%snext at a step: %s" what
|
||||
(Option.value ~default:"" (Wire.string_field r "message"));
|
||||
if not (stops_at "ticks)") then
|
||||
fail "%snext did not stop before the second form (at %s)" what
|
||||
(Option.value ~default:"<none>" (at ()));
|
||||
let r = ask "(:op \"restart\" :name \"continue\")" in
|
||||
if status r <> "ok" then
|
||||
fail "%scontinue at a step: %s" what
|
||||
(Option.value ~default:"" (Wire.string_field r "message"));
|
||||
(* The next call, 5ms on, steps again from the top. *)
|
||||
if not (stops_at "(set ticks") then
|
||||
fail "%sthe next call did not step again" what;
|
||||
let r =
|
||||
ask
|
||||
(Printf.sprintf "(:op \"eval\" :code %s :file \"/tmp/step.flan\")"
|
||||
(Wire.quote body))
|
||||
in
|
||||
if status r <> "ok" then
|
||||
fail "%sinstalling the plain defn: %s" what
|
||||
(Option.value ~default:"" (Wire.string_field r "message"));
|
||||
ignore (ask "(:op \"restart\" :name \"continue\")");
|
||||
if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then
|
||||
fail "%sthe program did not resume from the last step" what;
|
||||
let deadline = Unix.gettimeofday () +. 0.5 in
|
||||
let rec run_on () =
|
||||
if Unix.gettimeofday () > deadline then ()
|
||||
else if stopped (ask "(:op \"describe\")") then
|
||||
fail "%sthe plain defn still steps" what
|
||||
else begin
|
||||
ignore (Unix.select [] [] [] 0.01);
|
||||
run_on ()
|
||||
end
|
||||
in
|
||||
run_on ()
|
||||
end
|
||||
end
|
||||
|
||||
(* Eval-in-frame against dev-locals.flan's [look], stopped at its (error ...):
|
||||
the expression sees that frame's locals, the inner of two [label]s wins, a
|
||||
[set] writes the frame's own storage, and a local not bound yet is refused
|
||||
by name. [ask] sends one request. Run under each backend. *)
|
||||
let eval_in_frame_checks ~backend ask =
|
||||
let value code =
|
||||
let r =
|
||||
ask (Printf.sprintf "(:op \"eval-expr\" :frame 0 :code %S)" code)
|
||||
in
|
||||
if status r = "ok" then Ok (Option.value ~default:"" (Wire.string_field r "value"))
|
||||
else Error (Option.value ~default:(status r) (Wire.string_field r "message"))
|
||||
in
|
||||
let expect code want =
|
||||
match value code with
|
||||
| Ok v when v = want -> ()
|
||||
| Ok v -> fail "%s eval-in-frame %s answered %S, wanted %S" backend code v want
|
||||
| Error m -> fail "%s eval-in-frame %s: %s" backend code m
|
||||
in
|
||||
expect "(+ n 1)" "4";
|
||||
expect "(.y p)" "2.5";
|
||||
expect "label" "\"inner\"";
|
||||
expect "(do (set flag false) flag)" "false";
|
||||
(match
|
||||
Wire.field (ask "(:op \"locals\" :frame 0)") "locals"
|
||||
with
|
||||
| Some { Form.v = Form.List rows; _ } ->
|
||||
if not
|
||||
(List.exists
|
||||
(fun (e : Form.t) ->
|
||||
match e.Form.v with
|
||||
| Form.List ({ Form.v = Form.Str "flag"; _ } :: _
|
||||
:: { Form.v = Form.Str "false"; _ } :: _) -> true
|
||||
| _ -> false)
|
||||
rows)
|
||||
then fail "%s eval-in-frame: a set did not reach the frame" backend
|
||||
| _ -> fail "%s eval-in-frame: no locals after the set" backend);
|
||||
expect "(do (set flag true) flag)" "true";
|
||||
(match value "(+ after 1)" with
|
||||
| Error m when contains_sub m "after is not bound yet" -> ()
|
||||
| Error m -> fail "%s eval-in-frame of an unbound local said %s" backend m
|
||||
| Ok v -> fail "%s eval-in-frame read an unbound local as %s" backend v);
|
||||
(match value "(+ n \"x\")" with
|
||||
| Error _ -> ()
|
||||
| Ok v -> fail "%s eval-in-frame accepted a type error: %s" backend v);
|
||||
(* Addressed to a stop that is over: the agent drops it, and the reply says
|
||||
why at once rather than timing out. *)
|
||||
let t0 = Unix.gettimeofday () in
|
||||
let r = ask "(:op \"eval-expr\" :frame 0 :at-stop 999999 :code \"n\")" in
|
||||
let m = Option.value ~default:"" (Wire.string_field r "message") in
|
||||
if status r = "ok" then fail "%s eval-in-frame ran at a stop that is over" backend
|
||||
else if not (contains_sub m "resumed" || contains_sub m "stopped again") then
|
||||
fail "%s eval-in-frame at a stop that is over said %s" backend m
|
||||
else if Unix.gettimeofday () -. t0 > 4.0 then
|
||||
fail "%s eval-in-frame at a stop that is over waited out the clock" backend
|
||||
|
||||
(* ── The one verb whose reply races the process it ends ─────────────── *)
|
||||
|
||||
(* [abort] is answered twice over, and the two answers are not ordered. On the
|
||||
@ -194,7 +354,21 @@ let () =
|
||||
explain and is quoted as it stands. *)
|
||||
let other = Dev.refusal ~parked:true "err flan.abi.x86: the module is x86" in
|
||||
if not (contains_sub other "flan.abi.x86") then
|
||||
fail "a parked program's other refusals were rewritten too: %S" other
|
||||
fail "a parked program's other refusals were rewritten too: %S" other;
|
||||
(* The agent is always this compiler's, never the copy a program vendors:
|
||||
an old copy answers every frame at its function's own line. *)
|
||||
let dir = tmp "agent-dir" in
|
||||
(try Unix.mkdir dir 0o700 with Unix.Unix_error _ -> ());
|
||||
let csrcs, _ =
|
||||
Dev.with_agent ~dir [ "/far/vendor/agent/flan_agent.c"; "/far/x.c" ] []
|
||||
in
|
||||
let own = Filename.concat dir "flan_agent.c" in
|
||||
if csrcs <> [ "/far/x.c"; own ] then
|
||||
fail "a vendored agent was linked in place of the compiler's: %s"
|
||||
(String.concat " " csrcs)
|
||||
else if In_channel.with_open_bin own In_channel.input_all
|
||||
<> Runtime_src.agent_source then
|
||||
fail "the agent linked is not the compiler's own"
|
||||
|
||||
(* A daemon's death is reported by the signal's name. [WSIGNALED] carries
|
||||
OCaml's own numbering, in which SIGTERM is -11, and a SIGTERM printed as
|
||||
@ -2346,6 +2520,7 @@ let () =
|
||||
(String.concat ", "
|
||||
(List.map (fun (n, w, _) -> n ^ ": " ^ w) (pairs r "refused")))
|
||||
end;
|
||||
eval_in_frame_checks ~backend:"llvm" ask;
|
||||
(* A frame whose every slot the compiler invented is not an error and
|
||||
is not an empty answer either: it says which it is. *)
|
||||
let r = ask "(:op \"locals\" :frame 1)" in
|
||||
@ -4394,6 +4569,7 @@ let () =
|
||||
end
|
||||
else begin
|
||||
let c = connect sigsock in
|
||||
stepper_checks ~what:"llvm " (request c);
|
||||
let stopped r =
|
||||
match Wire.field r "stopped" with
|
||||
| Some { Form.v = Form.Sym "t"; _ } -> true
|
||||
@ -4858,6 +5034,13 @@ let () =
|
||||
if not (List.exists (String.equal "continue") names) then
|
||||
fail "a break at (pause) offers %s, wanted continue among them"
|
||||
(String.concat ", " names);
|
||||
(* [step] has no slots at all, so there is nothing to bind and no
|
||||
table for the program to answer from: an expression evaluated
|
||||
in its frame sees the globals. Frame 0 is [pause]'s own. *)
|
||||
(let r = ask "(:op \"eval-expr\" :frame 1 :code \"(+ ticks 0)\")" in
|
||||
if status r <> "ok" then
|
||||
fail "eval-in-frame of a frame with no slots: %s"
|
||||
(Option.value ~default:(status r) (Wire.string_field r "message")));
|
||||
|
||||
(* The second claim, and the one this block exists for. A plain
|
||||
re-evaluation of the same form replaces the stored declaration
|
||||
@ -4903,6 +5086,7 @@ let () =
|
||||
end
|
||||
end
|
||||
end;
|
||||
stepper_checks ~what:"x86 " ask;
|
||||
|
||||
(* The other way a thunk reaches a [(pause)], and the one no flag asks
|
||||
for: an ordinary [C-x C-e] over an expression that calls a body
|
||||
@ -5183,20 +5367,124 @@ let () =
|
||||
ignore (ask "(:op \"describe\")");
|
||||
contains_sub (Buffer.contents seen) "42"))
|
||||
then fail "--two-process: the reload was never installed";
|
||||
(* And the one verb this shape cannot have. Running [main] again means
|
||||
waking a thread that parked inside this process, and here the program
|
||||
is a child: when it finishes it is gone, and there is nothing to wake.
|
||||
Refused by naming what this daemon is rather than with the message a
|
||||
merged one gives, because "the program is already running" would send
|
||||
somebody back to try again after it had exited — and [--x86] arrives
|
||||
here too, since it refuses the merged daemon for the -rdynamic reason
|
||||
given below. *)
|
||||
(* A re-run here is a new process. Refused while the child runs; once
|
||||
it has finished, the program is built again from the session, so the
|
||||
redefined [step] is what the new run's first line prints — the host
|
||||
the daemon started with would print 1. *)
|
||||
let r = ask "(:op \"rerun\")" in
|
||||
let why = Option.value ~default:(status r) (Wire.string_field r "message") in
|
||||
if status r <> "error" then
|
||||
fail "--two-process answered a rerun it cannot perform"
|
||||
else if not (contains_sub why "two-process") then
|
||||
fail "--two-process refuses a rerun as: %s" why;
|
||||
if status r <> "error" || not (contains_sub why "still running") then
|
||||
fail "--two-process: a rerun while the child runs answered %s: %s"
|
||||
(status r) why;
|
||||
(* Two more deliveries take the program past its last two waits. *)
|
||||
List.iter
|
||||
(fun n ->
|
||||
let r =
|
||||
ask
|
||||
(Printf.sprintf
|
||||
"(:op \"eval\" :code \"(defn step [] i64 %d)\" \
|
||||
:file \"/tmp/buf.flan\")" n)
|
||||
in
|
||||
if status r <> "ok" then fail "--two-process: eval %d was refused" n;
|
||||
if not
|
||||
(await (fun () ->
|
||||
ignore (ask "(:op \"describe\")");
|
||||
contains_sub (Buffer.contents seen) (string_of_int n)))
|
||||
then fail "--two-process: %d was never installed" n)
|
||||
[ 43; 44 ];
|
||||
(* 44 was the old child's last line, so anything from here on is the
|
||||
new child's. *)
|
||||
Buffer.clear seen;
|
||||
let taken = ref (ask "(:op \"describe\")") in
|
||||
if not
|
||||
(await ~ms:10000 (fun () ->
|
||||
taken := ask "(:op \"rerun\")";
|
||||
status !taken = "ok"))
|
||||
then
|
||||
fail "--two-process: a rerun after the child finished: %s"
|
||||
(Option.value ~default:(status !taken)
|
||||
(Wire.string_field !taken "message"))
|
||||
else begin
|
||||
let note = Option.value ~default:"" (Wire.string_field !taken "note") in
|
||||
if not (contains_sub note "globals start over") then
|
||||
fail "--two-process: the rerun's note does not say the globals \
|
||||
start over: %S" note;
|
||||
if not
|
||||
(await (fun () ->
|
||||
ignore (ask "(:op \"describe\")");
|
||||
contains_sub (Buffer.contents seen) "\n"))
|
||||
then fail "--two-process: the new child printed nothing"
|
||||
else if not (String.starts_with ~prefix:"44\n" (Buffer.contents seen))
|
||||
then
|
||||
fail "--two-process: the new child did not start with the \
|
||||
redefinition: %S" (Buffer.contents seen);
|
||||
(* And it is reachable: a delivery to the new child installs. *)
|
||||
let r =
|
||||
ask
|
||||
"(:op \"eval\" :code \"(defn step [] i64 45)\" :file \"/tmp/buf.flan\")"
|
||||
in
|
||||
if status r <> "ok" then fail "--two-process: eval after rerun refused";
|
||||
if not
|
||||
(await (fun () ->
|
||||
ignore (ask "(:op \"describe\")");
|
||||
contains_sub (Buffer.contents seen) "45"))
|
||||
then fail "--two-process: the new child never installed a delivery";
|
||||
(* A signature change leaves [user] compiled for the old one. The
|
||||
next build is of the whole program, so the re-run is refused at
|
||||
the stale call; a fix evaluated while the child has ended goes
|
||||
into the session, and the re-run after it builds. *)
|
||||
let ev code =
|
||||
ask
|
||||
(Printf.sprintf "(:op \"eval\" :code %s :file \"/tmp/buf.flan\")"
|
||||
(Wire.quote code))
|
||||
in
|
||||
let alive () =
|
||||
match Wire.field (ask "(:op \"describe\")") "alive" with
|
||||
| Some { Form.v = Form.Sym "nil"; _ } -> false
|
||||
| _ -> true
|
||||
in
|
||||
List.iter
|
||||
(fun code ->
|
||||
if status (ev code) <> "ok" then
|
||||
fail "--two-process: %s was refused" code)
|
||||
[ "(defn helper [] i64 1)"; "(defn user [] i64 (helper))" ];
|
||||
if not (await ~ms:10000 (fun () -> not (alive ()))) then
|
||||
fail "--two-process: the new child did not finish"
|
||||
else begin
|
||||
let r = ev "(defn helper [x i64] i64 x)" in
|
||||
if status r <> "ok" then
|
||||
fail "--two-process: a change while the child has ended: %s"
|
||||
(Option.value ~default:"" (Wire.string_field r "message"));
|
||||
let r = ask "(:op \"rerun\")" in
|
||||
if status r <> "error"
|
||||
|| not (contains_sub
|
||||
(Option.value ~default:"" (Wire.string_field r "loc"))
|
||||
"/tmp/buf.flan:1:")
|
||||
then
|
||||
fail "--two-process: a re-run over a stale caller answered %s \
|
||||
(%s)" (status r)
|
||||
(Option.value ~default:"" (Wire.string_field r "message"));
|
||||
List.iter
|
||||
(fun code ->
|
||||
if status (ev code) <> "ok" then
|
||||
fail "--two-process: %s was refused" code)
|
||||
[ "(defn user [] i64 (helper 5))"; "(defn step [] i64 (user))" ];
|
||||
Buffer.clear seen;
|
||||
let r = ask "(:op \"rerun\")" in
|
||||
if status r <> "ok" then
|
||||
fail "--two-process: the re-run after the fix: %s"
|
||||
(Option.value ~default:"" (Wire.string_field r "message"))
|
||||
else if not
|
||||
(await (fun () ->
|
||||
ignore (ask "(:op \"describe\")");
|
||||
contains_sub (Buffer.contents seen) "\n"))
|
||||
|| not (String.starts_with ~prefix:"5\n"
|
||||
(Buffer.contents seen))
|
||||
then
|
||||
fail "--two-process: the fixed program printed %S"
|
||||
(Buffer.contents seen)
|
||||
end
|
||||
end;
|
||||
ignore (ask "(:op \"close\")");
|
||||
Unix.close tc
|
||||
end;
|
||||
@ -6203,6 +6491,7 @@ let () =
|
||||
(String.concat ", "
|
||||
(List.map (fun (n, w, _) -> n ^ ": " ^ w) (triples r "refused")))
|
||||
end;
|
||||
eval_in_frame_checks ~backend:"x86" (request c);
|
||||
(* One slot by index, which is the inspector's own root rather than
|
||||
[locals]' listing, and an aggregate for it: an x86 frame passes every
|
||||
aggregate by pointer, so a struct is where a recorded address could
|
||||
@ -6617,12 +6906,12 @@ let () =
|
||||
let answer r =
|
||||
Option.value ~default:"" (Wire.string_field r "value")
|
||||
in
|
||||
let read () =
|
||||
answer
|
||||
(request c
|
||||
"(:op \"eval-expr\" :code \"(get config :s)\" \
|
||||
:file \"programs/dev-dyn-global.flan\")")
|
||||
let read_reply () =
|
||||
request c
|
||||
"(:op \"eval-expr\" :code \"(get config :s)\" \
|
||||
:file \"programs/dev-dyn-global.flan\")"
|
||||
in
|
||||
let read () = answer (read_reply ()) in
|
||||
(* A hundred thousand small maps: flan_dyn.c collects at a
|
||||
one-megabyte floor, so this is several collections and not a
|
||||
heap that merely grew. *)
|
||||
@ -6642,11 +6931,17 @@ let () =
|
||||
if status r <> "ok" then
|
||||
fail "--%s: the churning thunk (cycle %d): %s" backend cycle
|
||||
(said r)
|
||||
else if not (contains_sub (read ()) "kept") then
|
||||
fail
|
||||
"--%s: after a thunk that allocates (cycle %d) the parked \
|
||||
program's dyn global reads %S"
|
||||
backend cycle (read ());
|
||||
else begin
|
||||
(* The failing reply itself, and not a second read: the one
|
||||
recorded failure here re-read and got "kept", so what the
|
||||
first read answered is the whole of the evidence. *)
|
||||
let r = read_reply () in
|
||||
if not (contains_sub (answer r) "kept") then
|
||||
fail
|
||||
"--%s: after a thunk that allocates (cycle %d) the \
|
||||
parked program's dyn global read %S (%s: %s)"
|
||||
backend cycle (answer r) (status r) (said r)
|
||||
end;
|
||||
(* And round main again, which re-enters the very code that
|
||||
pushed those roots. *)
|
||||
let r = request c "(:op \"rerun\")" in
|
||||
@ -6655,7 +6950,79 @@ let () =
|
||||
if not (await ~ms:20000 parked) then
|
||||
fail "--%s: the program did not park again (cycle %d)" backend
|
||||
cycle
|
||||
done
|
||||
done;
|
||||
(* An expression's module is unloaded once it returns, string
|
||||
literals and all: a literal is a copy the process keeps, so a
|
||||
global left holding one still reads it after the module that
|
||||
wrote it is gone and later ones have been mapped where it
|
||||
was. The mapping count is what the kernel limits. *)
|
||||
let ev code =
|
||||
request c
|
||||
(Printf.sprintf
|
||||
"(:op \"eval-expr\" :code %s \
|
||||
:file \"programs/dev-dyn-global.flan\")" (Wire.quote code))
|
||||
in
|
||||
let r =
|
||||
request c
|
||||
"(:op \"eval\" :code \"(defonce msg string)\" \
|
||||
:file \"programs/dev-dyn-global.flan\")"
|
||||
in
|
||||
if status r <> "ok" then fail "--%s: defonce msg: %s" backend (said r)
|
||||
else begin
|
||||
ignore (ev "(do (set msg \"tuned\") 0)");
|
||||
let maps () =
|
||||
List.length
|
||||
(String.split_on_char '\n'
|
||||
(In_channel.with_open_bin
|
||||
(Printf.sprintf "/proc/%d/maps" dpid)
|
||||
In_channel.input_all))
|
||||
in
|
||||
let m0 = maps () in
|
||||
for i = 1 to 20 do
|
||||
ignore (ev (Printf.sprintf "(do (println \"other %d\") %d)" i i))
|
||||
done;
|
||||
let m1 = maps () in
|
||||
if m1 - m0 >= 20 then
|
||||
fail "--%s: twenty expressions with a string literal left %d \
|
||||
more mappings" backend (m1 - m0);
|
||||
let r = ev "msg" in
|
||||
if Wire.string_field r "value" <> Some "\"tuned\"" then
|
||||
fail "--%s: a literal stored by an unloaded module reads %S \
|
||||
(%s)" backend
|
||||
(Option.value ~default:"" (Wire.string_field r "value"))
|
||||
(said r)
|
||||
end;
|
||||
(* A function value an expression makes has its code in that
|
||||
expression's module — a lambda's body, or the wrapper a named
|
||||
function is handed out through — so that module stays mapped.
|
||||
Later expressions are mapped between the store and the call,
|
||||
where an unloaded one would have been. *)
|
||||
let defd code =
|
||||
let r =
|
||||
request c
|
||||
(Printf.sprintf
|
||||
"(:op \"eval\" :code %s \
|
||||
:file \"programs/dev-dyn-global.flan\")" (Wire.quote code))
|
||||
in
|
||||
if status r <> "ok" then fail "--%s: %s: %s" backend code (said r)
|
||||
in
|
||||
defd "(defonce kept (Option (Fn [i64] i64)))";
|
||||
defd "(defn twice [x i64] i64 (* x 2))";
|
||||
let call_kept want what =
|
||||
for i = 1 to 3 do
|
||||
ignore (ev (Printf.sprintf "(do (println \"pad %d\") %d)" i i))
|
||||
done;
|
||||
let r = ev "(match kept (Some f) (f 1) (None) -1)" in
|
||||
if Wire.string_field r "value" <> Some want then
|
||||
fail "--%s: %s kept by an unloaded expression answered %S \
|
||||
(%s)" backend what
|
||||
(Option.value ~default:"" (Wire.string_field r "value"))
|
||||
(said r)
|
||||
in
|
||||
ignore (ev "(do (set kept (Some (fn [x] (+ x 7)))) 0)");
|
||||
call_kept "8" "a lambda";
|
||||
ignore (ev "(do (set kept (Some twice)) 0)");
|
||||
call_kept "2" "a named function"
|
||||
end;
|
||||
ignore (request c "(:op \"close\")");
|
||||
(try Unix.close c with Unix.Unix_error _ -> ());
|
||||
@ -8774,6 +9141,110 @@ let () =
|
||||
hook_block ~llvm:false;
|
||||
hook_block ~llvm:true;
|
||||
|
||||
(* ── --sanitize on the backend it cannot instrument ───────────── *)
|
||||
|
||||
(* Refused before anything is built, by name and with the way out. The
|
||||
session itself is driven under the sanitizers by @sanitize. *)
|
||||
let zerr = tmp "x86san.err" in
|
||||
let zfd = Unix.openfile zerr [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
|
||||
let zpid =
|
||||
Unix.create_process flan
|
||||
[| flan; "dev"; "programs/dev-loop.flan"; "-s"; tmp "x86san.sock";
|
||||
"--x86"; "--sanitize" |]
|
||||
Unix.stdin zfd zfd
|
||||
in
|
||||
Unix.close zfd;
|
||||
(match Unix.waitpid [] zpid with
|
||||
| _, Unix.WEXITED 1 ->
|
||||
let said = In_channel.with_open_bin zerr In_channel.input_all in
|
||||
if not (contains_sub said "--x86 --sanitize"
|
||||
&& contains_sub said "Drop --x86") then
|
||||
fail "flan dev --x86 --sanitize was refused as: %S" said
|
||||
| _ -> fail "flan dev --x86 --sanitize was not refused");
|
||||
(try Sys.remove zerr with Sys_error _ -> ());
|
||||
|
||||
(* ── Whose break it is ─────────────────────────────────────────── *)
|
||||
|
||||
(* The program stops on its own while an evaluation is in flight: [go]
|
||||
makes it sleep for longer than a module takes to build and then
|
||||
signal, without polling in between. The stop is fresh, as a thunk's
|
||||
would be, and it is not the expression's; the expression runs inside
|
||||
the program's break loop and its value is the answer. On the default
|
||||
backend, because the stop's owner is the agent's and not the
|
||||
backend's. *)
|
||||
let osock = tmp "ownbreak.sock" and oout = tmp "ownbreak.out" in
|
||||
(try Sys.remove osock with Sys_error _ -> ());
|
||||
let ofd = Unix.openfile oout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
|
||||
let opid =
|
||||
Unix.create_process flan
|
||||
[| flan; "dev"; "programs/dev-own-break.flan"; "-s"; osock |]
|
||||
Unix.stdin ofd Unix.stderr
|
||||
in
|
||||
Unix.close ofd;
|
||||
if not (listening ~pid:opid osock) then begin
|
||||
fail "the own-break daemon %s" !listen_why;
|
||||
(try Unix.kill opid Sys.sigkill with Unix.Unix_error _ -> ())
|
||||
end
|
||||
else begin
|
||||
let c = connect osock in
|
||||
let said r =
|
||||
Option.value ~default:(status r) (Wire.string_field r "message")
|
||||
in
|
||||
let ev code =
|
||||
request c
|
||||
(Printf.sprintf
|
||||
"(:op \"eval-expr\" :code %s :file \"programs/dev-own-break.flan\")"
|
||||
(Wire.quote code))
|
||||
in
|
||||
(* An expression stopped in a break and resumed by a restart finishes
|
||||
after the restart's reply, and here it finishes after the next
|
||||
expression has been sent: its value must not answer for that one. *)
|
||||
let r =
|
||||
ev "(restart-case (do (error (Late {})) 0) \
|
||||
(slow [] (do (usleep 500000) 5)))"
|
||||
in
|
||||
if status r <> "error" then
|
||||
fail "resumed value: the first expression did not stop: %s" (said r)
|
||||
else begin
|
||||
let r = request c "(:op \"restart\" :name \"slow\")" in
|
||||
if status r <> "ok" then fail "resumed value: restart: %s" (said r);
|
||||
let r = ev "(do (usleep 300000) 23)" in
|
||||
if Wire.string_field r "value" <> Some "23" then
|
||||
fail "resumed value: the next expression answered %S (%s)"
|
||||
(Option.value ~default:"" (Wire.string_field r "value")) (said r)
|
||||
end;
|
||||
let r = ev "(do (set go 1) 0)" in
|
||||
if status r <> "ok" then fail "own break: setting go: %s" (said r)
|
||||
else begin
|
||||
(* The sleep keeps the thunk running inside the program's break for
|
||||
many of the daemon's ticks, so a wait that took any fresh stop for
|
||||
the thunk's would answer before the value exists. *)
|
||||
let r = ev "(do (usleep 300000) 42)" in
|
||||
if status r <> "ok"
|
||||
|| Wire.string_field r "value" <> Some "42" then
|
||||
fail "own break: an expression in flight when the program stopped \
|
||||
on its own answered %s %S (value %S)"
|
||||
(status r) (said r)
|
||||
(Option.value ~default:"" (Wire.string_field r "value"));
|
||||
(match Wire.field r "condition" with
|
||||
| Some { Form.v = Form.Str "Late"; _ } -> ()
|
||||
| _ -> fail "own break: the reply does not carry the program's stop")
|
||||
end;
|
||||
ignore (aborted c);
|
||||
(try Unix.close c with Unix.Unix_error _ -> ());
|
||||
if not
|
||||
(await ~ms:10000 (fun () ->
|
||||
match Unix.waitpid [ Unix.WNOHANG ] opid with
|
||||
| 0, _ -> false
|
||||
| _ -> true))
|
||||
then begin
|
||||
fail "own break: the daemon did not end on abort";
|
||||
(try Unix.kill opid Sys.sigkill with Unix.Unix_error _ -> ());
|
||||
(try ignore (Unix.waitpid [] opid) with Unix.Unix_error _ -> ())
|
||||
end
|
||||
end;
|
||||
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ osock; oout ];
|
||||
|
||||
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
|
||||
[ sock; out; bsock; bout ];
|
||||
Test_support.report ~label:"dev" ()
|
||||
|
||||
@ -376,13 +376,8 @@ let dyn_sweep () =
|
||||
part that carries the weight; the run is what says the constructor the fix
|
||||
introduced actually calls both of the things it replaced.
|
||||
|
||||
Not covered, and worth naming rather than leaving to be discovered the way
|
||||
this bug was: a program driven by [flan dev] under ASan. The daemon builds
|
||||
its host through its own path and the CLI has no [--sanitize] to pass it,
|
||||
so that one wants a flag and a way through [Dev.serve]. See TODO.org, "A
|
||||
program driven by a real flan dev daemon under a sanitizer". The faulting
|
||||
dev build, which was on that list too, is covered now — see
|
||||
[dev_segv] below. *)
|
||||
A program driven by a real [flan dev] session is [dev_session] below, and
|
||||
the faulting dev build is [dev_segv]. *)
|
||||
let dev_corpus =
|
||||
[ (* The only [dev-*] program with no agent import: it prints and returns.
|
||||
Here because it is the one program in the tree written for a dev
|
||||
@ -474,6 +469,93 @@ let dev_segv () =
|
||||
prevent\n%s" text;
|
||||
(try Sys.remove exe with Sys_error _ -> ())
|
||||
|
||||
(* A program driven by a real [flan dev --sanitize] session: the host and the
|
||||
runtime under ASan and UBSan, the modules the session sends built as
|
||||
always (llc and ld, not instrumented). dev-break stops on its first frame,
|
||||
so the session starts at a break; it is resumed, [step] is redefined three
|
||||
times with an expression evaluated after each, an expression is evaluated
|
||||
into a second break and resumed out of it, and the session is closed. The
|
||||
daemon's own output is the program's stderr, so a report anywhere in the
|
||||
session lands in it. *)
|
||||
let dev_session () =
|
||||
let flan = "../bin/main.exe" in
|
||||
let sock = Filename.concat scratch "flan-san-dev.sock" in
|
||||
let log = Filename.concat scratch "flan-san-dev.log" in
|
||||
let src = "programs/dev-break.flan" in
|
||||
(try Sys.remove sock with Sys_error _ -> ());
|
||||
let fd = Unix.openfile log [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
|
||||
let env =
|
||||
Array.append (Unix.environment ())
|
||||
[| "ASAN_OPTIONS=detect_leaks=0"; "UBSAN_OPTIONS=print_stacktrace=1" |]
|
||||
in
|
||||
let pid =
|
||||
Unix.create_process_env flan
|
||||
[| flan; "dev"; src; "-s"; sock; "--sanitize" |]
|
||||
env Unix.stdin fd fd
|
||||
in
|
||||
Unix.close fd;
|
||||
let said () = In_channel.with_open_bin log In_channel.input_all in
|
||||
if not (Test_support.listening ~ms:180000 ~pid sock) then begin
|
||||
fail "dev session: flan dev --sanitize %s\n%s" !Test_support.listen_why
|
||||
(said ());
|
||||
(try Unix.kill pid Sys.sigkill with Unix.Unix_error _ -> ())
|
||||
end
|
||||
else begin
|
||||
let c = Test_support.connect sock in
|
||||
let ask q = Wire.parse (Wire.send c q; Wire.recv c) in
|
||||
let field r k = Option.value ~default:"" (Wire.string_field r k) in
|
||||
let stopped () =
|
||||
match Wire.field (ask "(:op \"describe\")") "stopped" with
|
||||
| Some { Form.v = Form.Sym "t"; _ } -> true
|
||||
| _ -> false
|
||||
in
|
||||
let expect what r =
|
||||
if field r "status" <> "ok" then
|
||||
fail "dev session: %s: %s" what (field r "message")
|
||||
in
|
||||
let f = Printf.sprintf ":file %S" src in
|
||||
if not (Test_support.await ~ms:30000 stopped) then
|
||||
fail "dev session: the program never reached its first break"
|
||||
else begin
|
||||
expect "retry" (ask "(:op \"restart\" :name \"retry\")");
|
||||
if not (Test_support.await ~ms:10000 (fun () -> not (stopped ()))) then
|
||||
fail "dev session: the program did not resume";
|
||||
for i = 1 to 3 do
|
||||
expect "a redefinition"
|
||||
(ask
|
||||
(Printf.sprintf
|
||||
"(:op \"eval\" :code \"(defn step [] i64 (set ticks (+ ticks \
|
||||
%d)) ticks)\" %s)" (100 * i) f));
|
||||
expect "an expression"
|
||||
(ask (Printf.sprintf "(:op \"eval-expr\" :code \"(+ ticks 1)\" %s)" f))
|
||||
done;
|
||||
let r = ask (Printf.sprintf "(:op \"eval-expr\" :code \"(divide 1 0)\" %s)" f) in
|
||||
if not (contains (field r "condition") "ArithError") then
|
||||
fail "dev session: (divide 1 0) did not stop on ArithError: %s"
|
||||
(field r "message");
|
||||
expect "use-zero" (ask "(:op \"restart\" :name \"use-zero\")");
|
||||
if not (Test_support.await ~ms:10000 (fun () -> not (stopped ()))) then
|
||||
fail "dev session: the program did not resume from the second break";
|
||||
expect "an expression after both breaks"
|
||||
(ask (Printf.sprintf "(:op \"eval-expr\" :code \"(+ 1 2)\" %s)" f))
|
||||
end;
|
||||
(try ignore (ask "(:op \"close\")") with _ -> ());
|
||||
(try Unix.close c with Unix.Unix_error _ -> ());
|
||||
if not
|
||||
(Test_support.await ~ms:30000 (fun () ->
|
||||
match Unix.waitpid [ Unix.WNOHANG ] pid with
|
||||
| 0, _ -> false
|
||||
| _ -> true))
|
||||
then begin
|
||||
fail "dev session: the daemon did not end on close";
|
||||
(try Unix.kill pid Sys.sigkill with Unix.Unix_error _ -> ());
|
||||
(try ignore (Unix.waitpid [] pid) with Unix.Unix_error _ -> ())
|
||||
end;
|
||||
if reported (said ()) then
|
||||
fail "dev session: sanitizer report\n%s" (said ())
|
||||
end;
|
||||
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ sock; log ]
|
||||
|
||||
(* The positive controls, which are the only evidence that a clean sweep means
|
||||
anything. Both are written here rather than kept in test/programs because
|
||||
neither is a program anybody should build: one reads off the end of an
|
||||
@ -600,6 +682,7 @@ let () =
|
||||
dyn_sweep ();
|
||||
dev_sweep ();
|
||||
dev_segv ();
|
||||
dev_session ();
|
||||
unchecked_controls ();
|
||||
if !failures = 0 then print_endline "sanitizer sweep: clean"
|
||||
else Printf.printf "%d sanitizer failure(s)\n" !failures;
|
||||
|
||||
@ -1385,17 +1385,25 @@ let () =
|
||||
if has c.Session.ir "@flan_reload_transient" then
|
||||
fail "a module that publishes a body claimed to be unloadable";
|
||||
|
||||
(* And a third condition, about data rather than text. A string literal lives
|
||||
in the evaluating module's own image, and an expression may store one
|
||||
anywhere: [(set msg "x")] on a string global would leave that global
|
||||
pointing into a mapping the agent then drops — and since the next thunk can
|
||||
be mapped at the same address, the result is silent garbage rather than a
|
||||
fault. A module carrying any string constant keeps its mapping. *)
|
||||
(* And a third condition, about data rather than text. An expression may
|
||||
store a string literal anywhere — [(set msg "x")] on a string global — so
|
||||
a literal's value is a copy [flan_dev_literal] keeps for the process, and
|
||||
nothing is left pointing into the module. A string constant the module
|
||||
does hand out still keeps its mapping: a condition's name, which a handler
|
||||
may carry away. *)
|
||||
let str = Session.eval_expr t "(println \"tuned\")" in
|
||||
if not (has str.Session.ir ".str.0") then
|
||||
fail "the fixture stopped carrying a string constant, so it proves nothing";
|
||||
if has str.Session.ir "@flan_reload_transient" then
|
||||
fail "an expression holding a string claimed to be unloadable";
|
||||
if not (has str.Session.ir "@flan_dev_literal(ptr") then
|
||||
fail "an expression's string literal is not a kept copy";
|
||||
if has str.Session.ir ".str." then
|
||||
fail "an expression's string literal is still a constant of its module";
|
||||
if not (has str.Session.ir "@flan_reload_transient") then
|
||||
fail "an expression whose only string is a literal kept its mapping";
|
||||
let held =
|
||||
Session.eval_expr t
|
||||
"(restart-case (+ 1 2) (use-zero [] :report \"Answer 0\" 0))"
|
||||
in
|
||||
if has held.Session.ir "@flan_reload_transient" then
|
||||
fail "an expression establishing a restart claimed to be unloadable";
|
||||
|
||||
(* ── Generics in the dev loop ─────────────────────────────────────────
|
||||
A generic [defn] produces no [Tast.fn] of its own — only its copies do —
|
||||
@ -1593,7 +1601,7 @@ let () =
|
||||
(* And the slot names, in the packed form the runtime splits — which is
|
||||
what says the call carries *this* class's new list and not some
|
||||
other module's leftovers. *)
|
||||
if not (has c.Session.ir "c\"x\\0Ay\\0Az\\00\"") then
|
||||
if not (has c.Session.ir "c\"x\\0Ay\\0Az\"") then
|
||||
fail "the registration did not carry the new slot list"
|
||||
| exception Loc.Error { Loc.dmsg = m; _ } ->
|
||||
fail "adding a slot to a class was refused: %s" m);
|
||||
@ -1626,7 +1634,7 @@ let () =
|
||||
| c ->
|
||||
if not (has c.Session.ir "call void @flan_dyn_class_def") then
|
||||
fail "an unchanged class definition registered nothing";
|
||||
if not (has c.Session.ir "c\"x\\0Ay\\00\"") then
|
||||
if not (has c.Session.ir "c\"x\\0Ay\"") then
|
||||
fail "an unchanged class registered some other slot list"
|
||||
| exception Loc.Error { Loc.dmsg = m; _ } ->
|
||||
fail "re-evaluating an unchanged class was refused: %s" m);
|
||||
@ -1690,7 +1698,7 @@ let () =
|
||||
ignore (Session.eval t "(defn origin [] dyn (point 0 0))");
|
||||
match Session.eval t "(defclass point [x i64 y])" with
|
||||
| c ->
|
||||
if not (has c.Session.ir "c\"x i64\\0Ay\\00\"") then
|
||||
if not (has c.Session.ir "c\"x i64\\0Ay\"") then
|
||||
fail "a slot's new type did not reach the registration"
|
||||
| exception Loc.Error { Loc.dmsg = m; _ } ->
|
||||
fail "a slot's type changed under a compiled caller was refused: %s" m);
|
||||
@ -1834,4 +1842,60 @@ let () =
|
||||
| _ -> fail "a package's bare name resolved from the program's own file"
|
||||
| exception Loc.Error _ -> ());
|
||||
|
||||
(* ── Every error in the form sent ───────────────────────────────────
|
||||
A refused subexpression stands as a value that fits anywhere, so the
|
||||
check goes on past it: three bad expressions are three errors, one three
|
||||
levels down is still found, and what a failure causes is not reported. *)
|
||||
(let errors src =
|
||||
let t, _ = Session.create ~file:"programs/reload.flan" () in
|
||||
match Session.eval t src with
|
||||
| _ -> fail "a form with errors was accepted: %s" src; []
|
||||
| exception Loc.Error d -> [ d ]
|
||||
| exception Loc.Errors ds -> ds
|
||||
in
|
||||
let msgs ds = String.concat " | " (List.map (fun (d : Loc.diag) -> d.Loc.dmsg) ds) in
|
||||
let three =
|
||||
errors
|
||||
"(defn three [] i64 (println (+ 1 \"a\")) (println (nope 2)) (+ 3 \"c\"))"
|
||||
in
|
||||
if List.length three <> 3 then
|
||||
fail "three bad expressions gave %d errors: %s" (List.length three) (msgs three);
|
||||
let deep =
|
||||
errors
|
||||
"(defn deep [] i64 (+ 1 \"a\") (if true (let [x (do (println (nope 2)) 1)] x) 0))"
|
||||
in
|
||||
if List.length deep <> 2 || not (has (msgs deep) "nope") then
|
||||
fail "an error three levels down was not reported: %s" (msgs deep);
|
||||
(* The failed call poisons the let's [x]; the field read of it and the sum
|
||||
it flows into are consequences, and are not said. *)
|
||||
let caused =
|
||||
errors "(defn caused [] i64 (let [x (nope 1)] (+ (.foo x) (+ x 1))))"
|
||||
in
|
||||
if List.length caused <> 1 || not (has (msgs caused) "nope") then
|
||||
fail "a failure's consequences were reported: %s" (msgs caused);
|
||||
(* A local bound to a refused initialiser and then called is the same
|
||||
consequence: no "unknown function p". *)
|
||||
let called = errors "(defn called [] i64 (let [p (nope 1)] (p 3)))" in
|
||||
if List.length called <> 1 then
|
||||
fail "calling a local bound to a failure was reported: %s" (msgs called);
|
||||
(* A call refused for its argument count still has its arguments checked. *)
|
||||
let arity =
|
||||
errors "(defn arity [] i64 (bump (nope2) 7 8))"
|
||||
in
|
||||
if List.length arity <> 2 || not (has (msgs arity) "nope2") then
|
||||
fail "an error inside a miscounted call was not reported: %s" (msgs arity);
|
||||
(* And the whole-file path: fn-no-type.flan has one mistake, reported once. *)
|
||||
(match Front.checked ~all:true "programs/fn-no-type.flan" with
|
||||
| _ -> fail "fn-no-type.flan checked"
|
||||
| exception Loc.Error _ -> ()
|
||||
| exception Loc.Errors ds ->
|
||||
if List.length ds <> 1 then
|
||||
fail "fn-no-type.flan gave %d errors: %s" (List.length ds) (msgs ds));
|
||||
(* One error is the [Loc.Error] every caller of one form expects. *)
|
||||
let t, _ = Session.create ~file:"programs/reload.flan" () in
|
||||
(match Session.eval t "(defn one [] i64 (nope 1))" with
|
||||
| _ -> fail "an unknown function was accepted"
|
||||
| exception Loc.Error _ -> ()
|
||||
| exception Loc.Errors _ -> fail "one error came as a list"));
|
||||
|
||||
Test_support.report ~label:"session" ()
|
||||
|
||||
105
vendor/agent/flan_agent.c
vendored
105
vendor/agent/flan_agent.c
vendored
@ -214,8 +214,19 @@ typedef struct {
|
||||
void *handle;
|
||||
int stopped_only;
|
||||
int32_t at_stop;
|
||||
uint32_t call_id; /* its place among jobs with a call; 0 if none */
|
||||
} job;
|
||||
|
||||
/* Which evaluated expression the result buffer holds. Every job with a call
|
||||
* is numbered as the listener queues it, and a call that returns records its
|
||||
* number, so a daemon waiting for its own expression's value is not answered
|
||||
* by an earlier expression that a restart resumed and that published after
|
||||
* the new one was sent. The highest wins: an expression run inside another's
|
||||
* break returns first, and the outer one only resumes on a later request.
|
||||
* The [calls] verb answers both counts. */
|
||||
static _Atomic uint32_t calls_queued;
|
||||
static _Atomic uint32_t calls_valued;
|
||||
|
||||
/* Said once, in one place, and shipped to the daemon over [refusals] rather
|
||||
* than written down again at the other end. A refusal is a sentence naming
|
||||
* what actually happened, and the thing that actually happened is not "the
|
||||
@ -437,6 +448,15 @@ static const uint8_t abandon_report[] =
|
||||
* saved and restored around the call like [eval_boundary]. */
|
||||
static sigjmp_buf *eval_escape;
|
||||
|
||||
/* Whether the game thread is inside an evaluated thunk's call, at any depth,
|
||||
* rather than in the program's own code. A break records it, and it is what
|
||||
* says whose break that is: a game loop that signals on its own while an
|
||||
* evaluation is in flight stops exactly as a thunk would, and the stop
|
||||
* counter cannot tell the two apart. Not [eval_boundary], which a class
|
||||
* migration clears inside a thunk, nor [frame_floor], which it sets outside
|
||||
* one. Game thread only, saved and restored around the call. */
|
||||
static int in_thunk;
|
||||
|
||||
/* What the chains looked like when the evaluation was called, weak for the
|
||||
* reason the frame walk below is: the runtime is linked into every program
|
||||
* that links this, but not every build carries the dev and dyn halves. */
|
||||
@ -505,6 +525,7 @@ static int migrate_call(void *fn, uint64_t instance, uint64_t added,
|
||||
void flan_agent_run_reset(void) {
|
||||
eval_boundary = NULL;
|
||||
eval_escape = NULL;
|
||||
in_thunk = 0;
|
||||
restart_floor = 0;
|
||||
frame_floor = -1;
|
||||
}
|
||||
@ -567,6 +588,7 @@ static _Atomic int aborting;
|
||||
|
||||
typedef struct {
|
||||
int32_t gen; /* never reused, never 0 */
|
||||
int32_t in_eval; /* stopped inside a thunk */
|
||||
/* Whether *any* restart on this list can be taken, which is a property of
|
||||
* the break and not of the restarts. [reachable] answers a different
|
||||
* question — that one is per restart, and it is about the thunk boundary.
|
||||
@ -773,6 +795,7 @@ static int snap_push(int resumable, void *cond) {
|
||||
snapshot *s = &snaps[d];
|
||||
int32_t n = flan_restart_count();
|
||||
s->gen = ++snap_gen;
|
||||
s->in_eval = in_thunk;
|
||||
s->resumable = resumable;
|
||||
s->cond = cond;
|
||||
s->sitelen = 0;
|
||||
@ -1310,6 +1333,7 @@ int32_t flan_agent_poll(void) {
|
||||
* signal handler, and the jump leaves the handler. */
|
||||
sigjmp_buf escape;
|
||||
sigjmp_buf *oescape = eval_escape;
|
||||
int othunk = in_thunk;
|
||||
void *mh = NULL, *mr = NULL, *mf = NULL;
|
||||
int32_t md = 0;
|
||||
int64_t mroots = 0;
|
||||
@ -1318,9 +1342,12 @@ int32_t flan_agent_poll(void) {
|
||||
if (flan_dyn_root_mark) mroots = flan_dyn_root_mark();
|
||||
uint64_t mctx[2] = { 0, 0 };
|
||||
if (flan_context_save) flan_context_save(mctx);
|
||||
in_thunk = 1;
|
||||
if (sigsetjmp(escape, 1) == 0) {
|
||||
eval_escape = &escape;
|
||||
j.call();
|
||||
if (j.call_id > atomic_load(&calls_valued))
|
||||
atomic_store(&calls_valued, j.call_id);
|
||||
} else {
|
||||
if (flan_condition_stacks_restore) flan_condition_stacks_restore(mh, mr, md);
|
||||
if (flan_dev_frames_restore) flan_dev_frames_restore(mf);
|
||||
@ -1328,6 +1355,7 @@ int32_t flan_agent_poll(void) {
|
||||
if (flan_context_load) flan_context_load(mctx);
|
||||
}
|
||||
eval_escape = oescape;
|
||||
in_thunk = othunk;
|
||||
/* Popped whichever way the thunk left — returning with a value, or
|
||||
* unwinding past this frame because someone abandoned it. */
|
||||
flan_restart_pop_c(eval_boundary);
|
||||
@ -1903,10 +1931,23 @@ static void handle_line(char *line, sink *o) {
|
||||
* of those have readers in flight and a reply format is a thing two ends
|
||||
* agree on. Answered while running as well, for [status]'s reason: an
|
||||
* editor polls this without knowing the state already. */
|
||||
/* After the number, whose code stopped: "eval" when the thread was inside
|
||||
* an evaluated thunk, "program" when it was in the program's own code. */
|
||||
if (strcmp(line, "calls") == 0) {
|
||||
char hdr[48];
|
||||
int k = snprintf(hdr, sizeof hdr, "%u %u\n",
|
||||
(unsigned)atomic_load(&calls_queued),
|
||||
(unsigned)atomic_load(&calls_valued));
|
||||
if (k > 0) emit(o, hdr, (size_t)k);
|
||||
return;
|
||||
}
|
||||
if (strcmp(line, "stop") == 0) {
|
||||
snapshot *s = (atomic_load(&depth) > 0) ? snap_top() : NULL;
|
||||
char hdr[32];
|
||||
int k = snprintf(hdr, sizeof hdr, "%d\n", s == NULL ? 0 : s->gen);
|
||||
int k = s == NULL
|
||||
? snprintf(hdr, sizeof hdr, "0\n")
|
||||
: snprintf(hdr, sizeof hdr, "%d %s\n", s->gen,
|
||||
s->in_eval ? "eval" : "program");
|
||||
if (k > 0) emit(o, hdr, (size_t)k);
|
||||
return;
|
||||
}
|
||||
@ -2179,7 +2220,9 @@ static void handle_line(char *line, sink *o) {
|
||||
* is the failure being fixed. */
|
||||
if (!publish((job){ .install = f, .call = c,
|
||||
.handle = transient == NULL ? NULL : h,
|
||||
.stopped_only = stopped_only, .at_stop = at_stop }))
|
||||
.stopped_only = stopped_only, .at_stop = at_stop,
|
||||
.call_id = c == NULL ? 0
|
||||
: atomic_fetch_add(&calls_queued, 1) + 1 }))
|
||||
fprintf(stderr, "flan: reload queue full after it was checked\n");
|
||||
return;
|
||||
}
|
||||
@ -2459,17 +2502,49 @@ failed:
|
||||
return -1;
|
||||
}
|
||||
|
||||
/* The daemon's socket for this process, or NULL when there is none.
|
||||
*
|
||||
* FLAN_AGENT_SOCKET alone is not enough, because an environment is inherited:
|
||||
* a shell started from inside a [flan dev] program, or anything that program
|
||||
* starts, carries it too, and binding unlinks the path first, so such a
|
||||
* process would take the session's socket from the program it belongs to. So
|
||||
* the daemon also names the process it launched, in FLAN_AGENT_OWNER, and the
|
||||
* path is honoured only there: the owner is this process in a merged build,
|
||||
* where the launcher execs into the program, and this process's parent under
|
||||
* --two-process, where the daemon started it. */
|
||||
static const char *daemon_socket(void) {
|
||||
const char *env = getenv("FLAN_AGENT_SOCKET");
|
||||
const char *own = getenv("FLAN_AGENT_OWNER");
|
||||
char *end;
|
||||
long pid;
|
||||
if (env == NULL || env[0] == '\0' || own == NULL || own[0] == '\0')
|
||||
return NULL;
|
||||
pid = strtol(own, &end, 10);
|
||||
if (end == own || *end != '\0' || pid <= 0) return NULL;
|
||||
if (pid == (long)getpid()) return env;
|
||||
/* The parent only under --two-process, which is the one shape that sets
|
||||
* FLAN_DEV_PARENT, and to the same pid. In a merged build the owner is the
|
||||
* program itself, so a process it starts has the owner as its parent and
|
||||
* must not take the socket. */
|
||||
{
|
||||
const char *par = getenv("FLAN_DEV_PARENT");
|
||||
if (par != NULL && strcmp(par, own) == 0 && pid == (long)getppid())
|
||||
return env;
|
||||
}
|
||||
return NULL;
|
||||
}
|
||||
|
||||
/* [path] is a Flan string: ptr and len, not NUL-terminated.
|
||||
*
|
||||
* FLAN_AGENT_SOCKET overrides it. A program's source has to name some path,
|
||||
* and the daemon that launches the program is the one that knows where it
|
||||
* The daemon's socket overrides it (see [daemon_socket]). A program's source
|
||||
* has to name some path, and the daemon that launches the program is the one that knows where it
|
||||
* wants to talk to it — without the override the daemon would have to guess,
|
||||
* and guessing wrong fails silently: everything compiles, the module is built,
|
||||
* and nothing ever receives it. */
|
||||
int32_t flan_agent_start(const uint8_t *path, int64_t len) {
|
||||
char buf[sizeof(((struct sockaddr_un *)0)->sun_path)];
|
||||
const char *env = getenv("FLAN_AGENT_SOCKET");
|
||||
if (env != NULL && env[0] != '\0') return start_on(env) < 0 ? -1 : 0;
|
||||
const char *env = daemon_socket();
|
||||
if (env != NULL) return start_on(env) < 0 ? -1 : 0;
|
||||
if (len <= 0 || (size_t)len >= sizeof buf) return -1;
|
||||
memcpy(buf, path, (size_t)len);
|
||||
buf[len] = '\0';
|
||||
@ -2493,8 +2568,8 @@ int32_t flan_agent_start_auto(void) {
|
||||
char path[sizeof(((struct sockaddr_un *)0)->sun_path)];
|
||||
struct timespec ts;
|
||||
int32_t r;
|
||||
const char *env = getenv("FLAN_AGENT_SOCKET");
|
||||
if (env != NULL && env[0] != '\0') return start_on(env) < 0 ? -1 : 0;
|
||||
const char *env = daemon_socket();
|
||||
if (env != NULL) return start_on(env) < 0 ? -1 : 0;
|
||||
if (clock_gettime(CLOCK_REALTIME, &ts) != 0) ts.tv_nsec = 0;
|
||||
snprintf(path, sizeof path, "/tmp/flan-agent-%ld-%08lx.sock",
|
||||
(long)getpid(), (unsigned long)(ts.tv_nsec & 0xffffffffL));
|
||||
@ -2511,11 +2586,11 @@ int32_t flan_agent_start_auto(void) {
|
||||
/* And the call itself, gone. A program under [flan dev] that imports this
|
||||
* package gets the listener before main, without asking.
|
||||
*
|
||||
* FLAN_AGENT_SOCKET is the whole condition, and it is the right one: the
|
||||
* daemon sets it in both shapes — before the fork in --two-process, before the
|
||||
* exec in the merged build — and nothing else on a machine sets it. So an
|
||||
* ordinary run of an ordinary program falls straight through here and this
|
||||
* costs it one getenv. (Not FLAN_DEV_PARENT, which is deliberately unset in
|
||||
* [daemon_socket] is the condition: the daemon sets both of its variables in
|
||||
* both shapes — before the fork in --two-process, before the exec in the
|
||||
* merged build — so an ordinary run of an ordinary program falls straight
|
||||
* through here, and so does a process that only inherited them. (Not
|
||||
* FLAN_DEV_PARENT, which is deliberately unset in
|
||||
* the merged build; gating on it would quietly skip half the daemon.)
|
||||
*
|
||||
* WHAT THIS DOES NOT REACH, because it is a fact about linking rather than a
|
||||
@ -2540,8 +2615,8 @@ int32_t flan_agent_start_auto(void) {
|
||||
* cannot, in either shape — it has an editor to hear from first, and a module
|
||||
* to compile after that. */
|
||||
__attribute__((constructor)) static void auto_start(void) {
|
||||
const char *env = getenv("FLAN_AGENT_SOCKET");
|
||||
if (env == NULL || env[0] == '\0') return;
|
||||
const char *env = daemon_socket();
|
||||
if (env == NULL) return;
|
||||
/* The answer is dropped because there is nobody to give it to: this is ELF
|
||||
* init, before main, before the program has decided anything. What matters
|
||||
* is that a failure here is not final — [start_on] gives [started] back, so
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user