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

Conditions have parents under Error, restarts carry where and why, and a handler reads the message with its values

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-25 14:51:18 +07:00
commit e2aa0196cf
39 changed files with 2341 additions and 463 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
TODO.org
View File

@ -392,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]
@ -418,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
@ -1463,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
@ -1479,19 +1463,6 @@ 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.
** 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
@ -1722,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
@ -2094,23 +2053,6 @@ each with its own sentence. Both backends choose the code on the cold path, so t
guard is still two compares. =lhs= and =rhs= still carry the range. Rules out
carrying the float value in the condition.
** TODO The break buffer prints fields, not the sentence the runtime wrote
=ArithError — op 4, lhs -2147483648, rhs 2147483647= where the runtime's own
sentence is "this value does not fit the integer type it is cast to"
(=runtime/flan_rt.c:986=). Worse for a dyn trap: =DynType= has no struct at all,
so the buffer says "no struct is named DynType" while =flan_dyn.c:799= has
written the operation, both tags and both values to stderr. The sentences exist
and go to the daemon buffer; the break buffer wants them on the wire.
=ArithError='s =op= being a bare number is the same gap — it is an enum spelled
as =i32=.
** TODO A backtrace frame names the function, not the call
=fninfo= (=lib/emit.ml:185=) holds one static =loc=, the =defn='s own, and
=flan_frame= (=runtime/flan_dev.c:1011=) adds no per-call location — so two
calls to the same function from one caller are indistinguishable in the stack.
Wants the caller storing its call site into the frame before the call, which is
a field and a store on every dev-build call.
** DONE The condition buffer cannot jump to the source
CLOSED: [2026-09-25]
RET (and =v=) on a frame or on the stop's =at= line opens the file there; TAB

4
bin/main.ml
View File

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

2
conditions.org
View File

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

95
emacs/flan-cnr.el
View File

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

16
emacs/flan.el
View File

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

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

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

16
lib/ast.ml
View File

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

191
lib/check.ml
View File

