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

A handler for a parent reads the condition's own name and message or the condition printed with its values, kept in the handler-case's own frame across the unwind, and a frame re-entered through a signal or a C call names where it is

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-25 13:16:35 +07:00
parent e75a66e463
commit d864818956
14 changed files with 578 additions and 158 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

140
lib/check.ml
View File

@ -2429,22 +2429,6 @@ let condition_chain env name =
in
go [] name
(* The sentence a handler for [Error] reads as the message, for the built-in
conditions the compiler itself signals. It has no values in it, because a
handler-case carries it past the frame that signalled; the fields carry
those. A program's own condition has none: its fields say what it is. The
runtime's own two, BoundsError and ArithError, are written in flan_rt.c. *)
let condition_message = function
| "StorageExhausted" -> "an allocator could not provide the memory asked of it"
| "FileError" -> "a file operation failed"
| "NoMethod" -> "no method answers this call"
| _ -> ""
let condition_desc env name =
{ Tast.cname = name;
cchain = List.map type_id (condition_chain env name);
cmessage = condition_message 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
@ -3172,6 +3156,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 ty) in
let bslice = Types.Slice (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 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 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 sty) (Tast.Local p))) in
@ -3971,7 +4019,7 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr =
| Ast.Serror -> (Types.Never, Tast.Serror)
in
expect ctx loc ~want
(mk loc ty (Tast.Signal (kind, condition_desc ctx.env name, c)))
(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
@ -4719,7 +4767,12 @@ and restart_clauses ctx ?want ?(hidden = false) ~what loc (tbody : Tast.expr)
rparams = params; rsig = sg; rsig_id = type_id sg; rbody = [ b ];
rloc = c.Ast.rloc;
rreport = Option.value c.Ast.rreport ~default:"";
rhidden = hidden })
rhidden = hidden;
rkeep =
hidden
&& (match params with
| [ (_, Types.Named n) ] -> error_shaped ctx.env n
| _ -> false) })
clauses
in
let ty = match !ty with Some t -> t | None -> Types.Never in
@ -6965,7 +7018,7 @@ and alloc_guard ctx loc (attempt : Tast.expr) =
in
let signal =
mk loc Types.Never
(Tast.Signal (Tast.Serror, condition_desc ctx.env "StorageExhausted",
(Tast.Signal (Tast.Serror, condition_desc ctx loc "StorageExhausted",
cond))
in
let attempt_then_signal =
@ -6982,7 +7035,8 @@ and alloc_guard ctx loc (attempt : Tast.expr) =
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 ];
rloc = loc; rreport = "Try the allocation again"; rhidden = false }
rloc = loc; rreport = "Try the allocation again"; rhidden = false;
rkeep = false }
in
let body =
mk loc Types.Unit (Tast.RestartCase ([ clause ], attempt_then_signal))
@ -7036,7 +7090,7 @@ and file_guard ctx loc ~path_slot ~op mk_steps =
in
let signal () =
mk loc Types.Never
(Tast.Signal (Tast.Serror, condition_desc ctx.env "FileError", cond))
(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]
@ -7053,7 +7107,7 @@ and file_guard ctx loc ~path_slot ~op mk_steps =
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 ];
rloc = loc; rreport = report; rhidden = false }
rloc = loc; rreport = report; rhidden = false; rkeep = false }
in
let body =
mk loc Types.Unit
@ -10832,29 +10886,37 @@ let rec defconst_type_shaped env gname (v : Ast.expr) =
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 =
let shaped 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
in
Hashtbl.iter
(fun child parent ->
let loc =
Option.value (Hashtbl.find_opt env.locs child) ~default:Loc.unknown
in
if not (shaped parent) then
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 %s has fields of its own. A \
handler for a parent is handed the name and the sentence of \
whatever it caught, not that condition's fields, so a parent has \
exactly [name string message string]. Give %s its own category \
with no field vector, (defstruct Category :parent Error), and \
name that as the parent"
child parent parent child;
"%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

80
lib/emit.ml
View File

@ -176,6 +176,10 @@ let globalptr n = "@" ^ quoted (Mangle.globalptr n)
let abi_marker = "flan.abi.llvm"
let abi_marker_sym = "@" ^ quoted abi_marker
(* The bytes a condition's message may take, flan_rt.c's FLAN_MESSAGE_MAX:
the buffer a handler-case landing owns for the message it is handed. *)
let message_max = 512
(* ── The runtime's own structs ───────────────────────────────────────── *)
(* Four structs that are not Flan types: they are declared in C, in
@ -223,7 +227,7 @@ module Rt = struct
"args", Ptr; "arity", I32; "sig_id", I32; "armed", I32;
"sig", Ptr; "siglen", I64;
"loc", Ptr; "loclen", I64; "report", Ptr; "reportlen", I64;
"flags", I32 ] }
"flags", I32; "keep", Ptr; "keepcap", I64 ] }
(* What a signal site says about its condition — the runtime's
[flan_condesc]. The first four fields are the prelude's [Error] laid out,
@ -234,7 +238,8 @@ module Rt = struct
{ sname = "condesc";
fields =
[ "name", Ptr; "namelen", I64; "message", Ptr; "messagelen", I64;
"chain", Ptr; "chainlen", I64; "loc", Ptr; "loclen", 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). *)
@ -1741,7 +1746,8 @@ let fninfo m (fn : Tast.fn) ~nslots =
site. *)
let condesc m (d : Tast.condesc) loc =
let nid, nlen = string_bytes m d.Tast.cname in
let mid, mlen = string_bytes m d.Tast.cmessage 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;
@ -1757,7 +1763,9 @@ let condesc m (d : Tast.condesc) loc =
(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 ]));
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 ───────────────────────────────────────────────────── *)
@ -1798,10 +1806,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 ();
@ -2331,7 +2359,11 @@ 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 ~at:e.Tast.loc f e.Tast.ty callee args
| Tast.Do body -> block f body
@ -2401,8 +2433,10 @@ and value_at f (e : Tast.expr) : string =
| Tast.Signal (Tast.Ssignal, d, c) ->
let p = addr_rooted f c in
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
@ -2411,6 +2445,7 @@ and value_at f (e : Tast.expr) : string =
| Tast.Signal (Tast.Serror, d, c) ->
let p = addr_rooted f c in
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";
@ -2730,18 +2765,6 @@ and body_of f ?loc flan =
p
end
(* A dev build's frame records the call it is making, after the arguments —
which may make calls of their own — and before the call itself, so a
backtrace names the call each caller is in and two calls to one function
from one caller are two different lines. One store; nothing in a release
build. *)
and 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
(* The signature word, at a call site through a cell: the one the cell holds
against the one this site was compiled with. Equal is the whole of the fast
path — a load, a compare, a branch not taken.
@ -2784,7 +2807,9 @@ and call f ?loc ret flan args =
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
@ -2816,7 +2841,9 @@ and call_ptr ?at f ret callee 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) at;
call_through f ?env ret code vs
let r = call_through f ?env ret code vs in
if at <> None then clear_call f;
r
(* The code address behind one of the three [fnref]s, which is the same string
whether it is wanted as a bare [Alloc] pointer or as the first word of a
@ -2902,7 +2929,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) ->
@ -2913,6 +2940,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"
@ -3100,6 +3128,16 @@ and emit_restart_case f ty clauses body =
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");
(* See [Tast.rclause.rkeep]; the size is flan_rt.c's
FLAN_MESSAGE_MAX. *)
if c.Tast.rkeep then begin
let kb = alloca_raw f (Printf.sprintf "[%d x i8]" message_max) in
ins f "store ptr %s, ptr %s" kb (restart_field f slot "keep");
ins f "store i64 %d, ptr %s" message_max (restart_field f slot "keepcap")
end else begin
ins f "store ptr null, ptr %s" (restart_field f slot "keep");
ins f "store i64 0, ptr %s" (restart_field f slot "keepcap")
end;
let args =
if c.Tast.rparams = [] then None
else begin
@ -4594,6 +4632,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)

