JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'master' into worktree-agent-ab75070e065de0e53

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-25 15:21:12 +07:00
commit 82b02b6584
63 changed files with 3902 additions and 751 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

126
TODO.org
View File

@ -242,12 +242,6 @@ arrives at the push. A =Vec= a call returned is accepted where an array a call
returned is refused: one dangles and one only leaks, and leaking is defined
behaviour here.
** NEXT (clone slice) as the general spelling of what (bytes s) does
Decided 2026-09-25: =(clone xs)= copies any slice into the context allocator, sharing =flan_bytes_dup='s lowering with =bytes=. The allocator's region answers who frees it.
Not built because of the who-frees question =bytes= answers by leaning on
free-all and arena-destroy. =flan_bytes_dup= is already the lowering, so if slices
grow a =clone= the two should share it.
** DONE The count is length, and len is a name a program can have
CLOSED: [2026-09-21]
One arm in the checker and one row in the builtin table. A call to an undefined
@ -398,13 +392,9 @@ expressible and a build-time refusal would be unusable. =barf= on web signals
no-op — which is how a save file disappears with nothing said — and the
build-time refusal.
** NEXT Conditions get a parent link, not class inheritance
Decided 2026-09-25: build it, with a root =Error= every built-in error descends from, so one handler catches any error. A catch-all handler gets the condition's name and the runtime's sentence, not its fields. =(pause)= and warnings are not under =Error=.
A condition type may name a parent where it is declared, and handler matching
walks that static chain. It buys the hierarchy conditions most lack — a catch-all
"any file error" handler — at compile-time cost only. Rules out the class answer:
a class condition allocates at the signal site, inverts the lifetime rule, and
lets a layout change under a standing handler frame. Not built.
** DONE Conditions get a parent link, not class inheritance
CLOSED: [2026-09-25]
A parent has exactly Error's fields; a handler matched through the link gets a view (name, message with the values), never the child's fields. Rules out parents with fields of their own.
** CANCELLED Can a condition be a class?
CLOSED: [2026-09-25]
@ -424,11 +414,6 @@ which takes the compiler, the session and the game. Abandoning drops the
expression; it does not undo it, and every surface says so. At a trap there is no
transfer channel, so nothing can be abandoned, and that is correct.
** TODO A restart-case clause has no report string
The field is cheap and the accessor is cheap, but the only consumer is the break
loop's listing, so it would ship as a field nothing read. It belongs with the
listing work.
** WAIT find-restart and compute-restarts
Blocked on a type, not on effort: the spec gives them =(Option Restart)= and a
list, and there is no =Restart= type and no list type to return one in. The
@ -1171,12 +1156,10 @@ The same holds for a closure environment a reload module allocated: the module
builds on both backends, and nothing yet collects while one is live.
For the next sweep rather than for a lane.
** NEXT A sliced string loses the trailing NUL
Decided 2026-09-25: both backends emit a NUL after every string literal, and a declare-c wrapper passes a literal argument to C without the copy it makes for any other string. A string is still pointer and length; no slice is promised a NUL. Rules out a NUL guarantee on every string.
The x86 backend emits a NUL after every string constant and the LLVM one does not,
so a =declare-c= wrapper leaning on the courtesy is already backend-dependent as
well as slice-dependent. The contract is pointer and length, and nothing promised
otherwise.
** DONE A string literal crosses to C uncopied
CLOSED: [2026-09-25]
Both backends write a NUL after every literal and a declare-c passes a literal argument
uncopied. Rules out a NUL guarantee on any other string: a slice is pointer and length.
** DONE Frame descriptions are gated on --debug
CLOSED: [2026-09-25]
@ -1241,12 +1224,10 @@ lowering buffer annotates all four sections, the two =llc= ones from a =--debug=
copy of the IR. Rules out writing a disassembler, and reading the source off disk
at disassembly time.
** NEXT A temporary allocator, wiped each frame
Decided 2026-09-25: Odin's context.temp_allocator. i64->bytes, f64->bytes and
other quick formatting allocate from it, so a number drawn every frame no longer
leaks from the default allocator. A dev build wipes it at each frame boundary;
otherwise the program calls (free-temp) once per frame. Text kept past the frame
is cloned.
** DONE A temporary allocator, wiped each frame
CLOSED: [2026-09-25]
=i64->bytes= and =f64->bytes= allocate from context/temp, which grows rather than failing. A
dev build wipes it at a top-level agent poll; an expression run at a stop gets a scratch temp arena.
* Runtime
@ -1313,12 +1294,10 @@ build, because a layout that changes with a build flag can disagree silently
across the reload boundary. One addition: a budget, because =retry= needs a
handler that can make the same request succeed.
** NEXT The Vec generation word has no reader
Decided 2026-09-25: remove the word, and in a dev build fill a Vec's old buffer with the dead-beef pattern when a push moves it, so a stale slice reads visibly wrong values. No slice layout change; a release build is untouched. Rules out a dev-only word on every slice.
It is bumped on reallocation and read by nothing. The stale-slice trap it exists
for needs a slice that can carry the Vec's identity, and a slice is pointer and
length — so either slices grow a word in a dev build or the trap does not exist.
Today it does not.
** DONE A stale slice reads poison in a dev build
CLOSED: [2026-09-25]
A dev build fills a Vec's old buffer with 0xDEADBEEF when a push moves it; nothing traps.
Rules out a dev-only word on every slice, which would change the slice layout per build.
** DONE The allocator's budget is not in the spec
CLOSED: [2026-09-25]
@ -1340,10 +1319,8 @@ No ordering of the frees fixes it: the container holds a pointer to the header.
allocator header — epoch bumped, procedure trapping as =DestroyedAllocator=,
never freed — so the stale check reads live memory on every side that makes it.
The next =arena-new= takes a retired header back, epoch kept, so a loop of them
stays flat and a container made before the destroy still traps. An =Allocator=
value kept past its destroy names the new arena once its header is reused.
Rules out freeing the header while any container may hold it. The
=DestroyedAllocator= trap prints no site: the allocator procedure is given none. See
stays flat and a container made before the destroy still traps.
Rules out freeing the header while any container may hold it. See
docs/BUILT.md, "Three amendments to a frozen spec".
** DONE Map removal costs a backward-shift loop
@ -1477,13 +1454,6 @@ runtime's design and a leak check produces a suppression list. A green sweep
therefore says nothing about who frees the newly allocating =(bytes s)=. Worth
asking on purpose one day, across the whole corpus and not one program.
** TODO An unhandled condition has no location
The error entry point takes five integer arguments, which fills the argument
registers; a location pair makes seven, so the x86 backend would need stack
argument passing at a call site whose register file is exactly full. The dev-side
half is different work: the trap hook hands control to a session in-process with
the compiler, which can read the source.
** DONE trap_oom has no site
CLOSED: [2026-09-25]
=flan_dyn_at=, =flan_dyn_set_at= and =flan_dyn_push= take the call's site as
@ -1493,26 +1463,10 @@ push gives one: its other callers are the collector's own allocations, which
have no line to name. A stale view's check prints the site when =at= or
=set-at= reaches it; reached from =length=, printing or equality, it has none.
** TODO A restart has no location
The restart frame is mirrored across both backends and the runtime, so giving
=continue= a file, line and column means two fields, stores in both backends, an
accessor, the snapshot copying it and the buffer printing it. A cross-backend ABI
change; do it as one lane, not as a rider. A site for user =error= calls is the
same lane if the frame is being touched anyway.
** TODO handler-case's own restart is listed in a break loop under it
The restart the form makes up for itself is on the restart stack like any other.
Hiding it means a new field in the frame layout written out in both backends and
the runtime. Choosing it is refused loudly rather than answered wrongly, so this is
cosmetic.
** NEXT A formatted number does not outlive its frame
Decided 2026-09-25: the conversion's bytes are always copied into the context allocator, so the string outlives the frame. Rules out refusing the escape, which needs flow tracking.
The conversion buffer is one frame slot per call site, so returning a string built
from it returns a view of storage the return has just released, and pushing one
pushes an element aliasing that slot. Neither shape is refused. Copy the bytes for
anything that outlives the expression that made them, which is what =append-i64=
and =append-f64= do.
** DONE A formatted number outlives its frame
CLOSED: [2026-09-25]
=i64->bytes= and =f64->bytes= copy their text into the temp allocator; the prelude and
the printer keep the frame slot. Rules out refusing the escape, which needs flow tracking.
** DONE A shift count is bounded two different ways
A literal count out of range is rejected by the checker; a computed one is masked
@ -1531,11 +1485,10 @@ Deleted, in a sweep for dead code across the repository in which each removal
was first shown unused. flan_dyn.c is the one implementation of the flan_dyn.h
ABI; a stand-in beside it is not to come back.
** NEXT A destroyed arena always traps, even after its record is reused
Decided 2026-09-25: an Allocator value is two words, the record and the
incarnation it was made for; every use compares the incarnation, so a destroyed
arena traps whether or not a later arena-new reused its record. Rules out
static tracking of destroy, which is move semantics.
** DONE A destroyed arena always traps, even after its record is reused
CLOSED: [2026-09-25]
An Allocator value is the record and the incarnation it was made for, compared on every use.
Rules out static tracking of destroy, which is move semantics. docs/BUILT.md has the cost.
** DONE A mixed array literal with no want is a dyn vector
CLOSED: [2026-09-25]
@ -1740,18 +1693,6 @@ a defcustom.
The agent keeps the condition pointer beside its name and a verb hands it back, so
the editor can render the condition's own fields rather than only its class.
** TODO A restart's source location and arity are not on the wire
The restart frame is =prev=, a name id, a name and a length. A backtrace and
locals landed out of the shadow stack and needed no debug information; these did
not come with them.
** TODO The editor half of a typed restart
The language half is in — a restart clause takes parameters and =invoke-restart=
passes them. What is missing is the half only an editor can do: arity and signature
on the frame, the restart listing carrying the signature, and the daemon compiling
each argument against the declared type and writing the values into the frame's
buffer before aiming the channel.
** NEXT The type identity of a local is not qualified
Decided 2026-09-25: a local's type prints package-qualified in the break buffer and the inspector, as a field's and a condition's already do.
Settled for conditions and for structs, because =Load= qualifies every declaration
@ -2112,23 +2053,6 @@ each with its own sentence. Both backends choose the code on the cold path, so t
guard is still two compares. =lhs= and =rhs= still carry the range. Rules out
carrying the float value in the condition.
** TODO The break buffer prints fields, not the sentence the runtime wrote
=ArithError — op 4, lhs -2147483648, rhs 2147483647= where the runtime's own
sentence is "this value does not fit the integer type it is cast to"
(=runtime/flan_rt.c:986=). Worse for a dyn trap: =DynType= has no struct at all,
so the buffer says "no struct is named DynType" while =flan_dyn.c:799= has
written the operation, both tags and both values to stderr. The sentences exist
and go to the daemon buffer; the break buffer wants them on the wire.
=ArithError='s =op= being a bare number is the same gap — it is an enum spelled
as =i32=.
** TODO A backtrace frame names the function, not the call
=fninfo= (=lib/emit.ml:185=) holds one static =loc=, the =defn='s own, and
=flan_frame= (=runtime/flan_dev.c:1011=) adds no per-call location — so two
calls to the same function from one caller are indistinguishable in the stack.
Wants the caller storing its call site into the frame before the call, which is
a field and a store on every dev-build call.
** DONE The condition buffer cannot jump to the source
CLOSED: [2026-09-25]
RET (and =v=) on a frame or on the stop's =at= line opens the file there; TAB

4
bin/main.ml
View File

@ -79,7 +79,7 @@ let summarise (d : Flan.Ast.decl) =
| Package n -> Printf.sprintf "package %s" n
| Import (a, p) -> Printf.sprintf "import %s %S" a p
| Defalias (n, _) -> Printf.sprintf "defalias %s" n
| Defstruct (n, fs) -> Printf.sprintf "defstruct %s (%d fields)" n (List.length fs)
| Defstruct (n, fs, _) -> Printf.sprintf "defstruct %s (%d fields)" n (List.length fs)
| Defdata (n, vs) -> Printf.sprintf "defdata %s (%d cases)" n (List.length vs)
| Defunion (n, ms) ->
Printf.sprintf "defunion %s (%d members)" n (List.length ms)
@ -420,7 +420,7 @@ let () =
List.filter_map
(fun (d : Flan.Ast.decl) ->
match d.Flan.Ast.d with
| Flan.Ast.Defstruct (n, fs) -> Some (n, fs)
| Flan.Ast.Defstruct (n, fs, _) -> Some (n, fs)
| _ -> None)
ds
in

2
conditions.org
View File

@ -10,7 +10,7 @@ Why it is shaped this way: [[file:spec-conditions.md][spec-conditions.md]]. Some
(signal c) ; (). Handler returns -> carry on. No handler -> no-op.
(error c) ; Never. Only a transfer gets past; else the program stops.
(handler-bind [(Type [c] body ...) ...] body ...) ; match by type, no hierarchy
(handler-bind [(Type [c] body ...) ...] body ...) ; match by type or a parent's
(restart-case BODY ; BODY and every clause have the same type = the form's
(name [p T ...] CLAUSE) ...)

43
docs/BUILT.md
View File

@ -2975,10 +2975,10 @@ What *does* need milestone 5 is a **user-written** allocator: "here is my proc,
`defn`'s name in value position. `make-allocator`, `allocator-from` and `allocator` are refused by name with that
reason, rather than coming back as unknown functions.
**An `Allocator` value is a pointer to the runtime's struct, never a copy of one.** That is forced, not chosen. The
**An `Allocator` value names the runtime's struct, never a copy of one.** That is forced, not chosen. The
capability set has to be readable from wherever a container landed, and `free-all` bumps an epoch every container made
from the allocator has to observe. A copied-by-value allocator gives each copy its own epoch and the dev trap never
fires.
fires. The value is two words: the struct's address and the incarnation of it the value was made for (see below).
### The surface
@ -3043,9 +3043,16 @@ turned the trap into a read of freed memory that happened to see the bumped valu
retired instead — epoch bumped, procedure swapped for one that traps as `DestroyedAllocator`, never freed — and put on a
list that the next `arena-new` takes from. The epoch is kept on reuse: it only ever rises on a header, so a container
made before the destroy still records an older number and still traps. Keeping every retired header instead grew
without bound — ten million `arena-new`/`arena-destroy` rounds peaked at 626 MB against 1.7 MB. The cost of reuse is
an `Allocator` value kept past its destroy: while its header is on the list it traps, and once a later `arena-new` has
taken the header it names that new arena. A second `arena-destroy` of the same allocator, before reuse, does nothing.
without bound — ten million `arena-new`/`arena-destroy` rounds peaked at 626 MB against 1.7 MB.
Reuse would let an `Allocator` value kept past its destroy name the next arena to take its header, so the value carries
the header's *incarnation*, which the retire bumps, and every use of a value (`flan_alloc_use`) compares the two. A
stale value traps as `DestroyedAllocator` at the site that used it, reused header or not, a second `arena-destroy`
included. The incarnation is its own counter rather than the epoch, because `free-all` keeps the arena and a value made
before one is still good. Containers need no change: they hold the header and already trap on its epoch. The cost is a
16-byte value and one call per use of a value — per `vec-new`, `with-allocator` or `free-all` naming one, not per push:
on a loop of `vec-new` + `with-allocator` + `free-all` against one arena, 50 more instructions an iteration out of 549
under LLVM and 69 out of 827 under `--x86`, cycles within noise. `test/programs/destroy-region.flan`, arguments 4 to 6.
**2. `context/allocator` and `context/temp` are dynamic variables with save and restore, not extra parameters.** The
spec says the allocator is "part of the calling convention". The literal reading touches every function signature, the
@ -3203,14 +3210,10 @@ that counter, and any operation on a container whose recorded epoch has moved tr
`test/programs/stale-region.flan` is the case, and the point of it is that `v` is still in scope, still looks fine, and
nothing marked it — which is precisely what a static rule cannot see.
**The generation word has no reader.** It is bumped on every reallocation, as specified, and the stale-slice trap it
exists for is not implemented: a slice is ptr+len and has nowhere to carry the Vec's identity or its generation. Said
plainly here rather than implied by the word's presence in the header.
It is not "not yet", either, and the runtime's own comment now says so. A reader for that word is a third word on every
slice in the language — a layout `spec-memory.md` fixes — so implementing the trap is a spec amendment and an ABI
change, not a runtime patch. The two live options are that amendment, or dropping the word from the header and from the
spec together; neither is a cleanup, and until one is taken the word is carried and trusted by nothing.
**A stale slice is not trapped.** A slice is ptr+len and has nowhere to carry the Vec's identity, and a word on every
slice is a layout `spec-memory.md` fixes. The generation word the header once carried for that trap is gone. What a dev
build does instead is fill a block a resize moved away from with `0xDEADBEEF` words (`flan_dev_poison`), so a slice
taken before the move reads a value nobody wrote instead of the old one. `test/programs/stale-slice-poison.flan`.
### What this leaves for steps 5 to 7
@ -4174,12 +4177,10 @@ a *run* of bytes, and `append` is that.
It takes a `(Ptr (Vec u8))` and not a `(Vec u8)`, and that is not style: a `Vec` parameter **moves**, so a by-value
builder would be consumed by its first append and refused on the second.
`append-i64` and `append-f64` are the argument for the whole shape. TODO.org, "A formatted number does not outlive
its frame", records that
`flan_i64_to_bytes` and its neighbours render into one `static char scratch[64]`, so two formatted numbers cannot be
held at once; these copy out of that buffer before returning, so the hazard ends at the call and a builder holds as
many numbers as it likes. `strings.flan` puts two integers and a float on one line, which is the case that could not
be written before.
`append-i64` and `append-f64` append a number's text to a builder. `i64->bytes` and `f64->bytes` render into a frame
slot and, outside the prelude, copy the text into the temp allocator so it outlives the frame; inside the prelude
they answer the slot, and these two copy it into the builder, so appending a number allocates nothing beyond the
builder's own growth. `strings.flan` puts two integers and a float on one line.
### `split` answers a `(Vec [const u8])`, and the owning shape is unrepresentable
@ -4687,8 +4688,8 @@ neither of them a function-value question:
1. The runtime calls `a->proc(a, mode, p, old_size, size, align)` — six C arguments and no transfer channel — and
every Flan function value's signature ends with one. It is the same mismatch a foreign function's address is
refused for, pointing the other way.
2. `Allocator` is opaque and pointer-width, so there is nowhere for a program to put the `flan_allocator` that
pointer would have to point at.
2. `Allocator` is opaque — a pointer to a runtime `flan_allocator` and an incarnation — so there is nowhere for a
program to put the `flan_allocator` that pointer would have to point at.
The refusal message says both, and `programs/user-allocator.flan` is the row that holds it. `(arena-new ...)` over a
backing buffer remains the parameterised allocator that does exist.

95
emacs/flan-cnr.el
View File

