diff --git a/TODO.org b/TODO.org index 80456edc..899c9b6e 100644 --- a/TODO.org +++ b/TODO.org @@ -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 diff --git a/bin/main.ml b/bin/main.ml index 7fb8306d..39e523ef 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -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 diff --git a/conditions.org b/conditions.org index c85873bf..97e9bddd 100644 --- a/conditions.org +++ b/conditions.org @@ -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) ...) diff --git a/docs/BUILT.md b/docs/BUILT.md index 4b2b6f75..2fc8b761 100644 --- a/docs/BUILT.md +++ b/docs/BUILT.md @@ -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. diff --git a/emacs/flan-cnr.el b/emacs/flan-cnr.el index 88973929..8f29907f 100644 --- a/emacs/flan-cnr.el +++ b/emacs/flan-cnr.el @@ -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. diff --git a/emacs/flan-mode.el b/emacs/flan-mode.el index 0dfa82cf..8785eebc 100644 --- a/emacs/flan-mode.el +++ b/emacs/flan-mode.el @@ -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 diff --git a/emacs/flan.el b/emacs/flan.el index bf3b1f50..92e42a89 100644 --- a/emacs/flan.el +++ b/emacs/flan.el @@ -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." diff --git a/emacs/test-flan-cider.el b/emacs/test-flan-cider.el index 662db688..1cdcaf74 100644 --- a/emacs/test-flan-cider.el +++ b/emacs/test-flan-cider.el @@ -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 diff --git a/examples/core-input-multitouch.flan b/examples/core-input-multitouch.flan index 4f55f080..c2d8a8b5 100644 --- a/examples/core-input-multitouch.flan +++ b/examples/core-input-multitouch.flan @@ -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)))) diff --git a/examples/core-input-virtual-controls.flan b/examples/core-input-virtual-controls.flan index 5cc7a6b3..5d892e67 100644 --- a/examples/core-input-virtual-controls.flan +++ b/examples/core-input-virtual-controls.flan @@ -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)))) diff --git a/examples/digits.flan b/examples/digits.flan index c9aa8e12..6fa674d6 100644 --- a/examples/digits.flan +++ b/examples/digits.flan @@ -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 diff --git a/lib/ast.ml b/lib/ast.ml index 368db447..bc5f0d67 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -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 diff --git a/lib/check.ml b/lib/check.ml index a97daa0a..ee0c4daf 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -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 = "" } +(* 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, diff --git a/lib/cimport.ml b/lib/cimport.ml index 6d5d067c..9fea9ebe 100644 --- a/lib/cimport.ml +++ b/lib/cimport.ml @@ -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) diff --git a/lib/dev.ml b/lib/dev.ml index 8f6d135c..7f052f25 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -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 diff --git a/lib/emit.ml b/lib/emit.ml index f2e599be..3572b27b 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -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 diff --git a/lib/load.ml b/lib/load.ml index 55c6b489..3df71271 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -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 diff --git a/lib/parse.ml b/lib/parse.ml index 73b6da79..e5190994 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -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 diff --git a/lib/prelude.ml b/lib/prelude.ml index 32e78d84..904da3c9 100644 --- a/lib/prelude.ml +++ b/lib/prelude.ml @@ -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) diff --git a/lib/reach.ml b/lib/reach.ml index a3000a3b..e350b561 100644 --- a/lib/reach.ml +++ b/lib/reach.ml @@ -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. *) | _ -> ()) diff --git a/lib/session.ml b/lib/session.ml index 6cac3334..c8553887 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -1318,6 +1318,21 @@ let eval ?(origin = "") ?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 + [], 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 "" 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 = "") 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 = "") 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 = "") 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:"" 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 = "") 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 diff --git a/lib/shim.ml b/lib/shim.ml index e185d325..c3070b04 100644 --- a/lib/shim.ml +++ b/lib/shim.ml @@ -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 diff --git a/lib/tast.ml b/lib/tast.ml index aacfa5e7..5267488e 100644 --- a/lib/tast.ml +++ b/lib/tast.ml @@ -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 } diff --git a/lib/types.ml b/lib/types.ml index d2dff244..3513621f 100644 --- a/lib/types.ml +++ b/lib/types.ml @@ -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, diff --git a/lib/x86.ml b/lib/x86.ml index b582287e..bcf1ae79 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -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 diff --git a/runtime/flan_dev.c b/runtime/flan_dev.c index bc8fb759..245541a0 100644 --- a/runtime/flan_dev.c +++ b/runtime/flan_dev.c @@ -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) { diff --git a/runtime/flan_dyn.c b/runtime/flan_dyn.c index 780f299e..208f1952 100644 --- a/runtime/flan_dyn.c +++ b/runtime/flan_dyn.c @@ -33,6 +33,7 @@ * be thread-local, and that is one change in two places rather than a rewrite. */ +#include #include #include #include @@ -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)) diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index 5e6bb186..b759c63a 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -11,6 +11,7 @@ * on x86-64 and silently does not on wasm32. */ +#include #include #include #include @@ -63,6 +64,142 @@ void flan_handler_pop(flan_handler *h) { handlers = h->prev; } +/* What a signal site says about its condition: Emit.Rt.condesc, field for + * field, which both backends lay out from one list. A compiled signal points + * at a constant; the runtime's own conditions build one on the failing + * frame's stack. + * + * A handler that matched through a parent link is not handed the condition, + * whose layout is its own type's, but a view laid out as the prelude's + * (defstruct Error [name string message string]) — the parent's type is + * Error-shaped, which the checker requires. The view's message is the + * condition with its values: [message] for the runtime's own conditions, + * which format their sentence before signalling; what [render] prints for a + * compiled one; and the condition's own fields when its type is Error-shaped + * itself ([flags] & FLAN_CONDESC_SELF), since then it is its own view. + * [chain] is the type ids from the condition's own type to its root. */ +typedef struct flan_condesc { + const uint8_t *name; + int64_t namelen; + const uint8_t *message; + int64_t messagelen; + const uint32_t *chain; + int64_t chainlen; + const uint8_t *loc; + int64_t loclen; + void (*render)(void *condition, void *xfer); + int32_t flags; +} flan_condesc; + +#define FLAN_CONDESC_SELF 1 +/* The runtime's own condition, whose name is this file's and whose message is + * already a copy in context/temp: a parent's view takes both as they are. */ +#define FLAN_CONDESC_RT 2 + +/* The view a parent's handler reads: Error's layout. */ +typedef struct { + const uint8_t *name; + int64_t namelen; + const uint8_t *message; + int64_t messagelen; +} flan_view; + +/* The most the break loop's sentence takes, and the unhandled message. A + * fixed buffer, so a longer one is cut — at a character, and said to be cut. */ +#define FLAN_SENTENCE_MAX 2048 + +/* How many of [p]'s [len] bytes fit in [max] without splitting a UTF-8 + * character: a cut that lands on a continuation byte backs up to the start + * of that character, so a shortened text is still text. */ +static int64_t utf8_fit(const uint8_t *p, int64_t len, int64_t max) { + int64_t m; + if (len <= max) return len; + m = max < 0 ? 0 : max; + while (m > 0 && (p[m] & 0xC0) == 0x80) m--; + return m; +} + +static const char ellipsis[] = "\xe2\x80\xa6"; + +/* [n] bytes from context/temp, or NULL; defined with the temp allocator. */ +static void *rt_temp_alloc(int64_t n); + +/* A copy of [n] bytes in context/temp: what a handler for a parent reads, and + * what a handler-case carries past the unwind. It lives until the frame ends — + * (free-temp), or the dev agent's poll — and a program that keeps it longer + * clones it, as it does any temp text. Empty when the arena has no room. */ +static const uint8_t *rt_temp_copy(const uint8_t *p, int64_t n, int64_t *len) { + uint8_t *q; + *len = 0; + if (n <= 0) return (const uint8_t *)""; + q = (uint8_t *)rt_temp_alloc(n); + if (q == NULL) return (const uint8_t *)""; + memcpy(q, p, (size_t)n); + *len = n; + return q; +} + +/* Where [render] prints, set around its synchronous calls. The printer runs + * twice: once with no buffer to count the bytes, once to write them into a + * block of exactly that size, so the message is never cut. A printer only + * formats, so nothing nests inside it. */ +static uint8_t *msg_out; +static int64_t msg_len; + +void flan_msg_emit(const uint8_t *p, int64_t n) { + if (n <= 0) return; + if (msg_out != NULL) memcpy(msg_out + msg_len, p, (size_t)n); + msg_len += n; +} + +/* The view of [condition] for a parent's handler, its name and message in + * context/temp — see [rt_temp_copy] for how long they live. An Error-shaped + * condition is its own view, and its strings are the program's own. */ +static void rt_view(const flan_condesc *d, void *condition, flan_view *v) { + if (d->flags & FLAN_CONDESC_SELF) { + *v = *(const flan_view *)condition; + return; + } + if (d->flags & FLAN_CONDESC_RT) { + v->name = d->name; + v->namelen = d->namelen; + v->message = d->message; + v->messagelen = d->messagelen; + return; + } + v->name = rt_temp_copy(d->name, d->namelen, &v->namelen); + if (d->messagelen > 0) + v->message = rt_temp_copy(d->message, d->messagelen, &v->messagelen); + else if (d->render != NULL) { + void *x = NULL; + msg_out = NULL; + msg_len = 0; + d->render(condition, &x); + v->message = (const uint8_t *)""; + v->messagelen = 0; + if (msg_len > 0 && (msg_out = (uint8_t *)rt_temp_alloc(msg_len)) != NULL) { + int64_t want = msg_len; + msg_len = 0; + d->render(condition, &x); + v->message = msg_out; + v->messagelen = want; + } + msg_out = NULL; + } else { + v->message = (const uint8_t *)""; + v->messagelen = 0; + } +} + +/* 1 when a handler for [type_id] answers the condition by its own type, 2 + * when it answers through a parent link, 0 when it does not answer. */ +static int flan_handles(uint32_t type_id, const flan_condesc *d) { + if (d->chainlen > 0 && d->chain[0] == type_id) return 1; + for (int64_t i = 1; i < d->chainlen; i++) + if (d->chain[i] == type_id) return 2; + return 0; +} + /* [xfer] is the signalling function's own end of the transfer channel * (spec-conditions.md §6), threaded through so that a handler invoking a * restart can write its target into it. That makes this C frame transparent to @@ -81,15 +218,26 @@ void flan_handler_pop(flan_handler *h) { * back afterwards whether or not the clause transferred: a transfer's target * can be a restart-case inside the handler-bind's own body, whose frame does * not pop this handler on the way there. */ -void flan_signal(uint32_t type_id, void *condition, void *xfer) { +void flan_signal(const flan_condesc *d, void *condition, void *xfer) { flan_handler *saved = handlers; - for (flan_handler *h = saved; h != NULL; h = h->prev) - if (h->type_id == type_id) { + /* The parent's view, made the first time a parent's handler needs it. Its + * strings are in context/temp, so a signal nested inside a handler makes its + * own and cannot write over the one the outer handler is reading. */ + flan_view v; + int viewed = 0; + for (flan_handler *h = saved; h != NULL; h = h->prev) { + int how = flan_handles(h->type_id, d); + if (how) { + if (how == 2 && !viewed) { + rt_view(d, condition, &v); + viewed = 1; + } handlers = h->prev; - h->fn(condition, xfer, h->env); + h->fn(how == 1 ? condition : (void *)&v, xfer, h->env); handlers = saved; if (*(void **)xfer != NULL) return; } + } } /* A restart stack, the same shape and for the same reasons. What a transfer @@ -99,6 +247,8 @@ void flan_signal(uint32_t type_id, void *condition, void *xfer) { * against every re-entry of the same restart-case. §4's "innermost frame * offering the name" is then just the order of the walk. */ +/* Field for field Emit.Rt.restart, which both backends lay out from one list; + * a field added there is added here, in the same place. */ typedef struct flan_restart { struct flan_restart *prev; uint32_t name_id; @@ -107,8 +257,29 @@ typedef struct flan_restart { * and nothing at run time can turn a hash back into a name. */ const uint8_t *name; int64_t namelen; + /* §3's parameters: the buffer the clause reads them from, how many, the + * hash of their spelling, whether an invoke filled the buffer in, and the + * spelling itself. */ + void *args; + int32_t arity; + uint32_t sig_id; + int32_t armed; + const uint8_t *sig; + int64_t siglen; + /* For a break loop only: where the clause is written, its :report sentence + * (empty when it wrote none), and [flags]. */ + const uint8_t *loc; + int64_t loclen; + const uint8_t *report; + int64_t reportlen; + int32_t flags; } flan_restart; +/* A clause the checker made up rather than one anybody wrote: a + * handler-case's landing, which is reached through its own handler and which + * a break loop does not offer. */ +#define FLAN_RESTART_HIDDEN 1 + static flan_restart *restarts; /* The frames a C caller pushes; see [flan_restart_push_c] below, which is @@ -125,6 +296,7 @@ void flan_restart_push(flan_restart *r) { void flan_restart_pop(flan_restart *r) { restarts = r->prev; } + /* What is on offer, innermost first — spec-conditions.md §4's walk, without * committing to anything. This is [compute-restarts]' data; today its only * caller is the break loop. */ @@ -164,6 +336,48 @@ void *flan_restart_frame(int32_t i) { return NULL; } +/* What a break loop shows about a frame [flan_restart_frame] handed out, read + * off the frame rather than walked for, so a snapshot taking all of them is one + * pass. The strings are the frame's own and live as long as the program. */ +const uint8_t *flan_restart_frame_loc(const void *frame, int64_t *len) { + const flan_restart *r = (const flan_restart *)frame; + *len = r->loclen; + return r->loc; +} + +const uint8_t *flan_restart_frame_report(const void *frame, int64_t *len) { + const flan_restart *r = (const flan_restart *)frame; + *len = r->reportlen; + return r->report; +} + +const uint8_t *flan_restart_frame_sig(const void *frame, int64_t *len) { + const flan_restart *r = (const flan_restart *)frame; + *len = r->siglen; + return r->sig; +} + +int32_t flan_restart_frame_arity(const void *frame) { + return ((const flan_restart *)frame)->arity; +} + +int32_t flan_restart_frame_hidden(const void *frame) { + return (((const flan_restart *)frame)->flags & FLAN_RESTART_HIDDEN) != 0; +} + +/* The other way a typed restart's buffer is filled: an invoke-restart writes + * it and sets [armed], and a break loop taking one by hand has an evaluated + * thunk do the same two things through these, before it aims the channel. */ +void *flan_restart_frame_args(const void *frame) { + return ((const flan_restart *)frame)->args; +} + +int32_t flan_restart_frame_armed(const void *frame) { + return ((const flan_restart *)frame)->armed; +} + +void flan_restart_frame_arm(void *frame) { ((flan_restart *)frame)->armed = 1; } + /* Aim the transfer channel at a frame obtained earlier. The same store an * invoke-restart makes — this only spells it without a lookup, for a caller * that did its looking up when the stack was worth reading. */ @@ -193,6 +407,10 @@ void flan_rt_init(int32_t argc, char **argv) { * is not [fflush(stdout)]. */ static _Noreturn void rt_die(void); static void rt_flush_out(void); +/* And the sentence a stop is told with; see "What the break loop is told + * about a stop" below. */ +static void rt_sentence(const char *fmt, ...); +static void rt_print_sentence(const uint8_t *loc, int64_t loclen); /* The one malloc in this file that is not an allocator's, because the argument * vector belongs to the process rather than to any region a Flan program named. @@ -306,11 +524,11 @@ void flan_condition_stacks_restore(void *h, void *r, int32_t d) { * printed the second number twice, with no crash and nothing for a sanitizer * to see, because the read was inside a buffer that was perfectly alive. * - * What this does *not* buy is storage: the slice points into the caller's - * frame, so holding one past the function that made it, or pushing it into a - * container that outlives the frame, is still the caller's problem. Copy the - * bytes for that. The size is agreed with check.ml, which allocates the slot — - * grep FLAN_NUM_BYTES there before changing it here. */ + * The slice points into the caller's frame, so the checker copies it into the + * temp allocator for i64->bytes and f64->bytes, whose results may outlive + * the frame. The printer writes each one out at once and takes no copy. The + * size is agreed with check.ml, which allocates the slot — grep + * FLAN_NUM_BYTES there before changing it here. */ #define FLAN_NUM_BYTES 64 /* snprintf returns what it *would* have written, not what it did. The three @@ -422,6 +640,15 @@ void flan_u64_to_bytes(uint64_t x, uint8_t *buf, flan_slice *out) { out->len = fit(n); } +/* A string literal on its way to a declare-c wrapper: the same pointer, with + * the length encoded as -(n+1). No other Flan string has a negative length, so + * the wrapper knows the bytes are the compiler's NUL-terminated constant and + * hands them to C uncopied (lib/shim.ml, flan_shim_cstr). */ +void flan_c_literal(const uint8_t *p, int64_t n, flan_slice *out) { + out->ptr = p; + out->len = -(n + 1); +} + /* The escape table itself: what one byte reads as inside a quoted string, * written into [out] and returning how many bytes that took. Never more than * four, which is what every caller's headroom is sized from. @@ -577,11 +804,17 @@ static _Noreturn void rt_die(void) { _exit(134); } +/* The sentence each bounds failure is told with — to stderr when nothing + * answered, and to the break loop before it is asked. */ +static void bounds_sentence(int64_t idx, int64_t len) { + rt_sentence("index %lld is out of bounds for length %lld", (long long)idx, + (long long)len); +} + _Noreturn void flan_bounds_fail(const uint8_t *loc, int64_t loclen, int64_t idx, int64_t len) { - rt_flush_out(); - fprintf(stderr, "%.*s: index %lld is out of bounds for length %lld\n", - (int)loclen, (const char *)loc, (long long)idx, (long long)len); + bounds_sentence(idx, len); + rt_print_sentence(loc, loclen); rt_die(); } @@ -690,6 +923,81 @@ _Noreturn void flan_trap(const uint8_t *name, int64_t namelen) { rt_trap(name, namelen); } +/* ── What the break loop is told about a stop ───────────────────────── + * + * Where the expression that stopped is written, and the sentence the runtime + * wrote about it — the loc every checked site already passes, and the words + * it prints to stderr. The frame chain says where each *call* was; the site + * is the only record of the `at` or the division itself, and the sentence is + * what the condition's fields mean ("this value does not fit the integer type + * it is cast to" rather than op 4 and two bounds). + * + * Set immediately before a break hook or a trap hook runs and cleared when a + * break hook returns, so the agent's snapshot (taken on entry to the break + * loop, on this same thread) reads them while they are true, and consumes + * them so that a break nested inside that one cannot inherit them. NULL and + * empty outside that window, which is the honest answer for a stop that has + * nothing to point at. */ +const uint8_t *flan_break_site; +int64_t flan_break_site_len; +char flan_break_sentence[FLAN_SENTENCE_MAX]; +int64_t flan_break_sentence_len; + +static void rt_sentencev(const char *fmt, va_list ap) { + int n = vsnprintf(flan_break_sentence, sizeof flan_break_sentence, fmt, ap); + if (n < 0) n = 0; + if (n >= (int)sizeof flan_break_sentence) { + /* Cut at a character and said to be cut. */ + int64_t m = utf8_fit((const uint8_t *)flan_break_sentence, + (int64_t)sizeof flan_break_sentence - 1, + (int64_t)sizeof flan_break_sentence - 4); + memcpy(flan_break_sentence + m, ellipsis, 3); + n = (int)m + 3; + } + flan_break_sentence_len = n; +} + +static void rt_sentence(const char *fmt, ...) { + va_list ap; + va_start(ap, fmt); + rt_sentencev(fmt, ap); + va_end(ap); +} + + +static void rt_break_clear(void) { + flan_break_site = NULL; + flan_break_site_len = 0; + flan_break_sentence_len = 0; +} + +/* The sentence already formatted, to stderr, after the site. */ +static void rt_print_sentence(const uint8_t *loc, int64_t loclen) { + rt_flush_out(); + if (loc != NULL && loclen > 0) + fprintf(stderr, "%.*s: ", (int)loclen, (const char *)loc); + fprintf(stderr, "%.*s\n", (int)flan_break_sentence_len, + flan_break_sentence); +} + +/* A trap's sentence: formatted once, printed where it always was, and left + * for the trap hook with the site beside it. [loc] may be NULL. Exported for + * flan_dyn.c, whose traps are this kind and must be told the same way. */ +void flan_sayv(const uint8_t *loc, int64_t loclen, const char *fmt, + va_list ap) { + rt_sentencev(fmt, ap); + rt_print_sentence(loc, loclen); + flan_break_site = loc; + flan_break_site_len = loc != NULL ? loclen : 0; +} + +void flan_say(const uint8_t *loc, int64_t loclen, const char *fmt, ...) { + va_list ap; + va_start(ap, fmt); + flan_sayv(loc, loclen, fmt, ap); + va_end(ap); +} + /* Must agree with Check.type_id, byte for byte, or a name typed at the break * loop matches nothing. FNV-1a over the name, 32 bits. */ static uint32_t flan_name_id(const uint8_t *s, int64_t n) { @@ -723,12 +1031,23 @@ static uint32_t flan_name_id(const uint8_t *s, int64_t n) { * NULL when there is no room, and then the caller simply has no restart to * offer — an evaluation that cannot be abandoned is worse than one that can, * and better than a scribble past the end of this array. */ -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) { if (c_restart_depth >= C_RESTARTS) return NULL; flan_restart *r = &c_restarts[c_restart_depth++]; + /* Every field, because the slot is reused: a frame that takes no parameters + * says so with the empty signature a written (name [] ...) has, and one + * pushed from C has no source line. */ + memset(r, 0, sizeof *r); r->name_id = flan_name_id(name, namelen); r->name = name; r->namelen = namelen; + r->sig = (const uint8_t *)"()"; + r->siglen = 2; + r->sig_id = flan_name_id(r->sig, r->siglen); + r->loc = (const uint8_t *)""; + r->report = report; + r->reportlen = reportlen; flan_restart_push(r); return r; } @@ -756,19 +1075,36 @@ void flan_restart_pop_c(void *frame) { * with the one in use. TODO.org, "The break loop's display pass", records the * choice by index that left it with no caller. Now there is no function. */ -void flan_error(uint32_t type_id, void *condition, void *xfer, - const uint8_t *name, int64_t namelen) { - flan_signal(type_id, condition, xfer); +void flan_error(const flan_condesc *d, void *condition, void *xfer) { + flan_signal(d, condition, xfer); if (*(void **)xfer != NULL) return; /* Nothing handled it. In a dev build that is a place to stand, not the end * of the program — which is the whole of §2 and the reason it is worth - * having. */ - if (flan_break_hook != NULL) { - flan_break_hook(name, namelen, condition, xfer); - if (*(void **)xfer != NULL) return; + * having. The site is the (error ...) itself, and the sentence is the + * condition's static one, or none: a program's own condition says what it + * is in its fields. */ + { + /* What the condition is, as a parent's handler would read it: the + * sentence, the printed condition, or an Error-shaped condition's own + * message. A condition with no parent and no sentence has none. */ + flan_view v; + rt_view(d, condition, &v); + if (flan_break_hook != NULL) { + flan_break_site = d->loclen > 0 ? d->loc : NULL; + flan_break_site_len = d->loclen; + rt_sentence("%.*s", (int)v.messagelen, (const char *)v.message); + flan_break_hook(d->name, d->namelen, condition, xfer); + rt_break_clear(); + if (*(void **)xfer != NULL) return; + } + if (v.messagelen > 0) + rt_sentence("unhandled %.*s: %.*s", (int)d->namelen, + (const char *)d->name, (int)v.messagelen, + (const char *)v.message); + else + rt_sentence("unhandled %.*s", (int)d->namelen, (const char *)d->name); } - rt_flush_out(); - fprintf(stderr, "unhandled %.*s\n", (int)namelen, (const char *)name); + rt_print_sentence(d->loc, d->loclen); rt_die(); } @@ -779,9 +1115,8 @@ void flan_error(uint32_t type_id, void *condition, void *xfer, * process, so that the stack that offered no such name can be read. */ _Noreturn void flan_restart_fail(const uint8_t *loc, int64_t loclen, const uint8_t *name, int64_t namelen) { - rt_flush_out(); - fprintf(stderr, "%.*s: no restart named %.*s is active\n", - (int)loclen, (const char *)loc, (int)namelen, (const char *)name); + flan_say(loc, loclen, "no restart named %.*s is active", (int)namelen, + (const char *)name); rt_trap((const uint8_t *)"NoSuchRestart", 13); } @@ -794,10 +1129,9 @@ _Noreturn void flan_restart_args_fail(const uint8_t *loc, int64_t loclen, const uint8_t *name, int64_t namelen, const uint8_t *want, int64_t wantlen, const uint8_t *got, int64_t gotlen) { - rt_flush_out(); - fprintf(stderr, "%.*s: restart %.*s takes %.*s, given %.*s\n", - (int)loclen, (const char *)loc, (int)namelen, (const char *)name, - (int)wantlen, (const char *)want, (int)gotlen, (const char *)got); + flan_say(loc, loclen, "restart %.*s takes %.*s, given %.*s", (int)namelen, + (const char *)name, (int)wantlen, (const char *)want, (int)gotlen, + (const char *)got); rt_trap((const uint8_t *)"RestartArity", 12); } @@ -809,12 +1143,8 @@ _Noreturn void flan_restart_args_fail(const uint8_t *loc, int64_t loclen, _Noreturn void flan_restart_unarmed(const uint8_t *loc, int64_t loclen, const uint8_t *name, int64_t namelen, const uint8_t *want, int64_t wantlen) { - rt_flush_out(); - fprintf(stderr, - "%.*s: restart %.*s takes %.*s, and none was supplied — a restart " - "with parameters cannot be taken from the break loop yet\n", - (int)loclen, (const char *)loc, (int)namelen, (const char *)name, - (int)wantlen, (const char *)want); + flan_say(loc, loclen, "restart %.*s takes %.*s, and none was supplied", + (int)namelen, (const char *)name, (int)wantlen, (const char *)want); rt_trap((const uint8_t *)"RestartUnarmed", 14); } @@ -824,19 +1154,19 @@ _Noreturn void flan_restart_unarmed(const uint8_t *loc, int64_t loclen, * lexical case is refused by the checker; this is the one that reaches a * function through a call, where nothing static could see it. */ _Noreturn void flan_transfer_fail(const uint8_t *loc, int64_t loclen) { - rt_flush_out(); - fprintf(stderr, - "%.*s: a defer invoked a restart, which a defer may not do\n", - (int)loclen, (const char *)loc); + flan_say(loc, loclen, "a defer invoked a restart, which a defer may not do"); rt_trap((const uint8_t *)"TransferFromDefer", 17); } +static void slice_sentence(int64_t lo, int64_t hi, int64_t len) { + rt_sentence("slice [%lld %lld) is out of bounds for length %lld", + (long long)lo, (long long)hi, (long long)len); +} + _Noreturn void flan_slice_fail(const uint8_t *loc, int64_t loclen, int64_t lo, int64_t hi, int64_t len) { - rt_flush_out(); - fprintf(stderr, "%.*s: slice [%lld %lld) is out of bounds for length %lld\n", - (int)loclen, (const char *)loc, (long long)lo, (long long)hi, - (long long)len); + slice_sentence(lo, hi, len); + rt_print_sentence(loc, loclen); rt_die(); } @@ -884,51 +1214,92 @@ typedef struct { int64_t low, high, length; } flan_bounds_cond; static const uint8_t flan_bounds_name[] = "BoundsError"; #define FLAN_BOUNDS_NAMELEN 11 -/* Where the expression that trapped is written — the loc every checked site - * already passes for its unhandled message, published for the break hook. - * The frame chain says where each *call* was; this is the only record of the - * `at` or the division itself, which is the line a person wants pointed at. - * - * Set immediately before the hook runs and cleared when it returns, so the - * agent's snapshot (taken on entry to the break loop, on this same thread) - * reads it while it is true and a later break through [flan_error] — a user - * (error ...), which carries no loc — cannot inherit a stale one. NULL - * outside that window, and NULL is the honest answer for a signal that has - * no expression to point at. */ -const uint8_t *flan_break_site; -int64_t flan_break_site_len; +/* The root every built-in error descends from, and the parent link the two + * conditions this file signals itself carry. Must agree with the prelude's + * (defstruct BoundsError :parent Error ...) — the same hand-kept agreement + * flan_name_id has with Check.type_id. */ +static const uint8_t flan_error_name[] = "Error"; +#define FLAN_ERROR_NAMELEN 5 -/* Returns nonzero if something transferred, in which case the caller returns - * and its caller's guard carries the transfer out. */ -static int flan_bounds_signal(const uint8_t *loc, int64_t loclen, void *xfer, - int64_t low, int64_t high, int64_t len) { - flan_bounds_cond c; - uint32_t id = flan_name_id(flan_bounds_name, FLAN_BOUNDS_NAMELEN); - c.low = low; - c.high = high; - c.length = len; - flan_signal(id, &c, xfer); - if (*(void **)xfer != NULL) return 1; +/* A descriptor for one of the runtime's own conditions, on the caller's + * stack; [chain] is the caller's too, two entries long. Its message is the + * sentence the caller has just formatted, copied into context/temp: that copy + * is what a parent's handler reads. The break loop does not read it — the + * caller formats the sentence again, in full, if nothing handled it. */ +static void rt_condesc(flan_condesc *d, uint32_t chain[2], const uint8_t *name, + int64_t namelen, const uint8_t *loc, int64_t loclen) { + d->render = NULL; + d->flags = FLAN_CONDESC_RT; + chain[0] = flan_name_id(name, namelen); + chain[1] = flan_name_id(flan_error_name, FLAN_ERROR_NAMELEN); + d->name = name; + d->namelen = namelen; + /* The sentence just formatted, copied out of the shared buffer before the + * walk, since a handler may stop on something of its own and write over + * it. */ + d->message = rt_temp_copy((const uint8_t *)flan_break_sentence, + flan_break_sentence_len, &d->messagelen); + /* Consumed: if a handler takes the condition, the next stop must not find + * this sentence waiting under its own name. */ + flan_break_sentence_len = 0; + d->chain = chain; + d->chainlen = 2; + d->loc = loc; + d->loclen = loclen; +} + +/* With nothing answering [d], stand in the break loop with the site and the + * sentence, which the caller has formatted after the walk and before this — + * after, because a handler the walk ran may have stopped on something of its + * own and written over it. Returns nonzero if the break loop transferred, in + * which case the caller returns and its caller's guard carries the transfer + * out. */ +static int rt_error_break(const flan_condesc *d, void *condition, void *xfer) { if (flan_break_hook != NULL) { - flan_break_site = loc; - flan_break_site_len = loclen; - flan_break_hook(flan_bounds_name, FLAN_BOUNDS_NAMELEN, &c, xfer); - flan_break_site = NULL; - flan_break_site_len = 0; - if (*(void **)xfer != NULL) return 1; + flan_break_site = d->loc; + flan_break_site_len = d->loclen; + flan_break_hook(d->name, d->namelen, condition, xfer); + if (*(void **)xfer != NULL) { rt_break_clear(); return 1; } } return 0; } +/* Which of the three sentences a BoundsError is told with. */ +enum { BOUNDS_AT, BOUNDS_SLICE, BOUNDS_PROMISE }; +static void promise_sentence(int64_t n); + +static int flan_bounds_signal(const uint8_t *loc, int64_t loclen, void *xfer, + int kind, int64_t low, int64_t high, + int64_t len) { + flan_bounds_cond c; + flan_condesc d; + uint32_t chain[2]; + c.low = low; + c.high = high; + c.length = len; + if (kind == BOUNDS_AT) bounds_sentence(low, len); + else if (kind == BOUNDS_SLICE) slice_sentence(low, high, len); + else promise_sentence(high); + rt_condesc(&d, chain, flan_bounds_name, FLAN_BOUNDS_NAMELEN, loc, loclen); + flan_signal(&d, &c, xfer); + if (*(void **)xfer != NULL) return 1; + /* Formatted again, in full: [said] may be cut, and a handler the walk ran + * may have written a sentence of its own over the shared one. */ + if (kind == BOUNDS_AT) bounds_sentence(low, len); + else if (kind == BOUNDS_SLICE) slice_sentence(low, high, len); + else promise_sentence(high); + return rt_error_break(&d, &c, xfer); +} + void flan_bounds_error(const uint8_t *loc, int64_t loclen, int64_t idx, int64_t len, void *xfer) { - if (flan_bounds_signal(loc, loclen, xfer, idx, idx, len)) return; + if (flan_bounds_signal(loc, loclen, xfer, BOUNDS_AT, idx, idx, len)) return; flan_bounds_fail(loc, loclen, idx, len); } void flan_slice_error(const uint8_t *loc, int64_t loclen, int64_t lo, int64_t hi, int64_t len, void *xfer) { - if (flan_bounds_signal(loc, loclen, xfer, lo, hi, len)) return; + if (flan_bounds_signal(loc, loclen, xfer, BOUNDS_SLICE, lo, hi, len)) return; flan_slice_fail(loc, loclen, lo, hi, len); } @@ -957,19 +1328,21 @@ void flan_slice_error(const uint8_t *loc, int64_t loclen, int64_t lo, * violated condition written as a range, which is what those fields can carry. * Deliberately not (0, n, n) — that reads as a range in bounds, and a handler * testing high <= length would wave the failure through. */ +static void promise_sentence(int64_t n) { + rt_sentence("slice-from-ptr was promised %lld elements behind the pointer, " + "and a count is never negative", (long long)n); +} + _Noreturn void flan_slice_promise_fail(const uint8_t *loc, int64_t loclen, int64_t n) { - rt_flush_out(); - fprintf(stderr, - "%.*s: slice-from-ptr was promised %lld elements behind the " - "pointer, and a count is never negative\n", - (int)loclen, (const char *)loc, (long long)n); + promise_sentence(n); + rt_print_sentence(loc, loclen); rt_die(); } void flan_slice_promise_error(const uint8_t *loc, int64_t loclen, int64_t n, void *xfer) { - if (flan_bounds_signal(loc, loclen, xfer, 0, n, 0)) return; + if (flan_bounds_signal(loc, loclen, xfer, BOUNDS_PROMISE, 0, n, 0)) return; flan_slice_promise_fail(loc, loclen, n); } @@ -1026,20 +1399,16 @@ typedef struct { int32_t op; int64_t lhs, rhs; } flan_arith_cond; static const uint8_t flan_arith_name[] = "ArithError"; #define FLAN_ARITH_NAMELEN 10 -/* The sentence each code gets when nothing answered. It is separate from the - * struct because the condition deliberately carries no rendered message: - * formatting is the unhandled path's job, and this is the unhandled path. */ -static void flan_arith_fail(const uint8_t *loc, int64_t loclen, int32_t op, - int64_t lhs, int64_t rhs) { - rt_flush_out(); +/* The sentence each code gets, with its values in it — for the break loop + * and for stderr when nothing answered. Separate from the struct because the + * condition deliberately carries no rendered message. */ +static void arith_sentence(int32_t op, int64_t lhs, int64_t rhs) { switch (op) { case FLAN_ARITH_DIV_ZERO: - fprintf(stderr, "%.*s: divide by zero: (/ %lld 0)\n", (int)loclen, - (const char *)loc, (long long)lhs); + rt_sentence("divide by zero: (/ %lld 0)", (long long)lhs); break; case FLAN_ARITH_REM_ZERO: - fprintf(stderr, "%.*s: remainder by zero: (%% %lld 0)\n", (int)loclen, - (const char *)loc, (long long)lhs); + rt_sentence("remainder by zero: (%% %lld 0)", (long long)lhs); break; /* Worth its own sentence rather than sharing the word "overflow", because * the reader who hits it has probably never had to think about this case: @@ -1047,62 +1416,49 @@ static void flan_arith_fail(const uint8_t *loc, int64_t loclen, int32_t op, * overflows, and it overshoots by exactly one. */ case FLAN_ARITH_DIV_OVERFLOW: case FLAN_ARITH_REM_OVERFLOW: - fprintf(stderr, - "%.*s: (%s %lld %lld) overflows — the quotient is one past the " - "largest value the type holds\n", - (int)loclen, (const char *)loc, - op == FLAN_ARITH_DIV_OVERFLOW ? "/" : "%", (long long)lhs, - (long long)rhs); + rt_sentence("(%s %lld %lld) overflows — the quotient is one past the " + "largest value the type holds", + op == FLAN_ARITH_DIV_OVERFLOW ? "/" : "%", (long long)lhs, + (long long)rhs); break; /* NaN and the infinities did not overshoot the range: no integer is * their value, whatever the type. Saying "does not fit" reads as too big. */ case FLAN_ARITH_CAST_NAN: - fprintf(stderr, - "%.*s: this value is NaN, which has no integer value to cast to\n", - (int)loclen, (const char *)loc); + rt_sentence("this value is NaN, which has no integer value to cast to"); break; case FLAN_ARITH_CAST_INF: - fprintf(stderr, - "%.*s: this value is infinite, which has no integer value to cast " - "to\n", - (int)loclen, (const char *)loc); + rt_sentence("this value is infinite, which has no integer value to cast " + "to"); break; /* An unsigned type's range starts at zero and a signed one's below it, so * the lower bound says how to read the upper one: u64's is all ones. */ default: if (lhs == 0) - fprintf(stderr, - "%.*s: this value does not fit the integer type it is cast to, " - "which holds [0 %llu]\n", - (int)loclen, (const char *)loc, (unsigned long long)rhs); + rt_sentence("this value does not fit the integer type it is cast to, " + "which holds [0 %llu]", (unsigned long long)rhs); else - fprintf(stderr, - "%.*s: this value does not fit the integer type it is cast to, " - "which holds [%lld %lld]\n", - (int)loclen, (const char *)loc, (long long)lhs, (long long)rhs); + rt_sentence("this value does not fit the integer type it is cast to, " + "which holds [%lld %lld]", (long long)lhs, (long long)rhs); break; } - rt_die(); } void flan_arith_error(const uint8_t *loc, int64_t loclen, int32_t op, int64_t lhs, int64_t rhs, void *xfer) { flan_arith_cond c; - uint32_t id = flan_name_id(flan_arith_name, FLAN_ARITH_NAMELEN); + flan_condesc d; + uint32_t chain[2]; c.op = op; c.lhs = lhs; c.rhs = rhs; - flan_signal(id, &c, xfer); + arith_sentence(op, lhs, rhs); + rt_condesc(&d, chain, flan_arith_name, FLAN_ARITH_NAMELEN, loc, loclen); + flan_signal(&d, &c, xfer); if (*(void **)xfer != NULL) return; - if (flan_break_hook != NULL) { - flan_break_site = loc; - flan_break_site_len = loclen; - flan_break_hook(flan_arith_name, FLAN_ARITH_NAMELEN, &c, xfer); - flan_break_site = NULL; - flan_break_site_len = 0; - if (*(void **)xfer != NULL) return; - } - flan_arith_fail(loc, loclen, op, lhs, rhs); + arith_sentence(op, lhs, rhs); /* in full; see flan_bounds_signal */ + if (rt_error_break(&d, &c, xfer)) return; + rt_print_sentence(loc, loclen); + rt_die(); } /* ── A call compiled against another signature ───────────────────────── @@ -1150,6 +1506,16 @@ static flan_slice flan_stale_copy(const char *s) { return r; } +static void stale_sentence(const char *callee, const char *want, + const char *now) { + rt_sentence("this call to %s was compiled for %s, and %s is defined as %s. " + "Evaluating the function this call is in again fixes its next " + "call. A function that is still running, such as main's loop, " + "is never called again: define %s with %s again, or run the " + "program again.", + callee, want, callee, now, callee, want); +} + void flan_stale_call(const char *site, const char *callee, const char *want, void *const *cell, void *xfer) { /* A registry cell nothing has published into yet has no text. */ @@ -1159,25 +1525,16 @@ void flan_stale_call(const char *site, const char *callee, const char *want, c.compiled = flan_stale_copy(want); c.current = flan_stale_copy(now); flan_slice where = flan_stale_copy(site); - uint32_t id = flan_name_id(flan_stale_name, FLAN_STALE_NAMELEN); - flan_signal(id, &c, xfer); + flan_condesc d; + uint32_t chain[2]; + stale_sentence(callee, want, now); + rt_condesc(&d, chain, flan_stale_name, FLAN_STALE_NAMELEN, where.ptr, + where.len); + flan_signal(&d, &c, xfer); if (*(void **)xfer != NULL) return; - if (flan_break_hook != NULL) { - flan_break_site = where.ptr; - flan_break_site_len = where.len; - flan_break_hook(flan_stale_name, FLAN_STALE_NAMELEN, &c, xfer); - flan_break_site = NULL; - flan_break_site_len = 0; - if (*(void **)xfer != NULL) return; - } - rt_flush_out(); - fprintf(stderr, - "%s: this call to %s was compiled for %s, and %s is defined as %s. " - "Evaluating the function this call is in again fixes its next call. " - "A function that is still running, such as main's loop, is never " - "called again: define %s with %s again, or run the program " - "again.\n", - site, callee, want, callee, now, callee, want); + stale_sentence(callee, want, now); /* in full; see flan_bounds_signal */ + if (rt_error_break(&d, &c, xfer)) return; + rt_print_sentence(where.ptr, where.len); rt_die(); } @@ -1188,7 +1545,8 @@ void flan_stale_call(const char *site, const char *callee, const char *want, * size and align as parameters because the only place the concrete type is * known is the call site. * - * A Flan `Allocator` value is a *pointer* to one of these, not a copy of it. + * A Flan `Allocator` value names one of these — its address and the + * [incarnation] it was made for, see flan_alloc_value — and is never a copy. * That is forced by two things in the spec and is not a convenience: the * capability set has to be readable at run time from wherever a container * landed, and `free-all` bumps an epoch that every container made from the @@ -1245,8 +1603,22 @@ struct flan_allocator { * the spec names as the handler that works, needs a ceiling to raise. It * doubles as the knob a test exhausts an allocator with on purpose. */ int64_t budget; + /* Bumped when arena-destroy retires this record. A Flan Allocator value is + * this record's address and the incarnation it was made for, and every use + * of one compares the two (flan_alloc_use), so a value kept past its + * arena's destroy traps even after arena-new has taken the record back for + * another arena. Separate from [epoch]: free-all keeps the arena, and a + * value made before a free-all is still good. */ + uint64_t incarnation; }; +/* A Flan Allocator value, two words. The compiler lays it out as { ptr, i64 } + * and hands the runtime its address. */ +typedef struct flan_alloc_value { + flan_allocator *rec; + uint64_t inc; +} flan_alloc_value; + /* ── Byte counts that cannot wrap ────────────────────────────────────── * * Every size this file computes is a signed 64-bit count of bytes, and every @@ -1307,6 +1679,9 @@ void flan_dev_reg_note(void *base, int64_t bytes, int64_t elem, const char *type, int64_t typelen); void flan_dev_reg_dead(void *base); void flan_dev_reg_dead_range(void *base, int64_t bytes); +/* flan_dev.c: a dev build fills a block a resize moved away from, so that a + * slice still pointing into it reads visibly wrong values. */ +void flan_dev_poison(void *p, int64_t bytes); /* -- The heap allocator: malloc, realloc, free. ---------------------- */ @@ -1341,6 +1716,7 @@ static void *flan_heap_proc(flan_allocator *a, int32_t mode, void *p, that got here — which is also why a resize needs no note of its own. */ if (p) { flan_dev_reg_dead(p); + flan_dev_poison(p, old_size); free(p); a->live_blocks--; a->live_bytes -= old_size; @@ -1364,7 +1740,7 @@ static void *flan_heap_proc(flan_allocator *a, int32_t mode, void *p, static flan_allocator flan_heap = { flan_heap_proc, NULL, FLAN_CAN_ALLOC | FLAN_CAN_RESIZE | FLAN_CAN_FREE, - 0, 0, 0, 0 + 0, 0, 0, 0, 0 }; /* -- Telling memcheck an arena reset happened. ----------------------- @@ -1440,13 +1816,66 @@ static flan_allocator flan_heap = { * The epoch is bumped either way: the pages are the same but every container * made before the reset is invalid, which is the whole point of the trap. */ +/* A block the temp arena grew out of. It still holds what was allocated from + * it before the growth, so it is kept until the next free-all. */ +typedef struct flan_chunk { + struct flan_chunk *next; + uint8_t *base; + int64_t cap; +} flan_chunk; + typedef struct flan_arena { uint8_t *base; int64_t cap; int64_t offset; int64_t peak; + /* The temp arena only: a request that does not fit starts a bigger block + * instead of failing, and [old] keeps the ones it outgrew until free-all, + * which keeps the biggest. A program that formats more text between two + * (free-temp)s than the first block holds gets more room rather than + * StorageExhausted, and one that never calls it grows the way the heap + * would. A program's own arena-new keeps its fixed capacity. */ + int grow; + flan_chunk *old; } flan_arena; +/* Retire the current block and start one that fits [need]. */ +static int flan_arena_grow(flan_arena *ar, int64_t need) { + flan_chunk *c; + uint8_t *b; + int64_t cap = ar->cap; + while (cap < need) { + if (cap > ((int64_t)1 << 40)) { cap = need; break; } + cap *= 2; + } + if (cap == ar->cap) cap *= 2; + c = (flan_chunk *)malloc(sizeof *c); + if (!c) return 0; + b = (uint8_t *)malloc((size_t)cap); + if (!b) { free(c); return 0; } + c->base = ar->base; + c->cap = ar->cap; + c->next = ar->old; + ar->old = c; + ar->base = b; + ar->cap = cap; + ar->offset = 0; + return 1; +} + +/* The blocks the arena outgrew, handed back; the dev registry and memcheck + * are told each one died, the same as the live block. */ +static void flan_arena_drop_old(flan_arena *ar) { + while (ar->old) { + flan_chunk *c = ar->old; + ar->old = c->next; + flan_dev_reg_dead_range(c->base, c->cap); + flan_dev_poison(c->base, c->cap); + free(c->base); + free(c); + } +} + static int64_t flan_align_up(int64_t x, int64_t a) { if (a <= 1) return x; return (x + a - 1) / a * a; @@ -1463,6 +1892,11 @@ static void *flan_arena_proc(flan_allocator *a, int32_t mode, void *p, if (align < 1) align = 1; start = flan_align_up(ar->offset, align); end = start + size; + if ((end > ar->cap || end < start) && ar->grow && size < ((int64_t)1 << 40) + && flan_arena_grow(ar, size + align)) { + start = flan_align_up(ar->offset, align); + end = start + size; + } if (end > ar->cap || end < start) return NULL; /* exhausted, or overflow */ ar->offset = end; if (end > ar->peak) ar->peak = end; @@ -1475,7 +1909,10 @@ static void *flan_arena_proc(flan_allocator *a, int32_t mode, void *p, /* Growing the most recent block in place is the one case worth special * casing: a Vec that is the only thing pushing into a frame arena grows * without copying, which is the common shape. */ - if (p && (uint8_t *)p + old_size == ar->base + ar->offset) { + /* A growing arena whose block cannot hold the new size falls through to + * the copy below, whose allocation starts a bigger block. */ + if (p && (uint8_t *)p + old_size == ar->base + ar->offset + && !(ar->grow && (int64_t)((uint8_t *)p - ar->base) + size > ar->cap)) { int64_t end = (int64_t)((uint8_t *)p - ar->base) + size; /* The budget is checked here as on every other path; a block grown in * place is still more live bytes. */ @@ -1488,8 +1925,10 @@ static void *flan_arena_proc(flan_allocator *a, int32_t mode, void *p, } q = flan_arena_proc(a, FLAN_ALLOC_ALLOC, NULL, 0, size, align); if (!q) return NULL; - if (p && old_size > 0) + if (p && old_size > 0) { memcpy(q, p, (size_t)(old_size < size ? old_size : size)); + flan_dev_poison(p, old_size); + } return q; /* the old block is not reclaimable */ } case FLAN_ALLOC_FREE: @@ -1511,7 +1950,12 @@ static void *flan_arena_proc(flan_allocator *a, int32_t mode, void *p, The whole capacity rather than [0, offset): everything past the offset is equally reusable and equally stale, and two calls would only be cheaper if the second could be skipped. */ + flan_arena_drop_old(ar); flan_dev_reg_dead_range(ar->base, ar->cap); + /* The temp arena's wipe, in a dev build, fills what was handed out with + the pattern a moved Vec's old buffer gets, so text kept past its frame + without a clone reads as garbage rather than as last frame's value. */ + if (ar->grow) flan_dev_poison(ar->base, ar->offset); FLAN_VG_MAKE_MEM_UNDEFINED(ar->base, ar->cap); ar->offset = 0; a->live_blocks = 0; @@ -1530,35 +1974,141 @@ static void *flan_arena_proc(flan_allocator *a, int32_t mode, void *p, * trampolines and the reload ABI, for the same observable behaviour. The * literal reading is deferred and docs/BUILT.md says so. * - * There are no threads in Flan, so a plain global is the whole of it. */ + * There are no threads in Flan, so a plain global is the whole of it. + * + * It holds an Allocator *value*, the record and its incarnation, and not the + * bare record: with-allocator restores what it displaced, and what it displaced + * may be an arena destroyed in the meantime whose record a later arena-new + * took. Holding the incarnation is what lets the next use of the context trap + * rather than allocate from that other arena. */ -static flan_allocator *flan_ctx_alloc = &flan_heap; +static flan_alloc_value flan_ctx = { &flan_heap, 0 }; static flan_allocator *flan_ctx_tmp = NULL; +/* The agent's scratch temp arenas; see flan_temp_scratch_begin. */ +#define FLAN_SCRATCH_LEVELS 16 +static flan_allocator *flan_scratch[FLAN_SCRATCH_LEVELS]; +/* The incarnation of the temp arena each level displaced, so the end puts it + * back only if the expression did not destroy it. */ +static uint64_t flan_scratch_prev_inc[FLAN_SCRATCH_LEVELS]; +static int flan_scratch_depth; flan_allocator *flan_arena_new(int64_t cap); +_Noreturn static void flan_destroyed_fail(const uint8_t *loc, int64_t loclen); -flan_allocator *flan_context_allocator(void) { return flan_ctx_alloc; } +/* The context's record, for the runtime's own callers: a zeroed container + * adopting the context on its first operation. Checked like any use. */ +flan_allocator *flan_context_allocator(void) { + if (flan_ctx.rec && flan_ctx.rec->incarnation != flan_ctx.inc) + flan_destroyed_fail((const uint8_t *)"context/allocator", 17); + return flan_ctx.rec; +} + +/* The same, for an operation the compiler emitted, which names its site. */ +flan_allocator *flan_context_use(const uint8_t *loc, int64_t loclen) { + if (flan_ctx.rec && flan_ctx.rec->incarnation != flan_ctx.inc) + flan_destroyed_fail(loc, loclen); + return flan_ctx.rec; +} + +/* context/allocator as a value: the one the context holds, incarnation and + * all, so a value read from the context goes stale with it. */ +void flan_context_value(flan_alloc_value *out) { *out = flan_ctx; } /* The default temp arena, made on first use. 1 MiB: big enough that the * per-frame tier does not fail on a toy program, small enough that a program * which never touches it has not paid for a heap. */ #define FLAN_TEMP_DEFAULT (1 << 20) +/* Odin's context.temp_allocator: where i64->bytes and f64->bytes put their + * text, and what context/temp names. It grows rather than failing (see + * flan_arena's [grow]), and it is wiped by (free-temp), which a program calls + * once a frame — and, in a dev build, by the agent at every frame boundary it + * polls at. Text kept past the frame is cloned out of it first. */ flan_allocator *flan_context_temp(void) { - if (!flan_ctx_tmp) flan_ctx_tmp = flan_arena_new(FLAN_TEMP_DEFAULT); + if (!flan_ctx_tmp) { + flan_ctx_tmp = flan_arena_new(FLAN_TEMP_DEFAULT); + if (flan_ctx_tmp) ((flan_arena *)flan_ctx_tmp->data)->grow = 1; + } return flan_ctx_tmp; } -/* Returns the previous one, which is what with-allocator restores — on the - * normal path and on the transfer path both. */ -flan_allocator *flan_context_set(flan_allocator *a) { - flan_allocator *prev = flan_ctx_alloc; - if (a) flan_ctx_alloc = a; +static void *rt_temp_alloc(int64_t n) { + flan_allocator *a = flan_context_temp(); + if (a == NULL) return NULL; + return a->proc(a, FLAN_ALLOC_ALLOC, NULL, 0, n, 1); +} + +/* (free-temp): everything in the temp arena dies, the same release free-all + * is, and a container made from it traps on its next use. Nothing to do when + * nothing has made it yet. */ +void flan_free_temp(void) { + flan_allocator *a = flan_ctx_tmp; + if (!a) return; + a->proc(a, FLAN_ALLOC_FREE_ALL, NULL, 0, 0, 0); + a->epoch++; +} + +/* An expression the agent runs while the program is stopped gets a temp + * arena of its own: [begin] points context/temp at a scratch arena and + * answers the program's, [end] wipes the scratch arena — poisoned in a dev + * build, as any free-temp is — and puts the program's back. The program's own + * temp arena is never touched, so text its stopped frames hold survives and a + * temp Vec it owns grows through its own allocator as usual. What the + * expression allocates from context/temp and stores into program state + * dangles once the expression ends, like any temp text kept past its frame, + * and reads as the poison pattern in a dev build. + * + * One scratch arena per nesting level — a stop inside an evaluated expression + * evaluates inside it — each kept and reused, so an evaluation costs a + * free-all and not a malloc. Past the last level the deepest is shared. */ + +void *flan_temp_scratch_begin(void) { + flan_allocator *prev = flan_ctx_tmp; + int d = flan_scratch_depth < FLAN_SCRATCH_LEVELS ? flan_scratch_depth + : FLAN_SCRATCH_LEVELS - 1; + if (!flan_scratch[d]) { + flan_scratch[d] = flan_arena_new(FLAN_TEMP_DEFAULT); + if (flan_scratch[d]) ((flan_arena *)flan_scratch[d]->data)->grow = 1; + } + flan_scratch_prev_inc[d] = prev ? prev->incarnation : 0; + flan_scratch_depth++; + if (flan_scratch[d]) flan_ctx_tmp = flan_scratch[d]; return prev; } -void flan_context_restore(flan_allocator *a) { - if (a) flan_ctx_alloc = a; +void flan_temp_scratch_end(void *prev) { + int d; + if (flan_scratch_depth > 0) flan_scratch_depth--; + d = flan_scratch_depth < FLAN_SCRATCH_LEVELS ? flan_scratch_depth + : FLAN_SCRATCH_LEVELS - 1; + if (flan_scratch[d] && flan_ctx_tmp == flan_scratch[d]) { + flan_scratch[d]->proc(flan_scratch[d], FLAN_ALLOC_FREE_ALL, NULL, 0, 0, 0); + flan_scratch[d]->epoch++; + } + /* An expression that destroyed the program's temp arena through an + * Allocator value it kept has retired its record, and a later arena-new may + * have taken it; putting it back would make context/temp that other arena. + * The context is then left without one, as the destroy left it, and the + * next use makes a new one. */ + { + flan_allocator *p = (flan_allocator *)prev; + flan_ctx_tmp = p && p->incarnation == flan_scratch_prev_inc[d] ? p : NULL; + } +} + +/* with-allocator hands in two values in its own frame: [0] the one to install + * and [1] where the displaced one is kept. It gets the same pointer back and + * passes it to restore — on the normal path and on the transfer path both — + * so a displaced value is restored with its incarnation. A null record in [0] + * is a zeroed Allocator and leaves the context as it was. */ +flan_alloc_value *flan_context_set(flan_alloc_value *v) { + v[1] = flan_ctx; + if (v[0].rec) flan_ctx = v[0]; + return v; +} + +void flan_context_restore(flan_alloc_value *v) { + if (v) flan_ctx = v[1]; } /* The context as it stands, and putting it back: the agent's way out of an @@ -1566,13 +2116,14 @@ void flan_context_restore(flan_allocator *a) { * restored it. Two words, which is room for whatever the context grows into; * the agent only carries them. */ void flan_context_save(uint64_t m[2]) { - m[0] = (uint64_t)(uintptr_t)flan_ctx_alloc; - m[1] = 0; + m[0] = (uint64_t)(uintptr_t)flan_ctx.rec; + m[1] = flan_ctx.inc; } void flan_context_load(const uint64_t m[2]) { flan_allocator *a = (flan_allocator *)(uintptr_t)m[0]; - flan_ctx_alloc = a ? a : &flan_heap; + flan_ctx.rec = a ? a : &flan_heap; + flan_ctx.inc = a ? m[1] : 0; } /* Allocator headers [flan_arena_destroy] retired, linked through [data]. See @@ -1618,14 +2169,15 @@ flan_allocator *flan_arena_new(int64_t cap) { /* What an allocator's procedure becomes once [flan_arena_destroy] has handed * its arena back. Every request traps, because there is nothing left to serve * it from and answering NULL would read as exhaustion — which a retry handler - * that raises the budget would then retry for ever. */ + * that raises the budget would then retry for ever. Flan code does not reach + * it: a stale Allocator value traps in flan_alloc_use and a stale container on + * its epoch first. It is the backstop for a caller holding the bare record. */ static void *flan_destroyed_proc(flan_allocator *a, int32_t mode, void *p, int64_t old_size, int64_t size, int64_t align) { (void)a; (void)mode; (void)p; (void)old_size; (void)size; (void)align; - rt_flush_out(); - fprintf(stderr, - "this allocator was destroyed by arena-destroy, so nothing can be " - "allocated from it or released through it\n"); + flan_say(NULL, 0, + "this allocator was destroyed by arena-destroy, so nothing can be " + "allocated from it or released through it"); rt_trap((const uint8_t *)"DestroyedAllocator", 18); } @@ -1639,16 +2191,20 @@ static void *flan_destroyed_proc(flan_allocator *a, int32_t mode, void *p, * makes and destroys arenas in a loop holds as many headers as it ever had * arenas alive at once. * - * A second destroy finds the retired procedure and does nothing — while the - * header is still on the list. Once a later arena-new has taken it back, the - * old Allocator value names the new arena. */ + * The Allocator value that named the arena carries the incarnation it was made + * for, which the retire bumps, so every later use of that value — a second + * destroy included — traps in flan_alloc_use before it reaches here, whether + * or not a later arena-new has taken the record back. */ void flan_arena_destroy(flan_allocator *a) { flan_arena *ar; if (!a || a->proc != flan_arena_proc) return; ar = (flan_arena *)a->data; - if (a == flan_ctx_alloc) flan_ctx_alloc = &flan_heap; + if (a == flan_ctx.rec) { flan_ctx.rec = &flan_heap; flan_ctx.inc = 0; } if (a == flan_ctx_tmp) flan_ctx_tmp = NULL; + for (int i = 0; i < FLAN_SCRATCH_LEVELS; i++) + if (flan_scratch[i] == a) flan_scratch[i] = NULL; a->epoch++; + flan_arena_drop_old(ar); flan_dev_reg_dead_range(ar->base, ar->cap); free(ar->base); free(ar); @@ -1656,6 +2212,7 @@ void flan_arena_destroy(flan_allocator *a) { } static void flan_header_retire(flan_allocator *a) { + a->incarnation++; a->proc = flan_destroyed_proc; a->live_blocks = 0; a->live_bytes = 0; @@ -1665,6 +2222,33 @@ static void flan_header_retire(flan_allocator *a) { flan_allocator *flan_heap_allocator(void) { return &flan_heap; } +/* An Allocator value made from a record: the record and its incarnation now. + * Through an out-pointer, since nothing here returns a struct by value. */ +void flan_alloc_seal(flan_allocator *a, flan_alloc_value *out) { + out->rec = a; + out->inc = a ? a->incarnation : 0; +} + +/* Every use of an Allocator value comes through here: the record, if the + * value's incarnation is still the record's. A mismatch is a value kept past + * its arena's destroy, and it traps whether the record is still retired or + * serves a newer arena — reaching the newer arena would be allocating from a + * region the program never named. A null record passes through to the + * operation's own null check, which names the site the same way. */ +flan_allocator *flan_alloc_use(const flan_alloc_value *v, const uint8_t *loc, + int64_t loclen) { + flan_allocator *a = v->rec; + if (a && a->incarnation != v->inc) flan_destroyed_fail(loc, loclen); + return a; +} + +_Noreturn static void flan_destroyed_fail(const uint8_t *loc, int64_t loclen) { + flan_say(loc, loclen, + "this allocator was destroyed by arena-destroy, so nothing can be " + "allocated from it or released through it"); + rt_trap((const uint8_t *)"DestroyedAllocator", 18); +} + int8_t flan_alloc_can_free(flan_allocator *a) { return (int8_t)(a && (a->caps & FLAN_CAN_FREE) ? 1 : 0); } @@ -1704,20 +2288,15 @@ void flan_alloc_free_all(flan_allocator *a, const uint8_t *loc, int64_t loclen) } _Noreturn void flan_null_alloc_fail(const uint8_t *loc, int64_t loclen) { - rt_flush_out(); - fprintf(stderr, - "%.*s: this allocator is null — a zeroed Allocator was never given " - "one\n", - (int)loclen, (const char *)loc); + flan_say(loc, loclen, + "this allocator is null — a zeroed Allocator was never given one"); rt_trap((const uint8_t *)"NullAllocator", 13); } _Noreturn void flan_free_all_fail(const uint8_t *loc, int64_t loclen) { - rt_flush_out(); - fprintf(stderr, - "%.*s: this allocator does not offer free-all — it has no region " - "to release\n", - (int)loclen, (const char *)loc); + flan_say(loc, loclen, + "this allocator does not offer free-all — it has no region to " + "release"); rt_trap((const uint8_t *)"NoFreeAll", 9); } @@ -1854,6 +2433,68 @@ int64_t flan_alloc_fail_bytes(void) { return flan_fail_bytes; } int64_t flan_alloc_fail_align(void) { return flan_fail_align; } int64_t flan_alloc_fail_id(void) { return flan_fail_id; } +/* i64->bytes and f64->bytes: the number's text in the temp arena, answered + * through [out]. When the current block has FLAN_NUM_BYTES to spare and no + * budget is set, the number is rendered straight into it and the offset moved + * past what was written — no copy, no call through the arena procedure. + * Otherwise it is rendered on the stack and allocated through the procedure, + * which grows the block. 0 is a failed allocation, reported like any other for + * the compiler's StorageExhausted guard; the temp arena grows, so that is + * malloc itself failing. */ +typedef int (*flan_render)(const void *x, char *buf, size_t cap); + +static int render_i64(const void *x, char *buf, size_t cap) { + return snprintf(buf, cap, "%lld", (long long)*(const int64_t *)x); +} + +static int render_f64(const void *x, char *buf, size_t cap) { + return flan_f64_format(*(const double *)x, buf, cap); +} + +static int8_t flan_temp_text(flan_render render, const void *x, + flan_slice *out) { + flan_allocator *a = flan_context_temp(); + flan_arena *ar; + uint8_t *q; + int64_t len; + if (!a) { + flan_fail_bytes = FLAN_NUM_BYTES; + flan_fail_align = 1; + flan_fail_id = 0; + return 0; + } + ar = (flan_arena *)a->data; + if (a->budget <= 0 && ar->cap - ar->offset >= FLAN_NUM_BYTES) { + q = ar->base + ar->offset; + len = fit(render(x, (char *)q, FLAN_NUM_BYTES)); + ar->offset += len; + if (ar->offset > ar->peak) ar->peak = ar->offset; + a->live_blocks++; + a->live_bytes += len; + } else { + char buf[FLAN_NUM_BYTES]; + len = fit(render(x, buf, sizeof buf)); + flan_fail_bytes = len; + flan_fail_align = 1; + flan_fail_id = (int64_t)(intptr_t)a; + q = (uint8_t *)a->proc(a, FLAN_ALLOC_ALLOC, NULL, 0, len, 1); + if (!q) return 0; + memcpy(q, buf, (size_t)len); + } + flan_dev_reg_note(q, len, 1, "u8", 2); + out->ptr = q; + out->len = len; + return 1; +} + +int8_t flan_i64_temp(int64_t x, flan_slice *out) { + return flan_temp_text(render_i64, &x, out); +} + +int8_t flan_f64_temp(double x, flan_slice *out) { + return flan_temp_text(render_f64, &x, out); +} + /* The allocator's identity, for the condition's :allocator field. The pointer * is the identity — the same thing the epoch hangs off. */ int64_t flan_alloc_id(flan_allocator *a) { return (int64_t)(intptr_t)a; } @@ -1966,8 +2607,8 @@ static int8_t flan_vec_grow(flan_vec *v, int64_t want, int64_t size, flan_vec_block_hook(v->ptr, p, bytes, v->alloc, v->epoch); v->ptr = p; v->cap = cap; - /* Any slice taken before this points at storage that may have moved. The - * word is bumped here and read nowhere yet; see docs/BUILT.md. */ + /* Any slice taken before this points at storage that may have moved; in a + * dev build the allocator has filled the old block (flan_dev_poison). */ return 1; } @@ -2028,7 +2669,8 @@ void *flan_vec_at(flan_vec *v, int32_t i, int64_t size, const uint8_t *loc, /* The same unsigned comparison the fixed-array bounds check uses: a negative * index sign-extends to a huge unsigned and is caught by the one test. */ if ((uint64_t)(int64_t)i >= (uint64_t)v->len) { - if (flan_bounds_signal(loc, loclen, xfer, (int64_t)i, (int64_t)i, v->len)) + if (flan_bounds_signal(loc, loclen, xfer, BOUNDS_AT, (int64_t)i, (int64_t)i, + v->len)) return NULL; flan_vec_bounds_fail(loc, loclen, (int64_t)i, v->len); } @@ -2046,7 +2688,8 @@ void flan_vec_as_slice(flan_vec *v, void *out, int32_t lo, int32_t hi, /* Both ends, because both are what went wrong — the fixed-array slice * check reports the same pair. [out] is left untouched on the transfer * path; the caller's guard branches before it reads the slice. */ - if (flan_bounds_signal(loc, loclen, xfer, l, h, v->len)) return; + if (flan_bounds_signal(loc, loclen, xfer, BOUNDS_SLICE, l, h, v->len)) + return; flan_vec_bounds_fail(loc, loclen, l, v->len); } s.p = (uint8_t *)v->ptr + l * size; @@ -2075,15 +2718,16 @@ void flan_vec_free(flan_vec *v, int64_t size, int64_t align, v->epoch = 0; } -/* (bytes s): a writable copy of a string's bytes, into a block the named +/* (bytes s) and (clone xs): a copy of n elements, into a block the named * allocator owns. The header the compiler hands in is a hidden temp — the * caller's answer is a slice over the block — but it is a real Vec, so the * registry note, the epoch word and free-all's reclaim all work on it the way - * they work on any Vec of u8. Element size and align are 1 by construction. */ + * they work on any Vec. (bytes s) passes a size and align of 1. */ int8_t flan_bytes_dup(flan_vec *v, flan_allocator *a, const uint8_t *p, - int64_t n, const uint8_t *loc, int64_t loclen) { - if (!flan_vec_init(v, a, n, 1, 1, loc, loclen)) return 0; - if (n > 0) memcpy(v->ptr, p, (size_t)n); + int64_t n, int64_t size, int64_t align, + const uint8_t *loc, int64_t loclen) { + if (!flan_vec_init(v, a, n, size, align, loc, loclen)) return 0; + if (n > 0) memcpy(v->ptr, p, (size_t)(n * size)); v->len = n; return 1; } diff --git a/spec-conditions.md b/spec-conditions.md index ed33eff9..5dcba462 100644 --- a/spec-conditions.md +++ b/spec-conditions.md @@ -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 `()` diff --git a/spec-memory.md b/spec-memory.md index c7a100dd..c06db1cd 100644 --- a/spec-memory.md +++ b/spec-memory.md @@ -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: diff --git a/test/agent_hooks.c b/test/agent_hooks.c index e8fb923d..455213e6 100644 --- a/test/agent_hooks.c +++ b/test/agent_hooks.c @@ -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); diff --git a/test/programs/arith-condition.flan b/test/programs/arith-condition.flan index 78bd2019..db7881f6 100644 --- a/test/programs/arith-condition.flan +++ b/test/programs/arith-condition.flan @@ -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) diff --git a/test/programs/break.flan b/test/programs/break.flan index fe37c9bb..3399fcbe 100644 --- a/test/programs/break.flan +++ b/test/programs/break.flan @@ -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) diff --git a/test/programs/clone-slice.flan b/test/programs/clone-slice.flan new file mode 100644 index 00000000..a7aa0b9e --- /dev/null +++ b/test/programs/clone-slice.flan @@ -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) diff --git a/test/programs/condition-longmessage.flan b/test/programs/condition-longmessage.flan new file mode 100644 index 00000000..3991b7ef --- /dev/null +++ b/test/programs/condition-longmessage.flan @@ -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) diff --git a/test/programs/condition-messages.flan b/test/programs/condition-messages.flan new file mode 100644 index 00000000..fcb51192 --- /dev/null +++ b/test/programs/condition-messages.flan @@ -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) diff --git a/test/programs/condition-parents.flan b/test/programs/condition-parents.flan new file mode 100644 index 00000000..302fd208 --- /dev/null +++ b/test/programs/condition-parents.flan @@ -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) diff --git a/test/programs/condition-temp.flan b/test/programs/condition-temp.flan new file mode 100644 index 00000000..ca69bb24 --- /dev/null +++ b/test/programs/condition-temp.flan @@ -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) diff --git a/test/programs/context-destroyed.flan b/test/programs/context-destroyed.flan new file mode 100644 index 00000000..65de8c53 --- /dev/null +++ b/test/programs/context-destroyed.flan @@ -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) diff --git a/test/programs/destroy-region.flan b/test/programs/destroy-region.flan index 680be7eb..7bc972de 100644 --- a/test/programs/destroy-region.flan +++ b/test/programs/destroy-region.flan @@ -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) diff --git a/test/programs/dev-alloc-param.flan b/test/programs/dev-alloc-param.flan new file mode 100644 index 00000000..6f858b87 --- /dev/null +++ b/test/programs/dev-alloc-param.flan @@ -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) diff --git a/test/programs/dev-break.flan b/test/programs/dev-break.flan index 24a353c9..05e306f7 100644 --- a/test/programs/dev-break.flan +++ b/test/programs/dev-break.flan @@ -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") diff --git a/test/programs/dev-bt-handler.flan b/test/programs/dev-bt-handler.flan new file mode 100644 index 00000000..a8b01638 --- /dev/null +++ b/test/programs/dev-bt-handler.flan @@ -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) diff --git a/test/programs/dev-temp-destroy.flan b/test/programs/dev-temp-destroy.flan new file mode 100644 index 00000000..c6e30af7 --- /dev/null +++ b/test/programs/dev-temp-destroy.flan @@ -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) diff --git a/test/programs/dev-temp-stop.flan b/test/programs/dev-temp-stop.flan new file mode 100644 index 00000000..666f3e09 --- /dev/null +++ b/test/programs/dev-temp-stop.flan @@ -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) diff --git a/test/programs/dev-trap-dyn.flan b/test/programs/dev-trap-dyn.flan new file mode 100644 index 00000000..dad26ced --- /dev/null +++ b/test/programs/dev-trap-dyn.flan @@ -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) diff --git a/test/programs/dev-trap-stale-sentence.flan b/test/programs/dev-trap-stale-sentence.flan new file mode 100644 index 00000000..589c30f5 --- /dev/null +++ b/test/programs/dev-trap-stale-sentence.flan @@ -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) diff --git a/test/programs/shim-literal.flan b/test/programs/shim-literal.flan new file mode 100644 index 00000000..8c9a3ac7 --- /dev/null +++ b/test/programs/shim-literal.flan @@ -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) diff --git a/test/programs/shim-nul-end.flan b/test/programs/shim-nul-end.flan new file mode 100644 index 00000000..621e82d0 --- /dev/null +++ b/test/programs/shim-nul-end.flan @@ -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) diff --git a/test/programs/stale-slice-poison.flan b/test/programs/stale-slice-poison.flan new file mode 100644 index 00000000..660d4711 --- /dev/null +++ b/test/programs/stale-slice-poison.flan @@ -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) diff --git a/test/programs/strings.flan b/test/programs/strings.flan index a7813768..30209f35 100644 --- a/test/programs/strings.flan +++ b/test/programs/strings.flan @@ -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) diff --git a/test/programs/temp-agent.flan b/test/programs/temp-agent.flan new file mode 100644 index 00000000..1d58531f --- /dev/null +++ b/test/programs/temp-agent.flan @@ -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) diff --git a/test/programs/temp-frame.flan b/test/programs/temp-frame.flan new file mode 100644 index 00000000..46e7b6d8 --- /dev/null +++ b/test/programs/temp-frame.flan @@ -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) diff --git a/test/programs/temp-grow.flan b/test/programs/temp-grow.flan new file mode 100644 index 00000000..3f7c6d4a --- /dev/null +++ b/test/programs/temp-grow.flan @@ -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) diff --git a/test/programs/two-numbers.flan b/test/programs/two-numbers.flan index 5c4a2d98..ba24e10a 100644 --- a/test/programs/two-numbers.flan +++ b/test/programs/two-numbers.flan @@ -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) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 9bbb2f8e..a0fe1a0f 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -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"; diff --git a/test/test_agent.ml b/test/test_agent.ml index 91a2489f..def7521c 100644 --- a/test/test_agent.ml +++ b/test/test_agent.ml @@ -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 diff --git a/test/test_dev.ml b/test/test_dev.ml index 3e6079dc..d5446668 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -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 diff --git a/test/test_flan.ml b/test/test_flan.ml index 24b53100..4d0f57f7 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -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" diff --git a/test/test_session.ml b/test/test_session.ml index 604b92b5..5af415c9 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -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); diff --git a/test/test_valgrind.ml b/test/test_valgrind.ml index 0bc12d9d..7d95d908 100644 --- a/test/test_valgrind.ml +++ b/test/test_valgrind.ml @@ -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", []; diff --git a/vendor/agent/flan_agent.c b/vendor/agent/flan_agent.c index d151ca7d..47aae148 100644 --- a/vendor/agent/flan_agent.c +++ b/vendor/agent/flan_agent.c @@ -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); diff --git a/web/index.html b/web/index.html index 9a3a3948..a4a686e5 100644 --- a/web/index.html +++ b/web/index.html @@ -531,7 +531,7 @@ notation reads as exactly one data item.

(Fn [T ...] R)a function value, which may have captureda code address and an environment pointer (CFn [T ...] R)a function value that cannot capture — the C is what a C function pointer would need, not a way to reach C todaya pointer dyna value the runtime knows the type of and the checker does not — see dynone word, on a collected heap -Allocatoran opaque builtin: a proc, its data and a capability seta pointer to that +Allocatoran opaque builtin: a proc, its data and a capability seta pointer to that, and a count that says whether it has since been destroyed $ta type variable — see genericswhatever it is instantiated at a structvalue typefields in declaration order a tagged data typedefdata, matched by casetag + the widest payload