5
lib/parse.ml
View File

@ -1326,9 +1326,10 @@ let rec decl (f : Form.t) : Ast.decl =
(match args with
| [ n; { v = Vec fs; _ } ] ->
mk (Ast.Defstruct (dname n, fields f fs, None))
| [ n; { v = Kw "parent"; _ }; p; { v = Vec fs; _ } ] ->
| [ n; { v = Kw "parent"; _ }; p; { v = Vec fs; _ } ] when fs <> [] ->
mk (Ast.Defstruct (dname n, fields f fs, Some (texpr p)))
| [ n; { v = Kw "parent"; _ }; 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 }

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. *)
| _ -> ())

29
lib/session.ml
View File

@ -1177,6 +1177,23 @@ let eval ?(origin = "<eval>") ?pause ?(running = true) t src : change =
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 = List.length t.env.Check.lifted
let claim_lifted t mark thunk =
let n = List.length t.env.Check.lifted - mark in
List.rev
(List.filter_map
(fun (f : Tast.fn) ->
if f.Tast.fparent = Some "<none>" then
Some { f with Tast.fparent = Some thunk }
else None)
(List.filteri (fun i _ -> i < n) t.env.Check.lifted))
type emitter = { ename : string; ety : Types.t }
let emit_bytes = { ename = "flan/dev-emit"; ety = Types.Slice (Types.Int Types.U8) }
@ -2043,6 +2060,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) ->
@ -2115,7 +2133,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 =
@ -2164,6 +2184,7 @@ let arm_restart ?(origin = "<restart>") t ~index ~(params : Types.t list)
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 ->
@ -2242,7 +2263,8 @@ let arm_restart ?(origin = "<restart>") t ~index ~(params : Types.t list)
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 =
@ -2384,6 +2406,7 @@ let eval_expr ?(origin = "<eval>") ?(pause = false) t src : change =
below — without this the thunk calls a symbol the module never defines
and the host has no cell for. *)
let mark = Check.instance_mark t.env in
let lmark = lifted_mark t in
let checked, base, bnames = Check.expression t.env parsed in
let fresh = Check.instances_since t.env mark in
(* The thunk's frame starts at whatever [Check.expression] needed and grows
@ -2423,7 +2446,7 @@ let eval_expr ?(origin = "<eval>") ?(pause = false) t src : change =
for every expression ever typed. *)
let program =
{ t.program with
Tast.fns = t.program.Tast.fns @ fresh @ [ thunk ];
Tast.fns = t.program.Tast.fns @ fresh @ claim_lifted t lmark name @ [ thunk ];
externs = t.program.Tast.externs @ externs }
in
let ir =