@ -109,6 +109,9 @@ type env = {
(* Enum name -> its members, in declaration order. A keyword at a call site
resolves against this and nothing else. *)
enums : (string, (string * int64) list) Hashtbl.t;
(* A condition type -> the parent it names, [(defstruct T :parent P ...)].
Handler matching walks this chain; see [condition_chain]. *)
parents : (string, string) Hashtbl.t;
(* Flan name -> the C symbol it is really called by. A foreign function is an
ordinary entry in [fns] as well; this only records how to name it. *)
externs : (string, string) Hashtbl.t;
@ -219,6 +222,7 @@ let new_env () = {
consts = Hashtbl.create 16;
locs = Hashtbl.create 16;
enums = Hashtbl.create 8;
parents = Hashtbl.create 8;
externs = Hashtbl.create 32;
extern_locs = Hashtbl.create 32;
fns = Hashtbl.create 32;
@ -2737,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
@ -3514,6 +3533,70 @@ let invented_ctx env ret =
in_defer = false; defer_ok = false; defer_block = "a nested form";
owner = "<none>" }
(* Whether a struct has exactly Error's two fields, which is what a parent must
have: a handler for a parent is handed a view of that shape. *)
let error_shaped env n =
match Hashtbl.find_opt env.structs n with
| Some s ->
(match s.Tast.fields with
| [ { Tast.fname = "name"; fty = Types.String };
{ Tast.fname = "message"; fty = Types.String } ] -> true
| _ -> false)
| None -> false
(* What a signal site tells the runtime about its condition. A condition that
something could catch through a parent, and that is not Error-shaped itself,
gets a printer lifted out of the signalling function: the runtime calls it
only when a parent's handler is about to run, or nothing handled it, so a
signal nobody catches that way costs nothing. It prints what [println]
prints, fields and values, and that is the message such a handler reads. *)
let condition_desc ctx loc name =
let chain = condition_chain ctx.env name in
let self = error_shaped ctx.env name in
let render =
if self || List.length chain < 2 then None
else begin
let ty = Types.Named name in
let hctx = { (invented_ctx ctx.env Types.Unit) with owner = ctx.owner } in
let pslot = fresh_slot hctx (Types.Ptr (Types.Mut, ty)) in
let bslice = Types.Slice (Types.Mut, Types.Int Types.U8) in
let emit x = mk loc Types.Unit (Tast.Prim (Tast.Rt "flan_msg_emit", [ x ])) in
let emitter : Render.emitter =
{ Render.ebytes = emit;
estr = (fun x -> emit (mk loc bslice (Tast.Prim (Tast.EscapeBytes, [ x ]))));
ei64 = (fun x -> emit (to_bytes hctx loc Tast.I64ToBytes x));
eu64 = (fun x -> emit (to_bytes hctx loc Tast.U64ToBytes x));
ef64 = (fun x -> emit (to_bytes hctx loc Tast.F64ToBytes x));
edyn = (fun x -> mk loc Types.Unit (Tast.Prim (Tast.Rt "flan_dyn_emit_msg", [ x ]))) }
in
let value =
mk loc ty (Tast.Deref (mk loc (Types.Ptr (Types.Mut, ty)) (Tast.Local pslot)))
in
let body = Render.render (render_ctx hctx emitter) 0 value in
let mine =
List.filter
(fun (l : Tast.fn) ->
l.Tast.fparent = Some ctx.owner
&& String.length l.Tast.name >= 8
&& String.sub l.Tast.name 0 8 = "message/")
ctx.env.lifted
in
let fname =
Printf.sprintf "message/%s/%d/%s" ctx.owner (List.length mine) name
in
ctx.env.lifted <-
{ Tast.name = fname; params = [ Types.Ptr (Types.Mut, ty) ];
slots = Array.of_list (List.rev hctx.slot_tys);
snames = Array.of_list (List.rev hctx.slot_names);
ret = Types.Unit; body; fdefers = [];
fenv = None; fparent = Some ctx.owner; floc = loc }
:: ctx.env.lifted;
Some fname
end
in
{ Tast.cname = name; cchain = List.map type_id chain; cself = self;
crender = render }
(* The address of field [i] of the struct the pointer in slot [p] points at. *)
let field_addr_of loc sty fty p i =
let target = mk loc sty (Tast.Deref (mk loc (Types.Ptr (Types.Mut, sty)) (Tast.Local p))) in
@ -4402,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
@ -5108,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. *)
@ -5162,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
@ -5275,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
@ -7782,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
@ -7797,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))
@ -7850,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]
@ -7863,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
@ -11903,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
@ -11958,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, _) ->
@ -12134,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
@ -12337,6 +12499,7 @@ let collect env (decls : Ast.decl list) =
in
settle ();
List.iter (fun c -> ignore (infer c)) !pending;
check_parents env;
(* The paired declarations, handed back so that pass two checks the bodies of
the same functions whose signatures this pass registered. Pairing needs the
type names, which only this pass has; every pass after it needs the result,

2
lib/cimport.ml
View File

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

153
lib/dev.ml
View File

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

159
lib/emit.ml
View File

@ -210,15 +210,32 @@ module Rt = struct
{ sname = "handler";
fields = [ "prev", Ptr; "type", I32; "fn", Ptr; "env", Ptr ] }
(* A restart frame. The first four fields are what the runtime's own
[flan_restart] declares and their offsets do not move; the rest are §3's
parameter passing, described where the type is written into the header. *)
(* A restart frame, field for field the runtime's [flan_restart]. The first
four are the lookup; [args] to [siglen] are §3's parameter passing,
described where the type is written into the header; the last five are
for a break loop and nothing reads them on the way to a transfer: where
the clause is written, its [:report] sentence, and [flags], whose bit 0
says the checker made the clause up (a [handler-case]'s landing). *)
let restart =
{ sname = "restart";
fields =
[ "prev", Ptr; "name_id", I32; "name", Ptr; "namelen", I64;
"args", Ptr; "arity", I32; "sig_id", I32; "armed", I32;
"sig", Ptr; "siglen", I64 ] }
"sig", Ptr; "siglen", I64;
"loc", Ptr; "loclen", I64; "report", Ptr; "reportlen", I64;
"flags", I32 ] }
(* What a signal site says about its condition — the runtime's
[flan_condesc]. The first four fields are the prelude's [Error] laid out,
because a handler that matched through a parent link is handed this
rather than the condition. [chain] is the type ids from the condition's
own to its root; [loc] is the signal site. *)
let condesc =
{ sname = "condesc";
fields =
[ "name", Ptr; "namelen", I64; "message", Ptr; "messagelen", I64;
"chain", Ptr; "chainlen", I64; "loc", Ptr; "loclen", I64;
"render", Ptr; "flags", I32 ] }
(* The static description of a function, and the shadow-stack frame that
points at one. Dev builds only (runtime/flan_dev.c). *)
@ -228,8 +245,12 @@ module Rt = struct
[ "name", Ptr; "namelen", I64; "loc", Ptr; "loclen", I64;
"nslots", I32; "slots_fp", I32; "refs_fp", I32 ] }
(* [at] is the call this frame is in: the site of the last Flan call it
made, as a NUL-terminated file:line:col, stored after the arguments and
before the call. Null until the first. *)
let flanframe =
{ sname = "flanframe"; fields = [ "prev", Ptr; "info", Ptr; "slots", Ptr ] }
{ sname = "flanframe";
fields = [ "prev", Ptr; "info", Ptr; "slots", Ptr; "at", Ptr ] }
let align_up n a = (n + a - 1) / a * a
@ -1926,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
@ -1967,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
@ -2005,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 ();
@ -2570,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
@ -2637,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"
@ -3006,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
@ -3023,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
@ -3042,7 +3134,10 @@ 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 [(Ptr ())] or as the first word of a
@ -3128,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) ->
@ -3139,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"
@ -3318,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
@ -4290,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
@ -4705,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
@ -4714,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
@ -4739,8 +4852,8 @@ 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)
@ -4837,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)