@ -234,6 +234,11 @@ indexing or the division itself, so it sits directly under the headline."
(insert (propertize name 'face (if paused 'warning 'error)))
(when numbers (insert " — " numbers))
(insert "\n")
;; The runtime's own sentence about it, when it wrote one: what the
;; fields below mean, or — for a trap, which has no fields — the whole of
;; what is known.
(let ((sentence (plist-get state :sentence)))
(when sentence (insert sentence "\n")))
(insert (propertize
(if paused
"stopped at (pause); nothing has been unwound\n"
@ -260,6 +265,10 @@ indexing or the division itself, so it sits directly under the headline."
(cond
((plist-get state :fields-empty)
" this condition has no fields\n")
;; A trap is not a struct. Its sentence, above, is what
;; there is to say about it.
((and (plist-get state :trap) (plist-get state :sentence))
" a trap carries no fields; the sentence above is what it refused\n")
(t (concat " not available — "
(or why (flan-cnr--why 'layout)) "\n")))
'face 'font-lock-comment-face))
@ -295,6 +304,7 @@ indexing or the division itself, so it sits directly under the headline."
(defun flan-cnr--insert-restarts (state)
(flan-cnr--section "Restarts (innermost first) — RET or a digit takes one:")
(let* ((names (plist-get state :restarts))
(details (plist-get state :details))
(rows (flan-cnr-annotate-restarts names
(plist-get state :unreachable)
(plist-get state :abandon)
@ -307,6 +317,12 @@ indexing or the division itself, so it sits directly under the headline."
(dolist (r rows)
(let* ((i (nth 0 r)) (name (nth 1 r)) (owner (nth 2 r))
(kind (nth 3 r))
(d (nth i details))
(report (let ((x (plist-get d :report)))
(and (stringp x) (not (string-empty-p x)) x)))
(params (and (> (or (plist-get d :arity) 0) 0)
(plist-get d :params)))
(at (plist-get d :at))
(start (point)))
;; SBCL's bracket: it is there when the name reaches this frame and
;; gone when it does not. A shadowed entry is still takeable — the
@ -326,6 +342,10 @@ indexing or the division itself, so it sits directly under the headline."
(if (or owner (memq kind '(unreachable trapped)))
" " "]")))
(insert (make-string (- w (length name)) ?\s))
;; What it takes, when it takes anything: taking it asks for one
;; value of each of these types.
(when params
(insert (propertize params 'face 'font-lock-type-face) " "))
(cond
;; What the reader wants nine times in ten after a C-x C-e went
;; wrong, so it says what it does *and* what it does not: nothing
@ -353,9 +373,20 @@ indexing or the division itself, so it sits directly under the headline."
(insert (propertize
(format "same name as %d; taken by its number" owner)
'face 'shadow))))
;; The clause's own sentence, SBCL's `:report'; after a refusal's
;; words when there are any, because those say whether it can be
;; taken at all. The name is the report when the clause wrote
;; none, as in SBCL, so nothing is added then.
(when (and report (not (eq kind 'abandon)))
(when (or owner (memq kind '(unreachable trapped))) (insert " "))
(insert report))
(when at
(insert (propertize (format " (%s)" at) 'face 'shadow)))
(insert "\n")
(add-text-properties start (point)
(list 'flan-cnr-restart name
'flan-cnr-restart-loc at
'flan-cnr-params params
'flan-cnr-shadowed owner
'flan-cnr-kind kind
'flan-cnr-index i
@ -583,8 +614,10 @@ puts the likely culprit on top."
"flan: restart %d is below the evaluation this break is inside, so a transfer to it has nowhere to land. Take one offered above it, or abandon the evaluation"
(get-text-property (point) 'flan-cnr-index)))
((get-text-property (point) 'flan-cnr-restart)
(flan-cnr--invoke (get-text-property (point) 'flan-cnr-index)
(get-text-property (point) 'flan-cnr-restart)))
(let ((name (get-text-property (point) 'flan-cnr-restart)))
(flan-cnr--invoke (get-text-property (point) 'flan-cnr-index) name
(flan-cnr--read-args
name (get-text-property (point) 'flan-cnr-params)))))
((get-text-property (point) 'flan-cnr-hidden) (flan-cnr-toggle-prelude))
((or (get-text-property (point) 'flan-cnr-frame)
(get-text-property (point) 'flan-cnr-loc))
@ -601,17 +634,25 @@ puts the likely culprit on top."
"the stop")))
(defun flan-cnr-visit ()
"Visit the source of the frame, or of the stop, on this line.
A frame's location is where its function is written; the stop's is the
"Visit the source of the frame, the restart or the stop on this line.
A frame's location is where it is: the call it is in, or for the innermost the
expression that stopped."
(interactive)
(let ((loc (get-text-property (point) 'flan-cnr-loc)))
(unless loc
(let ((loc (get-text-property (point) 'flan-cnr-loc))
(rloc (get-text-property (point) 'flan-cnr-restart-loc)))
(cond
(loc (flan-visit-loc loc (flan-cnr--loc-subject (point))))
;; A restart's clause, which `v' reaches and RET does not: RET takes it.
(rloc (flan-visit-loc rloc (format "restart %s"
(get-text-property (point)
'flan-cnr-restart))))
((get-text-property (point) 'flan-cnr-restart)
(user-error "flan: this restart was established from C and has no source"))
(t
(user-error
(if (get-text-property (point) 'flan-cnr-frame)
"flan: this frame has no location; the program did not report one"
"flan: point is not on a frame or on the stop")))
(flan-visit-loc loc (flan-cnr--loc-subject (point)))))
"flan: point is not on a frame, a restart or the stop"))))))
(defun flan-cnr-toggle-prelude ()
"Show or hide the prelude's frames in the stack section."
@ -661,15 +702,41 @@ visits the source of the one it lands on."
(when (eq next-error-last-buffer (current-buffer))
(setq next-error-last-buffer nil)))
(defun flan-cnr--invoke (index name)
"Take restart INDEX, named NAME.
(defun flan-cnr-param-types (params)
"The types in PARAMS, a restart's parameters as the program spells them.
PARAMS is a parenthesised list such as \"(i64 (Option string))\"; the result
is one string per type, or nil when it takes none or cannot be read."
(let ((form (and (stringp params)
(condition-case nil (car (read-from-string params))
(error nil)))))
(when (listp form)
(mapcar (lambda (ty) (format "%S" ty)) form))))
(defun flan-cnr--read-args (name params)
"One value for each of restart NAME's PARAMS, read in the minibuffer.
Each is Flan source, checked by the daemon against its parameter's type, as an
`invoke-restart' passing it would have been. Nil when it takes none."
(let* ((types (flan-cnr-param-types params))
(n (length types))
(i 0))
(mapcar (lambda (ty)
(setq i (1+ i))
(read-string (if (= n 1)
(format "%s, a value of type %s: " name ty)
(format "%s, value %d of %d, of type %s: " name i n ty))))
types)))
(defun flan-cnr--invoke (index name &optional args)
"Take restart INDEX, named NAME, passing ARGS when it takes values.
ARGS is one Flan expression per parameter, as strings.
By index, because the index is the identity — two frames can offer `retry'
and only one of them is the one on this line. The name rides along as a
receipt: the daemon checks it against what the program has at that index and
refuses if the two have drifted apart, so a stale buffer cannot take a
different restart than the one it showed."
(let ((r (funcall flan-cnr-request-function
(list :op "restart-at" :index index :name name))))
(append (list :op "restart-at" :index index :name name)
(and args (list :args args))))))
(if (equal (plist-get r :status) "ok")
;; Accepted, not resumed — the choice is validated against the stopped
;; stack and taken when that thread next comes round its loop. So the
@ -861,6 +928,10 @@ Takes the layout rather than fetching it, so this stays a function from data to
data and the fixture-driven tests can drive it without a socket."
(list :condition (plist-get reply :condition)
:restarts (plist-get reply :restarts)
;; Beside each name and in the same order: a plist of its `:report'
;; sentence, where the clause is written (`:at'), and the types it
;; takes (`:arity', `:params').
:details (plist-get reply :details)
;; The two facts about that list nothing here could work out. A
;; position is on `:unreachable' when the program will refuse it, and
;; `:abandon' is the position that drops the evaluation this break is
@ -877,6 +948,8 @@ data and the fixture-driven tests can drive it without a socket."
;; has none, and then the headline simply has no line to point at.
:site (plist-get reply :site)
:source (plist-get reply :source)
;; The runtime's sentence about the stop, when it wrote one.
:sentence (plist-get reply :sentence)
;; FIELDS is either the rows themselves — the fixtures' shape — or
;; `flan-cnr-condition-fields''s plist of rows plus the one-sentence
;; reason the values half is missing.

2
emacs/flan-mode.el
View File

@ -158,7 +158,7 @@ face says.")
"zeroed" "filled" "dead-beef"
;; allocators
"make-allocator" "allocator-from" "allocator" "heap-allocator"
"arena-new" "arena-destroy" "free-all" "can-free?" "can-free-all?"
"arena-new" "arena-destroy" "free-all" "free-temp" "can-free?" "can-free-all?"
"alloc-epoch" "alloc-id" "alloc-budget" "set-alloc-budget"
"alloc-live-blocks" "with-allocator"
;; Vec

16
emacs/flan.el
View File

@ -438,6 +438,7 @@ open, above its prompt, which is where whoever is typing there is looking."
;; so requiring it here would be a cycle, and it is wanted only at the moment
;; a program stops.
(autoload 'flan-cnr-show "flan-cnr" nil t)
(autoload 'flan-cnr--read-args "flan-cnr")
;;; Opening the break buffer when the program stops
@ -1222,12 +1223,14 @@ identity: two entries may read the same and mean different frames."
i))
restarts)))
(defun flan-restart-at (index name)
(defun flan-restart-at (index name &optional args)
"Resume the stopped program at the restart at position INDEX.
NAME is sent with it and is not the lookup: the program checks it against
the name it holds at that position and refuses if the two have drifted
apart, so a prompt cannot take a different restart than the one it showed."
(let ((r (flan--request (list :op "restart-at" :index index :name name))))
apart, so a prompt cannot take a different restart than the one it showed.
ARGS is one Flan expression per parameter, for a restart that takes values."
(let ((r (flan--request (append (list :op "restart-at" :index index :name name)
(and args (list :args args))))))
(if (equal (plist-get r :status) "ok")
(progn
;; Accepted, not resumed — see `flan-restart'.
@ -1347,7 +1350,12 @@ than being told so."
;; not something a person can type — but deriving the table wrongly
;; should say so rather than put nil on the wire as an index.
((null index) (user-error "flan: %s is not on the list" choice))
(t (flan-restart-at index (nth index restarts)))))))
(t (let ((name (nth index restarts)))
;; A restart that takes values asks for them, one per parameter.
(flan-restart-at
index name
(flan-cnr--read-args
name (plist-get (nth index (plist-get r :details)) :params)))))))))
(defun flan-describe ()
"Report what the running program currently defines."

77
emacs/test-flan-cider.el
View File

@ -1044,6 +1044,81 @@ would be overwritten. Look again and re-do the edit")
(test-flan--check "and the keys are shown" (and (string-match-p "TAB fold" text)
(string-match-p "P prelude frames" text))))
;; The runtime's sentence sits under the name. At a trap it is all there is:
;; a trap is not a struct, so the fields section says why it is empty rather
;; than that no struct has the name.
(let ((text (with-current-buffer
(test-flan--cnr
(list :condition "ArithError"
:sentence "divide by zero: (/ 10 0)"
:restarts '("continue")))
(buffer-string))))
(test-flan--check "the runtime's sentence is under the condition's name"
(string-match-p "\\`ArithError\ndivide by zero: (/ 10 0)\n" text)))
(let ((text (with-current-buffer
(test-flan--cnr
(list :condition "DynType" :trap t
:sentence "dyn +: int and text, and + wants two numbers — (+ 3 \"hi\")"
:restarts nil))
(buffer-string))))
(test-flan--check "a trap's sentence is shown"
(string-match-p "and \\+ wants two numbers" text))
(test-flan--check "and its missing fields are not called a missing struct"
(string-match-p "a trap carries no fields" text)))
;; What a restart says beside its name: its `:report' sentence, the types it
;; takes, and where its clause is written — and `v' on the row visits that.
(let* ((buf (test-flan--cnr
(list :condition "FileError"
:restarts '("retry" "use-value" "plain")
:details '((:report "Try the file operation again"
:at "/src/files.flan:12:3" :arity 0 :params "()")
(:report "Try again with another path"
:at "/src/files.flan:12:3" :arity 1
:params "(string)")
(:report "" :at nil :arity 0 :params "()")))))
(text (with-current-buffer buf (buffer-string))))
(test-flan--check "a restart's report is beside its name"
(string-match-p "\\[retry\\] +Try the file operation again" text))
(test-flan--check "and where its clause is written"
(string-match-p "again (/src/files.flan:12:3)" text))
(test-flan--check "a restart taking values shows their types"
(string-match-p "\\[use-value\\] +(string) Try again with another path"
text))
(test-flan--check "one with no report and no source shows its name alone"
(string-match-p " 2: \\[plain\\] *\n" text))
(let ((visited nil))
(cl-letf (((symbol-function 'flan-visit-loc)
(lambda (loc subject) (setq visited (list loc subject)))))
(with-current-buffer buf
(goto-char (point-min))
(search-forward " 1: ")
(flan-cnr-visit)))
(test-flan--check "v on a restart visits its clause"
(equal visited '("/src/files.flan:12:3" "restart use-value")))))
;; A restart that takes values asks for one per parameter and sends them.
(test-flan--check "a restart's parameter types are read from their spelling"
(equal (flan-cnr-param-types "(i64 (Option string))")
'("i64" "(Option string)")))
(let ((sent nil) (asked nil))
(let ((flan-cnr-request-function
(lambda (form) (setq sent form) (list :status "ok" :note "accepted"))))
(cl-letf (((symbol-function 'read-string)
(lambda (prompt &rest _) (push prompt asked) "(+ 40 2)")))
(with-current-buffer
(test-flan--cnr
(list :condition "ArithError" :restarts '("use-value")
:details '((:report "" :at nil :arity 1 :params "(i64)"))))
(goto-char (point-min))
(search-forward " 0: ")
(save-window-excursion (flan-cnr-take)))))
(test-flan--check "taking a typed restart asks for its value by type"
(equal asked '("use-value, a value of type i64: ")))
(test-flan--check "and sends it as :args"
(equal sent '(:op "restart-at" :index 0 :name "use-value"
:args ("(+ 40 2)")))))
;; A stopped program with nothing on offer between the error and the top. It
;; is a real state — spec-conditions §2's `error' with no `restart-case' above
;; it — and it must not look like a bug in the buffer.
@ -1285,7 +1360,7 @@ would be overwritten. Look again and re-do the edit")
(flan-cnr-toggle-prelude)
(test-flan--check "and P hides them again"
(not (string-match-p "0: > pause" (buffer-string))))
;; RET on a frame goes to where its function is written.
;; RET on a frame goes to its location.
(goto-char (point-min))
(search-forward " 2: > main")
(save-window-excursion

6
examples/core-input-multitouch.flan
View File

@ -65,4 +65,8 @@
rl/black))))
(rl/draw-text "touch the screen at multiple locations to get multiple balls"
10 10 20 rl/darkgray)))))
10 10 20 rl/darkgray))
;; The numbers drawn this frame were formatted into the temp allocator;
;; this hands that memory back once the frame is drawn.
(free-temp))))

6
examples/core-input-virtual-controls.flan
View File

@ -190,4 +190,8 @@
(rl/draw-text "button: " 10 34 20 rl/lightgray)
(rl/draw-text (string (i64->bytes (i64 pressed)))
(+ 10 (rl/measure-text "button: " 20)) 34 20
rl/lightgray)))))
rl/lightgray))
;; The number drawn this frame was formatted into the temp allocator;
;; this hands that memory back once the frame is drawn.
(free-temp))))

11
examples/digits.flan
View File

@ -24,13 +24,10 @@
;;;; a `char *` into a rotating static buffer, which `declare-c` refuses by
;;;; name anyway.
;;;;
;;;; ONE TRAP, and it is the reason every function below is written as a strict
;;;; sequence of format-draw-measure rather than as a let of several pieces:
;;;; `i64->bytes` and `f64->bytes` both write into a single shared static
;;;; buffer in the runtime, overwritten by the next such call. `(string ...)`
;;;; does not copy it. So a number must be *drawn before the next one is
;;;; formatted* — holding two at once is wrong pixels with no crash and no
;;;; diagnostic.
;;;; `i64->bytes` and `f64->bytes` put their text in the temp allocator, where
;;;; it lasts until the next `(free-temp)`. A program drawing these every frame
;;;; calls `(free-temp)` once per frame, after drawing, and clones any text it
;;;; keeps longer.
;;;;
;;;; Everything here needs a window: `measure-text` answers 0 for every string
;;;; until init-window has loaded the default font, and a zero advance would

16
lib/ast.ml
View File

@ -171,9 +171,14 @@ and hclause = { hty : texpr; hname : string; hbody : expr list; hloc : Loc.t }
(* [rparams] are §3's inline annotations, the same name/type pairs a [defn]
takes. They are bound in the clause body and filled in by whatever invoked
the restart, which is why their count and types are checked at run time
(§3): a restart is found by name on a dynamic stack. *)
(§3): a restart is found by name on a dynamic stack.
[rreport] is the sentence a break loop shows beside the name, written
[(name [p T] :report "..." body ...)] — Common Lisp's [:report], string
form only. *)
and rclause =
{ rname : string; rparams : field list; rbody : expr list; rloc : Loc.t }
{ rname : string; rparams : field list; rreport : string option;
rbody : expr list; rloc : Loc.t }
(* Inline name/type pairs, as in [defn], [let] and [defstruct]. Here because a
restart clause's parameters are one, and a clause is part of an expression. *)
@ -257,7 +262,10 @@ and decl_kind =
| Package of string
| Import of string * string (* alias, path *)
| Defalias of string * texpr
| Defstruct of string * field list
(* The third part is the parent a condition type names —
[(defstruct FileError :parent Error [...])] — and handler matching walks
that static chain. *)
| Defstruct of string * field list * texpr option
| Defdata of string * variant list
(* C's union: the members overlay one another at offset zero, the size is
the largest of them and the alignment the strictest. It carries the same
@ -389,7 +397,7 @@ let method_name (m : methd) = m.mgen ^ "@" ^ dispatch_text m.mkey
let declared_name (d : decl) =
match d.d with
| Defenum (n, _) | Defalias (n, _) | Defstruct (n, _) | Defdata (n, _)
| Defenum (n, _) | Defalias (n, _) | Defstruct (n, _, _) | Defdata (n, _)
| Defunion (n, _) | Defvar (n, _, _, _) | Defconst (n, _, _)
| Defclass (n, _) -> Some n
| Declare (fn, _) | DeclareC (fn, _) | Defn fn

578
lib/check.ml
View File

@ -109,6 +109,9 @@ type env = {
(* Enum name -> its members, in declaration order. A keyword at a call site
resolves against this and nothing else. *)
enums : (string, (string * int64) list) Hashtbl.t;
(* A condition type -> the parent it names, [(defstruct T :parent P ...)].
Handler matching walks this chain; see [condition_chain]. *)
parents : (string, string) Hashtbl.t;
(* Flan name -> the C symbol it is really called by. A foreign function is an
ordinary entry in [fns] as well; this only records how to name it. *)
externs : (string, string) Hashtbl.t;
@ -219,6 +222,7 @@ let new_env () = {
consts = Hashtbl.create 16;
locs = Hashtbl.create 16;
enums = Hashtbl.create 8;
parents = Hashtbl.create 8;
externs = Hashtbl.create 32;
extern_locs = Hashtbl.create 32;
fns = Hashtbl.create 32;
@ -967,6 +971,33 @@ let rec owning env ?(seen = []) (t : Types.t) =
(owning_fields env n)
| _ -> false
(* Does a value of this type hold a dyn anywhere — through a field, a case, an
element or a view? Asked where the program is still being checked, so it
reads the environment's tables rather than a finished program. *)
let rec holds_dyn env ?(seen = []) (t : Types.t) =
match t with
| Types.Dyn -> true
| Types.Array (_, e) | Types.Vec e | Types.Option e | Types.Slice (_, e)
| Types.Ptr (_, e) -> holds_dyn env ~seen e
| Types.Map (k, v) -> holds_dyn env ~seen k || holds_dyn env ~seen v
| Types.Named n when not (List.mem n seen) ->
let seen = n :: seen in
let fields (fs : Tast.field list) =
List.exists (fun (f : Tast.field) -> holds_dyn env ~seen f.Tast.fty) fs
in
(match Hashtbl.find_opt env.structs n with
| Some s -> fields s.Tast.fields
| None ->
match Hashtbl.find_opt env.unions n with
| Some u -> fields u.Tast.fields
| None ->
match Hashtbl.find_opt env.datas n with
| Some d ->
List.exists (fun (c : Tast.variant) -> fields c.Tast.vfields)
d.Tast.cases
| None -> false)
| _ -> false
(* Does a container of this type have to be built against an allocator that
cannot free one block? Only the half a release would have to walk is asked:
a map's key cannot own anything — [map_type] refuses one, because a key that
@ -2392,12 +2423,11 @@ and const_steps ro (ty : Types.t) n =
| _ -> ro
(* A copy of a read-only slice's elements that can be written, spelled so it
compiles. Only for elements that own nothing: an element holding a Vec or
a Map — directly or inside a struct — would copy only its header, and the
copy would share the original's block. *)
compiles: [clone], for exactly the element types clone copies. It refuses
elements that own storage — a copy would share their blocks — and
elements that hold a dyn, which its allocator storage cannot root. *)
let const_copy env (e : Types.t) =
if owning env e then None
else Some (Printf.sprintf "(slice (into v (vec-new %s)))" (Types.to_string e))
if owning env e || holds_dyn env e then None else Some "(clone v)"
(* A store through a read-only view: a [[const T]] or a (Ptr const T). *)
let refuse_const_place env loc (view : Types.t) =
@ -2547,16 +2577,12 @@ let align_of loc t = mk loc (Types.Int Types.I64) (Tast.Prim (Tast.AlignOf t, []
let addr_of loc (e : Tast.expr) =
mk loc (Types.Ptr (Types.Mut, e.Tast.ty)) (Tast.Prim (Tast.AddrOf, [ e ]))
(* ── Where a rendered number's bytes live ──────────────────────────────
(* ── A frame slot for a rendered number ────────────────────────────────
The three number-to-text conversions used to answer a slice into one static
buffer in the runtime, shared by every call in the process, and nothing
copied it: (print a) (print b) over two of them printed the second number
twice. No crash and nothing for a sanitizer to find, because the read was
inside a buffer that was perfectly alive — the wrong bytes, alive.
The buffer is now the caller's, one frame slot per call site, and it is
allocated here rather than in either backend on purpose: a slot is a
The printer and the prelude's number appends render a number into a
buffer that is the caller's, one frame slot per call site, and write or
copy it out before the next; i64->bytes and f64->bytes elsewhere answer
text in the temp allocator instead. The slot is allocated here rather than in either backend on purpose: a slot is a
function-lifetime frame location in both of them — an entry-block alloca in
[Emit], a prologue-allocated offset in [X86] — where a backend temporary in
[X86] is bump-allocated and reclaimed at the end of the expression that made
@ -2579,6 +2605,67 @@ let to_bytes ctx loc pr (x : Tast.expr) =
[ mk loc bslice
(Tast.Prim (pr, [ x; addr_of loc (mk loc bty (Tast.Local s)) ])) ]))
(* ── An Allocator value, made and used ─────────────────────────────────
A value is two words, flan_rt.c's [flan_alloc_value]: the runtime's
allocator record and the incarnation of it the value was made for, which
arena-destroy bumps. Every runtime operation takes the bare record, typed
[raw_alloc] here; [seal_alloc] makes a value from one and [use_alloc] opens
one, trapping if the incarnation has moved. So a value kept past its arena's
destroy traps at its next use, including after arena-new has taken the
record back for another arena — which a one-word value could not tell from
the new arena's own. Both cross through the value's address, since nothing
the runtime answers or takes is a struct by value. *)
let raw_alloc = Types.Ptr (Types.Mut, Types.Unit)
let seal_alloc ctx loc (record : Tast.expr) =
let s = fresh_slot ctx Types.Alloc in
mk loc Types.Alloc
(Tast.Let
([ (s, mk loc Types.Alloc (Tast.Zero Types.Alloc)) ],
[ rt loc Types.Unit "flan_alloc_seal"
[ record; addr_of loc (mk loc Types.Alloc (Tast.Local s)) ];
mk loc Types.Alloc (Tast.Local s) ]))
let use_alloc ctx loc (v : Tast.expr) =
let s = fresh_slot ctx Types.Alloc in
mk loc raw_alloc
(Tast.Let
([ (s, v) ],
[ rt loc raw_alloc "flan_alloc_use"
[ addr_of loc (mk loc Types.Alloc (Tast.Local s)); here loc ] ]))
(* A string literal handed to a [declare-c] function goes to C without the copy
the wrapper makes of any other string. Both backends write a NUL after a
literal's bytes, and here — the one place that knows the argument is a
literal — it is passed with its length encoded as -(n+1) by
[flan_c_literal]. No other Flan string has a negative length, so the
wrapper can tell ([Shim.cstr_helpers]); a string that merely ends in a NUL
is still copied and refused.
The callee is a declare-c when it binds the shim's symbol for its own name —
directly, or through the flattened [-c] declaration the shim puts under a
Flan wrapper. The encoded value passes through that wrapper untouched,
because its body only forwards it. *)
let c_literals ctx name (params : Types.t list) (args : Tast.expr list) =
let sym = Shim.shim_symbol name in
let bound n = Hashtbl.find_opt ctx.env.externs n = Some sym in
if not (bound name || bound (Shim.raw_name name)) then args
else
List.map2
(fun (p : Types.t) (a : Tast.expr) ->
match p, a.Tast.e with
| Types.String, Tast.Str _ ->
let loc = a.Tast.loc in
let s = fresh_slot ctx Types.String in
mk loc Types.String
(Tast.Let
([ (s, mk loc Types.String (Tast.Zero Types.String)) ],
[ rt loc Types.Unit "flan_c_literal"
[ a; addr_of loc (mk loc Types.String (Tast.Local s)) ];
mk loc Types.String (Tast.Local s) ]))
| _ -> a)
params args
(* ── The region requirement, emitted ───────────────────────────────────
spec-memory.md's arena rule, and the whole of what replaced the three
refusals a container of owning elements used to meet at its *type*. The
@ -2654,6 +2741,21 @@ let type_id name =
name;
!h
(* A condition type and every type it names as a parent, own first. The chain
is static: a signal site knows its condition's type, so the whole walk a
handler match makes is written into the site's descriptor, and the runtime
only compares numbers. [collect] has refused a cycle, but the walk stops at
one anyway rather than trusting that it ran. *)
let condition_chain env name =
let rec go seen n =
if List.mem n seen then List.rev seen
else
match Hashtbl.find_opt env.parents n with
| Some p -> go (n :: seen) p
| None -> List.rev (n :: seen)
in
go [] name
(* How a restart's parameter list is spelled, and with it what the two ends of
an [invoke-restart] compare — spec-conditions.md §3's run-time check. A
restart is found by name on a dynamic stack, so neither end can see the
@ -3264,19 +3366,12 @@ let numeric_note ~(want : Types.t) ~(got : Types.t) =
(%s x)"
(Types.to_string want)
(* The rest of the sentence when a read-only slice meets a writable one. Both
copies it names compile today: [string] reads any byte slice and [bytes]
copies a string, and [into] pushes any slice's elements into a Vec that
[slice] then views. *)
(* The rest of the sentence when a read-only slice meets a writable one. *)
let const_note env ~(want : Types.t) ~(got : Types.t) =
match want, got with
| Types.Slice (Types.Mut, e), Types.Slice (Types.Const, e')
when Types.equal e e' ->
let copy =
match e with
| Types.Int Types.U8 -> Some "(bytes (string v))"
| _ -> const_copy env e
in
let copy = const_copy env e in
Printf.sprintf
" — a %s can only be read, and never becomes a %s that can be written \
through. %sWhere nothing writes through it, the %s can be declared %s \
@ -3438,6 +3533,70 @@ let invented_ctx env ret =
in_defer = false; defer_ok = false; defer_block = "a nested form";
owner = "<none>" }
(* Whether a struct has exactly Error's two fields, which is what a parent must
have: a handler for a parent is handed a view of that shape. *)
let error_shaped env n =
match Hashtbl.find_opt env.structs n with
| Some s ->
(match s.Tast.fields with
| [ { Tast.fname = "name"; fty = Types.String };
{ Tast.fname = "message"; fty = Types.String } ] -> true
| _ -> false)
| None -> false
(* What a signal site tells the runtime about its condition. A condition that
something could catch through a parent, and that is not Error-shaped itself,
gets a printer lifted out of the signalling function: the runtime calls it
only when a parent's handler is about to run, or nothing handled it, so a
signal nobody catches that way costs nothing. It prints what [println]
prints, fields and values, and that is the message such a handler reads. *)
let condition_desc ctx loc name =
let chain = condition_chain ctx.env name in
let self = error_shaped ctx.env name in
let render =
if self || List.length chain < 2 then None
else begin
let ty = Types.Named name in
let hctx = { (invented_ctx ctx.env Types.Unit) with owner = ctx.owner } in
let pslot = fresh_slot hctx (Types.Ptr (Types.Mut, ty)) in
let bslice = Types.Slice (Types.Mut, Types.Int Types.U8) in
let emit x = mk loc Types.Unit (Tast.Prim (Tast.Rt "flan_msg_emit", [ x ])) in
let emitter : Render.emitter =
{ Render.ebytes = emit;
estr = (fun x -> emit (mk loc bslice (Tast.Prim (Tast.EscapeBytes, [ x ]))));
ei64 = (fun x -> emit (to_bytes hctx loc Tast.I64ToBytes x));
eu64 = (fun x -> emit (to_bytes hctx loc Tast.U64ToBytes x));
ef64 = (fun x -> emit (to_bytes hctx loc Tast.F64ToBytes x));
edyn = (fun x -> mk loc Types.Unit (Tast.Prim (Tast.Rt "flan_dyn_emit_msg", [ x ]))) }
in
let value =
mk loc ty (Tast.Deref (mk loc (Types.Ptr (Types.Mut, ty)) (Tast.Local pslot)))
in
let body = Render.render (render_ctx hctx emitter) 0 value in
let mine =
List.filter
(fun (l : Tast.fn) ->
l.Tast.fparent = Some ctx.owner
&& String.length l.Tast.name >= 8
&& String.sub l.Tast.name 0 8 = "message/")
ctx.env.lifted
in
let fname =
Printf.sprintf "message/%s/%d/%s" ctx.owner (List.length mine) name
in
ctx.env.lifted <-
{ Tast.name = fname; params = [ Types.Ptr (Types.Mut, ty) ];
slots = Array.of_list (List.rev hctx.slot_tys);
snames = Array.of_list (List.rev hctx.slot_names);
ret = Types.Unit; body; fdefers = [];
fenv = None; fparent = Some ctx.owner; floc = loc }
:: ctx.env.lifted;
Some fname
end
in
{ Tast.cname = name; cchain = List.map type_id chain; cself = self;
crender = render }
(* The address of field [i] of the struct the pointer in slot [p] points at. *)
let field_addr_of loc sty fty p i =
let target = mk loc sty (Tast.Deref (mk loc (Types.Ptr (Types.Mut, sty)) (Tast.Local p))) in
@ -3643,11 +3802,10 @@ and struct_key_pair env loc n =
end
(* The pair as two expressions, ready to be passed. Their Flan type is
[Alloc]: an opaque pointer-width value with no user-writable constructor,
which is all the backend needs and all any Flan type ever says about it. *)
[(Ptr ())]: one opaque word, which is all the backend needs. *)
let key_fns env loc k =
let h, e = key_pair env loc k in
mk loc Types.Alloc (Tast.FnAddr h), mk loc Types.Alloc (Tast.FnAddr e)
mk loc raw_alloc (Tast.FnAddr h), mk loc raw_alloc (Tast.FnAddr e)
(* ── The map operations, deferred to the instantiation ─────────────────
True when the key is a type variable, which means the operation cannot be
@ -3906,8 +4064,8 @@ and refuse_owned_copy ctx (r : Tast.expr) =
match r.Tast.ty with
| (Types.Vec _ | Types.Map _) when not (region_only ctx.env r.Tast.ty) ->
Printf.sprintf "(clone v) copies it into a %s of its own" t
(* TODO.org, "(clone slice)": once clone copies any value that owns
storage, this should say (clone v) too. *)
(* Nothing copies an array, an Option or a struct that owns storage,
nor a container whose elements do: its address is the way to it. *)
| _ -> Printf.sprintf "(addr v) gives a (Ptr const %s) to read it through" t
in
Loc.failk "check/const-owned-copy" r.Tast.loc
@ -4327,7 +4485,8 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr =
| Ast.Ssignal -> (Types.Unit, Tast.Ssignal)
| Ast.Serror -> (Types.Never, Tast.Serror)
in
expect ctx loc ~want (mk loc ty (Tast.Signal (kind, type_id name, c)))
expect ctx loc ~want
(mk loc ty (Tast.Signal (kind, condition_desc ctx loc name, c)))
| Ast.HandlerBind (clauses, body) -> check_handler_bind ctx ?want loc clauses body
| Ast.HandlerCase (body, clauses) -> check_handler_case ctx ?want loc body clauses
@ -4555,10 +4714,16 @@ and var ctx ?(qualified = false) loc ~want name =
the literal reading of "calling convention" is deferred. *)
| "context/allocator" ->
expect ctx loc ~want
(mk loc Types.Alloc (Tast.Prim (Tast.Rt "flan_context_allocator", [])))
(let s = fresh_slot ctx Types.Alloc in
mk loc Types.Alloc
(Tast.Let
([ (s, mk loc Types.Alloc (Tast.Zero Types.Alloc)) ],
[ rt loc Types.Unit "flan_context_value"
[ addr_of loc (mk loc Types.Alloc (Tast.Local s)) ];
mk loc Types.Alloc (Tast.Local s) ])))
| "context/temp" ->
expect ctx loc ~want
(mk loc Types.Alloc (Tast.Prim (Tast.Rt "flan_context_temp", [])))
(seal_alloc ctx loc (rt loc raw_alloc "flan_context_temp" []))
| _ when qualified ->
(* In [builtin_set] — the arm above checked — but not one of the four
arms above this one, so it is a builtin that exists only as a call.
@ -5027,7 +5192,8 @@ and check_restart_case ctx ?want loc body clauses =
been checked. Separate from the form above because [handler-case] supplies
its own body — a [handler-bind] it built — and has to name itself in the
refusals rather than naming the machinery it is made of. *)
and restart_clauses ctx ?want ~what loc (tbody : Tast.expr) clauses =
and restart_clauses ctx ?want ?(hidden = false) ~what loc (tbody : Tast.expr)
clauses =
(* With no expectation from outside, the body's own type is the expectation
the clauses are checked against — unless it produced no value at all, in
which case the first clause that does decides. *)
@ -5081,7 +5247,10 @@ and restart_clauses ctx ?want ~what loc (tbody : Tast.expr) clauses =
if !ty = None && b.Tast.ty <> Types.Never then ty := Some b.Tast.ty;
let sg = restart_sig (List.map snd params) in
{ Tast.rname_id = type_id c.Ast.rname; rname = c.Ast.rname;
rparams = params; rsig = sg; rsig_id = type_id sg; rbody = [ b ] })
rparams = params; rsig = sg; rsig_id = type_id sg; rbody = [ b ];
rloc = c.Ast.rloc;
rreport = Option.value c.Ast.rreport ~default:"";
rhidden = hidden })
clauses
in
let ty = match !ty with Some t -> t | None -> Types.Never in
@ -5194,11 +5363,13 @@ and check_handler_case ctx ?want loc body clauses =
rparams =
[ { Ast.fname = c.Ast.hname; fty = c.Ast.hty;
floc = c.Ast.hloc } ];
rbody = c.Ast.hbody; rloc = c.Ast.hloc })
rreport = None; rbody = c.Ast.hbody; rloc = c.Ast.hloc })
clauses rnames
in
let tbody = check_handler_bind ctx ?want ~what loc handlers [ body ] in
restart_clauses ctx ?want ~what loc tbody landings
(* Hidden: the landing is reached only through the handler above, and a break
loop under this form would otherwise list it as if someone could mean it. *)
restart_clauses ctx ?want ~hidden:true ~what loc tbody landings
(* The forms of a [defer], checked in place and hung on the function. What is
left where it stands is one store: this defer's number into the counter
@ -7701,7 +7872,8 @@ and alloc_guard ctx loc (attempt : Tast.expr) =
in
let signal =
mk loc Types.Never
(Tast.Signal (Tast.Serror, type_id "StorageExhausted", cond))
(Tast.Signal (Tast.Serror, condition_desc ctx loc "StorageExhausted",
cond))
in
let attempt_then_signal =
mk loc Types.Unit
@ -7716,7 +7888,8 @@ and alloc_guard ctx loc (attempt : Tast.expr) =
an [invoke-restart] cannot tell them apart. *)
let sg = restart_sig [] in
{ Tast.rname_id = type_id "retry"; rname = "retry"; rparams = [];
rsig = sg; rsig_id = type_id sg; rbody = [ unit_at loc ] }
rsig = sg; rsig_id = type_id sg; rbody = [ unit_at loc ];
rloc = loc; rreport = "Try the allocation again"; rhidden = false }
in
let body =
mk loc Types.Unit (Tast.RestartCase ([ clause ], attempt_then_signal))
@ -7769,7 +7942,8 @@ and file_guard ctx loc ~path_slot ~op mk_steps =
"flan_file_fail_reason" [] ])) ]))
in
let signal () =
mk loc Types.Never (Tast.Signal (Tast.Serror, type_id "FileError", cond))
mk loc Types.Never
(Tast.Signal (Tast.Serror, condition_desc ctx loc "FileError", cond))
in
(* One step of the attempt: run the runtime call, record whether it worked,
and signal if it did not. The last step a caller gives is what leaves [ok]
@ -7782,16 +7956,18 @@ and file_guard ctx loc ~path_slot ~op mk_steps =
mk loc Types.Bool (Tast.Prim (Tast.Ne, [ attempt; i8 0L ]))));
mk loc Types.Unit (Tast.If (notok (), signal (), unit_at loc)) ])
in
let clause name params =
let clause name report params =
let sg = restart_sig (List.map snd params) in
{ Tast.rname_id = type_id name; rname = name; rparams = params;
rsig = sg; rsig_id = type_id sg; rbody = [ unit_at loc ] }
rsig = sg; rsig_id = type_id sg; rbody = [ unit_at loc ];
rloc = loc; rreport = report; rhidden = false }
in
let body =
mk loc Types.Unit
(Tast.RestartCase
([ clause "retry" [];
clause "use-value" [ (path_slot, Types.String) ] ],
([ clause "retry" "Try the file operation again" [];
clause "use-value" "Try again with another path"
[ (path_slot, Types.String) ] ],
mk loc Types.Unit (Tast.Do (mk_steps try_))))
in
mk loc Types.Unit
@ -7952,10 +8128,59 @@ and vec_elem loc what (t : Types.t) =
implicit one. spec-memory.md: an operation never falls back to a hidden
global allocator, and an explicit allocator can override the context. *)
and allocator_arg ctx loc = function
| [] -> rt loc Types.Alloc "flan_context_allocator" []
| [ a ] -> check ctx ~want:Types.Alloc a
| [] -> rt loc raw_alloc "flan_context_use" [ here loc ]
| [ a ] -> alloc_value ctx loc a
| _ -> fail loc "at most one allocator may be named here"
(* An Allocator value, checked and opened: the record every runtime call
takes, after [use_alloc] has compared the incarnation. *)
and alloc_value ctx loc e = use_alloc ctx loc (check ctx ~want:Types.Alloc e)
(* A copy of [src]'s elements — a string's bytes or a slice's elements — into
a block from [a], answered as a slice over it: (bytes s), (clone xs) and the
number conversions. The lowering mirrors [vec-new]: a hidden (Vec T) temp
holds the block so the allocation registry can read its extent, the attempt
sits under [alloc_guard] so a failure signals StorageExhausted with retry,
and the answer is the [slice] of the whole of it. The slice carries no
allocator, so nothing can [free] the block through it — it lives until its
allocator's free-all or destroy.
The source is bound before the guard's loop, so a retry re-attempts the
same copy rather than re-evaluating the expression that produced it. Same
rule as [push]'s element. No [region_check]: that guard compares a Vec
header being *stored* against the region it lands in, and the header here
is a temp nothing stores. *)
and dup_elems ctx loc elem (src : Tast.expr) (a : Tast.expr) =
let sty = src.Tast.ty in
let sv = fresh_slot ctx sty in
let v = fresh_slot ctx (Types.Vec elem) in
let out = fresh_slot ctx (Types.Slice (Types.Mut, elem)) in
let attempt =
rt loc (Types.Int Types.I8) "flan_bytes_dup"
[ mk loc (Types.Vec elem) (Tast.Local v); a;
mk loc sty (Tast.Local sv); size_of loc elem; align_of loc elem;
here loc ]
in
let fill =
rt loc Types.Unit "flan_vec_as_slice"
[ mk loc (Types.Vec elem) (Tast.Local v);
addr_of loc (mk loc (Types.Slice (Types.Mut, elem)) (Tast.Local out));
mk loc index_ty (Tast.Int (0L, Types.I32));
mk loc index_ty (Tast.Int (-1L, Types.I32));
size_of loc elem; here loc ]
in
mk loc (Types.Slice (Types.Mut, elem))
(Tast.Let
([ (sv, src);
(v, mk loc (Types.Vec elem) (Tast.Zero (Types.Vec elem)));
(out, mk loc (Types.Slice (Types.Mut, elem)) (Tast.Zero (Types.Slice (Types.Mut, elem)))) ],
[ with_note loc (alloc_guard ctx loc attempt)
(reg_note loc "flan_dev_reg_note_vec"
(mk loc (Types.Vec elem) (Tast.Local v))
[ size_of loc elem ] elem);
fill;
mk loc (Types.Slice (Types.Mut, elem)) (Tast.Local out) ]))
(* The address of an element, bounds-checked, with the allocator's epoch
checked first. Both the value form [(at v i)] and the place form
[(set (at v i) x)] come through here, so they cannot drift apart — which is
@ -8585,7 +8810,7 @@ and named_call ?(qualified = false) ctx ~want loc name args =
| "heap-allocator" ->
arity ctx loc name 0 args;
expect ctx loc ~want
(mk loc Types.Alloc (Tast.Prim (Tast.Rt "flan_heap_allocator", [])))
(seal_alloc ctx loc (rt loc raw_alloc "flan_heap_allocator" []))
(* The capacity is explicit and there is no growing backing store: an arena
whose size is decided by the program is one a program can reason about,
and it is the only shape under which "exhausted" is a state a test can
@ -8594,20 +8819,23 @@ and named_call ?(qualified = false) ctx ~want loc name args =
arity ctx loc name 1 args;
let cap = check ctx ~want:(Types.Int Types.I64) (List.hd args) in
expect ctx loc ~want
(mk loc Types.Alloc (Tast.Prim (Tast.Rt "flan_arena_new", [ cap ])))
(seal_alloc ctx loc (rt loc raw_alloc "flan_arena_new" [ cap ]))
(* Hands the pages back, which [free-all] deliberately does not — see
TODO.org, "Allocators, (Vec T) and StorageExhausted". *)
| "arena-destroy" ->
arity ctx loc name 1 args;
let a = check ctx ~want:Types.Alloc (List.hd args) in
let a = alloc_value ctx loc (List.hd args) in
expect ctx loc ~want
(mk loc Types.Unit (Tast.Prim (Tast.Rt "flan_arena_destroy", [ a ])))
(* One of spec-memory.md's two release points. It takes the source location
as a string so that an allocator with no region to release names the site
rather than the runtime. *)
| "free-temp" ->
arity ctx loc name 0 args;
expect ctx loc ~want (rt loc Types.Unit "flan_free_temp" [])
| "free-all" ->
arity ctx loc name 1 args;
let a = check ctx ~want:Types.Alloc (List.hd args) in
let a = alloc_value ctx loc (List.hd args) in
expect ctx loc ~want
(mk loc Types.Unit
(Tast.Prim (Tast.Rt "flan_alloc_free_all", [ a; here loc ])))
@ -8616,7 +8844,7 @@ and named_call ?(qualified = false) ctx ~want loc name args =
answer without the round trip, which is the call this made. *)
| "can-free?" ->
arity ctx loc name 1 args;
let a = check ctx ~want:Types.Alloc (List.hd args) in
let a = alloc_value ctx loc (List.hd args) in
expect ctx loc ~want
(mk loc Types.Bool
(Tast.Prim (Tast.Ne,
@ -8625,7 +8853,7 @@ and named_call ?(qualified = false) ctx ~want loc name args =
mk loc (Types.Int Types.I8) (Tast.Int (0L, Types.I8)) ])))
| "can-free-all?" ->
arity ctx loc name 1 args;
let a = check ctx ~want:Types.Alloc (List.hd args) in
let a = alloc_value ctx loc (List.hd args) in
expect ctx loc ~want
(mk loc Types.Bool
(Tast.Prim (Tast.Ne,
@ -8637,7 +8865,7 @@ and named_call ?(qualified = false) ctx ~want loc name args =
saw. *)
| "alloc-epoch" ->
arity ctx loc name 1 args;
let a = check ctx ~want:Types.Alloc (List.hd args) in
let a = alloc_value ctx loc (List.hd args) in
expect ctx loc ~want
(mk loc (Types.Int Types.I64)
(Tast.Prim (Tast.Rt "flan_alloc_epoch", [ a ])))
@ -8646,7 +8874,7 @@ and named_call ?(qualified = false) ctx ~want loc name args =
which one ran out. *)
| "alloc-id" ->
arity ctx loc name 1 args;
let a = check ctx ~want:Types.Alloc (List.hd args) in
let a = alloc_value ctx loc (List.hd args) in
expect ctx loc ~want
(mk loc (Types.Int Types.I64) (Tast.Prim (Tast.Rt "flan_alloc_id", [ a ])))
(* A ceiling on live bytes, 0 for none. spec-memory.md's retry restart is
@ -8658,7 +8886,7 @@ and named_call ?(qualified = false) ctx ~want loc name args =
program exhausts an allocator on purpose. *)
| "alloc-budget" ->
arity ctx loc name 1 args;
let a = check ctx ~want:Types.Alloc (List.hd args) in
let a = alloc_value ctx loc (List.hd args) in
expect ctx loc ~want
(mk loc (Types.Int Types.I64)
(Tast.Prim (Tast.Rt "flan_alloc_budget", [ a ])))
@ -8666,7 +8894,7 @@ and named_call ?(qualified = false) ctx ~want loc name args =
arity ctx loc name 2 args;
(match args with
| [ a; n ] ->
let a = check ctx ~want:Types.Alloc a in
let a = alloc_value ctx loc a in
let n = check ctx ~want:(Types.Int Types.I64) n in
expect ctx loc ~want
(mk loc Types.Unit (Tast.Prim (Tast.Rt "flan_alloc_set_budget", [ a; n ])))
@ -8675,7 +8903,7 @@ and named_call ?(qualified = false) ctx ~want loc name args =
tier answering it — spec-memory.md, "Leaking is defined behaviour". *)
| "alloc-live-blocks" ->
arity ctx loc name 1 args;
let a = check ctx ~want:Types.Alloc (List.hd args) in
let a = alloc_value ctx loc (List.hd args) in
expect ctx loc ~want
(mk loc (Types.Int Types.I64)
(Tast.Prim (Tast.Rt "flan_alloc_live_blocks", [ a ])))
@ -8687,7 +8915,22 @@ and named_call ?(qualified = false) ctx ~want loc name args =
(match args with
| [] -> fail loc "with-allocator is (with-allocator allocator body ...)"
| a :: body ->
let a = check ctx ~want:Types.Alloc a in
(* Two values in this frame, handed to the runtime by address: the one
to install, checked here so a stale one traps at this site, and the
room for the one it displaces, so the restore puts that back with
its incarnation (flan_rt.c, flan_context_set). *)
let a =
let pair = Types.Array (2L, Types.Alloc) in
let s = fresh_slot ctx pair in
let first = addr_of loc (mk loc pair (Tast.Local s)) in
mk loc raw_alloc
(Tast.Let
([ (s, mk loc pair
(Tast.Arr [ check ctx ~want:Types.Alloc a;
mk loc Types.Alloc (Tast.Zero Types.Alloc) ])) ],
[ rt loc raw_alloc "flan_alloc_use" [ first; here loc ];
addr_of loc (mk loc pair (Tast.Local s)) ]))
in
let body, ty =
scoped ctx (fun () ->
match body with
@ -8931,6 +9174,26 @@ and named_call ?(qualified = false) ctx ~want loc name args =
can walk one to copy what it owns. Build a second container and \
insert into it"
(Types.to_string target.Tast.ty)
(* A slice's elements, copied into a block from the allocator and
answered as a slice over it — what (bytes s) does for a string's
bytes, and the same lowering. The same refusal as a Vec's, for the
same reason: a copy of owning elements is a copy of their headers. *)
| Types.Slice (_, elem) when owning ctx.env elem ->
fail loc
"%s cannot be cloned — its elements own storage, and nothing here \
can walk one to copy what it owns. Build a container and insert \
into it"
(Types.to_string target.Tast.ty)
(* The copy is a block from an allocator, which the collector does not
walk, so a dyn in it would be a root nothing marks. *)
| Types.Slice (_, elem) when holds_dyn ctx.env elem ->
fail loc
"%s cannot be cloned — its elements hold a dyn, and the copy would \
live in allocator storage the collector does not look in. Build \
a dyn vector from the elements instead"
(Types.to_string target.Tast.ty)
| Types.Slice (_, elem) ->
expect ctx loc ~want (dup_elems ctx loc elem target a)
(* A map's clone reinserts rather than copying the block, because the
seed is derived from the block's address — see flan_rt.c. That is
the runtime's business; from here it is one more allocating call
@ -9818,55 +10081,14 @@ and named_call ?(qualified = false) ctx ~want loc name args =
spec-memory.md's frozen rule over every allocating operation. It used to
be the zero-cost reinterpret above, and the author's in-place sort over
(bytes "INSERTIONSORT") wrote into the string constant; "I would expect
bytes to copy" is the ruling this implements.
The lowering mirrors [vec-new]: a hidden (Vec u8) temp holds the block so
the allocation registry can read its extent, the attempt sits under
[alloc_guard] so a failure signals StorageExhausted with retry, and the
answer is the [slice] of the whole of it. The slice carries no
allocator, so nothing can [free] this block through it — it lives until
its allocator's free-all or destroy, which is the story every borrowed
view already has and is written down in BUILT.md's surface table.
No [region_check]: that guard compares a Vec header being *stored* against
the region it lands in, and the header here is a temp nothing stores. *)
bytes to copy" is the ruling this implements. The lowering is
[dup_elems], which (clone xs) shares for any slice. *)
| "bytes" ->
(match args with
| s :: rest when List.length rest <= 1 ->
let u8 = Types.Int Types.U8 in
let s = check ctx ~want:Types.String s in
let a = allocator_arg ctx loc rest in
(* The string is bound before the guard's loop, so a retry re-attempts
the same copy rather than re-evaluating the expression that produced
the string. Same rule as [push]'s element. *)
let sv = fresh_slot ctx Types.String in
let v = fresh_slot ctx (Types.Vec u8) in
let out = fresh_slot ctx (Types.Slice (Types.Mut, u8)) in
let attempt =
rt loc (Types.Int Types.I8) "flan_bytes_dup"
[ mk loc (Types.Vec u8) (Tast.Local v); a;
mk loc Types.String (Tast.Local sv); here loc ]
in
let fill =
rt loc Types.Unit "flan_vec_as_slice"
[ mk loc (Types.Vec u8) (Tast.Local v);
addr_of loc (mk loc (Types.Slice (Types.Mut, u8)) (Tast.Local out));
mk loc index_ty (Tast.Int (0L, Types.I32));
mk loc index_ty (Tast.Int (-1L, Types.I32));
size_of loc u8; here loc ]
in
expect ctx loc ~want
(mk loc (Types.Slice (Types.Mut, u8))
(Tast.Let
([ (sv, s);
(v, mk loc (Types.Vec u8) (Tast.Zero (Types.Vec u8)));
(out, mk loc (Types.Slice (Types.Mut, u8)) (Tast.Zero (Types.Slice (Types.Mut, u8)))) ],
[ with_note loc (alloc_guard ctx loc attempt)
(reg_note loc "flan_dev_reg_note_vec"
(mk loc (Types.Vec u8) (Tast.Local v))
[ size_of loc u8 ] u8);
fill;
mk loc (Types.Slice (Types.Mut, u8)) (Tast.Local out) ])))
expect ctx loc ~want (dup_elems ctx loc (Types.Int Types.U8) s a)
| _ -> fail loc "bytes is (bytes s) or (bytes s allocator)")
(* (string b): a [u8] seen as a string. The mirror of (bytes-view s),
@ -9900,13 +10122,9 @@ and named_call ?(qualified = false) ctx ~want loc name args =
is read-only everywhere — so the result of (string b) can reach
strictly fewer stores than b could.
The sharp edge left here is one of lifetime and no longer one of sharing:
the slice that i64->bytes / f64->bytes / u64->bytes answer is a view into
a frame slot belonging to *that call site* (see [to_bytes]), so two of
them can be held at once and the text of one survives the making of the
next. What it does not survive is its frame — calling it a string does not
copy it, so storing one in a container or returning it hands back a view
of storage that has been reused. Copy the bytes for that. *)
The text i64->bytes and f64->bytes answer lives in the temp allocator
until the next (free-temp); calling it a string does not copy it, so text
kept past the frame is cloned first. *)
| "string" ->
arity ctx loc name 1 args;
prim Tast.StrOfBytes Types.String [ byte_slice ctx (List.hd args) ]
@ -9916,16 +10134,51 @@ and named_call ?(qualified = false) ctx ~want loc name args =
| "bytes->i64" ->
arity ctx loc name 1 args;
prim Tast.BytesToI64 (Types.Int Types.I64) [ byte_slice ctx (List.hd args) ]
| "f64->bytes" ->
(* The number's text in the temp allocator: flan_i64_temp and flan_f64_temp
render it and bump-allocate the bytes there in one call, so the slice
outlives the frame — a function may return one and a Vec may hold one —
until the next (free-temp). A number drawn every frame is reclaimed every
frame; text kept longer is cloned. The number is bound before the guard's
loop, so a retry does not evaluate it twice.
The prelude's calls — append-i64, append-f64, format-f64, gensym — are
answered with a frame slot instead ([to_bytes]): each copies the bytes
into a Vec before the next conversion, so the temp copy would be work
thrown away. *)
| "f64->bytes" | "i64->bytes" ->
arity ctx loc name 1 args;
let f64 = name = "f64->bytes" in
let nty = if f64 then Types.Float Types.F64 else Types.Int Types.I64 in
let x = check ctx ~want:nty (List.hd args) in
let bslice = Types.Slice (Types.Mut, Types.Int Types.U8) in
expect ctx loc ~want
(to_bytes ctx loc Tast.F64ToBytes
(check ctx ~want:(Types.Float Types.F64) (List.hd args)))
| "i64->bytes" ->
arity ctx loc name 1 args;
expect ctx loc ~want
(to_bytes ctx loc Tast.I64ToBytes
(check ctx ~want:(Types.Int Types.I64) (List.hd args)))
(if String.equal loc.Loc.file Prelude.file then
to_bytes ctx loc (if f64 then Tast.F64ToBytes else Tast.I64ToBytes) x
else
let xs = fresh_slot ctx nty and out = fresh_slot ctx bslice in
let attempt () =
rt loc (Types.Int Types.I8)
(if f64 then "flan_f64_temp" else "flan_i64_temp")
[ mk loc nty (Tast.Local xs);
addr_of loc (mk loc bslice (Tast.Local out)) ]
in
(* The guard — a retry restart around the attempt — is entered only
once a first attempt has failed, so the common case pays one call
and a compare. A failure then re-attempts under the guard exactly
as it would have. *)
let failed =
mk loc Types.Bool
(Tast.Prim (Tast.Eq,
[ attempt ();
mk loc (Types.Int Types.I8) (Tast.Int (0L, Types.I8)) ]))
in
mk loc bslice
(Tast.Let
([ (xs, x); (out, mk loc bslice (Tast.Zero bslice)) ],
[ mk loc Types.Unit
(Tast.If (failed, alloc_guard ctx loc (attempt ()),
unit_at loc));
mk loc bslice (Tast.Local out) ])))
| "write-stdout" ->
arity ctx loc name 1 args;
prim Tast.WriteStdout Types.Unit [ byte_slice ctx (List.hd args) ]
@ -10332,6 +10585,7 @@ and ordinary_call ctx ~want loc name args =
let args =
map2_lr (fun p a -> incr i; check_arg ctx name !i p a) params args
in
let args = c_literals ctx name params args in
(match Hashtbl.find_opt ctx.env.tracks name with
| Some tr -> expect ctx loc ~want (tracked_call loc ctx.env name tr ret args)
| None when Hashtbl.mem ctx.env.classes name ->
@ -11396,6 +11650,11 @@ let builtins : (string * string * string) list =
("arena-destroy", "arena-destroy [Allocator] ()",
"Hands the arena's pages back to the system, which free-all \
deliberately does not.");
("free-temp", "free-temp [] ()",
"Releases everything in the temp allocator, context/temp — where \
i64->bytes and f64->bytes put their text. Called once a frame; a dev \
build also does it at every frame boundary the agent polls at. Text \
kept past the frame is cloned out first.");
("free-all", "free-all [Allocator] ()",
"Releases everything the allocator holds and bumps its epoch, keeping \
the capacity. It traps rather than quietly doing nothing when there is \
@ -11443,10 +11702,12 @@ let builtins : (string * string * string) list =
"Releases the container's block. It does not recurse into elements that \
own storage — such a container is refused here, and releasing its \
region with free-all is the answer.");
("clone", "clone [(Vec T)|(Map K V) Allocator?] (Vec T)|(Map K V)",
("clone", "clone [(Vec T)|(Map K V)|[T] Allocator?] (Vec T)|(Map K V)|[T]",
"A deep, independent copy, from the current allocator or one named. \
Refused for a container whose elements own storage: a bytewise copy \
would alias the original's blocks under a name promising otherwise.");
A slice's copy is a slice over a new block, which lives until its \
allocator's free-all or destroy. Refused for elements that own \
storage: a bytewise copy would alias the original's blocks under a \
name promising otherwise.");
(* (Map K V) *)
("map-new", "map-new [K? V? Allocator?] (Map K V)",
@ -11568,12 +11829,11 @@ let builtins : (string * string * string) list =
("bytes->i64", "bytes->i64 [[const u8]] i64",
"Parses an integer out of the bytes.");
("f64->bytes", "f64->bytes [f64] [u8]",
"The number's text, in a frame slot belonging to this call site — so \
two of them can be held at once, and neither survives its frame. Copy \
the bytes to keep one.");
"The number's text, %g, in the temp allocator: it lasts until the next \
(free-temp). Clone it to keep it longer.");
("i64->bytes", "i64->bytes [i64] [u8]",
"The number's text, in a frame slot belonging to this call site; it \
does not survive the frame.");
"The number's text, in the temp allocator: it lasts until the next \
(free-temp). Clone it to keep it longer.");
("write-stdout", "write-stdout [[const u8]] ()",
"Writes the bytes to standard output exactly as given: no newline and \
no formatting.");
@ -11738,6 +11998,58 @@ let rec defconst_type_shaped env gname (v : Ast.expr) =
items
| _ -> ()
(* Every parent a struct names, now that every struct has its fields.
A parent has exactly [Error]'s two fields, [name string] and
[message string], and that is not a style rule: a handler that matched
through the link is handed the signal site's descriptor rather than the
condition, because the condition's layout is its own type's and the
handler's type is an ancestor's. The descriptor's first two fields are the
name and the sentence, so a parent shaped any other way would be read off
bytes that are not its fields. *)
let check_parents env =
Hashtbl.iter
(fun child parent ->
let loc =
Option.value (Hashtbl.find_opt env.locs child) ~default:Loc.unknown
in
if not (error_shaped env parent) then begin
let has =
match Hashtbl.find_opt env.structs parent with
| Some { Tast.fields = []; _ } -> "none"
| Some s ->
String.concat " "
(List.map
(fun (f : Tast.field) ->
f.Tast.fname ^ " " ^ Types.to_string f.Tast.fty)
s.Tast.fields)
| None -> "none"
in
let fix =
match Hashtbl.find_opt env.parents parent with
| Some _ -> Printf.sprintf "(defstruct %s :parent %s)" parent
(Hashtbl.find env.parents parent)
| None -> Printf.sprintf "(defstruct %s :parent Error)" parent
in
fail loc
"%s names %s as its parent, and a parent has exactly the fields \
[name string message string], because a handler for a parent is \
handed the name and the message of whatever it caught. %s has \
[%s]. Declare it with no field vector, %s, which gives it those \
two"
child parent parent has fix
end;
(* A cycle is a chain with no root; the walk stops at the repeat. *)
let chain = condition_chain env child in
match Hashtbl.find_opt env.parents (List.nth chain (List.length chain - 1)) with
| Some back ->
fail loc
"%s's parents go round in a loop, %s -> %s, and a chain of parents \
has to end at a type with no parent, such as Error"
child (String.concat " -> " chain) back
| None -> ())
env.parents
let collect env (decls : Ast.decl list) =
(* One pass over every declaration kind before any of the others, because
the tables below are per-kind — structs, data types, aliases, enums, functions
@ -11793,7 +12105,7 @@ let collect env (decls : Ast.decl list) =
List.iter
(fun (d : Ast.decl) ->
match d.Ast.d with
| Ast.Defstruct (n, _) ->
| Ast.Defstruct (n, _, _) ->
Hashtbl.replace env.locs n d.Ast.dloc;
Hashtbl.replace env.structs n { Tast.sname = n; fields = [] }
| Ast.Defdata (n, _) ->
@ -11969,10 +12281,25 @@ let collect env (decls : Ast.decl list) =
Hashtbl.replace env.externs fn.Ast.name csym;
Hashtbl.replace env.extern_locs fn.Ast.name loc
| Ast.Defalias _ -> ()
| Ast.Defstruct (n, fs) ->
| Ast.Defstruct (n, fs, parent) ->
let names = List.map (fun (f : Ast.field) -> f.Ast.fname) fs in
if List.length (List.sort_uniq compare names) <> List.length names then
fail loc "%s declares the same field twice" n;
(* The parent is recorded here and its shape checked once every
struct has its fields, below, since it may be declared later. *)
(match parent with
| None -> Hashtbl.remove env.parents n
| Some t ->
(match resolve env t with
| Types.Named pn when Hashtbl.mem env.structs pn ->
if String.equal pn n then
fail t.Ast.tloc "%s cannot be its own parent" n;
Hashtbl.replace env.parents n pn
| pt ->
fail t.Ast.tloc
"%s names %s as its parent, and a parent is a condition \
struct, such as Error, the root every error descends from"
n (Types.to_string pt)));
let fields = List.map field fs in
(* Recorded before the refusal below rather than after it, because the
refusal asks [region_only], which walks this very declaration: a
@ -12172,6 +12499,7 @@ let collect env (decls : Ast.decl list) =
in
settle ();
List.iter (fun c -> ignore (infer c)) !pending;
check_parents env;
(* The paired declarations, handed back so that pass two checks the bodies of
the same functions whose signatures this pass registered. Pairing needs the
type names, which only this pass has; every pass after it needs the result,

2
lib/cimport.ml
View File

@ -1749,7 +1749,7 @@ let regenerate ~loc ~header:h ~flags ~(ds : Ast.decl list) ~config ~out =
let pick f = List.filter_map f ds in
let structs =
pick (fun (d : Ast.decl) ->
match d.Ast.d with Ast.Defstruct (n, fs) -> Some (n, fs) | _ -> None)
match d.Ast.d with Ast.Defstruct (n, fs, _) -> Some (n, fs) | _ -> None)
and enums =
pick (fun (d : Ast.decl) ->
match d.Ast.d with Ast.Defenum (n, ms) -> Some (n, ms) | _ -> None)

153
lib/dev.ml
View File

@ -381,6 +381,15 @@ type restart_flag =
let takeable = function Takeable | Boundary -> true | Below -> false
(* One row. After the name, tab-separated, the agent sends what a listing
shows beside it: how many parameters the clause takes, how their types are
spelled, where it is written ([None] for a frame pushed from C) and its
:report sentence, [""] when it wrote none. A row without them — an older
agent — reads as a clause of no parameters with nothing to show. *)
type restart_row =
{ ridx : int; rflag : restart_flag; rname : string; rarity : int;
rsig : string; rat : string option; rreport : string }
(* The rows, and whether the break they came from was taken by a trap. *)
let restarts t =
match ask t "restarts" with
@ -401,17 +410,31 @@ let restarts t =
let rest = String.sub line (i + 1) (String.length line - i - 1) in
if String.length rest < 2 then None
else
let tail = String.sub rest 2 (String.length rest - 2) in
let name, arity, sg, at, report =
match String.split_on_char '\t' tail with
| name :: arity :: sg :: at :: report ->
( name,
Option.value (int_of_string_opt arity) ~default:0,
sg,
(if at = "-" || at = "" then None else Some at),
String.concat " " report )
| name :: _ -> (name, 0, "()", None, "")
| [] -> (tail, 0, "()", None, "")
in
Some
( idx,
{ ridx = idx;
(* An unknown character is read as [Below] rather than as
takeable: a flag this end does not recognise is a program
newer than the daemon, and refusing a restart that could
have been taken is the survivable half of that. *)
(match rest.[0] with
| '+' -> Takeable
| '*' -> Boundary
| _ -> Below),
String.sub rest 2 (String.length rest - 2) ))
rflag =
(match rest.[0] with
| '+' -> Takeable
| '*' -> Boundary
| _ -> Below);
rname = name; rarity = arity; rsig = sg; rat = at;
rreport = report })
in
Ok
( List.filter_map parse
@ -1995,6 +2018,19 @@ let site_fields t =
| None -> []
| Some text -> [ ":source " ^ Wire.quote text ])
(* The sentence the runtime wrote about the stop — "divide by zero: (/ 10 0)"
where the fields say op 0 — or nothing, for a program's own condition,
which says what it is in its fields, and for a (pause). A trap with no
struct behind it, DynType among them, has this and no fields at all. *)
let sentence_fields t =
match ask t "sentence" with
| exception Unix.Unix_error _ -> []
| text ->
let line = String.trim text in
if line = "" || line = "-" || (String.length line >= 4 && String.sub line 0 4 = "err ")
then []
else [ ":sentence " ^ Wire.quote line ]
let break t =
match liveness t with
| Gone -> error gone
@ -2026,11 +2062,26 @@ let break t =
rather than filtered, because a client that quietly dropped them
would leave someone asking where their restart went. *)
ok
([ ":restarts " ^ Wire.strings (List.map (fun (_, _, n) -> n) rs);
([ ":restarts " ^ Wire.strings (List.map (fun r -> r.rname) rs);
(* Beside each name and in the same order: its :report sentence,
where the clause is written, and the types it takes. *)
":details "
^ Wire.list
(List.map
(fun r ->
Wire.list
[ ":report"; Wire.quote r.rreport;
":at";
(match r.rat with
| Some a -> Wire.quote a
| None -> "nil");
":arity"; string_of_int r.rarity;
":params"; Wire.quote r.rsig ])
rs);
":unreachable "
^ Wire.ints
(List.filter_map
(fun (i, f, _) -> if takeable f then None else Some i)
(fun r -> if takeable r.rflag then None else Some r.ridx)
rs);
(* Which position abandons the evaluation this break is inside,
and [nil] when it is not inside one. A position and not the
@ -2040,8 +2091,8 @@ let break t =
the name would offer the program's restart as the way out of
an evaluation. *)
":abandon "
^ (match List.find_opt (fun (_, f, _) -> f = Boundary) rs with
| Some (i, _, _) -> string_of_int i
^ (match List.find_opt (fun r -> r.rflag = Boundary) rs with
| Some r -> string_of_int r.ridx
| None -> "nil");
(* Why those positions are refused, which is not the same
question as which they are. A break taken by a trap has no
@ -2054,7 +2105,7 @@ let break t =
program took on its own, and a list so long it was
truncated. *)
":trap " ^ (if trap then "t" else "nil") ]
@ site_fields t)
@ site_fields t @ sentence_fields t)
| Error m -> error ("the program refused to list its restarts: " ^ m))
(* [(:op "backtrace")] — the frames of a stopped program, innermost first.
@ -3387,7 +3438,55 @@ let accepted reply =
| "ok abandon" -> Some true
| _ -> None
let choose_at t ~index ~name =
(* A restart that takes values gets them before it is taken: [:args] is one
expression per parameter, which [Session.arm_restart] checks against the
parameter's own type and a thunk stores into the frame's buffer, as an
[invoke-restart] would have. Only then is the choice sent, and the agent
refuses a restart that takes values and was not given them. [Ok ""] when
nothing was given, without a round trip: most restarts take nothing, and
the agent says so when one that takes values was sent none. *)
let arm_restart t ~index ~name ~args =
if args = [] then Ok "" else
match restarts t with
| Error m -> Error ("the program refused to list its restarts: " ^ m)
| Ok (rows, _) ->
(match List.find_opt (fun r -> r.ridx = index) rows with
| None -> Error "there is no restart at that index; list the restarts again"
| Some r ->
(match name with
| Some n when not (String.equal n r.rname) ->
Error
("that index is now " ^ r.rname
^ ", not what you named; list the restarts again")
| _ ->
let given = List.length args in
if given <> r.rarity then
Error
(Printf.sprintf "restart %s takes %s, %d %s, and was given %d"
r.rname r.rsig r.rarity
(if r.rarity = 1 then "value" else "values")
given)
else
(match Session.restart_params t.session r.rsig with
| Error m -> Error m
| Ok params ->
(match stop_gen t with
| None | Some 0 ->
Error "the program resumed while this was being asked"
| Some gen ->
let held = Session.held t.session in
let refused m = Session.restore t.session held; Error m in
(match
Session.arm_restart t.session ~index ~params ~codes:args
with
| exception Loc.Error { Loc.dmsg = why; _ } -> refused why
| Error why -> refused why
| Ok (c, _) ->
(match run_render_thunk ~at_stop:gen t ~tag:"r" ~c with
| Error m -> refused m
| Ok v -> Ok v))))))
let choose_at ?(args = []) t ~index ~name =
match liveness t with
| Gone -> error gone
| Parked when not (parked_break t) ->
@ -3407,6 +3506,9 @@ let choose_at t ~index ~name =
| None -> false
then error "a restart name cannot contain a control character"
else
match arm_restart t ~index ~name ~args with
| Error m -> error m
| Ok given ->
let verb =
"restart-at " ^ string_of_int index
^ match name with Some n -> " " ^ n | None -> ""
@ -3414,9 +3516,12 @@ let choose_at t ~index ~name =
match ask t verb with
| reply when accepted reply <> None ->
ok
[ ":index " ^ string_of_int index;
":note "
^ taken_note ~abandoned:(accepted reply = Some true) ]
([ ":index " ^ string_of_int index;
":note "
^ taken_note ~abandoned:(accepted reply = Some true) ]
(* The values the clause will bind, as the program now holds them. *)
@ (if given = "" then []
else [ ":values " ^ Wire.strings (String.split_on_char '\n' given) ]))
| reply -> error (String.trim reply)
| exception Unix.Unix_error (e, _, _) ->
error (unreachable t e)
@ -3471,11 +3576,11 @@ let abort t =
[eval_escape]), and it is offered the same way. *)
| Parked
when match restarts t with
| Ok (rs, _) -> List.exists (fun (_, f, _) -> f = Boundary) rs
| Ok (rs, _) -> List.exists (fun r -> r.rflag = Boundary) rs
| _ -> false ->
(match restarts t with
| Ok (rs, _) ->
let i, _, _ = List.find (fun (_, f, _) -> f = Boundary) rs in
let i = (List.find (fun r -> r.rflag = Boundary) rs).ridx in
(match ask t ("restart-at " ^ string_of_int i) with
| reply when accepted reply <> None ->
ok
@ -4463,7 +4568,19 @@ let handle t req =
showed. *)
| Some "restart-at" ->
(match Wire.int_field req "index" with
| Some index -> choose_at t ~index ~name:(Wire.string_field req "name")
| Some index ->
(* [:args] is one expression per parameter, for a restart that takes
values; see [arm_restart]. *)
let args =
match Wire.field req "args" with
| Some { Form.v = Form.List l; _ } ->
List.filter_map
(fun (f : Form.t) ->
match f.Form.v with Form.Str s -> Some s | _ -> None)
l
| _ -> []
in
choose_at ~args t ~index ~name:(Wire.string_field req "name")
| None -> error "restart-at needs :index")
| Some "abort" -> abort t
(* No fields: the only thing it could take is which function to run, and the

212
lib/emit.ml
View File

@ -210,15 +210,32 @@ module Rt = struct
{ sname = "handler";
fields = [ "prev", Ptr; "type", I32; "fn", Ptr; "env", Ptr ] }
(* A restart frame. The first four fields are what the runtime's own
[flan_restart] declares and their offsets do not move; the rest are §3's
parameter passing, described where the type is written into the header. *)
(* A restart frame, field for field the runtime's [flan_restart]. The first
four are the lookup; [args] to [siglen] are §3's parameter passing,
described where the type is written into the header; the last five are
for a break loop and nothing reads them on the way to a transfer: where
the clause is written, its [:report] sentence, and [flags], whose bit 0
says the checker made the clause up (a [handler-case]'s landing). *)
let restart =
{ sname = "restart";
fields =
[ "prev", Ptr; "name_id", I32; "name", Ptr; "namelen", I64;
"args", Ptr; "arity", I32; "sig_id", I32; "armed", I32;
"sig", Ptr; "siglen", I64 ] }
"sig", Ptr; "siglen", I64;
"loc", Ptr; "loclen", I64; "report", Ptr; "reportlen", I64;
"flags", I32 ] }
(* What a signal site says about its condition — the runtime's
[flan_condesc]. The first four fields are the prelude's [Error] laid out,
because a handler that matched through a parent link is handed this
rather than the condition. [chain] is the type ids from the condition's
own to its root; [loc] is the signal site. *)
let condesc =
{ sname = "condesc";
fields =
[ "name", Ptr; "namelen", I64; "message", Ptr; "messagelen", I64;
"chain", Ptr; "chainlen", I64; "loc", Ptr; "loclen", I64;
"render", Ptr; "flags", I32 ] }
(* The static description of a function, and the shadow-stack frame that
points at one. Dev builds only (runtime/flan_dev.c). *)
@ -228,8 +245,12 @@ module Rt = struct
[ "name", Ptr; "namelen", I64; "loc", Ptr; "loclen", I64;
"nslots", I32; "slots_fp", I32; "refs_fp", I32 ] }
(* [at] is the call this frame is in: the site of the last Flan call it
made, as a NUL-terminated file:line:col, stored after the arguments and
before the call. Null until the first. *)
let flanframe =
{ sname = "flanframe"; fields = [ "prev", Ptr; "info", Ptr; "slots", Ptr ] }
{ sname = "flanframe";
fields = [ "prev", Ptr; "info", Ptr; "slots", Ptr; "at", Ptr ] }
let align_up n a = (n + a - 1) / a * a
@ -318,9 +339,10 @@ let rec ll (t : Types.t) =
| Types.Enum _ -> "i32"
| Types.Array (n, e) -> Printf.sprintf "[%Ld x %s]" n (ll e)
| Types.Ptr _ -> "ptr"
(* An [Allocator] is a pointer to the runtime's [flan_allocator] and never a
copy of one: see Types. Opaque here in the same sense [ptr] is. *)
| Types.Alloc -> "ptr"
(* An [Allocator] is the runtime's [flan_allocator] record and the
incarnation of it the value was made for — flan_rt.c's [flan_alloc_value].
The runtime is handed its address; see [Check.use_alloc]. *)
| Types.Alloc -> "%alloc"
(* A code address and the environment it is called with: two words, always,
whether or not this particular value captured anything. See [%fnv]. *)
| Types.Fn _ -> "%fnv"
@ -581,7 +603,7 @@ let rec lay m (t : Types.t) : int * int =
| Types.Unit | Types.Never -> 0, 1
| Types.Enum _ -> 4, 4
| Types.Ptr _ -> 8, 8
| Types.Alloc -> 8, 8
| Types.Alloc -> 16, 8
| Types.Fn _ -> 16, 8
| Types.CFn _ -> 8, 8
| Types.Vec _ | Types.Map _ -> 40, 8
@ -1095,19 +1117,20 @@ let rec dty m d (t : Types.t) : int =
(List.map (fun i -> Printf.sprintf "!%d" i) ms)));
id
| None -> internal "no debug type for struct %s" sn)
(* An opaque pointer under lldb, which is the truth: the allocator's
fields are the runtime's C and lldb already has that type from
flan_rt.c's own debug info. *)
(* The record as an opaque pointer — its fields are the runtime's C and
lldb already has that type from flan_rt.c's own debug info — and the
incarnation beside it. *)
| Types.Alloc ->
dnode d
"!DIDerivedType(tag: DW_TAG_pointer_type, name: \"Allocator\", baseType: null, size: 64)"
composite "Allocator"
[ ("record", Types.Ptr (Types.Mut, Types.Unit));
("incarnation", Types.Int Types.U64) ]
(* Shown as what it is. The epoch word is in the layout and so it is
here too: a debugger that showed four fields of a five-field struct
would put the reader's offsets out by one. *)
| Types.Vec e ->
composite (Types.to_string t)
[ ("ptr", Types.Ptr (Types.Mut, e)); ("len", Types.Int Types.I64);
("cap", Types.Int Types.I64); ("allocator", Types.Alloc);
("cap", Types.Int Types.I64); ("allocator", Types.Ptr (Types.Mut, Types.Unit));
("epoch", Types.Int Types.I64) ]
(* Five fields again, and shown as five for the same reason: a debugger
that showed fewer would put the reader's offsets out. [log2cap] is
@ -1118,7 +1141,7 @@ let rec dty m d (t : Types.t) : int =
composite (Types.to_string t)
[ ("data", Types.Ptr (Types.Mut, (Types.Int Types.U8)));
("len", Types.Int Types.I64); ("log2cap", Types.Int Types.I64);
("allocator", Types.Alloc); ("epoch", Types.Int Types.I64) ]
("allocator", Types.Ptr (Types.Mut, Types.Unit)); ("epoch", Types.Int Types.I64) ]
|> fun n -> ignore k; ignore v; n
(* Two words, and shown as two, the same rule the Vec and the Map above
follow: a debugger told a function value were one pointer would put
@ -1877,13 +1900,19 @@ let escape s =
Buffer.contents b
(* The constant itself, as the pointer and length a caller needs separately —
a bounds message crosses to C as ptr+len like any other slice. *)
a bounds message crosses to C as ptr+len like any other slice.
One byte more than the length, a NUL, which nothing reads through the
length. The x86 backend has always written it; this one writes it too, so
that a declare-c wrapper handed a literal can give C the constant itself
rather than a copy (see [Shim.cstr_helpers]) on either backend. A string
is still a pointer and a length, and no slice of one is promised a NUL. *)
let string_bytes m s =
let id = Printf.sprintf "@\".str.%d\"" m.nstr in
m.nstr <- m.nstr + 1;
Buffer.add_string m.strs
(Printf.sprintf "%s = private unnamed_addr constant [%d x i8] c\"%s\"\n"
id (String.length s) (escape s));
(Printf.sprintf "%s = private unnamed_addr constant [%d x i8] c\"%s\\00\"\n"
id (String.length s + 1) (escape s));
id, String.length s
let string_const m s =
@ -1918,6 +1947,18 @@ let fi_bytes m s =
id (String.length s) (escape s));
id, String.length s
(* A call site for a frame's [at], NUL-terminated because it is one pointer
stored per call and the reader takes its length. Counted on [m.nfi] for
[fi_bytes]' reason: the frame naming it is popped before the module could
go, and the break loop copies the text. *)
let fi_cstring m s =
let id = Printf.sprintf "@\".fi.%d\"" m.nfi in
m.nfi <- m.nfi + 1;
Buffer.add_string m.strs
(Printf.sprintf "%s = private unnamed_addr constant [%d x i8] c\"%s\\00\"\n"
id (String.length s + 1) (escape s));
id
(* What the two ends compare about a frame's slots, since neither can see the
other. Same idea as a restart frame's [rsig_id], and for the same reason: a
frame on the stack was compiled from *some* body, the session holds
@ -1959,6 +2000,36 @@ let fninfo m (fn : Tast.fn) ~nslots =
(Reach.ref_fingerprint ~is_global:(Hashtbl.mem m.globals) fn) ]));
id
(* A signal site's [%condesc], as a constant: the name and the sentence through
[string_bytes], because a handler may carry their addresses away (a
handler-case copies them out) and that is what keeps a module holding them
loaded; the chain and the site through [fi_bytes]'s counter, because
nothing reads them after the signal returns — the break loop copies the
site. *)
let condesc m (d : Tast.condesc) loc =
let nid, nlen = string_bytes m d.Tast.cname in
(* A compiled condition carries no sentence: the runtime asks [render]. *)
let mid, mlen = string_bytes m "" in
let lid, llen = fi_bytes m (Loc.to_string loc) in
let cid = Printf.sprintf "@\".cd.%d\"" m.nfi in
m.nfi <- m.nfi + 1;
Buffer.add_string m.strs
(Printf.sprintf "%s = private unnamed_addr constant [%d x i32] [%s]\n" cid
(List.length d.Tast.cchain)
(String.concat ", "
(List.map (fun i -> Printf.sprintf "i32 %d" i) d.Tast.cchain)));
let id = Printf.sprintf "@\".cd.%d\"" m.nfi in
m.nfi <- m.nfi + 1;
Buffer.add_string m.strs
(Printf.sprintf "%s = private unnamed_addr constant %s\n" id
(Rt.ll_init Rt.condesc
[ nid; string_of_int nlen; mid; string_of_int mlen; cid;
string_of_int (List.length d.Tast.cchain); lid;
string_of_int llen;
(match d.Tast.crender with Some r -> fname r | None -> "null");
(if d.Tast.cself then "1" else "0") ]));
id
(* ── Bounds checks ───────────────────────────────────────────────────── *)
(* A failure is a branch to a [noreturn] call and then [unreachable] — the same
@ -1997,10 +2068,30 @@ let fail_block f (loc : Loc.t) ok emit_call =
**That is the answer to "does a trap run defers": an answered one does, an
unanswered one still does not, because the unanswered one is still a die
inside C.** *)
(* A dev build's frame records where it is when it hands control to something
that can come back into Flan: a call, a signal, a C function, a runtime
check that signals. So a backtrace names the call each frame is in, and a
frame re-entered through a handler names the signal and not whatever it
called last. Stored before and cleared after, so a frame that has come back
names nothing rather than a call that has already returned. One store each
side; nothing in a release build. *)
let mark_call f at =
match f.frame with
| None -> ()
| Some _ ->
let id = fi_cstring f.md (Loc.to_string at) in
ins f "store ptr %s, ptr %%frame.a" id
let clear_call f =
match f.frame with
| None -> ()
| Some _ -> if f.live then ins f "store ptr null, ptr %%frame.a"
let signal_block f (loc : Loc.t) ~guard ok emit_call =
let good = fresh_label f "inb" and bad = fresh_label f "oob" in
term f "br i1 %s, label %%%s, label %%%s" ok good bad;
label f bad;
mark_call f loc;
let id, n = string_bytes f.md (Loc.to_string loc) in
emit_call id n;
guard ();
@ -2500,7 +2591,7 @@ and value_at f (e : Tast.expr) : string =
it there. See [%fnv].
Only a [Fn]-typed one. The same three [fnref] constructors are also asked
for as bare addresses — carrying [CFn], and carrying [Alloc] for the
for as bare addresses — carrying [CFn], and carrying [(Ptr ())] for the
map's hash and equality pair and a handler frame's clause, which are
fields of structs the runtime declares — and those stay one word. The
node's type is what says which is being asked for. *)
@ -2562,9 +2653,13 @@ and value_at f (e : Tast.expr) : string =
| Tast.Prim (p, args) -> prim f e p args
| Tast.Call (name, args) ->
(match Hashtbl.find_opt f.md.externs name with
| Some sym -> extern_call f e.Tast.ty ("@" ^ sym) args
| Some sym ->
(* A C function may call back into Flan. *)
let r = extern_call ~at:e.Tast.loc f e.Tast.ty ("@" ^ sym) args in
clear_call f;
r
| None -> call f ~loc:e.Tast.loc e.Tast.ty name args)
| Tast.CallPtr (callee, args) -> call_ptr f e.Tast.ty callee args
| Tast.CallPtr (callee, args) -> call_ptr ~at:e.Tast.loc f e.Tast.ty callee args
| Tast.Do body -> block f body
| Tast.Let (bs, body) ->
List.iter
@ -2629,21 +2724,23 @@ and value_at f (e : Tast.expr) : string =
| Tast.UnwrapSome v -> emit_unwrap f e.Tast.ty v
(* The condition crosses as a pointer: a handler runs while the signalling
frame is still alive, so there is nothing to copy and nothing to own. *)
| Tast.Signal (Tast.Ssignal, id, c) ->
| Tast.Signal (Tast.Ssignal, d, c) ->
let p = addr_rooted f c in
ins f "call void @flan_signal(i32 %d, ptr %s, ptr %s)" id p xfer_param;
let dp = condesc f.md d e.Tast.loc in
mark_call f e.Tast.loc;
ins f "call void @flan_signal(ptr %s, ptr %s, ptr %s)" dp p xfer_param;
guard f;
clear_call f;
"zeroinitializer"
(* §2's diverging variant. [flan_error] does not return unless a handler
transferred, so the guard is the only way out and the fall-through is
unreachable. It cannot be marked noreturn for that reason — it does
return, on exactly one path. *)
| Tast.Signal (Tast.Serror, id, c) ->
| Tast.Signal (Tast.Serror, d, c) ->
let p = addr_rooted f c in
let name = struct_name_of c.Tast.ty in
let nid, nn = string_bytes f.md name in
ins f "call void @flan_error(i32 %d, ptr %s, ptr %s, ptr %s, i64 %d)"
id p xfer_param nid nn;
let dp = condesc f.md d e.Tast.loc in
mark_call f e.Tast.loc;
ins f "call void @flan_error(ptr %s, ptr %s, ptr %s)" dp p xfer_param;
guard f;
term f "unreachable";
"zeroinitializer"
@ -2998,12 +3095,15 @@ and stale_check f loc flan cell ps r =
and call f ?loc ret flan args =
let vs = map_lr (fun (a : Tast.expr) ->
let v = value f a in Printf.sprintf "%s %s" (ll a.Tast.ty) v) args in
Option.iter (mark_call f) loc;
(* The cell is loaded *after* the arguments, so a redefinition that lands
between two calls still cannot land in the middle of one. The signature
word is read beside it, for the same reason: an argument that polls can
install a new body, and the word checked has to be the body's own. *)
let callee = body_of f ?loc flan in
call_through f ret callee vs
let r = call_through f ret callee vs in
if loc <> None then clear_call f;
r
(* A call through a function value. Identical to the direct case once the
callee is in hand — a Flan function's signature is its parameters followed
@ -3015,7 +3115,7 @@ and call f ?loc ret flan args =
written in and the order a reader expects; the direct case is the other way
round for a reason that does not apply here (there is no cell to keep out of
the middle of an argument list). *)
and call_ptr f ret callee args =
and call_ptr ?at f ret callee args =
let c = value f callee in
(* A [(Fn ...)] is two words and both are taken before the arguments are
evaluated: an argument may itself make a function value, and the two
@ -3034,10 +3134,13 @@ and call_ptr f ret callee args =
in
let vs = map_lr (fun (a : Tast.expr) ->
let v = value f a in Printf.sprintf "%s %s" (ll a.Tast.ty) v) args in
call_through f ?env ret code vs
Option.iter (mark_call f) at;
let r = call_through f ?env ret code vs in
if at <> None then clear_call f;
r
(* The code address behind one of the three [fnref]s, which is the same string
whether it is wanted as a bare [Alloc] pointer or as the first word of a
whether it is wanted as a bare [(Ptr ())] or as the first word of a
function value.
[Flanfn] and [Rtfn] are the symbol itself, not a load from it: a function's
@ -3120,7 +3223,7 @@ and current_pad f =
argument type is a scalar, because [check.ml] rejects an extern signature
that would need an aggregate — that is the shim's job, in C, where clang
knows the target's calling convention. *)
and extern_call f ret name args =
and extern_call ?at f ret name args =
let vs =
List.concat_map
(fun (a : Tast.expr) ->
@ -3131,6 +3234,7 @@ and extern_call f ret name args =
| ty -> [ Printf.sprintf "%s %s" (ll ty) (value f a) ])
args
in
Option.iter (mark_call f) at;
if is_void ret then begin
ins f "call void %s(%s)" name (String.concat ", " vs);
"zeroinitializer"
@ -3310,6 +3414,14 @@ and emit_restart_case f ty clauses body =
let gid, glen = string_bytes f.md c.Tast.rsig in
ins f "store ptr %s, ptr %s" gid (restart_field f slot "sig");
ins f "store i64 %d, ptr %s" glen (restart_field f slot "siglen");
let lid, llen = string_bytes f.md (Loc.to_string c.Tast.rloc) in
ins f "store ptr %s, ptr %s" lid (restart_field f slot "loc");
ins f "store i64 %d, ptr %s" llen (restart_field f slot "loclen");
let rid, rlen = string_bytes f.md c.Tast.rreport in
ins f "store ptr %s, ptr %s" rid (restart_field f slot "report");
ins f "store i64 %d, ptr %s" rlen (restart_field f slot "reportlen");
ins f "store i32 %d, ptr %s" (if c.Tast.rhidden then 1 else 0)
(restart_field f slot "flags");
let args =
if c.Tast.rparams = [] then None
else begin
@ -4282,6 +4394,10 @@ let emit_fn m ?(hidden = false) ?(pnames = []) (fn : Tast.fn) =
(Rt.index Rt.flanframe "slots");
Printf.sprintf "store ptr %s, ptr %%frame.s"
(match f.slotv with Some v -> v | None -> "null");
Printf.sprintf
"%%frame.a = getelementptr inbounds %%flanframe, ptr %%frame, i32 0, i32 %d"
(Rt.index Rt.flanframe "at");
"store ptr null, ptr %frame.a";
"store ptr %frame, ptr @flan_frame_head" ];
f.frame <- Some prev;
(* The parameters are bound before the body starts, so they are recorded
@ -4683,6 +4799,9 @@ let header = {|; Generated by flan. The layout is C's: no object headers anywher
; A value that captures nothing carries a null there and every call passes it
; on regardless; see [env_param].
%fnv = type { ptr, ptr }
; An Allocator value: the runtime's record, and the incarnation of it the value
; was made for, so a value kept past its arena's destroy is caught on use.
%alloc = type { ptr, i64 }
; (Vec T), spec-memory.md. The element type is nowhere in it: the runtime is
; type-erased and every operation is handed size and align at its call site.
%vec = type { ptr, i64, i64, ptr, i64 }
@ -4694,6 +4813,10 @@ let header = {|; Generated by flan. The layout is C's: no object headers anywher
; lifted function that runs, and the environment that function is handed.
; Allocated on the establishing frame's stack.
|} ^ Rt.ll_type Rt.handler ^ {|
; What a signal site says about its condition: its name, the sentence a
; handler for a parent reads, the type ids from its own to its root, and the
; site. A constant per site; see [condesc].
|} ^ Rt.ll_type Rt.condesc ^ {|
; A restart frame: the one it displaced and the name it offers. There is no
; target field, because the frame's own address *is* the target — which makes
; a transfer's aim exact, and makes re-entering a restart-case work with
@ -4703,8 +4826,9 @@ let header = {|; Generated by flan. The layout is C's: no object headers anywher
; restart-case, because the invoker's frame is gone by the time a clause runs —
; how many there are, the hash of how they are spelled, whether anything has
; filled the buffer in, and that spelling itself for the message when the two
; ends disagree. The first four fields are what the runtime's own
; [flan_restart] declares and their offsets do not move.
; ends disagree. Then, for a break loop only, where the clause is written, its
; :report sentence, and flags (bit 0: a handler-case's own landing). The C
; [flan_restart] declares every one of these, in this order.
|} ^ Rt.ll_type Rt.restart ^ {|
; A shadow-stack frame and the static description of the function that pushed
; it (runtime/flan_dev.c). Dev builds only: [emit_fn] pushes one on entry and
@ -4725,10 +4849,11 @@ declare void @flan_f64_to_bytes(double, ptr, ptr)
declare void @flan_i64_to_bytes(i64, ptr, ptr)
declare void @flan_u64_to_bytes(i64, ptr, ptr)
declare void @flan_escape_bytes(ptr, i64, ptr)
declare void @flan_c_literal(ptr, i64, ptr)
declare void @flan_handler_push(ptr)
declare void @flan_handler_pop(ptr)
declare void @flan_signal(i32, ptr, ptr)
declare void @flan_error(i32, ptr, ptr, ptr, i64)
declare void @flan_signal(ptr, ptr, ptr)
declare void @flan_error(ptr, ptr, ptr)
declare void @flan_restart_push(ptr)
declare void @flan_restart_pop(ptr)
declare ptr @flan_find_restart(i32)
@ -4751,6 +4876,13 @@ declare void @flan_arith_error(ptr, i64, i32, i64, i64, ptr) cold
; something answered.
declare void @flan_stale_call(ptr, ptr, ptr, ptr, ptr) cold
declare ptr @flan_context_allocator()
declare ptr @flan_context_use(ptr, i64)
declare void @flan_context_value(ptr)
declare void @flan_free_temp()
declare i8 @flan_i64_temp(i64, ptr)
declare i8 @flan_f64_temp(double, ptr)
declare void @flan_alloc_seal(ptr, ptr)
declare ptr @flan_alloc_use(ptr, ptr, i64)
declare ptr @flan_context_temp()
declare ptr @flan_heap_allocator()
declare ptr @flan_context_set(ptr)
@ -4818,6 +4950,8 @@ declare void @flan_dyn_emit_watch(i64)
; into every build, so these resolve in a release build too.
declare i32 @flan_dev_watch_begin_n(ptr, i64)
declare void @flan_dev_watch_emit(ptr, i64)
declare void @flan_msg_emit(ptr, i64)
declare void @flan_dyn_emit_msg(i64)
declare void @flan_dev_watch_emit_str(ptr, i64)
declare void @flan_dev_watch_emit_i64(i64)
declare void @flan_dev_watch_emit_u64(i64)
@ -4860,7 +4994,7 @@ declare i8 @flan_vec_init(ptr, ptr, i64, i64, i64, ptr, i64)
declare i8 @flan_vec_reserve(ptr, i64, i64, i64, ptr, i64)
declare i8 @flan_vec_push(ptr, ptr, i64, i64, ptr, i64)
declare i8 @flan_vec_clone(ptr, ptr, ptr, i64, i64, ptr, i64)
declare i8 @flan_bytes_dup(ptr, ptr, ptr, i64, ptr, i64)
declare i8 @flan_bytes_dup(ptr, ptr, ptr, i64, i64, i64, ptr, i64)
declare i64 @flan_vec_len(ptr, ptr, i64)
; These two take the transfer channel as well, because a Vec's bounds check is
; inside the runtime rather than emitted here and (at v i) has to signal the

14
lib/load.ml
View File

@ -457,8 +457,9 @@ let qualify_decl owned alias (d : Ast.decl) : Ast.decl =
Ast.Defconst (qualify alias n,
Option.map (rename_texpr owned alias) t,
rename_expr owned alias [] v)
| Ast.Defstruct (n, fs) ->
Ast.Defstruct (qualify alias n, List.map (rename_field owned alias) fs)
| Ast.Defstruct (n, fs, p) ->
Ast.Defstruct (qualify alias n, List.map (rename_field owned alias) fs,
Option.map (rename_texpr owned alias) p)
(* An untagged union imports exactly as a struct does, and for the reason
the data type above does not: it is a field list and a layout, with no
case table for the use site to resolve names against. The FFI is the
@ -597,7 +598,7 @@ let rename_refs owned alias (d : Ast.decl) : Ast.decl =
| Ast.Defenum (_, ms), Ast.Defenum (n, _) -> Ast.Defenum (n, ms)
| Ast.Defalias (_, t), Ast.Defalias (n, _) -> Ast.Defalias (n, t)
| Ast.Defconst (_, t, v), Ast.Defconst (n, _, _) -> Ast.Defconst (n, t, v)
| Ast.Defstruct (_, fs), Ast.Defstruct (n, _) -> Ast.Defstruct (n, fs)
| Ast.Defstruct (_, fs, p), Ast.Defstruct (n, _, _) -> Ast.Defstruct (n, fs, p)
| Ast.Defunion (_, fs), Ast.Defunion (n, _) -> Ast.Defunion (n, fs)
| Ast.Defdata (_, vs), Ast.Defdata (n, _) -> Ast.Defdata (n, vs)
| Ast.Defvar (_, t, i, r), Ast.Defvar (n, _, _, _) -> Ast.Defvar (n, t, i, r)
@ -907,7 +908,8 @@ let decl_uses acc (d : Ast.decl) =
match d.Ast.d with
| Ast.Package _ | Ast.Import _ | Ast.Defenum _ -> ()
| Ast.Defalias (_, t) -> texpr_uses acc t
| Ast.Defstruct (_, fs) | Ast.Defunion (_, fs) -> List.iter field fs
| Ast.Defstruct (_, fs, p) -> List.iter field fs; Option.iter (texpr_uses acc) p
| Ast.Defunion (_, fs) -> List.iter field fs
| Ast.Defdata (_, vs) ->
List.iter (fun (v : Ast.variant) -> List.iter field v.Ast.vfields) vs
| Ast.Defn f -> fn f
@ -1287,7 +1289,7 @@ let rec import ~seen ~open_ ~loc alias dir =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with
| Ast.Defstruct (n, _) -> Some n
| Ast.Defstruct (n, _, _) -> Some n
| _ -> None)
ds
and known_unions =
@ -1356,7 +1358,7 @@ let rec import ~seen ~open_ ~loc alias dir =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with
| Ast.Defstruct (n, fs) -> Some (n, fs, d.Ast.dloc)
| Ast.Defstruct (n, fs, _) -> Some (n, fs, d.Ast.dloc)
| _ -> None)
ds
in

42
lib/parse.ml
View File

@ -690,11 +690,28 @@ and form f mk (head : Form.t) (args : Form.t list) : Ast.expr =
in
let clause (c : Form.t) =
match c.Form.v with
(* [:report "..."] after the parameters is what a break loop shows
beside the name — SBCL's placement, and its string form only. *)
| Form.List
({ v = Form.Sym n; _ } :: { v = Form.Vec ps; _ }
:: { v = Form.Kw "report"; _ } :: { v = Form.Str r; _ } :: cbody)
when cbody <> [] ->
{ Ast.rname = n; rparams = fields c ps; rreport = Some r;
rbody = List.map expr cbody; rloc = c.Form.loc }
| Form.List
({ v = Form.Sym _; _ } :: { v = Form.Vec _; _ }
:: ({ v = Form.Kw "report"; _ } as k) :: _) ->
fail k
"a restart's :report is a string followed by the clause body, as in \
(retry [] :report \"Try again\" (do))"
| Form.List ({ v = Form.Sym n; _ } :: { v = Form.Vec ps; _ } :: cbody)
when cbody <> [] ->
{ Ast.rname = n; rparams = fields c ps;
{ Ast.rname = n; rparams = fields c ps; rreport = None;
rbody = List.map expr cbody; rloc = c.Form.loc }
| _ -> fail c "a restart-case clause is (name [p T] body ...)"
| _ ->
fail c
"a restart-case clause is (name [p T] body ...), or (name [p T] \
:report \"...\" body ...)"
in
mk (Ast.RestartCase (expr body, List.map clause clauses))
@ -1329,10 +1346,27 @@ let rec decl (f : Form.t) : Ast.decl =
| [ n; t ] -> mk (Ast.Defalias (dname n, texpr t))
| _ -> fail f "defalias is (defalias Name Type)")
(* A parent comes before the fields, where Common Lisp's define-condition
puts its supertypes. With no field vector the struct is a category: it
has the fields every parent has, which are the root [Error]'s, so a
handler for it reads the name and the sentence of whatever matched. *)
| List ({ v = Sym "defstruct"; _ } :: args) ->
(match args with
| [ n; { v = Vec fs; _ } ] -> mk (Ast.Defstruct (dname n, fields f fs))
| _ -> fail f "defstruct is (defstruct Name [field Type ...])")
| [ n; { v = Vec fs; _ } ] ->
mk (Ast.Defstruct (dname n, fields f fs, None))
| [ n; { v = Kw "parent"; _ }; p; { v = Vec fs; _ } ] when fs <> [] ->
mk (Ast.Defstruct (dname n, fields f fs, Some (texpr p)))
(* An empty field vector is the same category as none. *)
| [ n; { v = Kw "parent"; _ }; p ] | [ n; { v = Kw "parent"; _ }; p; { v = Vec []; _ } ] ->
let str name =
{ Ast.fname = name; fty = { Ast.t = Ast.Tname "string"; tloc = f.loc };
floc = f.loc }
in
mk (Ast.Defstruct (dname n, [ str "name"; str "message" ], Some (texpr p)))
| _ ->
fail f
"defstruct is (defstruct Name [field Type ...]), or with a parent \
(defstruct Name :parent Parent [field Type ...])")
| List ({ v = Sym "defdata"; _ } :: args) ->
(match args with

75
lib/prelude.ml
View File

@ -43,6 +43,25 @@
the printer it was being forced through was the wrong one. *)
let source = {flan|
;; The root every built-in error descends from. A condition type names its
;; parent where it is declared — (defstruct FileError :parent Error [...]) —
;; and a handler for a type answers every condition below it, so one handler
;; for Error catches any error:
;;
;; (handler-case (run) [(Error [e] (println (.name e)) (println (.message e)))])
;;
;; A handler that matched through a parent is handed the condition's name and
;; a sentence saying what went wrong, not the condition's own fields: the
;; handler's type is the parent's, and the fields are the child's. That is
;; why a parent has exactly these two fields, and why a type declared with a
;; parent and no field vector — a category, (defstruct Category :parent
;; Error) — gets them. The sentence has no values in it; a handler for the
;; condition's own type reads those from its fields. A program's own
;; condition has an empty sentence, since its fields say what it is.
;;
;; (pause) and warnings are not under Error: a breakpoint is not a failure.
(defstruct Error [name string message string])
;; The condition every allocating operation signals when the allocator cannot
;; satisfy a request — spec-memory.md, "Allocation failure". It is here rather
;; than built by the checker because it is an ordinary value struct and the
@ -54,7 +73,7 @@ let source = {flan|
;; allocator's address, which is its identity — the same thing the epoch hangs
;; off — so a handler can tell which region ran out. Rendering happens in the
;; handler or the break loop, where a working allocator is known.
(defstruct StorageExhausted [bytes i64 align i64 allocator i64])
(defstruct StorageExhausted :parent Error [bytes i64 align i64 allocator i64])
;; What an out-of-range index signals. Same shape as StorageExhausted and for
;; the same reasons: fixed numeric fields, no rendered message, nothing that
@ -92,7 +111,7 @@ let source = {flan|
;; being pushed here. That is plan.org's "restarts go at the resync point,
;; once", with allocation and file failure as the named exceptions and this on
;; the default side of the rule.
(defstruct BoundsError [low i64 high i64 length i64])
(defstruct BoundsError :parent Error [low i64 high i64 length i64])
;; What an arithmetic operation with no answer signals. Three situations, and
;; until now none of them had a defined behaviour: a divide or remainder by
@ -116,18 +135,17 @@ let source = {flan|
;; fields are a C struct that has to agree with this one field for field**,
;; the same hand-kept agreement flan_bounds_cond keeps with BoundsError.
;;
;; `op` is a small integer and not a keyword, exactly as FileError's `op` is,
;; because the field is filled in from C and a keyword is not a thing that
;; exists there. The codes:
;; `op` is an ArithOp, an i32 at run time, which is what lets the runtime fill
;; it in from C; the members' numbers are flan_rt.c's FLAN_ARITH_* codes:
;;
;; 0 (/ a 0) 1 (% a 0)
;; 2 (/ min -1) 3 (% min -1)
;; 4 a float to integer cast whose value does not fit
;; 5 a float to integer cast of NaN
;; 6 a float to integer cast of an infinity
;; :div-zero (/ a 0) :rem-zero (% a 0)
;; :div-overflow (/ min -1) :rem-overflow (% min -1)
;; :cast-range a float to integer cast whose value does not fit
;; :cast-nan a float to integer cast of NaN
;; :cast-inf a float to integer cast of an infinity
;;
;; `lhs` and `rhs` are the two operands for codes 0 through 3 and the
;; destination type's representable range for codes 4 through 6 — the violated condition
;; `lhs` and `rhs` are the two operands for the first four and the
;; destination type's representable range for the casts — the violated condition
;; written as a range, which is what flan_slice_promise_error already does
;; with BoundsError's fields. Two meanings over two fields rather than two
;; condition types, so that a handler writes one clause and not five. The
@ -152,7 +170,11 @@ let source = {flan|
;; division by zero is the restart the program already established, a frame
;; loop's `continue`, which is reachable from a handler without anything being
;; pushed here.
(defstruct ArithError [op i32 lhs i64 rhs i64])
(defenum ArithOp
[div-zero 0 rem-zero 1 div-overflow 2 rem-overflow 3
cast-range 4 cast-nan 5 cast-inf 6])
(defstruct ArithError :parent Error [op ArithOp lhs i64 rhs i64])
;; A call that was compiled against one signature, reaching a function that
;; now has another. It exists only in a dev build: there every call to a Flan
@ -173,7 +195,7 @@ let source = {flan|
;; agreement flan_bounds_cond keeps with BoundsError. No restart is
;; established at the call, BoundsError's decision for BoundsError's reason:
;; nothing a handler supplies makes the old arguments fit the new body.
(defstruct StaleCall [callee string compiled string current string])
(defstruct StaleCall :parent Error [callee string compiled string current string])
;; What a generic function signals when no method answers. `generic` is the
;; name written at the defgeneric or defmulti, and `value` is what the
@ -195,7 +217,7 @@ let source = {flan|
;;
;; No restart is established at the miss, which is BoundsError's decision
;; taken for BoundsError's reason -- see the note above it.
(defstruct NoMethod [generic string value dyn])
(defstruct NoMethod :parent Error [generic string value dyn])
;; A breakpoint. (pause) stops the program where it stands and hands it to the
;; break loop, with the whole stack under it readable — C-c C-b lists the
@ -1666,13 +1688,10 @@ let source = {flan|
(dotimes [i (length s)]
(push (deref b) (at s i))))
;; The two number appends, and they are the reason this shape is worth having
;; rather than a formatter that answers a slice. i64->bytes and f64->bytes
;; render into one shared static buffer in the runtime, so two of their results
;; cannot be held at once and (concat [(i64->bytes a) (i64->bytes b)]) is two
;; views of the same bytes — the second call overwrote the first. These copy
;; out of that buffer before returning, so the hazard ends at the call: a
;; builder can hold as many numbers as it likes.
;; The two number appends. Outside the prelude i64->bytes and f64->bytes copy
;; their text into the temp allocator; inside it they answer a view of the
;; frame slot they render into (check.ml, the "i64->bytes" arm), so these
;; append the text without an allocation per number.
(defn append-i64 [b (Ptr (Vec u8)) n i64] ()
(append b (i64->bytes n)))
@ -1791,14 +1810,10 @@ let source = {flan|
;; which is six significant digits and switches to exponent notation on its
;; own: a frame time of 0.0166667 is what a caller wanted two decimals of, and
;; 1.23457e+06 is what a score looks like once it passes a million. There is no
;; precision to pass it, and there cannot be — it renders into one shared
;; static buffer in the runtime, which is the same reason two of its results
;; cannot be held at once.
;; precision to pass it.
;;
;; This returns a Vec, so neither problem is inherited. It uses i64->bytes
;; twice and the two calls are strictly sequential — the integer part is copied
;; into the Vec before the fraction is rendered — which is the discipline the
;; shared buffer requires and the one append-i64 exists to make automatic.
;; This returns a Vec. Its i64->bytes calls answer frame-slot views, since this
;; is the prelude, and each is copied into the Vec before the next is made.
;;
;; Half away from zero, the same rule round-f32 follows, applied at the last
;; digit kept. That is not bit-for-bit printf: printf rounds the *binary* value
@ -1966,7 +1981,7 @@ let source = {flan|
;; parent link, not class inheritance", decides on is the
;; answer to that, and it is not built; when it is, these reasons can become
;; types without any call site changing.
(defstruct FileError [path string op i32 reason i32])
(defstruct FileError :parent Error [path string op i32 reason i32])
(defconst file-op-read i32 0)
(defconst file-op-write i32 1)

2
lib/reach.ml
View File

@ -59,6 +59,8 @@ let expr_refs f (e : Tast.expr) =
| Tast.Set (Tast.Pglobal n, _) | Tast.Addr (Tast.Pglobal n) -> f n
| Tast.Handled (frames, _) ->
List.iter (fun (h : Tast.hframe) -> f h.Tast.hfn) frames
(* The condition's printer, reached from the signal's descriptor. *)
| Tast.Signal (_, d, _) -> Option.iter f d.Tast.crender
(* A [CallPtr] roots no name: whatever it calls was reached as a value,
and the [FnAddr] that produced it is a node inside the callee. *)
| _ -> ())

152
lib/session.ml
View File

@ -1318,6 +1318,21 @@ let eval ?(origin = "<eval>") ?base ?forms ?pause ?(running = true) t src : chan
path for anything that prints, and a dev-only feature must not put a branch
in it. *)
(* The functions checking an expression lifted out of it — a handler clause,
a condition's printer — which the checker hangs on a function it calls
[<none>], since an expression has no enclosing one. They belong to the
thunk the expression becomes, and a redefinition module brings a lifted
function along only with its parent, so each is handed to [thunk]. *)
let lifted_mark t = Check.lifted_mark t.env
let claim_lifted t mark thunk =
List.filter_map
(fun (f : Tast.fn) ->
if f.Tast.fparent = Some "<none>" then
Some { f with Tast.fparent = Some thunk }
else None)
(Check.lifted_since t.env mark)
type emitter = { ename : string; ety : Types.t }
let emit_bytes = { ename = "flan/dev-emit"; ety = Types.Slice (Types.Mut, (Types.Int Types.U8)) }
@ -1350,6 +1365,15 @@ let externs : Tast.extern list =
{ Tast.ename = "flan/dev-cond"; esym = "flan_agent_condition";
eparams = []; eret = Types.Ptr (Types.Mut, (Types.Int Types.U8));
eloc = Loc.unknown };
(* A typed restart's parameter, by the restart's index in the snapshot on
top and a byte offset into its buffer, and the flag that says the
buffer was written. See [arm_restart]. *)
{ Tast.ename = "flan/dev-restart-arg"; esym = "flan_agent_restart_arg";
eparams = [ Types.Int Types.I64; Types.Int Types.I64 ];
eret = Types.Ptr (Types.Mut, Types.Int Types.U8); eloc = Loc.unknown };
{ Tast.ename = "flan/dev-restart-arm"; esym = "flan_agent_restart_arm";
eparams = [ Types.Int Types.I64 ]; eret = Types.Unit;
eloc = Loc.unknown };
(* The character beside a rendered byte. See [Render.pointers]. *)
{ Tast.ename = "flan/dev-emit-u8-char"; esym = "flan_dev_emit_u8_char";
eparams = [ Types.Int Types.I64 ]; eret = Types.Unit;
@ -2175,6 +2199,7 @@ let write_slot ?(origin = "<set>") t ~frame ~(fn : Tast.fn) ~slot ~path
thunk would have the second one's [let] reading and writing the
first one's storage. *)
let mark = Check.instance_mark t.env in
let lmark = lifted_mark t in
let wanted =
List.map
(fun (at, _, tty, code) ->
@ -2247,7 +2272,9 @@ let write_slot ?(origin = "<set>") t ~frame ~(fn : Tast.fn) ~slot ~path
in
let program =
{ t.program with
Tast.fns = t.program.Tast.fns @ fresh @ [ thunk ];
Tast.fns =
t.program.Tast.fns @ fresh @ claim_lifted t lmark tname
@ [ thunk ];
externs = t.program.Tast.externs @ externs }
in
let ir =
@ -2265,6 +2292,129 @@ let write_slot ?(origin = "<set>") t ~frame ~(fn : Tast.fn) ~slot ~path
({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] },
where, Types.to_string shown.Tast.ty))))
(* ── A typed restart, taken from the break loop ──────────────────────── *)
(* The types a restart takes, read back from how its frame spells them —
[Check.restart_sig], a parenthesised list of [Types.to_string]s, which the
reader reads as one list of type forms. *)
let restart_params t sg =
match Reader.read_all ~file:"<restart>" sg with
| [ { Form.v = Form.List forms; _ } ] ->
(match List.map (fun f -> Check.resolve t.env (Parse.texpr f)) forms with
| tys -> Ok tys
| exception Loc.Error { Loc.dmsg = why; _ } ->
Error ("the restart takes " ^ sg ^ ", and " ^ why))
| _ -> Error ("the restart's parameters are spelled " ^ sg ^ ", which is not a list of types")
(* What [invoke-restart] does to a frame before it aims the channel, done by a
thunk instead: each value, checked against the parameter's own type, stored
at its offset in the buffer the frame owns, and the flag set that says the
buffer was written. The offsets are [Emit.lay_fields] over the parameter
types, which is how both backends lay out that buffer and how the invoker
and the clause agree on it.
The values are expressions, checked in the session like any evaluated one,
so the refusal for a value that does not fit is the checker's own sentence.
The thunk renders the stored values back, which is what the program holds
now rather than what was asked for. *)
let arm_restart ?(origin = "<restart>") t ~index ~(params : Types.t list)
~(codes : string list) : (change * string list, string) result =
let loc = Loc.unknown in
let md = X86.layout_ctx ~checks:false ~dev:true t.program in
let _, _, offs = Emit.lay_fields md params in
let mark = Check.instance_mark t.env in
let lmark = lifted_mark t in
let wanted =
List.map2
(fun ty code ->
let form =
match Reader.read_all ~file:origin code with
| [ f ] -> f
| [] -> fail loc "a value for a %s is empty" (Types.to_string ty)
| _ :: f :: _ -> fail f.Form.loc "one value for each parameter"
in
(Some ty, Parse.with_imported t.macros (fun () -> Parse.expr form)))
params codes
in
let values, base, bnames = Check.expressions t.env wanted in
let fresh = Check.instances_since t.env mark in
let i64 n =
{ Tast.e = Tast.Int (Int64.of_int n, Types.I64); ty = Types.Int Types.I64; loc }
in
let at ty off =
let raw =
{ Tast.e = Tast.Call ("flan/dev-restart-arg", [ i64 index; i64 off ]);
ty = Types.Ptr (Types.Mut, Types.Int Types.U8); loc }
in
{ Tast.e = Tast.Prim (Tast.Cast (Types.Ptr (Types.Mut, ty)), [ raw ]); ty = Types.Ptr (Types.Mut, ty); loc }
in
let stores =
List.map2
(fun (ty, off) (v : Tast.expr) ->
{ Tast.e = Tast.Set (Tast.Pderef (at ty off), v); ty = Types.Unit; loc })
(List.combine params offs) values
in
let arm =
{ Tast.e = Tast.Call ("flan/dev-restart-arm", [ i64 index ]); ty = Types.Unit; loc }
in
let extra = ref [] and nslots = ref (Array.length base) in
let c =
{ Render.structs = t.program.Tast.structs;
datas = t.program.Tast.datas;
unions = t.program.Tast.unions;
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums [];
emit = dev_emitter;
ptrs = Some dev_pointers;
alloc = (fun ty ->
let i = !nslots in
incr nslots;
extra := ty :: !extra;
i) }
in
let bytes_of str =
{ Tast.e =
Tast.Prim (Tast.Bytes, [ { Tast.e = Tast.Str str; ty = Types.String; loc } ]);
ty = Types.Slice (Types.Mut, Types.Int Types.U8); loc }
in
let lit str = c.Render.emit.Render.ebytes (bytes_of str) in
match
List.concat
(List.map2
(fun (ty, off) k ->
(if k > 0 then [ lit "\n" ] else [])
@ Render.render c 0 { Tast.e = Tast.Deref (at ty off); ty; loc })
(List.combine params offs)
(List.init (List.length params) Fun.id))
with
| exception Loc.Error { Loc.dmsg = why; _ } -> Error why
| shown ->
let nullary n = { Tast.e = Tast.Call (n, []); ty = Types.Unit; loc } in
t.thunks <- t.thunks + 1;
let tname = Printf.sprintf "restart/%d" t.thunks in
let thunk : Tast.fn =
{ Tast.name = tname; params = []; ret = Types.Unit;
body =
stores @ [ arm ] @ (nullary "flan/dev-begin" :: shown)
@ [ nullary "flan/dev-end" ];
fdefers = []; fenv = None; fparent = None; floc = loc;
slots = Array.append base (Array.of_list (List.rev !extra));
snames = Array.append bnames (Array.make (List.length !extra) None) }
in
let program =
{ t.program with
Tast.fns =
t.program.Tast.fns @ fresh @ claim_lifted t lmark tname @ [ thunk ];
externs = t.program.Tast.externs @ externs }
in
let ir =
redefinition t ~call:tname program
~fns:(List.map (fun (f : Tast.fn) -> f.Tast.name) fresh @ [ tname ])
in
t.program <- { t.program with Tast.fns = t.program.Tast.fns @ fresh };
Ok
({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] },
List.map Types.to_string params)
(* ── The globals a stopped stack reaches ───────────────────────────── *)
(* The other half of what a break loop can show, and in this language arguably

25
lib/shim.ml
View File

@ -138,7 +138,7 @@ let scan (decls : Ast.decl list) =
List.iter
(fun (d : Ast.decl) ->
match d.Ast.d with
| Ast.Defstruct (n, fs) -> Hashtbl.replace env.structs n fs
| Ast.Defstruct (n, fs, _) -> Hashtbl.replace env.structs n fs
| Ast.Defenum (n, _) -> Hashtbl.replace env.enums n ()
| Ast.Defdata (n, _) -> Hashtbl.replace env.datas n ()
| Ast.Defunion (n, _) -> Hashtbl.replace env.unions n ()
@ -314,13 +314,26 @@ let header =
query needs for the same reason: C reads to the first NUL, so what crosses
would be a prefix of the string the program passed and the function would
act on a value nobody wrote. The refusal is the runtime's — the shim has no
condition channel — and it names the declare-c it came from. *)
condition channel — and it names the declare-c it came from.
A literal is the one string that crosses uncopied. Both backends write a
NUL after a literal's bytes, and at a declare-c call whose argument is a
literal the checker passes it with its length encoded as -(n+1)
([Check.c_literals]). No other Flan string has a negative length, so the
wrapper hands such a pointer to C as it is, after the same embedded-NUL
refusal. Every other string is copied, whatever its last byte is. *)
let cstr_helpers =
"_Noreturn void flan_shim_nul_fail(const char *site);\n\n\
static char *flan_shim_cstr(const char *p, int64_t n, char *buf, size_t cap,\n\
\ const char *site) {\n\
\ size_t len = n <= 0 ? 0 : (size_t)n;\n\
\ size_t len;\n\
\ char *d = buf;\n\
\ if (n < 0) { /* a literal, NUL-terminated by the compiler */\n\
\ len = (size_t)(-(n + 1));\n\
\ if (len != 0 && memchr(p, '\\0', len) != NULL) flan_shim_nul_fail(site);\n\
\ return (char *)p;\n\
\ }\n\
\ len = (size_t)n;\n\
\ if (len != 0 && memchr(p, '\\0', len) != NULL) flan_shim_nul_fail(site);\n\
\ if (len + 1 > cap) {\n\
\ d = (char *)malloc(len + 1);\n\
@ -330,8 +343,8 @@ let cstr_helpers =
\ d[len] = '\\0';\n\
\ return d;\n\
}\n\n\
static void flan_shim_cstr_free(char *d, char *buf) {\n\
\ if (d != buf) free(d);\n\
static void flan_shim_cstr_free(char *d, char *buf, const char *p) {\n\
\ if (d != buf && d != p) free(d);\n\
}\n\n"
let cstr_cap = 256
@ -480,7 +493,7 @@ let c_for (s : shim) =
match k with
| Pstr ->
let a = arg_name i in
Printf.bprintf b " flan_shim_cstr_free(%s, %s_b);\n" a a
Printf.bprintf b " flan_shim_cstr_free(%s, %s_b, %s_p);\n" a a a
| _ -> ())
s.sargs;
match s.sret with

26
lib/tast.ml
View File

@ -219,7 +219,7 @@ and expr_kind =
nothing here alters control flow. [HandlerBind] pushes one frame per
clause, runs its body, and pops them; each clause was lifted into its own
function by the checker, so what is left is the frame and the call. *)
| Signal of sigkind * int * expr (* how, the type id, the condition *)
| Signal of sigkind * condesc * expr (* how, what, the condition *)
| Handled of hframe list * expr list
(* The transfer, spec-conditions.md §3–§6. [RestartCase] pushes one frame per
clause, runs its body, and pops them; if a transfer arrives naming one of
@ -276,6 +276,20 @@ and fnref = Flanfn of string | Rtfn of string | Fnval of string
and sigkind = Ssignal | Serror
(* What a signal site says about its condition, which the backends write out
as a constant the runtime's [flan_condesc] reads: the type's name, the type
ids from its own to its root ([Check.condition_chain]), and how a handler
for a parent is told what it caught. *)
and condesc =
{ cname : string; cchain : int list;
(* The type's own fields are Error's, so the condition is its own view:
a handler for a parent reads its [name] and [message] directly. *)
cself : bool;
(* The lifted function that prints the condition, with its values, into
the runtime's message sink — what a handler for a parent reads as the
message. [None] when nothing can catch it through a parent. *)
crender : string option }
and place =
| Plocal of int
| Pglobal of string
@ -301,10 +315,16 @@ and hframe = { htype : int; hfn : string; henv : expr option }
[rparams] are the slots §3's parameters are bound to, in order, with their
types; the invoker stores into a buffer this frame owns and the clause loads
them from it. [rsig] is how those types are spelled and [rsig_id] its hash:
what the two ends compare, since neither can see the other. *)
what the two ends compare, since neither can see the other.
[rloc], [rreport] and [rhidden] are for a break loop and nothing else: where
the clause is written, the sentence it shows beside its name ([""] when it
wrote none), and whether it is one the checker made up — a [handler-case]'s
own landing, which no one at a break loop could mean to take. *)
and rclause =
{ rname_id : int; rname : string; rparams : (int * Types.t) list;
rsig : string; rsig_id : int; rbody : expr list }
rsig : string; rsig_id : int; rbody : expr list;
rloc : Loc.t; rreport : string; rhidden : bool }
(* [binds] are the slots the pattern's fields are bound to, in field order. *)
and arm = { acase : string option; binds : int list; abody : expr list }

7
lib/types.ml
View File

@ -49,9 +49,10 @@ type t =
is what lets spec-memory.md's "procedure plus an opaque data pointer" be
expressed with none of milestone 5's function values — the procedure is a
C symbol the emitter names and no Flan type ever mentions it. At run time
it is a pointer to the runtime's [flan_allocator], never a copy of one:
the capability set and the epoch have to be shared by every container
made from it, and a copy would give each its own. *)
it is two words: a pointer to the runtime's [flan_allocator], never a
copy of one — the capability set and the epoch have to be shared by every
container made from it — and the incarnation of it the value was made
for, which arena-destroy bumps so a stale value traps on use. *)
| Alloc
(* [(Vec T)]: ptr + len + cap + allocator, owning and move-only. One
type-erased runtime over (size, align) stands behind every instantiation,

119
lib/x86.ml
View File

@ -511,7 +511,9 @@ let is_agg (t : Types.t) =
(* A [(CFn ...)] is one word and crosses exactly as a pointer does, which
is the whole of its reason for existing. *)
| Types.Int _ | Types.Float _ | Types.Bool | Types.Ptr _ | Types.Enum _
| Types.Alloc | Types.CFn _ -> false
| Types.CFn _ -> false
(* The record and its incarnation — see [Emit]'s %alloc. *)
| Types.Alloc -> true
| Types.Unit | Types.Never -> false
(* A [(Fn ...)] is two words — the code address and the environment beside
it — so it crosses the way a slice does. [Emit.lay] is the one place that
@ -1057,6 +1059,44 @@ let fninfo f (fn : Tast.fn) ~nslots =
fn) ]));
l
(* A frame's [at]: [fi_bytes] with the NUL [Emit.fi_cstring] writes, since
the reader takes the length. *)
let fi_cstring f s =
let l = rodata_label f in
Buffer.add_string f.rodata (Printf.sprintf "\t.align 1\n%s:\n" l);
if String.length s > 0 then
Buffer.add_string f.rodata (Printf.sprintf "\t.byte %s\n" (escape_bytes s));
Buffer.add_string f.rodata "\t.byte 0x00\n";
l
(* A signal site's [flan_condesc], [emit.ml]'s [condesc] spelled for this
backend: the name and the sentence through [string_const], which counts
them, because a handler may carry their addresses away; the chain and the
site through [fi_bytes], because nothing reads them after the signal
returns. In [.data.rel.ro] for [fninfo]'s reason: it holds addresses. *)
let condesc f (d : Tast.condesc) loc =
let nlbl = string_const f d.Tast.cname in
let mlbl = string_const f "" in
let llbl, llen = fi_bytes f (Loc.to_string loc) in
let clbl = rodata_label f in
Buffer.add_string f.rodata
(Printf.sprintf "\t.align 4\n%s:\n%s" clbl
(String.concat ""
(List.map (fun i -> Printf.sprintf "\t.long\t%d\n" i) d.Tast.cchain)));
let l = rodata_label f in
Buffer.add_string f.rodata
(Printf.sprintf
"\t.section\t.data.rel.ro,\"aw\"\n\t.align 8\n%s:\n%s\t.section\t.rodata\n"
l
(Emit.Rt.asm_init Emit.Rt.condesc
[ nlbl; string_of_int (String.length d.Tast.cname); mlbl;
"0"; clbl;
string_of_int (List.length d.Tast.cchain); llbl;
string_of_int llen;
(match d.Tast.crender with Some r -> fsym r | None -> "0");
(if d.Tast.cself then "1" else "0") ]));
l
(* The store that says "this slot is bound now", and it is the address rather
than a flag for [emit.ml]'s reason: the reader needs the address anyway, so
one store carries both facts, and a slot the control flow has not reached
@ -1172,7 +1212,7 @@ let load_sym f ~dst s =
else load_int f.b ~dst ~mm:(Sym (s, 0)) ~size:8 ~signed:false
(* The code address behind one of the three [fnref]s, which is the same
sequence whether it is wanted as a bare [Alloc] pointer or as the first
sequence whether it is wanted as a bare [(Ptr ())] or as the first
word of a function value.
[Flanfn] and [Rtfn] are the symbol itself, not a load from it: a function's
@ -1803,7 +1843,7 @@ and lower_at f (e : Tast.expr) (dst : loc) : unit =
(* A [(Fn ...)] value: the code address, then the environment beside it.
Two words — see [Emit]'s %fnv. Only a [Fn]-typed node; the same three
constructors are also asked for as bare addresses, carrying [CFn] or
[Alloc], and those stay one word. The node's type says which. *)
[(Ptr ())], and those stay one word. The node's type says which. *)
| (Tast.FnAddr _ | Tast.Closure _ | Tast.Thicken _)
when (match t with Types.Fn _ -> true | _ -> false) ->
let env =
@ -1857,11 +1897,11 @@ and lower_at f (e : Tast.expr) (dst : loc) : unit =
| Tast.Prim (p, args) -> prim f e p args dst
| Tast.Call (name, args) ->
(match Hashtbl.find_opt f.externs name with
| Some sym -> call_c f ~sym ~args ~rty:t dst
| Some sym -> call_c ~at:e.Tast.loc f ~sym ~args ~rty:t dst
| None ->
(* A dev build calls through the cell so that a redefinition reaches
every existing call site; a release build names the symbol. *)
call_flan f
call_flan f ~at:e.Tast.loc
~target:(if f.md.Emit.dev then `Cell (name, e.Tast.loc)
else `Sym (fsym name))
~args ~rty:t dst)
@ -1876,7 +1916,7 @@ and lower_at f (e : Tast.expr) (dst : loc) : unit =
| Types.Fn _ -> Some (Aint (shift c 8, Types.Ptr (Types.Mut, Types.Unit)))
| _ -> None
in
call_flan f ?env ~target:(`Loc c) ~args ~rty:t dst
call_flan f ?env ~at:e.Tast.loc ~target:(`Loc c) ~args ~rty:t dst
| Tast.Do body -> block f body dst t
| Tast.Let (bs, body) ->
List.iter
@ -2015,27 +2055,27 @@ and lower_at f (e : Tast.expr) (dst : loc) : unit =
| Tast.Match (scrut, arms) -> emit_match f scrut arms dst t
(* The condition crosses as a pointer: a handler runs while the signalling
frame is still alive, so there is nothing to copy and nothing to own. *)
| Tast.Signal (Tast.Ssignal, id, c) ->
| Tast.Signal (Tast.Ssignal, d, c) ->
scoped f (fun () ->
let l = lvalue_rooted f c in
addr_into f ~reg:rsi l;
imm_into f ~reg:rdi (Int64.of_int id);
lea f.b ~dst:rdi ~mm:(Sym (condesc f d e.Tast.loc, 0));
chan_into f ~reg:rdx;
mark_at f e.Tast.loc;
xor_rr f.b ~dst:rax ~src:rax;
call_sym f.b "flan_signal";
clear_at f;
guard f)
(* §2's diverging variant. [flan_error] does not return unless a handler
transferred, so the guard is the only way out and the fall-through is
[ud2] — where [emit.ml] writes [unreachable]. *)
| Tast.Signal (Tast.Serror, id, c) ->
| Tast.Signal (Tast.Serror, d, c) ->
scoped f (fun () ->
let l = lvalue_rooted f c in
addr_into f ~reg:rsi l;
imm_into f ~reg:rdi (Int64.of_int id);
lea f.b ~dst:rdi ~mm:(Sym (condesc f d e.Tast.loc, 0));
chan_into f ~reg:rdx;
let name =
match c.Tast.ty with Types.Named n -> n | _ -> "a condition" in
str_args f ~preg:rcx ~nreg:r8 name;
mark_at f e.Tast.loc;
xor_rr f.b ~dst:rax ~src:rax;
call_sym f.b "flan_error";
guard f;
@ -2213,6 +2253,14 @@ and emit_restart_case f clauses body dst t =
str_args f ~preg:rax ~nreg:rcx c.Tast.rsig;
store_int f.b ~src:rax ~mm:(Frame (slot + r_sig)) ~size:8;
store_int f.b ~src:rcx ~mm:(Frame (slot + r_siglen)) ~size:8;
str_args f ~preg:rax ~nreg:rcx (Loc.to_string c.Tast.rloc);
store_int f.b ~src:rax ~mm:(Frame (slot + r_field "loc")) ~size:8;
store_int f.b ~src:rcx ~mm:(Frame (slot + r_field "loclen")) ~size:8;
str_args f ~preg:rax ~nreg:rcx c.Tast.rreport;
store_int f.b ~src:rax ~mm:(Frame (slot + r_field "report")) ~size:8;
store_int f.b ~src:rcx ~mm:(Frame (slot + r_field "reportlen")) ~size:8;
imm_into f ~reg:rax (if c.Tast.rhidden then 1L else 0L);
store_int f.b ~src:rax ~mm:(Frame (slot + r_field "flags")) ~size:4;
(match args with
| None -> ()
| Some (buf, _) ->
@ -2666,6 +2714,7 @@ and bounds_call f sym (loc : Loc.t) (extra : int list) =
load_int f.b ~dst:regs.(k) ~mm:(Frame off) ~size:8 ~signed:true)
extra;
chan_into f ~reg:regs.(List.length extra);
mark_at f loc;
xor_rr f.b ~dst:rax ~src:rax;
call_sym f.b sym;
guard f;
@ -2976,7 +3025,7 @@ and ret_loc f = if is_agg f.fret then Lp (f.sret_off, 0) else Lf f.retval
integer or SSE sequence, every aggregate by pointer, a hidden [sret] in the
first integer register when the result is an aggregate, and the transfer
channel last of all. *)
and call_flan f ?env ~target ~args ~rty dst =
and call_flan f ?env ?at ~target ~args ~rty dst =
let vals = List.map (fun (a : Tast.expr) -> eval f a, a.Tast.ty) args in
let callee =
match target with
@ -3003,6 +3052,9 @@ and call_flan f ?env ~target ~args ~rty dst =
the position is argued. *)
let tail = match env with None -> [] | Some a -> [ a ] in
ignore (emit_args f (head @ body @ chan @ tail));
(* The call this frame is making, for a backtrace — [Emit.mark_call]. After
the arguments, which may make calls of their own. *)
Option.iter (mark_at f) at;
(* The cell is loaded *after* the arguments, and [emit.ml] has the same as a
load-bearing comment: a redefinition that lands between two calls still
must not land in the middle of one. [r11] is scratch and no argument
@ -3050,13 +3102,33 @@ and call_flan f ?env ~target ~args ~rty dst =
else if (not (is_void rty)) && Emit.traced f.md rty then begin
let o = agg_tmp f rty in
copy_loc f ~dst:(Lf o) ~src:dst (sizeof f.md rty)
end
end;
if at <> None then clear_at f
(* Flan calling C. SysV exactly, because this is the boundary where it has to
be — and the only aggregates that get here are the ones the shim rules
already flatten. *)
and call_c f ~sym ~args ~rty dst =
call_native f ~sym:(asm_sym sym) ~args ~rty dst
and call_c ?at f ~sym ~args ~rty dst =
call_native ?at f ~sym:(asm_sym sym) ~args ~rty dst
(* [Emit.mark_call] and [Emit.clear_call]: where this frame is while control
is somewhere that can come back into Flan. Through [r11], which holds no
argument and no result. *)
and mark_at f at =
match f.dframe with
| Some fr ->
lea f.b ~dst:r11 ~mm:(Sym (fi_cstring f (Loc.to_string at), 0));
store_int f.b ~src:r11
~mm:(Frame (fr + Emit.Rt.field Emit.Rt.flanframe "at")) ~size:8
| None -> ()
and clear_at f =
match f.dframe with
| Some fr ->
xor_rr f.b ~dst:r11 ~src:r11;
store_int f.b ~src:r11
~mm:(Frame (fr + Emit.Rt.field Emit.Rt.flanframe "at")) ~size:8
| None -> ()
(* The two runtime entry points whose bounds check signals. They are the only
[Rt] symbols that can transfer, so they are the only ones that take the
@ -3086,7 +3158,7 @@ and call_rt f ~sym ~args ~rty dst =
store_int f.b ~src:rax ~mm:(Frame slot) ~size:8
end
and call_native f ~sym ?(chan = false) ~(args : Tast.expr list) ~rty dst =
and call_native ?at f ~sym ?(chan = false) ~(args : Tast.expr list) ~rty dst =
(* A Vec and a Map cross to the runtime as their
*address*, which is what lets an operation mutate the caller's container
in place. [eval] would hand over the address of a copy, and the runtime
@ -3105,10 +3177,13 @@ and call_native f ~sym ?(chan = false) ~(args : Tast.expr list) ~rty dst =
let flat = List.concat_map (fun (l, ty) -> classify_c l ty) vals in
let flat = if chan then flat @ [ Aint (Lf f.xfer_off, Types.Ptr (Types.Mut, Types.Unit)) ] else flat in
let nsse = emit_args f flat in
(* A C function may call back into Flan. *)
Option.iter (mark_at f) at;
(* [al] is how many SSE registers were used, which a variadic callee reads.
Harmless on a fixed one, and a [declare] does not say which it is. *)
imm_into f ~reg:rax (Int64.of_int nsse);
call_sym f.b sym;
if at <> None then clear_at f;
if chan then guard f;
if not (is_void rty) then begin
(* Unreachable, and it is worth saying why rather than leaving it reading
@ -3120,8 +3195,8 @@ and call_native f ~sym ?(chan = false) ~(args : Tast.expr list) ~rty dst =
[Unit] or a scalar. [flan_vec_as_slice] is the one that looks like a
counter-example and is not: [check.ml] builds it as [rt loc
Types.Unit] and [flan_rt.c] writes the two words through [void *out].
Every other [rt] builder in the file answers [Unit], an [Int], a
[Ptr] or an [Alloc].
Every other [rt] builder in the file answers [Unit], an [Int]
or a [Ptr].
- [crossable], which admits [String] and [Slice _] only as "a
parameter" and refuses an aggregate return from a [declare] outright.
@ -4100,6 +4175,10 @@ let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false)
store_int f.b
~src:rax ~mm:(Frame (fr + Emit.Rt.field Emit.Rt.flanframe "slots"))
~size:8;
xor_rr f.b ~dst:rax ~src:rax;
store_int f.b
~src:rax ~mm:(Frame (fr + Emit.Rt.field Emit.Rt.flanframe "at"))
~size:8;
lea f.b ~dst:rax ~mm:(Frame fr);
store_int f.b ~src:rax ~mm:(lmem f head ~scratch:r11) ~size:8;
(* The parameters are bound before the body starts, so they are recorded

30
runtime/flan_dev.c
View File

@ -1046,6 +1046,12 @@ typedef struct flan_frame {
* with no named slot, and in a release build there is no frame at all.
* Read through [flan_dev_frame_slot], which is where the bound is checked. */
void **slots;
/* The call this frame is in: the site of the last Flan call it made,
* NUL-terminated, stored after the arguments and before the call. NULL
* until its first. Stale in the innermost frame, which may have returned
* from that call since — which is why [flan_dev_frame_at_loc] is read for
* the outer frames only. */
const char *at;
} flan_frame;
/* The compiler names this symbol directly. A redefinition module reaches it
@ -1100,6 +1106,14 @@ const char *flan_dev_frame_loc(const void *frame, int64_t *len) {
return f->info->loc;
}
/* Where the frame is: the call it is in, or NULL when it has made none. */
const char *flan_dev_frame_at_loc(const void *frame, int64_t *len) {
const flan_frame *f = frame;
if (f == NULL || f->at == NULL) { *len = 0; return NULL; }
*len = (int64_t)strlen(f->at);
return f->at;
}
int32_t flan_dev_frame_nslots(const void *frame) {
const flan_frame *f = frame;
return (f == NULL || f->info == NULL) ? 0 : f->info->nslots;
@ -1418,6 +1432,22 @@ void flan_dev_reg_enable(void) {
int flan_dev_reg_enabled(void) { return flan_reg_on; }
/* A block a resize moved away from, filled with 0xDEADBEEF words in a dev
* build. A slice is a pointer and a length and carries nothing that could say
* the Vec under it grew, so a slice taken before a push that moved the storage
* still reads the old block — which, unpoisoned, holds exactly the values it
* held, and the stale read looks right. Filled, it reads a value nobody
* wrote. A release build keeps the load and the branch and nothing else.
* Byte-wise at the tail so that an element size that is not a multiple of
* four is still filled to its end. */
void flan_dev_poison(void *p, int64_t bytes) {
static const uint8_t pat[4] = { 0xEF, 0xBE, 0xAD, 0xDE };
uint8_t *b = (uint8_t *)p;
int64_t i;
if (!flan_reg_on || p == NULL || bytes <= 0) return;
for (i = 0; i < bytes; i++) b[i] = pat[i & 3];
}
/* Knuth's multiplicative hash over the address, which is what an allocator
* hands out: aligned, and therefore dense in its low bits. */
static size_t flan_reg_slot(uintptr_t a) {

142
runtime/flan_dyn.c
View File

@ -33,6 +33,7 @@
* be thread-local, and that is one change in two places rather than a rewrite.
*/
#include <stdarg.h>
#include <stdint.h>
#include <stddef.h>
#include <stdio.h>
@ -62,6 +63,9 @@ void flan_dev_watch_emit(const uint8_t *bytes, int64_t len);
* program die where it stands", which that file went to some trouble to have
* only one of. So flan_rt.c exports a thin wrapper and this calls it. */
_Noreturn void flan_trap(const uint8_t *name, int64_t namelen);
/* A trap's sentence, printed after its site and kept for the break loop, which
* shows it beside the trap's name (flan_rt.c). */
void flan_say(const uint8_t *loc, int64_t loclen, const char *fmt, ...);
/* Growing a Vec through a dyn view borrows flan_rt.c's own growth: doubling,
* allocator adoption and the epoch check all live in [flan_vec_push], and
@ -695,6 +699,10 @@ void flan_dyn_print(flan_dyn v) { render(flan_write_stdout, v, 0, 0); }
void flan_dyn_emit_dev(flan_dyn v) { render(flan_dev_emit, v, 0, 1); }
void flan_dyn_emit_watch(flan_dyn v) { render(flan_dev_watch_emit, v, 0, 1); }
/* And into a condition's message, which flan_rt.c's sink bounds. */
void flan_msg_emit(const uint8_t *p, int64_t n);
void flan_dyn_emit_msg(flan_dyn v) { render(flan_msg_emit, v, 0, 1); }
/* The same walk into a buffer, for a trap's sentence. Bounded and truncated
* rather than allocating: a trap is the one moment when allocating would be a
* second thing to go wrong, and the message's job is to name the value, not to
@ -836,9 +844,9 @@ static void say(char *buf, int64_t cap, flan_dyn v) {
* which without reading the sentence twice — and because the break loop lists
* them by name. */
/* Where the operation was written, printed as flan_rt.c's traps print it: the
* GNU "file:line:col: " prefix, so `next-error` walks to the dyn failure the
* same way it walks to a bounds failure. The pair is what an emitted string
/* Where the operation was written, printed as flan_rt.c's traps print it
* ([flan_say] writes both): the GNU "file:line:col: " prefix, so `next-error`
* walks to the dyn failure the same way it walks to a bounds failure. The pair is what an emitted string
* literal already is — a pointer and a length, not a C string — and the
* emitter hands it over exactly as [flan_dyn_cast_kind]'s site does.
*
@ -847,9 +855,21 @@ static void say(char *buf, int64_t cap, flan_dyn v) {
* given a site (everything but the arithmetic, the ordering, [at], [set-at]
* and [push]) pass NULL, and so does test/dyn_ops.c, which calls the runtime
* directly and has no source position to offer. */
static void trap_where(const uint8_t *loc, int64_t loclen) {
if (loc != NULL && loclen > 0)
fprintf(stderr, "%.*s: ", (int)loclen, (const char *)loc);
/* A trap's sentence written in pieces, then said in one through [flan_say],
* so it reaches the break loop like every other. */
static char said_buf[2048];
static size_t said_len;
static void said_add(const char *fmt, ...) {
va_list ap;
int n;
if (said_len >= sizeof said_buf) return;
va_start(ap, fmt);
n = vsnprintf(said_buf + said_len, sizeof said_buf - said_len, fmt, ap);
va_end(ap);
if (n > 0) said_len += (size_t)n;
if (said_len >= sizeof said_buf) said_len = sizeof said_buf - 1;
}
static _Noreturn void trap2(const uint8_t *loc, int64_t loclen,
@ -858,10 +878,8 @@ static _Noreturn void trap2(const uint8_t *loc, int64_t loclen,
char sa[SAY_MAX], sb[SAY_MAX];
say(sa, SAY_MAX, a);
say(sb, SAY_MAX, b);
fflush(stdout);
trap_where(loc, loclen);
fprintf(stderr, "dyn %s: %s and %s, and %s — (%s %s %s)\n", op, tag_of(a),
tag_of(b), why, op, sa, sb);
flan_say(loc, loclen, "dyn %s: %s and %s, and %s — (%s %s %s)", op,
tag_of(a), tag_of(b), why, op, sa, sb);
flan_trap((const uint8_t *)name, namelen);
}
@ -870,9 +888,8 @@ static _Noreturn void trap1(const uint8_t *loc, int64_t loclen,
const char *why, flan_dyn a) {
char sa[SAY_MAX];
say(sa, SAY_MAX, a);
fflush(stdout);
trap_where(loc, loclen);
fprintf(stderr, "dyn %s: %s, and %s — (%s %s)\n", op, tag_of(a), why, op, sa);
flan_say(loc, loclen, "dyn %s: %s, and %s — (%s %s)", op, tag_of(a), why, op,
sa);
flan_trap((const uint8_t *)name, namelen);
}
@ -885,11 +902,9 @@ static _Noreturn void trap_range(const uint8_t *loc, int64_t loclen,
int64_t len) {
char sv[SAY_MAX];
say(sv, SAY_MAX, v);
fflush(stdout);
trap_where(loc, loclen);
fprintf(stderr,
"dyn %s: index %lld is out of bounds for %s of length %lld — %s\n",
op, (long long)i, tag_of(v), (long long)len, sv);
flan_say(loc, loclen,
"dyn %s: index %lld is out of bounds for %s of length %lld — %s", op,
(long long)i, tag_of(v), (long long)len, sv);
flan_trap((const uint8_t *)"DynRange", 8);
}
@ -960,11 +975,9 @@ void flan_gc_collect(void) {
* NULL, which prints no prefix. */
static _Noreturn void trap_oom(const uint8_t *loc, int64_t loclen,
int64_t want) {
fflush(stdout);
trap_where(loc, loclen);
fprintf(stderr,
"dyn heap: %lld bytes could not be allocated, with %lld live\n",
(long long)want, (long long)gc_bytes);
flan_say(loc, loclen,
"dyn heap: %lld bytes could not be allocated, with %lld live",
(long long)want, (long long)gc_bytes);
flan_trap((const uint8_t *)"DynHeap", 7);
}
@ -1914,15 +1927,14 @@ static void class_hook(flan_obj *o, flan_dyn inst, flan_dyn added,
free(snap);
if (r == 2) {
kw_entry *c = o->u.v.klass;
fflush(stdout);
fprintf(stderr,
"dyn migrate: update-instance-for-redefined-class, migrating an "
"instance of %.*s, was left for a restart established outside "
"it. A migration runs inside get, put or set, and cannot be "
"left for one of their callers; the instance is kept as its "
"slots matched by name. Take migrate-by-name, or handle the "
"condition inside the method\n",
(int)c->len, (const char *)(c + 1));
flan_say(NULL, 0,
"dyn migrate: update-instance-for-redefined-class, migrating an "
"instance of %.*s, was left for a restart established outside "
"it. A migration runs inside get, put or set, and cannot be "
"left for one of their callers; the instance is kept as its "
"slots matched by name. Take migrate-by-name, or handle the "
"condition inside the method",
(int)c->len, (const char *)(c + 1));
flan_trap((const uint8_t *)"DynMigrate", 10);
}
}
@ -2757,12 +2769,10 @@ static void view_vec_check(const uint8_t *loc, int64_t loclen, const char *op,
if (h->alloc) {
flan_dyn_alloc_hdr *a = (flan_dyn_alloc_hdr *)h->alloc;
if ((int64_t)a->epoch != h->epoch) {
fflush(stdout);
trap_where(loc, loclen);
fprintf(stderr,
"dyn %s: this view's container's allocator was released — the "
"Vec was made at epoch %lld and the allocator is at %lld now\n",
op, (long long)h->epoch, (long long)(int64_t)a->epoch);
flan_say(loc, loclen,
"dyn %s: this view's container's allocator was released — the "
"Vec was made at epoch %lld and the allocator is at %lld now",
op, (long long)h->epoch, (long long)(int64_t)a->epoch);
flan_trap((const uint8_t *)"DynRange", 8);
}
}
@ -3064,12 +3074,8 @@ static _Noreturn void trap_slot_type(const uint8_t *loc, int64_t loclen,
say(sm, SAY_MAX, m);
say(sv, SAY_MAX, v);
slot_type_text(t, st, sizeof st);
fflush(stdout);
/* A constructor's refusal is placed at the call that was wrong, when the
call said where it was, and names the slot's declaration after it. */
trap_where(by == BY_NEW && site_building != NULL ? site_building : loc,
by == BY_NEW && site_building != NULL ? site_building_len : loclen);
fprintf(stderr, "dyn %s: the slot :%.*s of %.*s is declared %s, and ",
said_len = 0;
said_add("dyn %s: the slot :%.*s of %.*s is declared %s, and ",
by == BY_PUT ? "put" : by == BY_SET ? "set" : "construct", sn, ss,
cn, cs, st);
/* A number of the right kind that does not fit is not news about its tag. */
@ -3077,20 +3083,25 @@ static _Noreturn void trap_slot_type(const uint8_t *loc, int64_t loclen,
|| (t->kind == ST_FLOAT
&& (flan_dyn_tag(v) == FLAN_DYN_TAG_INT
|| flan_dyn_tag(v) == FLAN_DYN_TAG_FLOAT)))
fprintf(stderr, "%s is not a value it holds exactly — ", sv);
said_add("%s is not a value it holds exactly — ", sv);
else if (t->kind == ST_CLASS && flan_dyn_tag(v) == FLAN_DYN_TAG_MAP)
fprintf(stderr, "this is not an instance of it — ");
said_add("this is not an instance of it — ");
else
fprintf(stderr, "this is %s — ", tag_of(v));
said_add("this is %s — ", tag_of(v));
if (by == BY_PUT)
fprintf(stderr, "(put %s :%.*s %s)\n", sm, sn, ss, sv);
said_add("(put %s :%.*s %s)", sm, sn, ss, sv);
else if (by == BY_SET)
fprintf(stderr, "(set (get %s :%.*s) %s)\n", sm, sn, ss, sv);
said_add("(set (get %s :%.*s) %s)", sm, sn, ss, sv);
else if (site_building != NULL && loc != NULL)
fprintf(stderr, "(%.*s ...) with :%.*s %s; the slot is declared at %.*s\n",
said_add("(%.*s ...) with :%.*s %s; the slot is declared at %.*s",
cn, cs, sn, ss, sv, (int)loclen, (const char *)loc);
else
fprintf(stderr, "(%.*s ...) with :%.*s %s\n", cn, cs, sn, ss, sv);
said_add("(%.*s ...) with :%.*s %s", cn, cs, sn, ss, sv);
/* A constructor's refusal is placed at the call that was wrong, when the
call said where it was, and names the slot's declaration after it. */
flan_say(by == BY_NEW && site_building != NULL ? site_building : loc,
by == BY_NEW && site_building != NULL ? site_building_len : loclen,
"%s", said_buf);
flan_trap((const uint8_t *)"DynType", 7);
}
@ -3137,13 +3148,11 @@ void flan_dyn_slot_set(flan_dyn m, flan_dyn k, flan_dyn v,
if (!is_map(m) || dyn_obj(m)->u.v.klass == NULL) {
char sm[SAY_MAX];
say(sm, SAY_MAX, m);
fflush(stdout);
trap_where(loc, loclen);
fprintf(stderr,
"dyn set: (get m k) is a place only on a class instance, and "
"this is %s%s — %s. A map's entries are written with put\n",
is_map(m) ? "a map with no class" : "a ",
is_map(m) ? "" : tag_of(m), sm);
flan_say(loc, loclen,
"dyn set: (get m k) is a place only on a class instance, and "
"this is %s%s — %s. A map's entries are written with put",
is_map(m) ? "a map with no class" : "a ",
is_map(m) ? "" : tag_of(m), sm);
flan_trap((const uint8_t *)"DynType", 7);
}
o = dyn_obj(m);
@ -3154,17 +3163,16 @@ void flan_dyn_slot_set(flan_dyn m, flan_dyn k, flan_dyn v,
kw_entry *c = o->u.v.klass;
int64_t i;
say(sk, SAY_MAX, k);
fflush(stdout);
trap_where(loc, loclen);
fprintf(stderr, "dyn set: %.*s has no slot %s. Its slots are",
(int)c->len, (const char *)(c + 1), sk);
if (e == NULL || e->nslots == 0) fprintf(stderr, " none");
said_len = 0;
said_add("dyn set: %.*s has no slot %s. Its slots are",
(int)c->len, (const char *)(c + 1), sk);
if (e == NULL || e->nslots == 0) said_add(" none");
else
for (i = 0; i < e->nslots; i++)
fprintf(stderr, " :%.*s", (int)e->slots[i]->len,
(const char *)(e->slots[i] + 1));
fprintf(stderr, "; a key the class does not declare is added with put, "
"not set\n");
said_add(" :%.*s", (int)e->slots[i]->len,
(const char *)(e->slots[i] + 1));
said_add("; a key the class does not declare is added with put, not set");
flan_say(loc, loclen, "%s", said_buf);
flan_trap((const uint8_t *)"DynType", 7);
}
if (!slot_admit(&e->types[j], v, &out))

1020
runtime/flan_rt.c
View File

File diff suppressed because it is too large Load Diff

7
spec-conditions.md
View File

@ -4,8 +4,11 @@ Status: **frozen** for the six hard cases below. Everything not listed here is
still open, but nothing in the implementation may depend on the unlisted parts.
Four operators: `handler-bind`, `handler-case`, `restart-case`, `invoke-restart`.
No condition class hierarchy — condition types are structs, matching is by type
plus an optional predicate.
No condition class hierarchy — condition types are structs, matching is by type,
and a type may name one parent (`(defstruct FileError :parent Error [...])`), so
a handler for a type answers every condition below it in that static chain. A
handler matched through a parent is handed the condition's name and sentence
(the root `Error`'s two fields), not the condition's own fields.
## 1. `signal` returns `()`

22
spec-memory.md
View File

@ -34,7 +34,7 @@ facility (see plan.org, "Managed classes").
`(clone x)` is the spelling of an independent one. Using a binding after
assigning it away is ordinary: the header is still there, and a program that frees
through it twice or reads through it after a free misbehaves at run time,
where the allocator and the dev build's generation word are the net.
where the allocator and the dev build's poisoned buffers are the net.
## Maps — first implementation
@ -113,8 +113,11 @@ region" for the rule that stands in its place and for what it costs.
wholesale. Same leak as `(length (mk))`, same rule as overwriting a global
`Vec`: manual memory management, and the program's business.
- **The first implementation follows Zig/Odin's explicit model, not Rust's
borrow checker.** Dev builds carry a generation word on `Vec` and trap on use
of a stale slice. `Ptr` is the explicit lower-level escape hatch and has the
borrow checker.** A slice is pointer and length and carries nothing that
could detect a stale one. A dev build fills a `Vec`'s old buffer with
`0xDEADBEEF` words when a push moves it, so a slice taken before the move
reads visibly wrong values; nothing traps, and a release build does not fill.
`Ptr` is the explicit lower-level escape hatch and has the
same lifetime contract.
- A future lightweight provenance pass may reject the obvious mistakes (a
borrow of a local escaping, use after an owner moves, and reallocation with a
@ -486,9 +489,11 @@ There are exactly two release points, and neither of them is a scope.
error.
2. **Region release** — `(free-all a)` on an allocator, which releases
everything made from it at once, including storage reachable from bindings
that are still in scope. The per-frame `(free-all context/temp)` at the top
of a game loop *is* the frame arena, and it is the normal way arena-tier
storage dies.
that are still in scope. The per-frame `(free-temp)`, which is
`(free-all context/temp)`, *is* the frame arena, and it is the normal way
arena-tier storage dies. `i64->bytes` and `f64->bytes` put their text there,
and a dev build also wipes it at every frame boundary the agent polls at.
The temp allocator grows rather than running out.
**Nothing is released at scope exit.** Not at the end of a `let`, not at the end
of a function, not at the end of a `with-allocator` body. `with-allocator`
@ -612,6 +617,11 @@ operation. It works because an `Allocator` is a **pointer** to the allocator
and not a copy of one — a copied-by-value allocator would give each copy its
own epoch, and a copy taken before the bump would never notice it.
An `Allocator` value is two words: that pointer, and the incarnation of the
allocator it was made for, which `arena-destroy` bumps. Every use of the value
compares the two, so a value kept past its arena's destroy traps at its next
use, even after a later `arena-new` has taken the allocator's record back.
### `drop` — owning something that is not memory
A type may name one hook:

17
test/agent_hooks.c
View File

@ -31,7 +31,8 @@ void flan_agent_request_free(char *p);
extern void (*flan_agent_break_poll_hook)(void);
extern void (*flan_break_hook)(const uint8_t *name, int64_t namelen,
void *condition, void *xfer);
void *flan_restart_push_c(const uint8_t *name, int64_t namelen);
void *flan_restart_push_c(const uint8_t *name, int64_t namelen,
const uint8_t *report, int64_t reportlen);
void flan_restart_pop_c(void *frame);
/* The trailing ptr is the transfer channel every Flan signature carries. */
@ -76,10 +77,14 @@ static void list_and_take(void) {
const char *name;
int len;
if (nl == NULL) break;
/* "I F NAME" */
/* "I F NAME\tARITY\tSIG\tLOC\tREPORT"; the name ends at the tab. */
name = strchr(p, ' ');
name = name ? strchr(name + 1, ' ') : NULL;
len = name ? (int)(nl - name - 1) : -1;
if (name != NULL) {
const char *tab = memchr(name + 1, '\t', (size_t)(nl - name - 1));
len = (int)((tab != NULL ? tab : nl) - name - 1);
} else
len = -1;
if (len > longest) longest = len;
if (len < shortest) shortest = len;
listed++;
@ -140,7 +145,7 @@ static void stale_hook(void) {
if (outer_turns == 1) {
void *xin = NULL;
printf("outer choice %s", ask("restart-at 1 outer-a"));
inner = flan_restart_push_c((const uint8_t *)"inner", 5);
inner = flan_restart_push_c((const uint8_t *)"inner", 5, NULL, 0);
level = 2;
flan_break_hook((const uint8_t *)"Inner", 5, NULL, &xin);
level = 1;
@ -169,8 +174,8 @@ static void stale_hook(void) {
static int stale(void) {
void *xout = NULL;
outer_a = flan_restart_push_c((const uint8_t *)"outer-a", 7);
outer_b = flan_restart_push_c((const uint8_t *)"outer-b", 7);
outer_a = flan_restart_push_c((const uint8_t *)"outer-a", 7, NULL, 0);
outer_b = flan_restart_push_c((const uint8_t *)"outer-b", 7, NULL, 0);
level = 1;
flan_agent_break_poll_hook = stale_hook;
flan_break_hook((const uint8_t *)"Outer", 5, NULL, &xout);

2
test/programs/arith-condition.flan
View File

@ -47,7 +47,7 @@
(defonce frames i64)
(defonce skipped i64)
(defonce cleaned i64)
(defonce op i32)
(defonce op ArithOp)
(defonce lhs i64)
(defonce rhs i64)

14
test/programs/break.flan
View File

@ -11,7 +11,7 @@
(defn fetch [n i32] i32
(restart-case
(do (error (Missing {.id n})) 0)
(use-placeholder [] -1)
(use-placeholder [] :report "Answer -1 for the missing value" -1)
(retry [] 7)))
;;; Two frames offering the same name, which §4 says resolves to the inner one
@ -26,9 +26,21 @@
100)
(retry [] 900)))
(defstruct Other [])
;;; A handler-case establishes a restart of its own, under a name nobody wrote,
;;; and a break loop inside it must not offer that one: it is reached through
;;; the form's handler, which carries the condition in. Only [keep] is listed.
(defn caught [n i32] i32
(restart-case
(handler-case (do (error (Missing {.id n})) 0)
[(Other [_o] 5)])
(keep [] :report "Answer 42" 42)))
(defn main [] i32
(agent/start "/tmp/flan-break.sock")
(print (fetch 1)) (println "")
(print (fetch 2)) (println "")
(print (shadowed 3)) (println "")
(print (caught 4)) (println "")
0)

30
test/programs/clone-slice.flan Normal file
View File

@ -0,0 +1,30 @@
;;;; (clone xs) on a slice: the elements copied into a block from the context
;;;; allocator, or from one named, and answered as a slice over it. Writing
;;;; through the copy leaves the original alone, and the other way round.
(defstruct P [x i32 y f64])
(defn show [xs [i32]] ()
(dotimes [i (length xs)]
(print (at xs i))
(print " "))
(println ""))
(defn main [] i32
(let [arr [1 2 3 4 5]
c (clone (slice arr 1 4))]
(set (at c 0) 20)
(set (at arr 2) 30)
(show c)
(show (slice arr)))
;; From a Vec's view, into a named arena; wider elements than a byte.
(let [a (arena-new 1024)
v (vec-new P)]
(push v (P {.x 1 .y 1.5}))
(push v (P {.x 2 .y 2.5}))
(let [c (clone (slice v) a)]
(set (.x (at v 0)) 9)
(println (.x (at c 0)) (.y (at c 1)) (length c))))
;; An empty slice clones to an empty slice.
(let [e (clone (slice (bytes-view "abc") 1 1))]
(println (length e)))
0)

15
test/programs/condition-longmessage.flan Normal file
View File

@ -0,0 +1,15 @@
;;;; A message is never cut when a handler reads it: it is made in
;;;; context/temp at the size it needs. The unhandled message goes through the
;;;; break loop's fixed buffer, and there it is cut at a character — never
;;;; inside one — and says so: "unhandled Longs: " is an odd number of bytes
;;;; before 1100 two-byte characters, so a cut at a fixed byte count would
;;;; land inside one.
(defstruct Wide :parent Error [code i32 why string])
(defstruct Longs :parent Error)
(defn main [] i32
(handler-case (do (error (Wide {.code 123 .why "éééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééé"})) 0)
[(Error [e] (println (.message e)) 0)])
(error (Longs {.name "longs" .message "éééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééééé"}))
0)

34
test/programs/condition-messages.flan Normal file
View File

@ -0,0 +1,34 @@
;;;; What a handler for a parent reads as the message, and that it is still
;;;; there after the unwind. The clause below runs after the signalling frames
;;;; are gone, and [scribble] reuses their stack before the message is
;;;; printed, so a message left pointing into them prints as garbage.
(defstruct IoError :parent Error)
(defstruct Empty :parent Error [])
(defstruct MyErr :parent Error [code i32 why string])
(defonce zero i64)
;; Deep enough, and wide enough, to overwrite what the signal left below.
(defn scribble [n i32] i64
(let [junk (array-fill [64] (i64 n))]
(if (= n 0) (at junk 3) (+ (at junk 5) (scribble (- n 1))))))
(defn caught [thunk (Fn [] i32)] i32
(handler-case (thunk)
[(Error [e]
(scribble 40)
(println (.name e))
(println (.message e))
-1)]))
(defn main [] i32
;; A category the program filled in is its own name and message.
(caught (fn [] (do (error (IoError {.name "io" .message "disk gone"})) 0)))
;; An empty field vector is the same category.
(caught (fn [] (do (error (Empty {.name "empty" .message "nothing"})) 0)))
;; A program's own condition is printed with its values.
(caught (fn [] (do (error (MyErr {.code 3 .why "bad"})) 0)))
;; A runtime condition carries the sentence with its values.
(caught (fn [] (i32 (/ 7 zero))))
0)

59
test/programs/condition-parents.flan Normal file
View File

@ -0,0 +1,59 @@
;;;; A condition type names its parent, and a handler for a type answers every
;;;; condition below it. Error is the root every built-in error descends from,
;;;; so one handler for it catches a bad index, an arithmetic failure and a
;;;; program's own error alike — and is handed the name and the runtime's
;;;; sentence, not the fields, since its type is the parent's.
;; A category: a parent with no field vector, which gets Error's two fields.
(defstruct IoError :parent Error)
(defstruct DiskFull :parent IoError [free i64])
;; A condition with no parent is matched by its own type and nothing else.
(defstruct Loner [n i32])
(defonce zero i64)
(defonce grid [4 i32])
(defn risky [n i32] i32
(cond
(= n 0) (i32 (/ 10 zero))
(= n 1) (at grid (+ n 5))
(= n 2) (do (error (DiskFull {.free 7})) 0)
:else n))
;; The catch-all. The clause runs after the unwind, so the name and the
;; sentence it prints are copies that outlived the frame that signalled.
(defn guarded [n i32] i32
(handler-case (risky n)
[(Error [e]
(println (.name e))
(println (.message e))
-1)]))
(defn main [] i32
(println (guarded 0))
(println (guarded 1))
(println (guarded 2))
(println (guarded 3))
;; A handler for the middle of the chain.
(println (handler-case (risky 2) [(IoError [e] (println (.name e)) -2)]))
;; A handler for the condition's own type still reads its fields, and is
;; the innermost, so it answers first.
(println
(handler-case
(handler-case (risky 2) [(DiskFull [d] (i32 (.free d)))])
[(Error [_e] -3)]))
;; A non-unwinding handler for Error sees the same two fields while the
;; signalling frame is alive, and the handler for ArithError inside it
;; reads the op as the enum it is.
(println
(handler-case
(handler-bind [(Error [e] (println (.message e)))]
(handler-bind [(ArithError [a] (println (= (.op a) :div-zero)))]
(risky 0)))
[(ArithError [_a] -4)]))
;; A condition outside the chain is not an Error.
(println
(handler-case
(handler-case (do (error (Loner {.n 1})) 0) [(Error [_e] -5)])
[(Loner [l] (.n l))]))
0)

27
test/programs/condition-temp.flan Normal file
View File

@ -0,0 +1,27 @@
;;;; The message a handler for a parent reads lives in context/temp, so it is
;;;; good until the frame ends, not only while the clause runs: [why] hands it
;;;; back to its caller, which writes over the stack before printing it. Kept
;;;; past (free-temp) without a clone, a dev build has poisoned it with
;;;; 0xDEADBEEF, so its first byte is one of that pattern's; a release build
;;;; still has "(" there.
(defstruct MyErr :parent Error [code i32])
(defn why [] string
(handler-case (do (error (MyErr {.code 3})) "")
[(Error [e] (.message e))]))
(defn scribble [n i32] i64
(let [junk (array-fill [64] (i64 n))]
(if (= n 0) (at junk 3) (+ (at junk 5) (scribble (- n 1))))))
(defn main [] i32
(let [m (why)]
(scribble 40)
(println m))
(let [m (why)]
(free-temp)
(let [b (at (bytes-view m) 0)]
(println (or (= b (u8 0xEF)) (= b (u8 0xBE)) (= b (u8 0xAD))
(= b (u8 0xDE))))))
0)

22
test/programs/context-destroyed.flan Normal file
View File

@ -0,0 +1,22 @@
;;;; The context allocator holds an Allocator value, incarnation and all. Here
;;;; the inner with-allocator destroys the arena the outer one installed, and
;;;; on the way out the outer one is put back; the next arena-new takes the
;;;; destroyed arena's record. Allocating from the context must then trap,
;;;; not quietly allocate from the new arena. Argument 1 reads context/allocator
;;;; as a value first and uses that instead, which traps the same way.
(defn main [args [string]] i32
(let [which (if (> (length args) 1) (bytes->i64 (bytes-view (at args 1))) 0)
a (arena-new 4096)]
(with-allocator a
(let [held context/allocator]
(with-allocator (heap-allocator)
(arena-destroy a))
(let [b (arena-new 4096)
w (vec-new i32 b)]
(push w 5)
(println (at w 0))
(if (= which 1)
(let [v (vec-new i32 held)] (push v 1))
(let [v (vec-new i32)] (push v 1)))
(println "unreachable")))))
0)

21
test/programs/destroy-region.flan
View File

@ -13,6 +13,11 @@
;;;; container made before the destroy still traps, because the epoch on a
;;;; header only ever rises.
;;;;
;;;; Arguments 4, 5 and 6 use the destroyed Allocator value itself after the
;;;; next arena-new took its record back — for a new container, through
;;;; with-allocator, and in a second destroy. The value carries the incarnation
;;;; it was made for, so each traps instead of reaching the new arena.
;;;;
;;;; Argument 3 makes and destroys arenas in a loop, as many times as the
;;;; second argument says. A retired allocator is reused rather than kept, so
;;;; the loop's memory stays flat however long it runs.
@ -35,6 +40,22 @@
(push w 5)
(println (at w 0))
(println (at v 0))))
;; The Allocator value itself, kept past its destroy, after arena-new
;; took its record back: b works, and a traps rather than naming b's
;; arena. Argument 5 is the same through with-allocator, and 6 through
;; a second arena-destroy.
(>= which 4)
(do
(arena-destroy a)
(let [b (arena-new 4096)
w (vec-new i32 b)]
(push w 5)
(println (at w 0))
(cond
(= which 4) (let [x (vec-new i32 a)] (push x 1))
(= which 5) (with-allocator a (let [x (vec-new i32)] (push x 1)))
:else (arena-destroy a))
(println "unreachable")))
(= which 3)
(let [n (bytes->i64 (bytes-view (at args 2)))]
(arena-destroy a)

20
test/programs/dev-alloc-param.flan Normal file
View File

@ -0,0 +1,20 @@
;;;; A function taking an Allocator, redefined while the program runs. The value
;;;; is two words, the record and its incarnation, and the redefined body is
;;;; compiled by the reload emitter and called through the host's cell, so the
;;;; two have to agree on how those words cross. test_dev.ml runs it on both
;;;; backends.
(import agent "vendor:agent")
(defonce region Allocator)
(defn fill [a Allocator n i32] i64
(let [v (vec-new i64 a)]
(dotimes [i n] (push v (i64 i)))
(i64 (length v))))
(defn main [] i32
(agent/start)
(set region (arena-new 4096))
(dotimes [i 4000]
(agent/wait 5))
0)

8
test/programs/dev-break.flan
View File

@ -15,7 +15,7 @@
(defn fetch [n i32] i32
(restart-case
(do (error (Missing {.id n})) 0)
(use-placeholder [] -1)
(use-placeholder [] :report "Answer -1" -1)
(retry [] 7)))
(defonce ticks i64)
@ -30,10 +30,14 @@
;;; the prelude, and the break loop's render now reads them field by field,
;;; padding and all. A layout that drifted would show the op in `lhs'.
;;; The operands are parameters so nothing constant-folds the division away.
;;; And a restart that takes a value, which the break loop has to be given.
(defonce got i64)
(defn divide [a i64 b i64] i64
(restart-case
(/ a b)
(use-zero [] 0)))
(use-zero [] 0)
(use-value [v i64] :report "Answer v instead" v)))
(defn main [] i32
(agent/start "/tmp/flan-dev-break-fallback.sock")

23
test/programs/dev-bt-handler.flan Normal file
View File

@ -0,0 +1,23 @@
;;;; A frame re-entered through a handler names the signal it is in, not the
;;;; last Flan call it made: [inner] calls [helper] on line 11 and stops on
;;;; line 12, and the handler pauses, so the backtrace shows [inner] at 12.
(import agent "vendor:agent")
(defstruct Oops [n i32])
(defn helper [] i32 1)
(defn inner [] i32
(helper)
(error (Oops {.n 1}))
0)
(defn go [] i32
(restart-case
(handler-bind [(Oops [_o] (pause))] (inner))
(skip [] 5)))
(defn main [] i32
(agent/start "/tmp/flan-dev-bt-handler-fallback.sock")
(println (go))
0)

36
test/programs/dev-temp-destroy.flan Normal file
View File

@ -0,0 +1,36 @@
;;;; A program that keeps its own temp arena as an Allocator value and stops.
;;;; test_dev.ml destroys that arena from an expression at the stop, makes a
;;;; new arena — which takes the destroyed one's record — and a Vec in it, then
;;;; resumes. The expression's scratch temp arena must not put the destroyed
;;;; record back as context/temp, or the next frame boundary would wipe the new
;;;; arena as the temp one and the Vec made there would trap.
(import agent "vendor:agent")
(defstruct Missing [id i32])
(defonce ar Allocator)
(defonce tv Allocator)
(defonce av (Vec u8))
(defn fetch [] i32
(restart-case
(do (error (Missing {.id 1})) 0)
(retry [] 7)))
(defn hold [] i32
(set tv context/temp)
(let [r (fetch)]
(println (string (i64->bytes 31)))
r))
(defn main [] i32
(agent/start)
(println (hold))
;; A frame boundary, which in a dev build wipes context/temp — the new
;; arena, had the destroyed record been put back as it.
(agent/poll)
(println (length av))
(println (at av 0))
(dotimes [i 4000]
(agent/wait 5))
0)

36
test/programs/dev-temp-stop.flan Normal file
View File

@ -0,0 +1,36 @@
;;;; A program that stops while it holds things in the temp allocator: [hold]'s
;;;; formatted text in a live frame, and [keep], a Vec made from context/temp.
;;;; [fetch] errors with nothing handling it, so the program stops there.
;;;; Expressions evaluated at the stop format numbers of their own and push
;;;; into [keep], which grows it through the program's temp arena, possibly
;;;; into a new chunk. After the retry restart the program prints the text and
;;;; [keep]'s length, first and last element; all of it has to be intact.
;;;; test_dev.ml drives it.
(import agent "vendor:agent")
(defstruct Missing [id i32])
(defonce keep (Vec u8))
(defn fetch [] i32
(restart-case
(do (error (Missing {.id 1})) 0)
(retry [] 7)))
(defn hold [] i32
(set keep (vec-new u8 context/temp))
(push keep (u8 5))
(let [s (string (i64->bytes 4242))
r (fetch)]
(println s)
(println (length keep))
(println (at keep 0))
(println (at keep (- (length keep) 1)))
r))
(defn main [] i32
(agent/start)
(println (hold))
(dotimes [i 4000]
(agent/wait 5))
0)

11
test/programs/dev-trap-dyn.flan Normal file
View File

@ -0,0 +1,11 @@
;;;; A dyn type mismatch is a trap, with no struct behind it: what it refused
;;;; is the sentence the runtime wrote, which the break loop carries to the
;;;; editor in place of fields.
(import agent "vendor:agent")
(defn add [x dyn y dyn] dyn (+ x y))
(defn main [] i32
(agent/start "/tmp/flan-dev-trap-dyn-fallback.sock")
(add 3 "hi")
0)

16
test/programs/dev-trap-stale-sentence.flan Normal file
View File

@ -0,0 +1,16 @@
;;;; A handled condition's sentence does not linger for the next stop: a bad
;;;; index is caught through Error, then a set on a slot the class does not
;;;; declare traps, and the break must carry that trap's own sentence.
(import agent "vendor:agent")
(defclass point [x y])
(defonce grid [3 i32])
(defonce far i32 4)
(defn main [] i32
(agent/start "/tmp/flan-dev-trap-stale-sentence-fallback.sock")
(println (handler-case (at grid far) [(Error [_e] -1)]))
(let [p (point 1 2)]
(set (get p :z) 1))
0)

34
test/programs/shim-literal.flan Normal file
View File

@ -0,0 +1,34 @@
;;;; A string literal handed to a declare-c goes to C uncopied; any other string
;;;; is copied and terminated.
;;;;
;;;; basename is bound for the pointer it returns, which for a name with no
;;;; slash in it is the pointer it was given: the literal's own address in the
;;;; program image for the first call, and the wrapper's stack buffer for the
;;;; second, whose string is a local and gets the copy. The two are far apart
;;;; only when the literal was not copied.
;;;;
;;;; puts then shows the bytes C read: the literal, the empty literal, and a
;;;; sub-view that has no NUL after it and so must still be copied.
;;;;
;;;; c-where2 is the same question through a signature with a struct in it,
;;;; which the shim answers with a Flan wrapper over a flattened declaration:
;;;; the literal has to pass through that wrapper. It binds glibc's POSIX
;;;; basename, which answers the same pointer and ignores the extra argument.
(defstruct Ch [c i32])
(declare-c c-where [s string] i64 "basename")
(declare-c c-where2 [s string c Ch] i64 "__xpg_basename")
(declare-c c-puts [s string] i32 "puts")
(defn far? [a i64 b i64] bool
(let [d (- a b)]
(> (if (< d 0) (- 0 d) d) 1048576)))
(defn main [] i32
(let [s "hello"]
(println (far? (c-where "hello") (c-where s)))
(println (far? (c-where2 "hello" (Ch {.c 104})) (c-where2 s (Ch {.c 104}))))
(c-puts "hello")
(c-puts "")
(c-puts (string (slice (bytes-view "hello world") 0 3))))
0)

17
test/programs/shim-nul-end.flan Normal file
View File

@ -0,0 +1,17 @@
;;;; A NUL as a string's last byte, handed to C. Only a literal crosses
;;;; uncopied, and only because the checker marks it at the call; a string that
;;;; merely ends in a NUL is copied like any other, and the NUL inside it is
;;;; refused. Each argument is one way to spell such a string, and each is
;;;; refused naming the call.
(declare-c c-puts [s string] i32 "puts")
(defn main [args [string]] i32
(let [which (if (> (length args) 1) (bytes->i64 (bytes-view (at args 1))) 0)]
(println "before")
(cond
(= which 1) (let [s "ab\0"] (c-puts s))
(= which 2) (c-puts (string (slice (bytes-view "ab\0c") 0 3)))
(= which 3) (c-puts (string (bytes "q\0")))
:else (c-puts "ab\0"))
(println "unreachable"))
0)

19
test/programs/stale-slice-poison.flan Normal file
View File

@ -0,0 +1,19 @@
;;;; A slice taken before a push moved the Vec's storage still points at the
;;;; old block. In a dev build that block is filled with 0xDEADBEEF words when
;;;; the move happens, so the stale read shows a value nobody wrote; a release
;;;; build leaves the old values where they were.
;;;;
;;;; The Vec lives in an arena so the old block stays mapped and the read is of
;;;; live memory. A second arena allocation between the two pushes keeps the
;;;; first block from being grown in place.
(defn main [] i32
(let [a (arena-new 4096)
v (vec-new i32 a)]
(dotimes [i 4] (push v (+ i 1)))
(let [s (slice v)
other (vec-new i32 a)]
(push other 0)
(push v 5)
(println (at s 0))
(println (at v 0))))
0)

5
test/programs/strings.flan
View File

@ -15,10 +15,7 @@
(println (string (slice (deref v)))))
(defn main [] i32
;; The builder. Three appends and two numbers into one Vec, which is the
;; case the shared static scratch buffer in the runtime makes impossible for
;; i64->bytes on its own: two of its results cannot be held at once, and
;; these two numbers are both in the answer.
;; The builder. Three appends and two numbers into one Vec.
(let [b (vec-new u8)]
(append (addr b) (bytes-view "x="))
(append-i64 (addr b) 42)

18
test/programs/temp-agent.flan Normal file
View File

@ -0,0 +1,18 @@
;;;; The dev half of temp-frame.flan: a frame loop that polls the agent at the
;;;; top of every frame and never calls (free-temp). In a dev build the poll is
;;;; a frame boundary and wipes the temp allocator, so the registry does not
;;;; fill; the last line is whether it overflowed.
(import agent "vendor:agent")
(declare-c reg-overflowed [] i32 "flan_dev_reg_overflowed")
(defn main [args [string]] i32
(let [n (bytes->i64 (bytes-view (at args 1)))
total (i64 0)]
(dotimes [i (i32 n)]
(agent/poll)
(let [s (string (i64->bytes (i64 i)))]
(set total (+ total (i64 (length (bytes-view s)))))))
(println total)
(println (reg-overflowed)))
0)

30
test/programs/temp-frame.flan Normal file
View File

@ -0,0 +1,30 @@
;;;; A frame loop that formats numbers every frame and calls (free-temp) at the
;;;; end of each. i64->bytes and f64->bytes put their text in the temp
;;;; allocator, so the loop's memory stays flat however many frames it runs,
;;;; and in a dev build the allocation registry does not fill: each frame's
;;;; blocks die at the free-temp and their addresses are handed out again.
;;;; Frame 7's text is kept past its free-temp by cloning it into the heap,
;;;; which is how text outlives its frame.
;;;;
;;;; The argument is the frame count. A negative one runs that many frames and
;;;; never calls free-temp, which is the control: memory grows and a dev
;;;; build's registry fills. The last line is whether the registry overflowed.
(declare-c reg-overflowed [] i32 "flan_dev_reg_overflowed")
(defn main [args [string]] i32
(let [arg (bytes->i64 (bytes-view (at args 1)))
n (if (< arg 0) (- 0 arg) arg)
total (i64 0)
kept (bytes-view "")]
(dotimes [i (i32 n)]
(let [s (string (i64->bytes (i64 i)))
f (f64->bytes (+ (f64 i) 0.5))]
(set total (+ total (i64 (+ (length (bytes-view s)) (length f)))))
(when (= i 7)
(set kept (clone f (heap-allocator)))))
(when (> arg 0)
(free-temp)))
(println total)
(println (string kept))
(println (reg-overflowed)))
0)

20
test/programs/temp-grow.flan Normal file
View File

@ -0,0 +1,20 @@
;;;; The temp allocator grows instead of failing. A Vec in it that is the
;;;; newest block and outgrows the current chunk is moved to a bigger one rather
;;;; than refused, whether it was made under with-allocator or named directly.
;;;;
;;;; Then text kept past a (free-temp) without a clone: a dev build has filled
;;;; the wiped bytes with 0xDEADBEEF, so its first byte reads 239 (0xEF); a
;;;; release build leaves the old text, whose first byte is the digit 4 (52).
(defn main [] i32
(with-allocator context/temp
(let [v (vec-new u8)]
(dotimes [i 3000000] (push v (u8 1)))
(println (length v))))
(let [w (vec-new u8 context/temp)]
(dotimes [i 3000000] (push w (u8 1)))
(println (length w)))
(free-temp)
(let [s (i64->bytes 42)]
(free-temp)
(println (at s 0)))
0)

31
test/programs/two-numbers.flan
View File

@ -8,12 +8,12 @@
;;;; No crash, no diagnostic, and nothing for a sanitizer to catch, because
;;;; every byte read was inside an object that was alive. The wrong bytes.
;;;;
;;;; The buffer is the caller's now, one frame slot per call site, which is why
;;;; the two conversions below do not collide and why the f64 held across an
;;;; i64 conversion — a different shim, and the same buffer before — survives
;;;; it. What the slice still does not outlive is its frame: storing one in a
;;;; container that lives longer, or returning it, hands back a view of storage
;;;; that has been reused. That is copying's job and is said in check.ml.
;;;; The conversion's bytes are now copied into the temp allocator, so a
;;;; result outlives the frame that made it: the last two cases return one from
;;;; a function and push them into a Vec that outlives the loop that made them.
(defn numstr [n i64] string
(string (i64->bytes n)))
(defn main [] i32
;; Two i64 conversions alive at the same time.
(let [a (string (i64->bytes 11))
@ -32,11 +32,24 @@
n (string (i64->bytes 7))]
(print x) (print " ") (println n)) ; 2.5 7
;; Inside a loop, where the slot is reused per iteration: each turn's text is
;; read before the next turn writes it, which is the contract a frame slot
;; gives. Printed on one line so the loop's shape is visible in the output.
;; Inside a loop, one conversion per turn. Printed on one line so the
;; loop's shape is visible in the output.
(dotimes [i 4]
(let [s (string (i64->bytes (i64 (* i 11))))]
(print s) (print " ")))
(println "") ; 0 11 22 33
;; Returned from the function that made it. With the text in that
;; function's frame, the second call wrote over the first.
(let [a (numstr 11)
b (numstr 22)]
(print a) (print " ") (println b)) ; 11 22
;; Pushed, and read after the loop.
(let [v (vec-new [u8])]
(dotimes [i 3]
(push v (f64->bytes (+ (f64 i) 0.5))))
(dotimes [i 3]
(print (string (at v i))) (print " "))
(println "")) ; 0.5 1.5 2.5
0)

265
test/test_acceptance.ml
View File

@ -940,17 +940,182 @@ let () =
outputs "string of bytes" "programs/string-of-bytes.flan" string_of_bytes_out;
outputs ~opt:"-O0" "string of bytes, -O0" "programs/string-of-bytes.flan"
string_of_bytes_out;
(* A literal crosses a declare-c uncopied, directly and through the Flan
wrapper a struct parameter makes; a sub-view with no NUL after it is
still copied. Every backend, because each writes the literal's NUL. *)
let shim_literal_out = "true\ntrue\nhello\n\nhel\n" in
outputs "a literal crosses to C uncopied" "programs/shim-literal.flan"
shim_literal_out;
outputs ~opt:"-O0" "a literal crosses to C uncopied, -O0"
"programs/shim-literal.flan" shim_literal_out;
outputs ~x86:true "a literal crosses to C uncopied, --x86"
"programs/shim-literal.flan" shim_literal_out;
(* (clone xs) on a slice: an independent copy, from the context or a named
allocator, of elements a byte wide and wider. *)
let clone_slice_out = "20 3 4 \n1 2 30 4 5 \n1 2.5 2\n0\n" in
outputs "clone of a slice" "programs/clone-slice.flan" clone_slice_out;
outputs ~opt:"-O0" "clone of a slice, -O0" "programs/clone-slice.flan"
clone_slice_out;
outputs ~x86:true "clone of a slice, --x86" "programs/clone-slice.flan"
clone_slice_out;
(* The temp allocator. A frame loop that formats numbers and calls
(free-temp) each frame stays flat from a thousand frames to a million,
and in a dev build the registry does not fill; frame 7's text survives
because it was cloned. The negative count, which never frees, is the
control that shows the check can fail. Every backend and a dev build. *)
let peak exe arg =
let o = Filename.concat scratch
(Printf.sprintf "flan-temp-%d.rss" (Unix.getpid ())) in
let code =
Sys.command
(Printf.sprintf "/usr/bin/time -f %%M -o %s %s %s > /dev/null 2>&1"
(Filename.quote o) (Filename.quote exe) arg)
in
let kb =
try int_of_string (String.trim (In_channel.with_open_bin o
In_channel.input_all))
with _ -> -1
in
(try Sys.remove o with Sys_error _ -> ());
(code, kb)
in
List.iter
(fun (x86, opt, dev, tag) ->
let exe = compile ~x86 ~opt ~dev "programs/temp-frame.flan" in
let code, text = run exe (Some "1000") in
if code <> 0 || text <> "7780\n7.5\n0\n" then begin
incr failures;
Printf.printf "FAIL a frame loop over the temp allocator%s\n\
\ got: %S (exit %d)\n" tag text code
end;
if Sys.file_exists "/usr/bin/time" then begin
let c1, small = peak exe "1000" and c2, large = peak exe "1000000" in
if c1 <> 0 || c2 <> 0 || small < 0 || large < 0
|| large - small > 4_000 then begin
incr failures;
Printf.printf
"FAIL free-temp keeps a frame loop flat%s\n\
\ got: %d KB after 1000 frames, %d KB after 1000000\n"
tag small large
end;
if dev then begin
let _, text = run exe (Some "1000000") in
if not (contains text "\n0\n") then begin
incr failures;
Printf.printf "FAIL the dev registry fills under free-temp%s\n\
\ got: %S\n" tag text
end;
let _, text = run exe (Some "-10000") in
if not (contains text "\n1\n") then begin
incr failures;
Printf.printf "FAIL the control: with no free-temp the dev \
registry never filled%s\n got: %S\n" tag text
end
end
end;
(try Sys.remove exe with Sys_error _ -> ()))
[ (false, "-O2", false, ""); (false, "-O0", false, ", -O0");
(true, "-O2", false, ", --x86"); (false, "-O2", true, ", dev");
(true, "-O2", true, ", dev --x86") ];
(* The temp arena's newest block outgrowing its chunk moves to a bigger
one, and a dev wipe poisons what it released. It reads stale memory on
purpose, so it stays out of the valgrind list. *)
let tg = "programs/temp-grow.flan" in
let tg_out d = "3000000\n3000000\n" ^ d ^ "\n" in
outputs "the temp allocator grows a Vec past its chunk" tg (tg_out "52");
outputs ~opt:"-O0" "the temp allocator grows a Vec past its chunk, -O0" tg
(tg_out "52");
outputs ~x86:true "the temp allocator grows a Vec past its chunk, --x86" tg
(tg_out "52");
outputs ~dev:true "a dev free-temp poisons the wiped text" tg (tg_out "239");
outputs ~dev:true ~x86:true "a dev free-temp poisons the wiped text, --x86"
tg (tg_out "239");
(* A dev build's agent poll is a frame boundary and wipes the temp
allocator itself: a loop that polls and never calls free-temp does not
fill the registry. *)
List.iter
(fun (x86, tag) ->
let exe = compile ~x86 ~dev:true "programs/temp-agent.flan" in
let code, text = run exe (Some "20000") in
if code <> 0 || text <> "88890\n0\n" then begin
incr failures;
Printf.printf "FAIL a dev agent poll wipes the temp allocator%s\n\
\ got: %S (exit %d)\n" tag text code
end;
(try Sys.remove exe with Sys_error _ -> ()))
[ (false, ""); (true, ", --x86") ];
(* The context restored by with-allocator after its arena was destroyed and
its record reused: the next use of the context, or of a value read
from it, traps at its site. *)
List.iter
(fun (x86, opt, tag) ->
let exe = compile ~x86 ~opt "programs/context-destroyed.flan" in
List.iter
(fun (arg, line) ->
let code, text = run exe (Some arg) in
if code <> 134 || not (contains text "5\n")
|| not (contains text
(Printf.sprintf "programs/context-destroyed.flan:%d:" line))
|| not (contains text "destroyed by arena-destroy")
|| contains text "unreachable"
then begin
incr failures;
Printf.printf
"FAIL a restored context whose arena was destroyed, \
argument %s%s\n got: %S (exit %d)\n"
arg tag text code
end)
[ ("0", 20); ("1", 19) ];
(try Sys.remove exe with Sys_error _ -> ()))
[ (false, "-O2", ""); (false, "-O0", ", -O0"); (true, "-O2", ", --x86") ];
(* A string ending in a NUL is refused however it is spelled — only a
literal the checker marked skips the copy, and its embedded NUL is
refused too. *)
List.iter
(fun (x86, opt, tag) ->
let exe = compile ~x86 ~opt "programs/shim-nul-end.flan" in
List.iter
(fun arg ->
let code, text = run exe (Some arg) in
if code <> 134 || not (contains text "before")
|| not (contains text "c-puts: a string passed to C contains a NUL byte")
|| contains text "unreachable"
then begin
incr failures;
Printf.printf
"FAIL a string ending in NUL is refused at the C boundary, \
argument %s%s\n got: %S (exit %d)\n"
arg tag text code
end)
[ "0"; "1"; "2"; "3" ];
(try Sys.remove exe with Sys_error _ -> ()))
[ (false, "-O2", ""); (false, "-O0", ", -O0"); (true, "-O2", ", --x86") ];
(* A slice taken before a push moved its Vec reads 0xDEADBEEF in a dev
build and the old value in a release one. *)
let poison = "programs/stale-slice-poison.flan" in
outputs ~dev:true "a dev build poisons a Vec's old buffer" poison
"-559038737\n1\n";
outputs ~dev:true ~opt:"-O0" "a dev build poisons a Vec's old buffer, -O0"
poison "-559038737\n1\n";
outputs ~dev:true ~x86:true "a dev build poisons a Vec's old buffer, --x86"
poison "-559038737\n1\n";
outputs "a release build leaves a Vec's old buffer alone" poison "1\n1\n";
(* Two rendered numbers held at once, which is what one shared buffer in
the runtime made impossible: this printed "22 22" and could not have
been caught by a sanitizer, because every byte read was inside a live
object — the wrong one. -O0 too, since the buffer is now a frame slot
and mem2reg is what decides whether the address escapes. *)
let two_numbers_out = "11 22\n123\n2.5 7\n0 11 22 33 \n" in
object — the wrong one. Then one returned from the function that made
it and three pushed into a Vec, which a frame slot could not outlive.
Every backend and level, since each lays out its frames its own way. *)
let two_numbers_out =
"11 22\n123\n2.5 7\n0 11 22 33 \n11 22\n0.5 1.5 2.5 \n"
in
outputs "two rendered numbers at once" "programs/two-numbers.flan"
two_numbers_out;
outputs ~opt:"-O0" "two rendered numbers at once, -O0"
"programs/two-numbers.flan" two_numbers_out;
outputs ~x86:true "two rendered numbers at once, --x86"
"programs/two-numbers.flan" two_numbers_out;
(* The other side of that boundary: bytes the copy cannot represent. A NUL
inside the string is where ptr+len and C's "ends at the first NUL" stop
@ -2061,13 +2226,13 @@ let () =
traps, because the epoch on a header only rises. *)
let code, text = run exe (Some "2") in
if code <> 134 || not (contains text "5\n")
|| not (contains text "programs/destroy-region.flan:37:")
|| not (contains text "programs/destroy-region.flan:42:")
|| not (contains text "allocator was released")
then begin
incr failures;
Printf.printf
"FAIL a container whose destroyed allocator was reused\n\
\ got: %S (exit %d)\n wanted: 5, then the trap at 37 (exit 134)\n"
\ got: %S (exit %d)\n wanted: 5, then the trap at 42 (exit 134)\n"
text code
end;
(* And the reuse is what keeps a make-and-destroy loop flat: two million
@ -2103,6 +2268,33 @@ let () =
end
end;
(try Sys.remove exe with Sys_error _ -> ());
(* The destroyed Allocator value itself, used after the next arena-new
took its record back: a new container, a with-allocator and a second
destroy each trap at the use rather than reaching the new arena. All
three backends, since the value's two words are laid out by each. *)
List.iter
(fun (x86, opt, tag) ->
let exe = compile ~x86 ~opt "programs/destroy-region.flan" in
List.iter
(fun (arg, line) ->
let code, text = run exe (Some arg) in
if code <> 134 || not (contains text "5\n")
|| not (contains text
(Printf.sprintf "programs/destroy-region.flan:%d:" line))
|| not (contains text "destroyed by arena-destroy")
|| contains text "unreachable"
then begin
incr failures;
Printf.printf
"FAIL a destroyed Allocator value whose record was reused, \
argument %s%s\n\
\ got: %S (exit %d)\n wanted: 5, then the trap at \
%d (exit 134)\n"
arg tag text code line
end)
[ ("4", 55); ("5", 56); ("6", 57) ];
(try Sys.remove exe with Sys_error _ -> ()))
[ (false, "-O2", ""); (false, "-O0", ", -O0"); (true, "-O2", ", --x86") ];
(try Sys.remove exe with Sys_error _ -> ());
@ -2954,6 +3146,63 @@ let () =
outputs ~dev:true "arithmetic with no answer is a condition, dev"
"programs/arith-condition.flan" arith_cond_out;
(* A handler for a parent answers every condition below it, and is handed
the name and the message — the condition with its values — rather than
its fields. *)
let parents_out =
"ArithError\ndivide by zero: (/ 10 0)\n-1\n\
BoundsError\nindex 6 is out of bounds for length 4\n-1\n\
DiskFull\n(DiskFull {.free 7})\n-1\n3\nDiskFull\n-2\n7\n\
true\ndivide by zero: (/ 10 0)\n-4\n1\n"
in
outputs "conditions have a parent link" "programs/condition-parents.flan"
parents_out;
outputs ~x86:true "conditions have a parent link, --x86"
"programs/condition-parents.flan" parents_out;
outputs ~dev:true "conditions have a parent link, dev"
"programs/condition-parents.flan" parents_out;
(* And the message outlives the frames it was made in: the clause runs
after the unwind and writes over their stack before printing it. *)
let messages_out =
"io\ndisk gone\nempty\nnothing\nMyErr\n(MyErr {.code 3 .why \"bad\"})\n\
ArithError\ndivide by zero: (/ 7 0)\n"
in
outputs "a parent's message outlives the unwind"
"programs/condition-messages.flan" messages_out;
outputs ~x86:true "a parent's message outlives the unwind, --x86"
"programs/condition-messages.flan" messages_out;
(* It lives until the frame ends: returned from the handler-case, it
survives the stack being reused, and a dev free-temp poisons it. *)
let ct = "programs/condition-temp.flan" in
let ct_out d = "(MyErr {.code 3})\n" ^ d ^ "\n" in
outputs "a parent's message lives in context/temp" ct (ct_out "false");
outputs ~x86:true "a parent's message lives in context/temp, --x86" ct
(ct_out "false");
outputs ~dev:true "a parent's message kept past free-temp is poisoned" ct
(ct_out "true");
outputs ~dev:true ~x86:true
"a parent's message kept past free-temp is poisoned, --x86" ct
(ct_out "true");
(* A handler reads a message at the size it needs; the unhandled message
goes through a fixed buffer and is cut there at a character, with an
ellipsis. *)
let e n = String.concat "" (List.init n (fun _ -> "\xc3\xa9")) in
let whole = "(Wide {.code 123 .why \"" ^ e 400 ^ "\"})\n" in
let cut = "unhandled Longs: " ^ e 1013 ^ "\xe2\x80\xa6\n" in
List.iter
(fun x86 ->
let exe = compile ~x86 "programs/condition-longmessage.flan" in
let code, text = run exe None in
if code <> 134 || not (contains text whole) || not (contains text cut)
then begin
incr failures;
Printf.printf
"FAIL a long message is whole, and cut at a character where it is cut%s\n got: %S (exit %d)\n"
(if x86 then ", --x86" else "") text code
end;
(try Sys.remove exe with Sys_error _ -> ()))
[ false; true ];
(* And the half that finishes that thought. bounds-condition.flan's last
line is `10 99 12 13` — an abandoned frame's leftovers — and a restart
undoes none of it, because a restart is not a transaction
@ -4016,12 +4265,12 @@ level "1"
"(declare-c open-it [path string] bool \"OpenIt\")"
[ "char a0_b[256];";
"flan_shim_cstr(a0_p, a0_n, a0_b, sizeof a0_b, \"open-it\")";
"bool r = OpenIt(a0);"; "flan_shim_cstr_free(a0, a0_b);";
"bool r = OpenIt(a0);"; "flan_shim_cstr_free(a0, a0_b, a0_p);";
" return r;\n" ];
shim_case "declare-c: two strings get two buffers"
"(declare-c both [a string b string] \"Both\")"
[ "char a0_b[256];"; "char a1_b[256];";
"flan_shim_cstr_free(a0, a0_b);"; "flan_shim_cstr_free(a1, a1_b);" ];
"flan_shim_cstr_free(a0, a0_b, a0_p);"; "flan_shim_cstr_free(a1, a1_b, a1_p);" ];
(* [declare] is untouched by any of this: its signature still IS the C
signature, which is what vendor/agent's flan_agent_start and the
@ -4061,7 +4310,7 @@ level "1"
shim_case "declare-c: a returned string outlives the argument copies"
"(declare-c base [p string] string \"Base\")"
[ "const char *r = flan_shim_ret_keep(Base(a0), out_n);\n\
\ flan_shim_cstr_free(a0, a0_b);\n return r;\n" ];
\ flan_shim_cstr_free(a0, a0_b, a0_p);\n return r;\n" ];
shim_refuses "declare-c: a callback"
"(declare-c each [f (Fn [i32] ())] \"Each\")"
"a C callback is not implemented";

37
test/test_agent.ml
View File

@ -32,6 +32,17 @@ let fail fmt = Test_support.fail fmt
let tmp name = Test_support.tmp "flan-agent-" name
let await ?(ms = 3000) f = Test_support.await ~ms f
(* A [restarts] reply with each row cut at its first tab: the index, the flag
and the name, which is what most checks below are about. *)
let names_only reply =
String.concat "\n"
(List.map
(fun l ->
match String.index_opt l '\t' with
| Some i -> String.sub l 0 i
| None -> l)
(String.split_on_char '\n' reply))
let send path line =
let s = Test_support.connect ~ms:2000 path in
let msg = line ^ "\n" in
@ -421,9 +432,17 @@ let () =
then fail "the program never reached the break loop: %S" !listed
else begin
(* Innermost first, and both on offer. *)
if !listed <> "0 + retry\n1 + use-placeholder\n.\n" then
(* After each name, tab-separated: the parameter count, their
spelling, where the clause is written, and its :report sentence —
empty for [retry], which wrote none. *)
let want =
"0 + retry\t0\t()\tprograms/break.flan:15:5\t\n\
1 + use-placeholder\t0\t()\tprograms/break.flan:14:5\t\
Answer -1 for the missing value\n.\n"
in
if !listed <> want then
fail "restarts on offer\n got: %S\n wanted: %S" !listed
"0 + retry\n1 + use-placeholder\n.\n";
want;
(* A name nothing offers is refused *here*, before the reply. Answering
ok and discovering it on the game thread would report success for
something that cannot happen. *)
@ -443,7 +462,7 @@ let () =
in
if not (await printed) then
fail "the first restart never produced its value"
else if not (await (fun () -> send bsock "restarts"
else if not (await (fun () -> names_only (send bsock "restarts")
= "0 + retry\n1 + use-placeholder\n.\n"))
then fail "the program never stopped a second time"
else begin
@ -462,7 +481,7 @@ let () =
in
if not (await printed2) then
fail "the second restart never produced its value"
else if not (await (fun () -> send bsock "restarts"
else if not (await (fun () -> names_only (send bsock "restarts")
= "0 + retry\n1 + retry\n.\n"))
then fail "the program never stopped on the shadowed pair"
else begin
@ -476,7 +495,13 @@ let () =
let drift = send bsock "restart-at 1 use-placeholder" in
if not (String.length drift >= 3 && String.sub drift 0 3 = "err")
then fail "an index whose name had drifted was accepted: %S" drift;
ignore (send bsock "restart-at 1 retry")
ignore (send bsock "restart-at 1 retry");
if not (await (fun () ->
names_only (send bsock "restarts") = "0 + keep\n.\n"))
then
fail "a handler-case's own restart was listed: %S"
(send bsock "restarts")
else ignore (send bsock "restart-at 0 keep")
end
end
end
@ -494,7 +519,7 @@ let () =
end
else begin
let text = In_channel.with_open_bin bout In_channel.input_all in
let want = "7\n-1\n900\n" in
let want = "7\n-1\n900\n42\n" in
let got =
String.concat "\n"
(List.filter

461
test/test_dev.ml
View File

@ -925,6 +925,19 @@ let () =
if names <> [ "retry"; "use-placeholder" ] then
fail "restarts on offer: %s" (String.concat ", " names)
| _ -> fail "break did not list the restarts");
(* Beside each name, in the same order: its :report sentence and
where its clause is written. [retry] wrote no report. *)
(match Wire.field r "details" with
| Some { Form.v = Form.List [ d0; d1 ]; _ } ->
let str = Wire.string_field in
if str d0 "report" <> Some "" || str d1 "report" <> Some "Answer -1"
then fail "the restarts' reports did not arrive";
(match str d1 "at" with
| Some at when contains_sub at "dev-break.flan:18:" -> ()
| at ->
fail "use-placeholder's clause is at %s"
(Option.value at ~default:"nowhere"))
| _ -> fail "break did not carry a detail per restart");
(* Where it is, which is the other half of what a stopped program can
be asked. The shadow stack is dev-only and the daemon owns the
@ -955,14 +968,17 @@ let () =
(Option.value ~default:(status r) (Wire.string_field r "message"))
else begin
match frames r with
| [ ("fetch", floc, "program"); ("main", _, "program") ] ->
| [ ("fetch", floc, "program"); ("main", mloc, "program") ] ->
(* Absolute and pointing into the program's own source, for the
same reason [defs] is: an editor is not in this process's
working directory. It comes off the frame, not off this end's
session, so a redefined body reports where the *installed* one
is written. *)
if String.length floc = 0 || floc.[0] <> '/' then
fail "a frame's location is not absolute: %s" floc
fail "a frame's location is not absolute: %s" floc;
(* And an outer frame is at the call it is in, not at its defn. *)
if not (contains_sub mloc "dev-break.flan:44:10") then
fail "main's frame is at %s, not at its call to fetch" mloc
| fs ->
fail "backtrace of a stopped program: %s"
(String.concat ", "
@ -979,6 +995,19 @@ let () =
if Wire.string_field r "value" <> Some "23" then
fail "C-x C-e while stopped: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"));
(* A parked expression's temp text is wiped when it finishes: the
second expression finds nothing live in context/temp, although the
first formatted a number into it. *)
ignore
(ask "(:op \"eval-expr\" :code \"(length (i64->bytes 12345))\" :file \"/tmp/buf.flan\")");
let r =
ask "(:op \"eval-expr\" :code \"(alloc-live-blocks context/temp)\" :file \"/tmp/buf.flan\")"
in
if Wire.string_field r "value" <> Some "0" then
fail "a parked expression's temp text was not wiped: %s"
(Option.value ~default:(status r)
(match Wire.string_field r "value" with
| Some v -> Some v | None -> Wire.string_field r "message"));
(* And installing, which the break loop deliberately allows: there is
no frame in progress, so the rule about swapping a body that is on
@ -1370,13 +1399,14 @@ let () =
l
| _ -> []
in
(* op 0 is FLAN_ARITH_DIV_ZERO; lhs is the dividend and rhs the
divisor, which is the pair the unhandled message prints. Each
read at its own offset, so an i32 followed by two i64s is the
layout both ends have to agree on. *)
(* op is ArithOp, an i32 at run time, and 0 is :div-zero; lhs is the
dividend and rhs the divisor, which is the pair the unhandled
message prints. Each read at its own offset, so an i32 followed
by two i64s is the layout both ends have to agree on. *)
if
fields
<> [ ("op", "i32", "0"); ("lhs", "i64", "1"); ("rhs", "i64", "0") ]
<> [ ("op", "ArithOp", ":div-zero"); ("lhs", "i64", "1");
("rhs", "i64", "0") ]
then
fail "ArithError's rendered fields: %s"
(String.concat ", "
@ -1390,6 +1420,12 @@ let () =
| Some site when contains_sub site "dev-break.flan:" && site.[0] = '/' -> ()
| Some site -> fail "the arith site points at %s" site
| None -> fail "a division by zero carries no :site");
(* And the runtime's sentence, which says what op 0 and the two
operands mean. *)
(match Wire.string_field (ask "(:op \"break\")") "sentence" with
| Some "divide by zero: (/ 1 0)" -> ()
| Some s -> fail "the arith sentence is %S" s
| None -> fail "a division by zero carries no :sentence");
let r = ask "(:op \"restart\" :name \"use-zero\")" in
if status r <> "ok" then
fail "resuming past a division by zero: %s"
@ -1398,6 +1434,80 @@ let () =
fail "the program never resumed past a division by zero"
end);
(* ── A restart that takes a value, taken from the break loop ────────
[use-value] takes an i64. The break names what it takes; taking it
without a value is refused with that; a value of the wrong type is
refused by the checker, in its own words; and a value that fits is
stored into the frame's buffer by a thunk and the clause binds it —
so [got] is 42 afterwards, a number only the typed value can make. *)
(let r =
ask
"(:op \"eval-expr\" :code \"(set got (divide (i64 5) (i64 0)))\" \
:file \"/tmp/buf.flan\")"
in
if status r <> "error" then
fail "a division by zero under use-value answered instead of stopping"
else if not (await (fun () -> stopped (ask "(:op \"describe\")"))) then
fail "a division by zero under use-value never stopped"
else begin
let r = ask "(:op \"break\")" in
let names =
match Wire.field r "restarts" with
| Some { Form.v = Form.List l; _ } ->
List.filter_map
(fun (n : Form.t) ->
match n.Form.v with Form.Str x -> Some x | _ -> None)
l
| _ -> []
in
let rec index_of i = function
| [] -> -1
| n :: rest -> if n = "use-value" then i else index_of (i + 1) rest
in
let i = index_of 0 names in
if i < 0 then fail "use-value is not on offer: %s" (String.concat ", " names)
else begin
(match Wire.field r "details" with
| Some { Form.v = Form.List ds; _ } when List.length ds > i ->
let d = List.nth ds i in
if Wire.string_field d "params" <> Some "(i64)" then
fail "use-value's parameters are not on the wire as (i64)"
| _ -> fail "break carried no details for use-value");
let take args =
ask
(Printf.sprintf
"(:op \"restart-at\" :index %d :name \"use-value\"%s)" i
(if args = "" then "" else " :args " ^ args))
in
let said r = Option.value ~default:"" (Wire.string_field r "message") in
let r = take "" in
if status r <> "error" || not (contains_sub (said r) "takes (i64)") then
fail "use-value taken with no value: %s" (said r);
let r = take "(\"1\" \"2\")" in
if status r <> "error" || not (contains_sub (said r) "was given 2") then
fail "use-value taken with two values: %s" (said r);
let r = take "(\"\\\"text\\\"\")" in
if status r <> "error" || not (contains_sub (said r) "i64") then
fail "use-value taken with a string: %s" (said r);
let r = take "(\"(+ 40 2)\")" in
if status r <> "ok" then fail "use-value taken with 42: %s" (said r)
else begin
(match Wire.field r "values" with
| Some { Form.v = Form.List [ { Form.v = Form.Str "42"; _ } ]; _ } -> ()
| _ -> fail "the reply does not show the value the clause binds");
if not (await (fun () -> not (stopped (ask "(:op \"describe\")"))))
then fail "the program never resumed through use-value"
else
let r =
ask "(:op \"eval-expr\" :code \"got\" :file \"/tmp/buf.flan\")"
in
if Wire.string_field r "value" <> Some "42" then
fail "use-value's clause bound %s, not 42"
(Option.value ~default:(said r) (Wire.string_field r "value"))
end
end
end);
(* ...and the other way out. Every check above is of an abort being
*refused*; the accepted path is the one that must not be left as code
that has never run, because it is the one that ends a program. Break
@ -1647,12 +1757,14 @@ let () =
in
if status r <> "error" then
fail "an expression that stopped inside the bounds break answered anyway";
(* Its site is its own (error ...), in the evaluated buffer. *)
(let r = ask "(:op \"break\")" in
if status r <> "ok" then fail "break inside the bounds break: %s" (status r)
else
match Wire.string_field r "site" with
| None -> ()
| Some site -> fail "the inner break inherited the trap's site: %s" site);
| Some site when contains_sub site "/tmp/buf.flan:" -> ()
| Some site -> fail "the inner break inherited the trap's site: %s" site
| None -> fail "the inner break's (error ...) carried no site");
let r = ask "(:op \"restart\" :name \"back\")" in
if status r <> "ok" then
fail "resuming the inner break: %s"
@ -1661,7 +1773,10 @@ let () =
if not
(await (fun () ->
let r = ask "(:op \"break\")" in
status r = "ok" && Wire.string_field r "site" <> None))
status r = "ok"
&& (match Wire.string_field r "site" with
| Some site -> contains_sub site "dev-break-bounds.flan:"
| None -> false)))
then fail "the outer bounds break lost its site after the inner one";
(* And the payoff: taking it resumes, which is the difference between a
stop you can recover from and a dead session. *)
@ -1779,7 +1894,8 @@ let () =
standalone half of the same claim is test_acceptance.ml's
free-all-refused, which still exits 134: nothing installs the hook in a
program that did not import the agent. *)
let trap_park ?(refault = false) ?(trapping = "") what prog cond restarts =
let trap_park ?(refault = false) ?(trapping = "") ?(sentence = "")
?(x86 = false) what prog cond restarts =
let tsock = tmp (prog ^ ".sock") and tout = tmp (prog ^ ".out") in
(try Sys.remove tsock with Sys_error _ -> ());
let tfd =
@ -1787,7 +1903,8 @@ let () =
in
let tpid =
Unix.create_process flan
[| flan; "dev"; "programs/" ^ prog; "-s"; tsock |]
(Array.append [| flan; "dev"; "programs/" ^ prog; "-s"; tsock |]
(if x86 then [| "--x86" |] else [||]))
Unix.stdin tfd Unix.stderr
in
Unix.close tfd;
@ -1842,6 +1959,12 @@ let () =
like it had been unwound. *)
let r = ask "(:op \"break\")" in
if status r <> "ok" then fail "break at the %s trap: %s" what (status r);
(* A trap has no fields; what it refused is its sentence. *)
if sentence <> "" then
(match Wire.string_field r "sentence" with
| Some s when contains_sub s sentence -> ()
| Some s -> fail "the %s trap's sentence is %S" what s
| None -> fail "the %s trap carried no :sentence" what);
(match Wire.field r "restarts" with
| Some { Form.v = Form.List l; _ } ->
let names =
@ -2014,9 +2137,21 @@ let () =
end
end
in
trap_park "free-all" "dev-trap-free-all.flan" "NoFreeAll" [ "continue" ];
trap_park ~trapping:"(do (free-all nowhere) 0)" "null allocator"
trap_park ~sentence:"does not offer free-all" "free-all"
"dev-trap-free-all.flan" "NoFreeAll" [ "continue" ];
trap_park ~sentence:"this allocator is null"
~trapping:"(do (free-all nowhere) 0)" "null allocator"
"dev-trap-null-alloc.flan" "NullAllocator" [];
trap_park ~sentence:"dyn +: int and text"
"dyn type" "dev-trap-dyn.flan" "DynType" [];
(* A condition a handler took leaves no sentence behind for the next stop,
and a class-slot trap says its own. *)
List.iter
(fun x86 ->
trap_park ~x86 ~sentence:"dyn set: point has no slot :z"
(if x86 then "stale sentence, --x86" else "stale sentence")
"dev-trap-stale-sentence.flan" "DynType" [])
[ false; true ];
(* And the one that used to be a silent death rather than an exit code:
SIGSEGV. The author's dogfooding session sorted (bytes "INSERTIONSORT")
in place — the old aliasing bytes — and the session vanished without a
@ -5924,22 +6059,24 @@ let () =
{ Form.v = Form.Str "i32"; _ };
{ Form.v = Form.Str "7"; _ } ]; _ } ]; _ } -> ()
| _ -> fail "x86 condition did not render (Boom {.why 7})");
(* And a user [error] carries no site — there is no trapping
expression behind it — which is the same answer LLVM gives. Said
rather than left untested: the site is absent here for a reason,
not because this backend cannot produce one. *)
(* And a user [error] carries its own site, the (error ...) in
[look], which is the same answer LLVM gives: the descriptor the
signal passes holds it on both backends. *)
(match Wire.string_field (request c "(:op \"break\")") "site" with
| None -> ()
| Some site -> fail "an x86 user error carried a site: %s" site);
| Some site when contains_sub site "dev-locals.flan:" -> ()
| Some site -> fail "an x86 user error's site is %s" site
| None -> fail "an x86 user error carried no site");
if status r <> "ok" then fail "x86 backtrace: %s" (said r)
else
(match frames with
| [ ("look", l0, "program"); ("main", _, "program") ] ->
(* The location travels in the frame's own descriptor, so a wrong
one is a descriptor built from the wrong function rather than a
cosmetic slip. *)
if not (contains_sub l0 "dev-locals.flan:14") then
fail "x86 backtrace put look at %S" l0
| [ ("look", l0, "program"); ("main", l1, "program") ] ->
(* Where each frame is: the innermost at the (error ...) that
stopped it, and main at its call to [look] — the store each
call makes into its caller's frame, on this backend. *)
if not (contains_sub l0 "dev-locals.flan:35:13") then
fail "x86 backtrace put look at %S" l0;
if not (contains_sub l1 "dev-locals.flan:46:10") then
fail "x86 backtrace put main at %S" l1
| _ ->
fail "x86 backtrace: %s"
(String.concat ", "
@ -7375,6 +7512,216 @@ let () =
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ csock; cout ];
(* ── A function taking an Allocator, redefined ─────────────────
An Allocator value is two words, the record and its incarnation. The
redefined body is built by the reload emitter and reached through the
host's cell, so the host and the module have to agree on how the two
words cross; each backend is its own pair of emitters. *)
List.iter
(fun mode ->
let asock = tmp ("alloc" ^ mode ^ ".sock")
and aout = tmp ("alloc" ^ mode ^ ".out") in
(try Sys.remove asock with Sys_error _ -> ());
let afd =
Unix.openfile aout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
in
let apid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-alloc-param.flan"; "-s"; asock; mode |]
Unix.stdin afd Unix.stderr
in
Unix.close afd;
if not (listening ~pid:apid asock) then begin
fail "the %s allocator daemon %s" mode !listen_why;
(try Unix.kill apid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect asock in
let value r = Option.value ~default:"" (Wire.string_field r "value") in
let ask code =
request c
(Printf.sprintf
"(:op \"eval-expr\" :code %S :file \"programs/dev-alloc-param.flan\")"
code)
in
let answered = ref "" in
let asked () =
let r = ask "(fill region 3)" in
status r = "ok" && (answered := value r; true)
in
if not (await asked) then
fail "the %s allocator daemon never reached a frame boundary" mode
else begin
if !answered <> "3" then
fail "%s: fill as built answered %S" mode !answered;
let r =
request c
"(:op \"eval\" :code \"(defn fill [a Allocator n i32] i64 (let \
[v (vec-new i64 a)] (dotimes [i (* n 10)] (push v (i64 i))) \
(+ 1000 (i64 (length v)))))\" :file \
\"programs/dev-alloc-param.flan\")"
in
if status r <> "ok" then fail "%s: redefining fill: %s" mode (status r)
else begin
let r = ask "(fill region 3)" in
if value r <> "1030" then
fail "%s: the redefined fill answered %S" mode (value r)
end
end;
(try Unix.close c with Unix.Unix_error _ -> ());
(try Unix.kill apid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] apid) with Unix.Unix_error _ -> ())
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ asock; aout ])
[ "--llvm"; "--x86" ];
(* ── Temp text held by a stopped frame ─────────────────────────
An expression evaluated at a stop runs with context/temp pointed at a
scratch arena that is wiped when it finishes: what it formatted is
reclaimed, so the scratch arena is empty at the start of every
evaluation. The program's own temp arena is not touched: the text the
stopped frame formatted is intact when the program resumes, and a temp
Vec it owns, pushed into at the stop, keeps what it held and what was
pushed — whether it grew in place or into a new chunk. *)
List.iter
(fun (mode, pushes) ->
let tsock = tmp (Printf.sprintf "tstop%s%d.sock" mode pushes) in
(try Sys.remove tsock with Sys_error _ -> ());
let tpid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-temp-stop.flan"; "-s"; tsock; mode |]
Unix.stdin Unix.stdout Unix.stderr
in
if not (listening ~pid:tpid tsock) then begin
fail "the %s temp-stop daemon %s" mode !listen_why;
(try Unix.kill tpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect tsock in
let out = Buffer.create 64 in
let ask sexp =
let r = Wire.parse (Wire.send c sexp; Wire.recv c) in
(match Wire.string_field r "output" with
| Some t -> Buffer.add_string out t
| None -> ());
r
in
let stopped r =
match Wire.field r "stopped" with
| Some { Form.v = Form.Sym "t"; _ } -> true
| _ -> false
in
let eval code =
ask
(Printf.sprintf
"(:op \"eval-expr\" :code %S :file \"programs/dev-temp-stop.flan\")"
code)
in
let live () =
Option.value ~default:"?"
(Wire.string_field (eval "(alloc-live-blocks context/temp)") "value")
in
if not (await (fun () -> stopped (ask "(:op \"describe\")"))) then
fail "%s: the temp-stop program never stopped" mode
else begin
for _ = 1 to 5 do
ignore (eval "(length (i64->bytes 123456789))")
done;
let after = live () in
if after <> "0" then
fail "%s: an expression at a stop found %s blocks left in its temp arena"
mode after;
let r =
eval (Printf.sprintf "(dotimes [i %d] (push keep (u8 9)))" pushes)
in
if status r <> "ok" then
fail "%s: pushing into the program's temp Vec at a stop: %s" mode
(Option.value ~default:(status r) (Wire.string_field r "message"));
let r = ask "(:op \"restart\" :name \"retry\")" in
if status r <> "ok" then fail "%s: retry at the stop: %s" mode (status r)
else if not
(await (fun () ->
ignore (ask "(:op \"describe\")");
contains_sub (Buffer.contents out)
(Printf.sprintf "4242\n%d\n5\n9\n7\n" (pushes + 1))))
then
fail "%s: the stopped frame's text did not survive: %S" mode
(Buffer.contents out)
end;
(try Unix.close c with Unix.Unix_error _ -> ());
(try Unix.kill tpid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] tpid) with Unix.Unix_error _ -> ())
end;
(try Sys.remove tsock with Sys_error _ -> ()))
[ ("--llvm", 20); ("--x86", 20); ("--llvm", 3000000); ("--x86", 3000000) ];
(* ── The program's temp arena destroyed from a stop ────────────
The scratch arena's end must not put back a temp arena the expression
destroyed: a later arena-new takes its record, and context/temp would
then be that other arena. *)
List.iter
(fun mode ->
let dsock = tmp ("tdestroy" ^ mode ^ ".sock") in
(try Sys.remove dsock with Sys_error _ -> ());
let dpid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-temp-destroy.flan"; "-s"; dsock; mode |]
Unix.stdin Unix.stdout Unix.stderr
in
if not (listening ~pid:dpid dsock) then begin
fail "the %s temp-destroy daemon %s" mode !listen_why;
(try Unix.kill dpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect dsock in
let out = Buffer.create 64 in
let ask sexp =
let r = Wire.parse (Wire.send c sexp; Wire.recv c) in
(match Wire.string_field r "output" with
| Some t -> Buffer.add_string out t
| None -> ());
r
in
let stopped r =
match Wire.field r "stopped" with
| Some { Form.v = Form.Sym "t"; _ } -> true
| _ -> false
in
let eval code =
ask
(Printf.sprintf
"(:op \"eval-expr\" :code %S :file \"programs/dev-temp-destroy.flan\")"
code)
in
if not (await (fun () -> stopped (ask "(:op \"describe\")"))) then
fail "%s: the temp-destroy program never stopped" mode
else begin
List.iter
(fun code ->
let r = eval code in
if status r <> "ok" then
fail "%s: %s at the stop: %s" mode code
(Option.value ~default:(status r)
(Wire.string_field r "message")))
[ "(arena-destroy tv)"; "(set ar (arena-new 4096))";
"(set av (vec-new u8 ar))"; "(push av (u8 7))" ];
ignore (ask "(:op \"restart\" :name \"retry\")");
if not
(await (fun () ->
(try ignore (ask "(:op \"describe\")") with _ -> ());
contains_sub (Buffer.contents out) "31\n7\n1\n7\n"))
then
fail "%s: after destroying the temp arena at a stop: %S" mode
(Buffer.contents out)
end;
(try Unix.close c with Unix.Unix_error _ -> ());
(try Unix.kill dpid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] dpid) with Unix.Unix_error _ -> ())
end;
(try Sys.remove dsock with Sys_error _ -> ()))
[ "--llvm"; "--x86" ];
(* ══ The agent socket is not the editor protocol ══════════════════
Two daemons of their own, both about what a session owes an editor
@ -7495,6 +7842,68 @@ let () =
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ lsock; lout ];
(* ── A frame re-entered through a handler names its signal ─────────
[inner] calls [helper] and then signals; a handler pauses. The pause
stands in the handler, so [inner] is an outer frame, and it must name
the (error ...) it is in — line 12 — and not its call to [helper] on
line 11, which has returned. On both backends. *)
List.iter
(fun backend ->
let bsock = tmp ("bt-" ^ backend ^ ".sock")
and bout = tmp ("bt-" ^ backend ^ ".out") in
(try Sys.remove bsock with Sys_error _ -> ());
let bfd =
Unix.openfile bout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
in
let bpid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-bt-handler.flan"; "-s"; bsock;
"--" ^ backend |]
Unix.stdin bfd Unix.stderr
in
Unix.close bfd;
if not (listening ~pid:bpid bsock) then begin
fail "the backtrace-handler daemon (--%s) %s" backend !listen_why;
(try Unix.kill bpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect bsock in
let stopped () =
match Wire.field (request c "(:op \"describe\")") "stopped" with
| Some { Form.v = Form.Sym "t"; _ } -> true
| _ -> false
in
if not (await stopped) then
fail "--%s: the handler's pause never stopped the program" backend
else begin
let r = request c "(:op \"backtrace\")" in
let frames =
match Wire.field r "frames" with
| Some { Form.v = Form.List l; _ } ->
List.filter_map
(fun (e : Form.t) ->
match e.Form.v with
| Form.List
({ Form.v = Form.Str n; _ }
:: { Form.v = Form.Str loc; _ } :: _) -> Some (n, loc)
| _ -> None)
l
| _ -> []
in
match List.assoc_opt "inner" frames with
| Some loc when contains_sub loc "dev-bt-handler.flan:12:" -> ()
| Some loc -> fail "--%s: inner's frame is at %s, not line 12" backend loc
| None ->
fail "--%s: no inner frame: %s" backend
(String.concat ", " (List.map fst frames))
end;
(try Unix.close c with Unix.Unix_error _ -> ());
(try Unix.kill bpid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] bpid) with Unix.Unix_error _ -> ())
end;
List.iter (fun p -> try Sys.remove p with Sys_error _ -> ()) [ bsock; bout ])
[ "llvm"; "x86" ];
(* ── The parked note, once per park ────────────────────────────────
A finished program is parked, so re-evaluating while a run's output is
still on the screen is the commonest thing there is — and it used to

70
test/test_flan.ml
View File

@ -2283,7 +2283,18 @@ let () =
~needle:"expected [u8], found [const u8]";
rejects_check "and the refusal names the copy"
"(defn g [b [u8]] () (set (at b 0) 1)) (defn f [s [const u8]] () (g s))"
~needle:"(bytes (string v)) copies v";
~needle:"(clone v) copies v into a [u8] of its own";
accepts "and the copy it names compiles"
"(defn g [b [u8]] () (set (at b 0) 1)) (defn f [s [const u8]] () (g (clone s)))";
rejects_check "a store through a const slice names clone"
"(defstruct P [x i32]) (defn f [v [const P]] () (set (.x (at v 0)) 1))"
~needle:"(clone v) copies v's elements into one";
accepts "and that clone compiles"
"(defstruct P [x i32]) \
(defn f [v [const P]] () (let [w (clone v)] (set (.x (at w 0)) 1)))";
rejects_check "no clone named for elements clone refuses"
"(defn f [v [const dyn]] () (set (at v 0) 1))"
~needle:"take it as a [dyn] instead";
rejects_check "a generic writer does not take a const slice"
"(defn f [s [const i32]] () (sort s))"
~needle:"sort takes a slice it may write through";
@ -3168,6 +3179,17 @@ let () =
"(defdata V [Nil (L [xs (Vec V)])])\n\
(defn f [v (Vec V)] () (let [c (clone v)] (free c)))"
~needle:"cannot be cloned";
rejects_check "clone on a slice of dyn, at the clone"
"(defonce pair [2 dyn])\n(defn make [] [dyn] (clone (slice pair)))"
~needle:"[dyn] cannot be cloned — its elements hold a dyn";
rejects_check "clone on a slice of structs holding a dyn"
"(defstruct B [d dyn])\n(defn make [xs [B]] [B] (clone xs))"
~needle:"[B] cannot be cloned — its elements hold a dyn";
rejects_check "clone on a slice of owning elements"
"(defn f [v [(Vec i32)]] i32 (length (clone v)))"
~needle:"[(Vec i32)] cannot be cloned";
accepts "clone on a slice, with and without an allocator"
"(defn f [v [f64] a Allocator] i32 (+ (length (clone v)) (length (clone v a))))";
(* ── A move-only global ─────────────────────────────────────────────
Legal, started zeroed, and since the repeal of the flow analysis it is
@ -3680,6 +3702,46 @@ let () =
(* The rule the blanket one could not express, both ways round. A loop
wholly inside a restart-case body keeps its local break; a break that
would *leave* the restart-case is refused, and says so. *)
(* A condition's parent. A parent has exactly Error's two fields, because a
handler for it is handed the name and the sentence and not the fields. *)
accepts "a condition may name Error as its parent"
"(defstruct Oops :parent Error [n i32]) (defn f [] () (error (Oops {.n 1})))";
accepts "a category with no field vector gets Error's fields"
"(defstruct Io :parent Error) (defstruct Full :parent Io [n i32]) \
(defn f [e Io] string (.message e))";
accepts "the suggested category spelling compiles"
"(defstruct Category :parent Error)";
rejects_check "a parent with fields of its own is refused, fixed at the parent"
"(defstruct Oops :parent Error [n i32]) (defstruct Worse :parent Oops [m i32])"
~needle:"Oops has [n i32]. Declare it with no field vector, \
(defstruct Oops :parent Error)";
rejects_check "a parent with no fields at all is not said to have some"
"(defstruct E []) (defstruct Worse :parent E [m i32])"
~needle:"E has [none]. Declare it with no field vector, \
(defstruct E :parent Error)";
accepts "an empty field vector under a parent is a category"
"(defstruct Io :parent Error []) (defstruct Full :parent Io [n i32]) \
(defn f [e Io] string (.message e))";
rejects_check "a parent that is not a struct is refused"
"(defstruct Oops :parent i32 [n i32])"
~needle:"a parent is a condition struct";
rejects_check "a condition cannot be its own parent"
"(defstruct Oops :parent Oops)" ~needle:"cannot be its own parent";
rejects_check "a chain of parents that loops is refused"
"(defstruct A :parent B) (defstruct B :parent A)"
~needle:"a chain of parents has to end";
parse_rejects "a parent comes before the fields"
"(defstruct Oops [n i32] :parent Error)"
~needle:"(defstruct Name :parent Parent [field Type ...])";
(* SBCL's placement for a clause's report: after the parameters. *)
accepts "a restart clause may carry a :report sentence"
"(defn f [] i64 (restart-case 1 (retry [] :report \"Try again\" (do) 2)))";
accepts "the suggested :report spelling compiles"
"(defn f [] () (restart-case (do) (retry [] :report \"Try again\" (do))))";
parse_rejects "a :report that is not a string is refused"
"(defn f [] i64 (restart-case 1 (retry [] :report 5 2)))"
~needle:"a restart's :report is a string";
accepts "a loop inside a restart-case may break out of itself"
"(defn f [] () (restart-case (while true (break)) (go [] (println \"\"))))";
rejects_check "break may not leave a restart-case"
@ -4636,7 +4698,7 @@ let () =
let known_structs =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with Ast.Defstruct (n, _) -> Some n | _ -> None)
match d.Ast.d with Ast.Defstruct (n, _, _) -> Some n | _ -> None)
ds
and known_unions =
List.filter_map
@ -4733,7 +4795,7 @@ let () =
let known_structs =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with Ast.Defstruct (n, _) -> Some n | _ -> None)
match d.Ast.d with Ast.Defstruct (n, _, _) -> Some n | _ -> None)
fixture_ds
and known_unions =
List.filter_map
@ -4905,7 +4967,7 @@ let () =
let structs_of ds =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with Ast.Defstruct (n, fs) -> Some (n, fs) | _ -> None)
match d.Ast.d with Ast.Defstruct (n, fs, _) -> Some (n, fs) | _ -> None)
ds
in
check "a defstruct that matches the header is not reported"

6
test/test_session.ml
View File

@ -1523,7 +1523,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\"") then
if not (has c.Session.ir "c\"x\\0Ay\\0Az\\00\"") 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);
@ -1556,7 +1556,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\"") then
if not (has c.Session.ir "c\"x\\0Ay\\00\"") 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);
@ -1620,7 +1620,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\"") then
if not (has c.Session.ir "c\"x i64\\0Ay\\00\"") 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);

3
test/test_valgrind.ml
View File

@ -254,6 +254,9 @@ let corpus =
"programs/destroy-region.flan", [ "1" ];
"programs/destroy-region.flan", [ "2" ];
"programs/destroy-region.flan", [ "3"; "1000" ];
"programs/destroy-region.flan", [ "4" ];
"programs/destroy-region.flan", [ "5" ];
"programs/destroy-region.flan", [ "6" ];
"programs/string-of-bytes.flan", [];
"programs/text.flan", [];
"programs/time.flan", [];

212
vendor/agent/flan_agent.c vendored
View File

@ -115,6 +115,9 @@ int64_t flan_dev_reg_by_type(int32_t live_only, int64_t *counts,
int64_t *typelens, int64_t cap, int64_t *unread);
int flan_dev_reg_enabled(void);
int flan_dev_reg_overflowed(void);
void flan_free_temp(void);
void *flan_temp_scratch_begin(void);
void flan_temp_scratch_end(void *prev);
/* A ring the listener writes and the game thread reads. One producer, one
* consumer, so two atomics and no lock — the game thread must never block on
@ -319,6 +322,7 @@ extern int32_t flan_dev_frame_count(void);
extern void *flan_dev_frame_at(int32_t i);
extern const char *flan_dev_frame_name(const void *frame, int64_t *len);
extern const char *flan_dev_frame_loc(const void *frame, int64_t *len);
extern const char *flan_dev_frame_at_loc(const void *frame, int64_t *len);
extern int32_t flan_dev_frame_nslots(const void *frame);
extern int32_t flan_dev_frame_slotsig(const void *frame);
extern int32_t flan_dev_frame_refsig(const void *frame);
@ -332,10 +336,25 @@ extern void flan_restart_take(void *frame, void *xfer);
* thread the trap stopped. */
extern const uint8_t *flan_break_site;
extern int64_t flan_break_site_len;
/* And the sentence the runtime wrote about the stop — what the condition's
* fields mean, or what a trap with no fields refused — under the same rule. */
extern char flan_break_sentence[];
extern int64_t flan_break_sentence_len;
/* A restart frame with no Flan function under it, which is what the boundary
* below is made of. The storage belongs to flan_rt.c for the reason the
* shadow-stack frame's shape does: the struct is declared in one file. */
extern void *flan_restart_push_c(const uint8_t *name, int64_t namelen);
extern void *flan_restart_push_c(const uint8_t *name, int64_t namelen,
const uint8_t *report, int64_t reportlen);
/* What a break loop shows about a restart beyond its name, read off a frame
* [flan_restart_frame] handed out. */
extern const uint8_t *flan_restart_frame_loc(const void *frame, int64_t *len);
extern const uint8_t *flan_restart_frame_report(const void *frame, int64_t *len);
extern const uint8_t *flan_restart_frame_sig(const void *frame, int64_t *len);
extern int32_t flan_restart_frame_arity(const void *frame);
extern int32_t flan_restart_frame_hidden(const void *frame);
extern void *flan_restart_frame_args(const void *frame);
extern int32_t flan_restart_frame_armed(const void *frame);
extern void flan_restart_frame_arm(void *frame);
extern void flan_restart_pop_c(void *frame);
extern int (*flan_dyn_migrate_hook)(void *fn, uint64_t instance,
uint64_t added, uint64_t discarded);
@ -404,6 +423,8 @@ static int32_t frame_floor = -1;
* around the call like the floors, so nesting names the innermost. */
static void *eval_boundary;
static const uint8_t abandon_name[] = "abandon-evaluation";
static const uint8_t abandon_report[] =
"Stop running the expression; the program carries on";
/* The way out of the innermost evaluation for a break that has no transfer
* channel — a trap: a fault, a failed bounds check, a null allocator. A
@ -458,7 +479,7 @@ static int migrate_call(void *fn, uint64_t instance, uint64_t added,
restart_floor = flan_restart_count();
frame_floor = flan_dev_frame_count();
eval_boundary = NULL;
mine = flan_restart_push_c(migrate_name, sizeof migrate_name - 1);
mine = flan_restart_push_c(migrate_name, sizeof migrate_name - 1, NULL, 0);
((migrate_fn_t)fn)(instance, added, discarded, &xfer);
flan_restart_pop_c(mine);
eval_boundary = obound;
@ -539,6 +560,8 @@ static _Atomic int aborting;
* comes from here and nothing re-reads the live stack. */
#define SNAP_MAX 64 /* restarts offered at one break */
#define SNAP_NAMES 4096 /* bytes of names behind them */
#define SNAP_TEXT 16384 /* and of what a listing shows
* beside each name */
#define FRAME_MAX 64 /* frames listed in a backtrace */
#define FRAME_TEXT 8192 /* bytes of names and locations */
@ -575,6 +598,17 @@ typedef struct {
int32_t escapable;
int32_t used;
char names[SNAP_NAMES];
/* Beside each name: how many parameters the clause takes, how their types
* are spelled, where the clause is written and its :report sentence. Copied
* for the reason the names are — the frame they are read from can be popped
* while this break is still being asked about. Tabs and newlines in them are
* spaces here, because a tab is what separates them on the wire. */
int32_t arity[SNAP_MAX];
int32_t sigoff[SNAP_MAX], siglen[SNAP_MAX];
int32_t locoff[SNAP_MAX], loclen[SNAP_MAX];
int32_t repoff[SNAP_MAX], replen[SNAP_MAX];
int32_t tused;
char text[SNAP_TEXT];
/* Where the stopped thread is, taken at the same moment and for the same
* reason: the chain is the game thread's, and it is holding still only
* because it is parked in this loop. [fframe] is kept as well as the text,
@ -606,6 +640,10 @@ typedef struct {
* Empty for a stop with no site — a user (error ...), a (pause). */
int32_t sitelen;
char site[512];
/* The runtime's sentence about the stop, copied and consumed with the
* site. Empty for a stop whose condition says what it is in its fields. */
int32_t sentencelen;
char sentence[2048]; /* FLAN_SENTENCE_MAX */
} snapshot;
/* One per nested break loop, because an inner break must not answer with the
@ -658,6 +696,67 @@ static snapshot *snap_top(void) {
return d <= 0 ? NULL : &snaps[d - 1];
}
/* Where a restart's parameter lives, for the thunk the daemon builds to fill
* one in before taking it: restart [i] of the snapshot on top, [off] bytes
* into its buffer. The daemon lays the buffer out the way both backends do
* (Emit.lay_fields over the clause's types), so [off] is its to compute.
* NULL for an index this snapshot does not have or a restart that takes
* nothing, and the thunk is built only for one that takes something. */
void *flan_agent_restart_arg(int64_t i, int64_t off) {
snapshot *s = snap_top();
void *args;
if (s == NULL || i < 0 || i >= s->n || off < 0) return NULL;
if (s->arity[i] <= 0) return NULL;
args = flan_restart_frame_args(s->frame[i]);
return args == NULL ? NULL : (char *)args + off;
}
/* And the flag an invoke-restart sets beside the values: the clause refuses a
* buffer nobody wrote, and this says somebody did. */
void flan_agent_restart_arm(int64_t i) {
snapshot *s = snap_top();
if (s == NULL || i < 0 || i >= s->n || s->arity[i] <= 0) return;
flan_restart_frame_arm(s->frame[i]);
}
/* A restart that takes values and has not been given them is refused here,
* where the reason can be said, rather than taken and refused at the clause,
* which is a trap the program cannot come back from. */
static int unarmed(snapshot *s, int32_t i) {
return s->arity[i] > 0 && !flan_restart_frame_armed(s->frame[i]);
}
/* One string into the snapshot's text pool, with its offset and length. A
* string that does not fit is recorded as empty rather than cut: an empty
* report or location is a state the reader handles, and half of one is not. */
static void snap_text(snapshot *s, const uint8_t *p, int64_t n, int32_t *off,
int32_t *len) {
*off = s->tused;
*len = 0;
if (p == NULL || n <= 0 || (int64_t)s->tused + n + 1 > SNAP_TEXT) return;
for (int64_t i = 0; i < n; i++) {
char c = (char)p[i];
s->text[s->tused + i] = (c == '\t' || c == '\n' || c == '\r') ? ' ' : c;
}
s->tused += (int32_t)n;
s->text[s->tused++] = 0;
*len = (int32_t)n;
}
/* The four facts about entry [k] beside its name, off its frame. */
static void snap_detail(snapshot *s, int32_t k, const void *fr) {
int64_t n;
const uint8_t *p;
s->arity[k] = flan_restart_frame_arity(fr);
p = flan_restart_frame_sig(fr, &n);
snap_text(s, p, n, &s->sigoff[k], &s->siglen[k]);
p = flan_restart_frame_loc(fr, &n);
snap_text(s, p, n, &s->locoff[k], &s->loclen[k]);
p = flan_restart_frame_report(fr, &n);
snap_text(s, p, n, &s->repoff[k], &s->replen[k]);
}
/* Called on the game thread with the stack held still. 0 if there is no room
* to nest, which the caller reports rather than serving a stale one. */
static int32_t snap_gen; /* monotone; 0 is "no snapshot" */
@ -695,8 +794,25 @@ static int snap_push(int resumable, void *cond) {
flan_break_site = NULL;
flan_break_site_len = 0;
}
s->sentencelen = 0;
if (flan_break_sentence_len > 0) {
int64_t k = flan_break_sentence_len;
if (k > (int64_t)sizeof s->sentence) {
/* Never splitting a UTF-8 character. */
k = (int64_t)sizeof s->sentence;
while (k > 0 && ((uint8_t)flan_break_sentence[k] & 0xC0) == 0x80) k--;
}
memcpy(s->sentence, flan_break_sentence, (size_t)k);
/* One line on the wire: a newline in it would end the reply early. */
for (int64_t i = 0; i < k; i++)
if (s->sentence[i] == '\n' || s->sentence[i] == '\r')
s->sentence[i] = ' ';
s->sentencelen = (int32_t)k;
flan_break_sentence_len = 0;
}
s->total = n;
s->used = 0;
s->tused = 0;
s->n = 0;
s->boundary = -1;
/* One slot and one name's worth of bytes kept back for the boundary, and the
@ -719,6 +835,12 @@ static int snap_push(int resumable, void *cond) {
const uint8_t *nm = flan_restart_name(i, &len);
void *fr = flan_restart_frame(i);
if (nm == NULL || fr == NULL) continue;
/* A handler-case's own landing is left off. It is reached through the
* handler the form installed, carries the condition that handler copies
* in, and has nothing to offer a person at a break loop — taking it by
* hand is refused at the clause for want of that condition. Dropped from
* the count as well, so "and N more" counts only what could be listed. */
if (flan_restart_frame_hidden(fr)) { s->total--; continue; }
if (len < 0) len = 0;
if ((int64_t)s->used + len + 1 > SNAP_NAMES - held_bytes) break;
s->frame[s->n] = fr;
@ -727,6 +849,7 @@ static int snap_push(int resumable, void *cond) {
/* The outermost [restart_floor] frames are below the thunk boundary. */
s->reachable[s->n] = (i < n - restart_floor);
if (fr == eval_boundary && eval_boundary != NULL) s->boundary = s->n;
snap_detail(s, s->n, fr);
memcpy(s->names + s->used, nm, (size_t)len);
s->used += (int32_t)len;
s->names[s->used++] = 0;
@ -748,6 +871,7 @@ static int snap_push(int resumable, void *cond) {
* is what [reachable] is measured against. */
s->reachable[s->n] = 1;
s->boundary = s->n;
snap_detail(s, s->n, eval_boundary);
memcpy(s->names + s->used, abandon_name, (size_t)len);
s->used += len;
s->names[s->used++] = 0;
@ -768,7 +892,20 @@ static int snap_push(int resumable, void *cond) {
const char *nm, *lc;
if (fr == NULL) break;
nm = flan_dev_frame_name(fr, &nl);
lc = flan_dev_frame_loc(fr, &ll);
/* Where the frame *is*, not where its function is written: the break
* site for the innermost, which is the expression that stopped, and the
* call each outer frame is in — so two calls to one function from one
* caller are two lines. The innermost frame's recorded call may be one
* it has since returned from, so it is not used there. Either falls back
* to the function's own location when there is nothing better. */
lc = NULL;
ll = 0;
if (i == 0 && s->sitelen > 0) {
lc = s->site;
ll = s->sitelen;
} else if (i > 0)
lc = flan_dev_frame_at_loc(fr, &ll);
if (lc == NULL || ll <= 0) lc = flan_dev_frame_loc(fr, &ll);
if (nl < 0) nl = 0;
if (ll < 0) ll = 0;
if ((int64_t)s->fused + nl + ll + 2 > FRAME_TEXT) break;
@ -926,6 +1063,10 @@ static void break_loop_at(const uint8_t *name, int64_t namelen, void *condition,
* when none of it can be taken — and because the same names come back
* from a `restarts' query, and the terminal and the socket must not be
* describing two different programs. */
/* The runtime's sentence, under the name. A trap has printed its own
* already, just above; a signalled condition has not. */
if (s->resumable && s->sentencelen > 0)
fprintf(stderr, " %.*s\n", (int)s->sentencelen, s->sentence);
if (s->escapable)
fprintf(stderr,
" nothing here can be resumed into; abandon the expression, "
@ -941,7 +1082,11 @@ static void break_loop_at(const uint8_t *name, int64_t namelen, void *condition,
* not takeable - a restart below the thunk boundary is shown rather
* than hidden, since "why can I not have that one" is a fair question
* and silence is how this went wrong the first time. */
fprintf(stderr, " %2d. restart: %s%s\n", i, s->names + s->off[i],
fprintf(stderr, " %2d. restart: %s%s%s%s\n", i, s->names + s->off[i],
/* Not for the boundary, whose own words follow. */
s->replen[i] > 0 && i != s->boundary ? " — " : "",
s->replen[i] > 0 && i != s->boundary ? s->text + s->repoff[i]
: "",
i == s->boundary && can_take(s, i)
? " (stop running the expression; the program carries on)"
: !s->resumable ? " (cannot be taken from this trap)"
@ -1087,6 +1232,12 @@ static void trap_stop(const uint8_t *name, int64_t namelen) {
* thread writes tail, nesting included. */
int32_t flan_agent_poll(void) {
int32_t n = 0;
/* A poll the game loop makes is a frame boundary, and a dev build wipes the
* temp allocator there, as the program's own (free-temp) would. Not a poll
* from a break loop or from inside a thunk: the stopped frames below it,
* or the thunk's own caller, may still be holding text from it. */
if (atomic_load(&depth) <= 0 && eval_boundary == NULL && flan_dev_reg_enabled())
flan_free_temp();
for (;;) {
unsigned t = atomic_load_explicit(&tail, memory_order_relaxed);
unsigned h = atomic_load_explicit(&head, memory_order_acquire);
@ -1138,12 +1289,21 @@ int32_t flan_agent_poll(void) {
int32_t outer = restart_floor;
int32_t oframe = frame_floor;
void *obound = eval_boundary;
/* An expression run while the program is stopped gets a scratch temp
* arena for its duration (flan_rt.c, flan_temp_scratch_begin), wiped
* when it ends however it ends — returning, or the jump back below
* after a trap — and the program's own temp arena put back untouched.
* Text the expression leaves in program state from it dangles. */
int scratch = atomic_load(&depth) > 0;
void *otemp = scratch ? flan_temp_scratch_begin() : NULL;
restart_floor = flan_restart_count();
frame_floor = flan_dev_frame_count();
/* After the floor is read and not before: the floor counts the frames
* that were there when the thunk started, and this one is the thunk's.
* Pushed first it would be below its own boundary and refused. */
eval_boundary = flan_restart_push_c(abandon_name, sizeof abandon_name - 1);
eval_boundary = flan_restart_push_c(abandon_name, sizeof abandon_name - 1,
abandon_report,
sizeof abandon_report - 1);
/* The marks are taken after the boundary is pushed, so a jump back
* here leaves it on the chain for the pop below, as a return does.
* [sigsetjmp] with the mask saved: a fault's break loop runs inside the
@ -1174,6 +1334,7 @@ int32_t flan_agent_poll(void) {
eval_boundary = obound;
restart_floor = outer;
frame_floor = oframe;
if (scratch) flan_temp_scratch_end(otemp);
}
if (j.handle != NULL) { dlclose(j.handle); }
}
@ -1306,6 +1467,16 @@ static const char *abi_mismatch(const char *err) {
* It is held across the [dlopen], which is milliseconds. That is what the
* accept loop already did to itself by serving connections inline, so no
* caller waits longer than it did before. The game thread never takes it. */
/* [unarmed]'s refusal, with what the restart takes. */
static void reply_unarmed(sink *o, snapshot *s, int32_t i) {
reply(o, "err restart ");
reply(o, s->names + s->off[i]);
reply(o, " takes ");
emit(o, s->text + s->sigoff[i], (size_t)s->siglen[i]);
reply(o, "; give it one value of each type, which the break buffer asks for "
"when it is taken\n");
}
static pthread_mutex_t request_lock = PTHREAD_MUTEX_INITIALIZER;
static void handle_line(char *line, sink *o) {
@ -1365,11 +1536,30 @@ static void handle_line(char *line, sink *o) {
reply(o, "\n");
return;
}
/* The runtime's sentence about the stop, on one line, or [-] for a stop
* that has none: a program's own condition, which says what it is in its
* fields, and a (pause). */
if (strcmp(line, "sentence") == 0) {
if (!(atomic_load(&depth) > 0)) { reply(o, "err not stopped\n"); return; }
snapshot *s = snap_top();
if (s == NULL) { reply(o, "err no snapshot\n"); return; }
if (s->sentencelen > 0) emit(o, s->sentence, (size_t)s->sentencelen);
else reply(o, "-");
reply(o, "\n");
return;
}
/* One line per restart, innermost first: the index it is taken by, a flag
* for whether it can be taken at all, and the name. The index leads
* because it is the identity - two frames can offer [retry] and only one
* of them is the one meant, which is the whole reason this is not a list
* of names any more. Read from the snapshot, never from the live stack. */
* of names any more. Read from the snapshot, never from the live stack.
*
* After the name, each behind a tab: how many parameters the clause takes,
* how their types are spelled, where it is written ([-] for a frame pushed
* from C) and its :report sentence, which may be empty and may contain
* spaces, so it is last. A tab because a name has no space in it and a
* report does; the snapshot has already turned any tab in them to a
* space. */
if (strcmp(line, "restarts") == 0) {
if (!(atomic_load(&depth) > 0)) { reply(o, "err not stopped\n"); return; }
snapshot *s = snap_top();
@ -1408,6 +1598,14 @@ static void handle_line(char *line, sink *o) {
: '+');
if (k > 0) emit(o, hdr, (size_t)k);
emit(o, s->names + s->off[i], (size_t)s->len[i]);
k = snprintf(hdr, sizeof hdr, "\t%d\t", s->arity[i]);
if (k > 0) emit(o, hdr, (size_t)k);
emit(o, s->text + s->sigoff[i], (size_t)s->siglen[i]);
reply(o, "\t");
if (s->loclen[i] > 0) emit(o, s->text + s->locoff[i], (size_t)s->loclen[i]);
else reply(o, "-");
reply(o, "\t");
emit(o, s->text + s->repoff[i], (size_t)s->replen[i]);
reply(o, "\n");
}
reply(o, ".\n");
@ -1543,6 +1741,7 @@ static void handle_line(char *line, sink *o) {
"above it, or abort\n");
return;
}
if (unarmed(s, (int32_t)idx)) { reply_unarmed(o, s, (int32_t)idx); return; }
atomic_store(&chosen_index, (int)idx);
atomic_store(&chosen_gen, s->gen);
/* Published last, so the game thread never reads an index that is about
@ -1591,6 +1790,7 @@ static void handle_line(char *line, sink *o) {
"above it, or abort\n");
return;
}
if (unarmed(s, at)) { reply_unarmed(o, s, at); return; }
atomic_store(&chosen_index, at);
atomic_store(&chosen_gen, s->gen);
atomic_store(&chosen_ready, 1);

2
web/index.html
View File

@ -531,7 +531,7 @@ notation reads as exactly one data item.</p>
<tr><td><code>(Fn [T ...] R)</code></td><td>a function value, which may have captured</td><td>a code address and an environment pointer</td></tr>
<tr><td><code>(CFn [T ...] R)</code></td><td>a function value that cannot capture — the <code>C</code> is what a C function pointer would need, not a way to reach C today</td><td>a pointer</td></tr>
<tr><td><code>dyn</code></td><td>a value the runtime knows the type of and the checker does not — see <a href="#dyn">dyn</a></td><td>one word, on a collected heap</td></tr>
<tr><td><code>Allocator</code></td><td>an opaque builtin: a proc, its data and a capability set</td><td>a pointer to that</td></tr>
<tr><td><code>Allocator</code></td><td>an opaque builtin: a proc, its data and a capability set</td><td>a pointer to that, and a count that says whether it has since been destroyed</td></tr>
<tr><td><code>$t</code></td><td>a type variable — see <a href="#generics">generics</a></td><td>whatever it is instantiated at</td></tr>
<tr><td>a struct</td><td>value type</td><td>fields in declaration order</td></tr>
<tr><td>a tagged data type</td><td><code>defdata</code>, matched by case</td><td>tag + the widest payload</td></tr>