19
lib/tast.ml
View File

@ -277,9 +277,17 @@ 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 the sentence a
handler for a parent reads as the message. *)
and condesc = { cname : string; cchain : int list; cmessage : string }
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
@ -315,7 +323,10 @@ and hframe = { htype : int; hfn : string; henv : expr option }
and rclause =
{ rname_id : int; rname : string; rparams : (int * Types.t) list;
rsig : string; rsig_id : int; rbody : expr list;
rloc : Loc.t; rreport : string; rhidden : bool }
rloc : Loc.t; rreport : string; rhidden : bool;
(* A handler-case landing whose condition may arrive as a parent's view:
the frame owns a buffer the message is copied into before the unwind. *)
rkeep : 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 }

73
lib/x86.ml
View File

@ -1073,7 +1073,7 @@ let fi_cstring f s =
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 d.Tast.cmessage 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
@ -1087,9 +1087,11 @@ let condesc f (d : Tast.condesc) loc =
l
(Emit.Rt.asm_init Emit.Rt.condesc
[ nlbl; string_of_int (String.length d.Tast.cname); mlbl;
string_of_int (String.length d.Tast.cmessage); clbl;
"0"; clbl;
string_of_int (List.length d.Tast.cchain); llbl;
string_of_int llen ]));
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
@ -1864,7 +1866,7 @@ 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. *)
@ -2028,8 +2030,10 @@ and lower_at f (e : Tast.expr) (dst : loc) : unit =
addr_into f ~reg:rsi l;
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
@ -2040,6 +2044,7 @@ and lower_at f (e : Tast.expr) (dst : loc) : unit =
addr_into f ~reg:rsi l;
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_error";
guard f;
@ -2197,8 +2202,15 @@ and emit_restart_case f clauses body dst t =
(c, slot, args))
clauses
in
let keeps =
List.map
(fun ((c : Tast.rclause), slot, _) ->
slot, if c.Tast.rkeep then Some (alloc f Emit.message_max 8) else None)
frames
in
List.iter
(fun ((c : Tast.rclause), slot, args) ->
let keep = List.assoc slot keeps in
imm_into f ~reg:rax (Int64.of_int c.Tast.rname_id);
store_int f.b ~src:rax ~mm:(Frame (slot + r_name_id)) ~size:4;
(* The name itself, beside the hash. A hash is all that matching needs,
@ -2225,6 +2237,17 @@ and emit_restart_case f clauses body dst t =
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;
(* [Tast.rclause.rkeep]: the landing's own message buffer. *)
(match keep with
| Some kb ->
lea f.b ~dst:rax ~mm:(Frame kb);
store_int f.b ~src:rax ~mm:(Frame (slot + r_field "keep")) ~size:8;
imm_into f ~reg:rax (Int64.of_int Emit.message_max);
store_int f.b ~src:rax ~mm:(Frame (slot + r_field "keepcap")) ~size:8
| None ->
xor_rr f.b ~dst:rax ~src:rax;
store_int f.b ~src:rax ~mm:(Frame (slot + r_field "keep")) ~size:8;
store_int f.b ~src:rax ~mm:(Frame (slot + r_field "keepcap")) ~size:8);
(match args with
| None -> ()
| Some (buf, _) ->
@ -2678,6 +2701,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;
@ -3016,14 +3040,8 @@ and call_flan f ?env ?at ~target ~args ~rty dst =
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, and through [r11],
which no argument is in. *)
(match f.dframe, at with
| Some fr, Some at ->
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
| _ -> ());
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
@ -3071,13 +3089,33 @@ and call_flan f ?env ?at ~target ~args ~rty dst =
else if (not (is_void rty)) && Emit.dyn_offsets 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
@ -3107,7 +3145,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
@ -3126,10 +3164,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.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

4
runtime/flan_dyn.c
View File

@ -665,6 +665,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

230
runtime/flan_rt.c
View File

@ -69,19 +69,15 @@ void flan_handler_pop(flan_handler *h) {
* at a constant; the runtime's own conditions build one on the failing
* frame's stack.
*
* The first four fields are laid out as the prelude's
* (defstruct Error [name string message string]), and that is the point of
* their order: a handler that matched through a parent link is handed *this*
* rather than the condition, because the condition's layout is its own type's
* and the handler's type is an ancestor's. A parent is a type with exactly
* Error's fields — the checker refuses any other — so every such handler reads
* the name and the sentence and nothing it could misread.
*
* [message] is a sentence with no values in it, and static: a handler-case
* copies the view out before the signalling frame is unwound, so the bytes it
* points at must outlive that frame. The sentence with the values in it is the
* break loop's, below. [chain] is the type ids from the condition's own type
* to its root, own first. */
* 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;
@ -91,8 +87,72 @@ typedef struct flan_condesc {
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 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 a message takes, here and in the buffer a handler-case landing
* owns (Emit.message_max). A longer one is cut and ends in "…", which says it
* was cut rather than passing for the whole of it. */
#define FLAN_MESSAGE_MAX 512
/* Where [render] prints: the buffer of the signal asking, set around the one
* synchronous call. A printer only formats, so nothing nests inside it. */
static char *msg_out;
static int64_t msg_len;
static int msg_cut;
static void msg_append(const uint8_t *p, int64_t n) {
static const char ell[] = "\xe2\x80\xa6";
if (msg_out == NULL || msg_cut || n <= 0) return;
if (msg_len + n > FLAN_MESSAGE_MAX - 4) {
int64_t room = FLAN_MESSAGE_MAX - 4 - msg_len;
if (room > 0) { memcpy(msg_out + msg_len, p, (size_t)room); msg_len += room; }
memcpy(msg_out + msg_len, ell, 3);
msg_len += 3;
msg_cut = 1;
return;
}
memcpy(msg_out + msg_len, p, (size_t)n);
msg_len += n;
}
void flan_msg_emit(const uint8_t *p, int64_t n) { msg_append(p, n); }
/* The view of [condition] for a parent's handler, its message in [buf],
* which the caller owns and which lives as long as the handler runs. */
static void rt_view(const flan_condesc *d, void *condition, char *buf,
flan_view *v) {
if (d->flags & FLAN_CONDESC_SELF) {
*v = *(const flan_view *)condition;
return;
}
v->name = d->name;
v->namelen = d->namelen;
v->message = (const uint8_t *)buf;
msg_out = buf;
msg_len = 0;
msg_cut = 0;
if (d->messagelen > 0)
msg_append(d->message, d->messagelen);
else if (d->render != NULL) {
void *x = NULL;
d->render(condition, &x);
}
v->messagelen = msg_len;
msg_out = NULL;
}
/* 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) {
@ -120,17 +180,28 @@ static int flan_handles(uint32_t type_id, const flan_condesc *d) {
* 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. */
static void rt_keep(void *target, const flan_view *v);
void flan_signal(const flan_condesc *d, void *condition, void *xfer) {
flan_handler *saved = handlers;
/* The parent's view, made the first time a parent's handler needs it and
* living in this frame for as long as the walk. Its own, so a signal nested
* inside a handler cannot write over the message the outer one is reading. */
char buf[FLAN_MESSAGE_MAX];
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, buf, &v); viewed = 1; }
handlers = h->prev;
/* A parent's handler reads the name and the sentence; see
* flan_condesc. */
h->fn(how == 1 ? condition : (void *)d, xfer, h->env);
h->fn(how == 1 ? condition : (void *)&v, xfer, h->env);
handlers = saved;
if (*(void **)xfer != NULL) return;
if (*(void **)xfer != NULL) {
if (how == 2 && !(d->flags & FLAN_CONDESC_SELF))
rt_keep(*(void **)xfer, &v);
return;
}
}
}
}
@ -168,6 +239,10 @@ typedef struct flan_restart {
const uint8_t *report;
int64_t reportlen;
int32_t flags;
/* A handler-case landing's own buffer for the message of a condition that
* arrives as a parent's view, or NULL; see [rt_keep]. */
char *keep;
int64_t keepcap;
} flan_restart;
/* A clause the checker made up rather than one anybody wrote: a
@ -191,6 +266,25 @@ void flan_restart_push(flan_restart *r) {
void flan_restart_pop(flan_restart *r) { restarts = r->prev; }
/* A parent's handler in a handler-case has just aimed the transfer at the
* form's landing, with the view copied into the landing's argument buffer —
* and the view's message is in [flan_signal]'s frame, which the unwind is
* about to take. So the bytes go into the landing's own buffer now, while
* both frames are alive, and the copy in the argument buffer is pointed at
* them. Anything else the transfer is aimed at owns no such buffer. */
static void rt_keep(void *target, const flan_view *v) {
flan_restart *r = (flan_restart *)target;
flan_view *arg;
int64_t n = v->messagelen;
if (r->keep == NULL || r->args == NULL || !r->armed) return;
arg = (flan_view *)r->args;
if (arg->message != v->message) return;
if (n > r->keepcap) n = r->keepcap;
memcpy(r->keep, v->message, (size_t)n);
arg->message = (const uint8_t *)r->keep;
arg->messagelen = n;
}
/* 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. */
@ -808,6 +902,14 @@ static void rt_sentence(const char *fmt, ...) {
va_end(ap);
}
/* The sentence just formatted, NUL-terminated into a caller's buffer. */
static void rt_sentence_copy(char *out) {
int64_t n = flan_break_sentence_len;
if (n > FLAN_MESSAGE_MAX - 1) n = FLAN_MESSAGE_MAX - 1;
memcpy(out, flan_break_sentence, (size_t)n);
out[n] = 0;
}
static void rt_break_clear(void) {
flan_break_site = NULL;
flan_break_site_len = 0;
@ -926,20 +1028,28 @@ void flan_error(const flan_condesc *d, void *condition, void *xfer) {
* 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. */
if (flan_break_hook != NULL) {
flan_break_site = d->loclen > 0 ? d->loc : NULL;
flan_break_site_len = d->loclen;
rt_sentence("%.*s", (int)d->messagelen, (const char *)d->message);
flan_break_hook(d->name, d->namelen, condition, xfer);
rt_break_clear();
if (*(void **)xfer != NULL) return;
{
/* 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. */
char buf[FLAN_MESSAGE_MAX];
flan_view v;
rt_view(d, condition, buf, &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);
}
if (d->messagelen > 0)
rt_sentence("unhandled %.*s: %.*s", (int)d->namelen,
(const char *)d->name, (int)d->messagelen,
(const char *)d->message);
else
rt_sentence("unhandled %.*s", (int)d->namelen, (const char *)d->name);
rt_print_sentence(d->loc, d->loclen);
rt_die();
}
@ -1058,10 +1168,16 @@ static const uint8_t flan_error_name[] = "Error";
#define FLAN_ERROR_NAMELEN 5
/* A descriptor for one of the runtime's own conditions, on the caller's
* stack; [chain] is the caller's too, two entries long. */
* stack; [chain] is the caller's too, two entries long. [message] is the
* sentence with its values, which the caller has formatted into a buffer of
* its own frame before signalling: a parent's handler reads it, and so does
* the break loop after the walk, when a handler may have written over the
* shared one. */
static void rt_condesc(flan_condesc *d, uint32_t chain[2], const uint8_t *name,
int64_t namelen, const char *message,
const uint8_t *loc, int64_t loclen) {
d->render = NULL;
d->flags = 0;
chain[0] = flan_name_id(name, namelen);
chain[1] = flan_name_id(flan_error_name, FLAN_ERROR_NAMELEN);
d->name = name;
@ -1081,6 +1197,7 @@ static void rt_condesc(flan_condesc *d, uint32_t chain[2], const uint8_t *name,
* 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) {
rt_sentence("%.*s", (int)d->messagelen, (const char *)d->message);
if (flan_break_hook != NULL) {
flan_break_site = d->loc;
flan_break_site_len = d->loclen;
@ -1100,16 +1217,18 @@ static int flan_bounds_signal(const uint8_t *loc, int64_t loclen, void *xfer,
flan_bounds_cond c;
flan_condesc d;
uint32_t chain[2];
char said[FLAN_MESSAGE_MAX];
c.low = low;
c.high = high;
c.length = len;
rt_condesc(&d, chain, flan_bounds_name, FLAN_BOUNDS_NAMELEN,
"an index or a range is out of bounds", loc, loclen);
flan_signal(&d, &c, xfer);
if (*(void **)xfer != NULL) return 1;
if (kind == BOUNDS_AT) bounds_sentence(low, len);
else if (kind == BOUNDS_SLICE) slice_sentence(low, high, len);
else promise_sentence(high);
rt_sentence_copy(said);
rt_condesc(&d, chain, flan_bounds_name, FLAN_BOUNDS_NAMELEN, said, loc,
loclen);
flan_signal(&d, &c, xfer);
if (*(void **)xfer != NULL) return 1;
return rt_error_break(&d, &c, xfer);
}
@ -1265,28 +1384,6 @@ static void arith_sentence(int32_t op, int64_t lhs, int64_t rhs) {
}
}
/* The same, with no values in it: what a handler for Error reads as the
* message. Static, because a handler-case carries it past the frame that
* signalled. */
static const char *arith_message(int32_t op) {
switch (op) {
case FLAN_ARITH_DIV_ZERO: return "divide by zero";
case FLAN_ARITH_REM_ZERO: return "remainder by zero";
case FLAN_ARITH_DIV_OVERFLOW:
return "a division overflows: the quotient is one past the largest value "
"the type holds";
case FLAN_ARITH_REM_OVERFLOW:
return "a remainder overflows: the quotient is one past the largest value "
"the type holds";
case FLAN_ARITH_CAST_NAN:
return "a NaN has no integer value to cast to";
case FLAN_ARITH_CAST_INF:
return "an infinity has no integer value to cast to";
default:
return "a value does not fit the integer type it is cast to";
}
}
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;
@ -1295,11 +1392,13 @@ void flan_arith_error(const uint8_t *loc, int64_t loclen, int32_t op,
c.op = op;
c.lhs = lhs;
c.rhs = rhs;
rt_condesc(&d, chain, flan_arith_name, FLAN_ARITH_NAMELEN, arith_message(op),
loc, loclen);
char said[FLAN_MESSAGE_MAX];
arith_sentence(op, lhs, rhs);
rt_sentence_copy(said);
rt_condesc(&d, chain, flan_arith_name, FLAN_ARITH_NAMELEN, said, loc,
loclen);
flan_signal(&d, &c, xfer);
if (*(void **)xfer != NULL) return;
arith_sentence(op, lhs, rhs);
if (rt_error_break(&d, &c, xfer)) return;
rt_print_sentence(loc, loclen);
rt_die();
@ -1361,17 +1460,18 @@ void flan_stale_call(const char *site, const char *callee, const char *want,
flan_slice where = flan_stale_copy(site);
flan_condesc d;
uint32_t chain[2];
rt_condesc(&d, chain, flan_stale_name, FLAN_STALE_NAMELEN,
"a call was compiled for a signature its function no longer has",
where.ptr, where.len);
flan_signal(&d, &c, xfer);
if (*(void **)xfer != NULL) return;
char said[FLAN_MESSAGE_MAX];
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);
rt_sentence_copy(said);
rt_condesc(&d, chain, flan_stale_name, FLAN_STALE_NAMELEN, said, where.ptr,
where.len);
flan_signal(&d, &c, xfer);
if (*(void **)xfer != NULL) return;
if (rt_error_break(&d, &c, xfer)) return;
rt_print_sentence(where.ptr, where.len);
rt_die();

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)

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)

23
test/test_acceptance.ml
View File

@ -2905,14 +2905,13 @@ let () =
"programs/arith-condition.flan" arith_cond_out;
(* A handler for a parent answers every condition below it, and is handed
the name and the sentence rather than the fields. The empty line is
DiskFull's sentence: a program's own condition says what it is in its
fields. *)
the name and the message — the condition with its values — rather than
its fields. *)
let parents_out =
"ArithError\ndivide by zero\n-1\n\
BoundsError\nan index or a range is out of bounds\n-1\n\
DiskFull\n\n-1\n3\nDiskFull\n-2\n7\n\
true\ndivide by zero\n-4\n1\n"
"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;
@ -2920,6 +2919,16 @@ let () =
"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;
(* 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

62
test/test_dev.ml
View File

@ -7687,6 +7687,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

12
test/test_flan.ml
View File

@ -3416,9 +3416,17 @@ let () =
(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"
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:"Worse names Oops as its parent, and Oops has fields of its own";
~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";