14
lib/load.ml
View File

@ -449,8 +449,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
@ -589,7 +590,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)
@ -899,7 +900,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
@ -1279,7 +1281,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 =
@ -1348,7 +1350,7 @@ let rec import ~seen ~open_ ~loc alias dir =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with
| Ast.Defstruct (n, fs) -> Some (n, fs, d.Ast.dloc)
| Ast.Defstruct (n, fs, _) -> Some (n, fs, d.Ast.dloc)
| _ -> None)
ds
in

42
lib/parse.ml
View File

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

54
lib/prelude.ml
View File

@ -43,6 +43,25 @@
the printer it was being forced through was the wrong one. *)
let source = {flan|
;; The root every built-in error descends from. A condition type names its
;; parent where it is declared — (defstruct FileError :parent Error [...]) —
;; and a handler for a type answers every condition below it, so one handler
;; for Error catches any error:
;;
;; (handler-case (run) [(Error [e] (println (.name e)) (println (.message e)))])
;;
;; A handler that matched through a parent is handed the condition's name and
;; a sentence saying what went wrong, not the condition's own fields: the
;; handler's type is the parent's, and the fields are the child's. That is
;; why a parent has exactly these two fields, and why a type declared with a
;; parent and no field vector — a category, (defstruct Category :parent
;; Error) — gets them. The sentence has no values in it; a handler for the
;; condition's own type reads those from its fields. A program's own
;; condition has an empty sentence, since its fields say what it is.
;;
;; (pause) and warnings are not under Error: a breakpoint is not a failure.
(defstruct Error [name string message string])
;; The condition every allocating operation signals when the allocator cannot
;; satisfy a request — spec-memory.md, "Allocation failure". It is here rather
;; than built by the checker because it is an ordinary value struct and the
@ -54,7 +73,7 @@ let source = {flan|
;; allocator's address, which is its identity — the same thing the epoch hangs
;; off — so a handler can tell which region ran out. Rendering happens in the
;; handler or the break loop, where a working allocator is known.
(defstruct StorageExhausted [bytes i64 align i64 allocator i64])
(defstruct StorageExhausted :parent Error [bytes i64 align i64 allocator i64])
;; What an out-of-range index signals. Same shape as StorageExhausted and for
;; the same reasons: fixed numeric fields, no rendered message, nothing that
@ -92,7 +111,7 @@ let source = {flan|
;; being pushed here. That is plan.org's "restarts go at the resync point,
;; once", with allocation and file failure as the named exceptions and this on
;; the default side of the rule.
(defstruct BoundsError [low i64 high i64 length i64])
(defstruct BoundsError :parent Error [low i64 high i64 length i64])
;; What an arithmetic operation with no answer signals. Three situations, and
;; until now none of them had a defined behaviour: a divide or remainder by
@ -116,18 +135,17 @@ let source = {flan|
;; fields are a C struct that has to agree with this one field for field**,
;; the same hand-kept agreement flan_bounds_cond keeps with BoundsError.
;;
;; `op` is a small integer and not a keyword, exactly as FileError's `op` is,
;; because the field is filled in from C and a keyword is not a thing that
;; exists there. The codes:
;; `op` is an ArithOp, an i32 at run time, which is what lets the runtime fill
;; it in from C; the members' numbers are flan_rt.c's FLAN_ARITH_* codes:
;;
;; 0 (/ a 0) 1 (% a 0)
;; 2 (/ min -1) 3 (% min -1)
;; 4 a float to integer cast whose value does not fit
;; 5 a float to integer cast of NaN
;; 6 a float to integer cast of an infinity
;; :div-zero (/ a 0) :rem-zero (% a 0)
;; :div-overflow (/ min -1) :rem-overflow (% min -1)
;; :cast-range a float to integer cast whose value does not fit
;; :cast-nan a float to integer cast of NaN
;; :cast-inf a float to integer cast of an infinity
;;
;; `lhs` and `rhs` are the two operands for codes 0 through 3 and the
;; destination type's representable range for codes 4 through 6 — the violated condition
;; `lhs` and `rhs` are the two operands for the first four and the
;; destination type's representable range for the casts — the violated condition
;; written as a range, which is what flan_slice_promise_error already does
;; with BoundsError's fields. Two meanings over two fields rather than two
;; condition types, so that a handler writes one clause and not five. The
@ -152,7 +170,11 @@ let source = {flan|
;; division by zero is the restart the program already established, a frame
;; loop's `continue`, which is reachable from a handler without anything being
;; pushed here.
(defstruct ArithError [op i32 lhs i64 rhs i64])
(defenum ArithOp
[div-zero 0 rem-zero 1 div-overflow 2 rem-overflow 3
cast-range 4 cast-nan 5 cast-inf 6])
(defstruct ArithError :parent Error [op ArithOp lhs i64 rhs i64])
;; A call that was compiled against one signature, reaching a function that
;; now has another. It exists only in a dev build: there every call to a Flan
@ -173,7 +195,7 @@ let source = {flan|
;; agreement flan_bounds_cond keeps with BoundsError. No restart is
;; established at the call, BoundsError's decision for BoundsError's reason:
;; nothing a handler supplies makes the old arguments fit the new body.
(defstruct StaleCall [callee string compiled string current string])
(defstruct StaleCall :parent Error [callee string compiled string current string])
;; What a generic function signals when no method answers. `generic` is the
;; name written at the defgeneric or defmulti, and `value` is what the
@ -195,7 +217,7 @@ let source = {flan|
;;
;; No restart is established at the miss, which is BoundsError's decision
;; taken for BoundsError's reason -- see the note above it.
(defstruct NoMethod [generic string value dyn])
(defstruct NoMethod :parent Error [generic string value dyn])
;; A breakpoint. (pause) stops the program where it stands and hands it to the
;; break loop, with the whole stack under it readable — C-c C-b lists the
@ -1959,7 +1981,7 @@ let source = {flan|
;; parent link, not class inheritance", decides on is the
;; answer to that, and it is not built; when it is, these reasons can become
;; types without any call site changing.
(defstruct FileError [path string op i32 reason i32])
(defstruct FileError :parent Error [path string op i32 reason i32])
(defconst file-op-read i32 0)
(defconst file-op-write i32 1)

2
lib/reach.ml
View File

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

152
lib/session.ml
View File

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

2
lib/shim.ml
View File

@ -138,7 +138,7 @@ let scan (decls : Ast.decl list) =
List.iter
(fun (d : Ast.decl) ->
match d.Ast.d with
| Ast.Defstruct (n, fs) -> Hashtbl.replace env.structs n fs
| Ast.Defstruct (n, fs, _) -> Hashtbl.replace env.structs n fs
| Ast.Defenum (n, _) -> Hashtbl.replace env.enums n ()
| Ast.Defdata (n, _) -> Hashtbl.replace env.datas n ()
| Ast.Defunion (n, _) -> Hashtbl.replace env.unions n ()

26
lib/tast.ml
View File

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

107
lib/x86.ml
View File

@ -1059,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
@ -1859,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)
@ -1878,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
@ -2017,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;
@ -2215,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, _) ->
@ -2668,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;
@ -2978,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
@ -3005,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
@ -3052,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
@ -3088,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
@ -3107,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
@ -4102,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

14
runtime/flan_dev.c
View File

@ -1046,6 +1046,12 @@ typedef struct flan_frame {
* with no named slot, and in a release build there is no frame at all.
* Read through [flan_dev_frame_slot], which is where the bound is checked. */
void **slots;
/* The call this frame is in: the site of the last Flan call it made,
* NUL-terminated, stored after the arguments and before the call. NULL
* until its first. Stale in the innermost frame, which may have returned
* from that call since — which is why [flan_dev_frame_at_loc] is read for
* the outer frames only. */
const char *at;
} flan_frame;
/* The compiler names this symbol directly. A redefinition module reaches it
@ -1100,6 +1106,14 @@ const char *flan_dev_frame_loc(const void *frame, int64_t *len) {
return f->info->loc;
}
/* Where the frame is: the call it is in, or NULL when it has made none. */
const char *flan_dev_frame_at_loc(const void *frame, int64_t *len) {
const flan_frame *f = frame;
if (f == NULL || f->at == NULL) { *len = 0; return NULL; }
*len = (int64_t)strlen(f->at);
return f->at;
}
int32_t flan_dev_frame_nslots(const void *frame) {
const flan_frame *f = frame;
return (f == NULL || f->info == NULL) ? 0 : f->info->nslots;

142
runtime/flan_dyn.c
View File

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

664
runtime/flan_rt.c
View File

@ -11,6 +11,7 @@
* on x86-64 and silently does not on wasm32.
*/
#include <stdarg.h>
#include <stdint.h>
#include <stddef.h>
#include <stdio.h>
@ -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.
@ -586,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();
}
@ -699,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) {
@ -732,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;
}
@ -765,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();
}
@ -788,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);
}
@ -803,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);
}
@ -818,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);
}
@ -833,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();
}
@ -893,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);
}
@ -966,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);
}
@ -1035,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:
@ -1056,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 ─────────────────────────
@ -1159,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. */
@ -1168,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();
}
@ -1684,6 +2032,12 @@ flan_allocator *flan_context_temp(void) {
return flan_ctx_tmp;
}
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. */
@ -1821,10 +2175,9 @@ flan_allocator *flan_arena_new(int64_t cap) {
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);
}
@ -1890,11 +2243,9 @@ flan_allocator *flan_alloc_use(const flan_alloc_value *v, const uint8_t *loc,
}
_Noreturn static void flan_destroyed_fail(const uint8_t *loc, int64_t loclen) {
rt_flush_out();
fprintf(stderr,
"%.*s: this allocator was destroyed by arena-destroy, so nothing "
"can be allocated from it or released through it\n",
(int)loclen, (const char *)loc);
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);
}
@ -1937,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);
}
@ -2323,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);
}
@ -2341,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;

