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

A restart frame carries where its clause is written, its :report sentence and whether a handler-case made it up, and the break loop shows the first two and hides the third

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-25 11:35:12 +07:00
parent 8b4c6f81df
commit 680c12e686
17 changed files with 424 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
emacs/flan-cnr.el
View File

@ -294,6 +294,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)
@ -306,6 +307,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
@ -325,6 +332,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
@ -352,9 +363,19 @@ 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-shadowed owner
'flan-cnr-kind kind
'flan-cnr-index i
@ -604,13 +625,21 @@ puts the likely culprit on top."
A frame's location is where its function is written; the stop's is 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."
@ -873,6 +902,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

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

@ -1044,6 +1044,37 @@ 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))))
;; 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 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.

9
lib/ast.ml
View File

@ -167,9 +167,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. *)

27
lib/check.ml
View File

@ -4391,7 +4391,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. *)
@ -4445,7 +4446,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
@ -4558,11 +4562,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
@ -6630,7 +6636,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))
@ -6696,16 +6703,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

58
lib/dev.ml
View File

@ -378,6 +378,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
@ -398,17 +407,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
@ -1797,11 +1820,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
@ -1811,8 +1849,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

26
lib/emit.ml
View File

@ -163,15 +163,20 @@ 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 ] }
(* The static description of a function, and the shadow-stack frame that
points at one. Dev builds only (runtime/flan_dev.c). *)
@ -2922,6 +2927,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
@ -4298,8 +4311,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

21
lib/parse.ml
View File

@ -675,11 +675,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))

10
lib/tast.ml
View File

@ -300,10 +300,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 }

8
lib/x86.ml
View File

@ -2118,6 +2118,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, _) ->

65
runtime/flan_rt.c
View File

@ -87,6 +87,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;
@ -95,8 +97,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
@ -152,6 +175,35 @@ 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;
}
/* 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. */
@ -676,12 +728,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;
}

17
test/agent_hooks.c
View File

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

14
test/programs/break.flan
View File

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

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

@ -15,7 +15,7 @@
(defn fetch [n i32] i32
(restart-case
(do (error (Missing {.id n})) 0)
(use-placeholder [] -1)
(use-placeholder [] :report "Answer -1" -1)
(retry [] 7)))
(defonce ticks i64)

37
test/test_agent.ml
View File

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

13
test/test_dev.ml
View File

@ -925,6 +925,19 @@ let () =
if names <> [ "retry"; "use-placeholder" ] then
fail "restarts on offer: %s" (String.concat ", " names)
| _ -> fail "break did not list the restarts");
(* Beside each name, in the same order: its :report sentence and
where its clause is written. [retry] wrote no report. *)
(match Wire.field r "details" with
| Some { Form.v = Form.List [ d0; d1 ]; _ } ->
let str = Wire.string_field in
if str d0 "report" <> Some "" || str d1 "report" <> Some "Answer -1"
then fail "the restarts' reports did not arrive";
(match str d1 "at" with
| Some at when contains_sub at "dev-break.flan:18:" -> ()
| at ->
fail "use-placeholder's clause is at %s"
(Option.value at ~default:"nowhere"))
| _ -> fail "break did not carry a detail per restart");
(* Where it is, which is the other half of what a stopped program can
be asked. The shadow stack is dev-only and the daemon owns the

8
test/test_flan.ml
View File

@ -3307,6 +3307,14 @@ 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. *)
(* 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"

91
vendor/agent/flan_agent.c vendored
View File

@ -334,7 +334,15 @@ extern int64_t flan_break_site_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_pop_c(void *frame);
/* -- How far down a transfer can actually land ----------------------- */
@ -401,6 +409,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 three of them, dropped between two runs of [main]. The counterpart of
* flan_rt.c's [flan_condition_stacks_reset] and flan_dev.c's
@ -472,6 +482,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 */
@ -505,6 +517,17 @@ typedef struct {
int32_t boundary;
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,
@ -588,6 +611,36 @@ static snapshot *snap_top(void) {
return d <= 0 ? NULL : &snaps[d - 1];
}
/* 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" */
@ -621,6 +674,7 @@ static int snap_push(int resumable, void *cond) {
}
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
@ -643,6 +697,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;
@ -651,6 +711,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;
@ -672,6 +733,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;
@ -860,7 +922,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]
: "",
!s->resumable ? " (cannot be taken from this trap)"
: i == s->boundary
? " (stop running the expression; the program carries on)"
@ -1041,7 +1107,9 @@ int32_t flan_agent_poll(void) {
/* 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);
j.call();
/* Popped whichever way the thunk left — returning with a value, or
* unwinding past this frame because someone abandoned it. */
@ -1234,7 +1302,14 @@ static void handle_line(char *line, sink *o) {
* 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();
@ -1273,6 +1348,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");