7
spec-conditions.md
View File

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

17
test/agent_hooks.c
View File

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

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

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

14
test/programs/break.flan
View File

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

57
test/test_acceptance.ml
View File

@ -3146,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

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

238
test/test_dev.ml
View File

@ -925,6 +925,19 @@ let () =
if names <> [ "retry"; "use-placeholder" ] then
fail "restarts on offer: %s" (String.concat ", " names)
| _ -> fail "break did not list the restarts");
(* Beside each name, in the same order: its :report sentence and
where its clause is written. [retry] wrote no report. *)
(match Wire.field r "details" with
| Some { Form.v = Form.List [ d0; d1 ]; _ } ->
let str = Wire.string_field in
if str d0 "report" <> Some "" || str d1 "report" <> Some "Answer -1"
then fail "the restarts' reports did not arrive";
(match str d1 "at" with
| Some at when contains_sub at "dev-break.flan:18:" -> ()
| at ->
fail "use-placeholder's clause is at %s"
(Option.value at ~default:"nowhere"))
| _ -> fail "break did not carry a detail per restart");
(* Where it is, which is the other half of what a stopped program can
be asked. The shadow stack is dev-only and the daemon owns the
@ -955,14 +968,17 @@ let () =
(Option.value ~default:(status r) (Wire.string_field r "message"))
else begin
match frames r with
| [ ("fetch", floc, "program"); ("main", _, "program") ] ->
| [ ("fetch", floc, "program"); ("main", mloc, "program") ] ->
(* Absolute and pointing into the program's own source, for the
same reason [defs] is: an editor is not in this process's
working directory. It comes off the frame, not off this end's
session, so a redefined body reports where the *installed* one
is written. *)
if String.length floc = 0 || floc.[0] <> '/' then
fail "a frame's location is not absolute: %s" floc
fail "a frame's location is not absolute: %s" floc;
(* And an outer frame is at the call it is in, not at its defn. *)
if not (contains_sub mloc "dev-break.flan:44:10") then
fail "main's frame is at %s, not at its call to fetch" mloc
| fs ->
fail "backtrace of a stopped program: %s"
(String.concat ", "
@ -1383,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 ", "
@ -1403,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"
@ -1411,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
@ -1660,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"
@ -1674,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. *)
@ -1792,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 =
@ -1800,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;
@ -1855,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 =
@ -2027,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
@ -5937,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 ", "
@ -7718,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

46
test/test_flan.ml
View File

@ -3702,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"
@ -4658,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
@ -4755,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
@ -4927,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"

195
vendor/agent/flan_agent.c vendored
View File

@ -322,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);
@ -335,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);
@ -407,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
@ -461,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;
@ -542,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 */
@ -578,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,
@ -609,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
@ -661,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" */
@ -698,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
@ -722,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;
@ -730,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;
@ -751,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;
@ -771,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;
@ -929,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, "
@ -944,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)"
@ -1159,7 +1301,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);
/* 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
@ -1323,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) {
@ -1382,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();
@ -1425,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");
@ -1560,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
@ -1608,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);