diff --git a/bin/main.ml b/bin/main.ml index 032fe0e..1b3193e 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -195,9 +195,17 @@ let llvm_flag = "--llvm" assembler is worth measuring rather than asserting. *) let no_annotate_flag = "--no-annotate" +(* "This program carries no collector", and the way it is kept is a refusal + rather than a different lowering: every dyn left in the program is named, + with its location, and nothing downstream is told the flag was given. See + [Check.no_gc], which is a pass between checking and emission and answers + unit — an annotated program's output is byte for byte what it is without + the flag, and that is the property the flag is worth having for. *) +let no_gc_flag = "--no-gc" + let flags = [ no_checks_flag; dev_flag; debug_flag; sanitize_flag; two_process_flag; - x86_flag; llvm_flag; no_annotate_flag ] + x86_flag; llvm_flag; no_annotate_flag; no_gc_flag ] (* Which backend a command got, from the two flags and the default it would have taken. One function because there is one rule, and the only thing that @@ -616,8 +624,12 @@ let () = with_errors path (fun () -> let l = load path in let pnames = if debug then param_names l else [] in - Flan.Check.program_all l.decls - |> Flan.Emit.program ~checks ~dev ~debug ~pnames ~sanitize + let p = Flan.Check.program_all l.decls in + (* Between checking and emission, and it hands the very same program + on: the flag is a question asked of what was checked, never a + parameter of what is emitted. *) + if List.mem no_gc_flag args then Flan.Check.no_gc p; + Flan.Emit.program ~checks ~dev ~debug ~pnames ~sanitize p |> print_string)) files | _ :: "build" :: path :: rest -> @@ -654,12 +666,17 @@ let () = prerr_endline "usage: flan build [-o out] [-O0|-O1|-O2|-O3] \ [--no-bounds-checks] \ - [--dev] [--debug] [--sanitize] [--target=wasm32-wasi|web|js]"; + [--dev] [--debug] [--sanitize] [--no-gc] [--target=wasm32-wasi|web|js]"; exit 2 in with_errors path (fun () -> let l = load path in let p = Flan.Check.program_all l.decls in + (* Before reachability rather than after: a dyn in a function nothing + calls is still a dyn somebody wrote, and a refusal that depended on + what [main] happened to reach would come and go as the program was + edited elsewhere. *) + if List.mem no_gc_flag rest then Flan.Check.no_gc p; (* The link follows the program, not the import list: a package nothing reachable calls into contributes no C and no linker argument, and its functions are not emitted either. That is what lets one file import diff --git a/docs/handoffs/HANDOFF-dyn-m1.md b/docs/handoffs/HANDOFF-dyn-m1.md new file mode 100644 index 0000000..5220e97 --- /dev/null +++ b/docs/handoffs/HANDOFF-dyn-m1.md @@ -0,0 +1,138 @@ +# dyn, milestone 1 — what was decided and what is left + +The compiler half of dynamic-by-default. The runtime half is a sibling's, built +in parallel against `runtime/flan_dyn.h`, which is the fixed ABI and the thing +the two copies are diffed against. + +## Two decisions that differ from the brief + +**The return slot stays mandatory; `dyn` is written out in it.** The brief +expected `ret = None` to grow a third state meaning "unannotated", and listed +mechanical fallout in `load.ml`, `shim.ml` and `cimport.ml`. That fallout does +not exist, because the change was not made. The reason is in `parse.ml` beside +the `defn` case: an optional return slot has *no* syntactic resolution, since a +capitalised head in a list is both a type application and a struct literal — +`(defn f [] (Rune {.code 65}) (bar))` is the misparse that removed the old +optional slot, and it would come straight back. A parameter vector has no such +case, because every slot in it is a name or a type and never an expression. So +`ret = None` still means Unit and only `declare` and the shim produce it. One +token in the return position buys a decision the file paid for twice in one day. + +**The parameter rule is resolved in `Check`, not in `parse.ml`.** The brief +asked for "a known type name is a type, anything else is another dyn param", +written where `parse.ml` argues its other misparse-closing decisions. That +lookup is exactly the one `parse.ml:904` records being removed for being wrong +twice in one day, and at parse time the set of type names is incomplete *by +construction* — macros generate definitions, packages are loaded later, C +headers are imported later. `cimport.ml` decides it: `named env n = tname n` +passes C type names through verbatim, so POSIX's `stat` and `timespec` are +lowercase Flan type names writable in parameter position, and no syntactic rule +("capitalised is a type") can be made sound. + +So the vector is carried undecided as `Ast.pitem`s and paired in +`Check.pair_params`, after every file is loaded, every macro expanded and every +header imported. The argument is written at `parse.ml`'s `defn` case as asked. + +## The residual the parent owns + +The set of type names is complete at a point in time and **not across time**. +`(defn f [x y] ...)` is two dyn parameters until somebody writes +`(defstruct y ...)` — or imports a header that declares one — and then it is one +parameter of type `y`, with no edit to `f`. The signature changes underneath it, +and arity changes with it. + +`Session.compatible` is where that is felt: it compares with `Types.equal` over +parameters and return, so a redefinition that changes dyn-ness is refused like +any other signature change (this falls out; it is pinned in `test_session.ml`). +But the *first* definition after such an edit is the one that changes, and +nothing warns. + +## What the feature costs, and what was taken back + +A parameter slot with no type used to be a syntax error. It is now a `dyn` +parameter, so **a mistyped type silently becomes an extra parameter** — the +arity changes with no diagnostic, which is the failure class `parse.ml` calls +the worst available. Two rules take most of it back, in `dyn_param_or_typo`: + +- a name within one edit of a type's name gets the resolver's own "did you + mean", and +- an unknown **capitalised** name is reported as an unknown type. Not one + parameter in the corpus is capitalised, while `Form`, `Cursor` and `Vector2` + appear in these vectors constantly. + +What is left uncovered is a lowercase name resembling no type: `(defn f [x +widget] ())` is two dyn parameters and nothing in the text says otherwise. That +is the feature working as specified. + +**Sharp edge of the near-miss rule.** `near_miss` treats any two single-char +names as one edit apart, and it compares against every struct name in scope. So +a `(defstruct D ...)` anywhere in the program makes `(defn f [a d] ...)` a +refusal rather than two dyn parameters. The message is actionable — write the +type, or rename — but it is a refusal a user will meet without having done +anything wrong. + +## Open ABI point for the integrator + +**A rooted slot holding 0 is not a value, and the collector must skip it.** +This is written into `runtime/flan_dyn.h` beside the root functions, and it is +the one thing in that header decided by one side alone. Roots are pushed in the +function's entry block, before the code that fills them has run and possibly for +a branch that never runs, so the compiler zeroes every root slot and must mean +something by it — and 0 is the only pattern it can write without knowing the +encoding. + +If the real runtime NaN-boxes and integer zero is the zero word, this is wrong +and the two sides need a different sentinel. Do not fix it on one side. + +## Not in milestone 1, each refused by name with a location + +- a typed container boxing into dyn (`(Vec i64)` → dyn): "not yet"; the + heterogeneous container is the runtime's own from `(vec-new dyn)` +- a dyn in a condition's payload, or in a field of one: milestone 2 — a payload + crosses a handler boundary and must stay rooted across the transfer +- a dyn crossing to C through `declare`/`declare-c`: it is one word and would + have passed as an integer with nothing on the other side able to ask what it + means. This one was **not** in the brief and is the dangerous one, because the + general "cannot cross to C" arm would have caught it with advice (`pass (Ptr + T)`) that is wrong for dyn. +- integer widths other than i64 and floats other than f64 unboxing from dyn: + the ABI carries one of each, and a `need_i64` plus a truncation would put an + implicit narrowing at the one boundary where the value's type was already + uncertain +- the x86 dev backend, and the JS dialect, refuse dyn entirely + +## Roots: what is and is not verified + +Every dyn slot and every dyn-producing runtime call is rooted, pushed in the +entry block and popped at every `ret` — which is the funnel all five exits pass +through, the transfer landing block included. Pushes and pops balance **by +construction**: `dyn_roots` counts before emission, the slots are minted from +that count, and `dyn_tmp` only hands them out. + +**The stub verifies none of this.** `flan_dyn_stub.c` mallocs and never frees, +so a program with entirely wrong root discipline passes every test that runs +against it. What is checked instead is the IR, and that check earned its keep — +it found a real hole. A defer appears twice in the typed IR, spliced into `body` +for the normal path and again in `fdefers` for the path a transfer leaves +through, so a dyn temporary inside one is emitted twice; `dyn_roots` counted +only the body's, and the second copy went into slots the collector had never +been told about. + +Nothing failed, which is the point. `dyn_tmp` falls back to a plain unrooted +slot rather than unbalancing the stack, so the pushes and the pops still +matched, the program ran and printed the right answer, and four dyn values were +simply invisible. Under a stub that never collects there is no symptom at all. + +The assertion that caught it is in `test_acceptance.ml`: a rooted slot is +spelled `%dr` and the fallback `%dx`, and no dyn program in the corpus may emit +the latter. When the real collector lands, that is the check to extend rather +than replace — it is the only one that can see a missing root before there is a +collector to lose one by. + +Cost: a rooted alloca has its address escape through `flan_dyn_root_push`, so +mem2reg cannot promote it. Every dyn local and every dyn temporary is a real +stack slot with a real store, at every optimisation level. That is inherent to a +precise collector with an address-registration ABI rather than stack maps. + +A function with no dyn emits nothing — no push, no pop, not a `pop(0)` — which +is what makes `--no-gc` byte-identity hold. diff --git a/lib/ast.ml b/lib/ast.ml index e80f8ae..76e941b 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -106,6 +106,19 @@ and rclause = restart clause's parameters are one, and a clause is part of an expression. *) and field = { fname : string; fty : texpr; floc : Loc.t } +(* One slot of a [defn]'s parameter vector, before it is known whether the slot + is a name or a type. [(defn f [x y] ...)] is two dyn parameters if [y] is + not a type and one parameter [x : y] if it is, and the parser cannot tell: + the type names are not all known until macros have run and every file has + been loaded. So the vector is carried undecided and paired in [Check], where + the set is complete. See the argument in Parse beside the [defn] case. *) +and pitem = + (* A bare symbol: either a parameter's name or a type's. *) + | Pname of string * Loc.t + (* Anything that cannot be a parameter name — [(Ptr T)], [[T]], [[n T]], [()] + — and so is a type whatever the environment says. *) + | Ptype of texpr + (* Two unwrap operators, because they are two different things — plan.org. *) and unwrap = Usome | Utry @@ -136,6 +149,13 @@ type pred = { pname : string; pvar : string; ploc : Loc.t } type fn = { name : string; params : field list; + (* [Some items] means the parameter vector has not been paired yet: it was + written by a [defn], where a slot with no type means [dyn], and [Check] + fills [params] from it before anything reads them. [None] is every other + way a signature is built — [declare], the shim, the C importer — where + every parameter's type was written out and the pairing was never in + doubt. Nothing downstream of [Check.pair_params] sees [Some]. *) + praw : pitem list option; ret : texpr option; (* None means (); only declare omits it *) (* The [{:where ...}] map at the head of the body, already unpacked. Empty for every function that has none, which is every function that is not diff --git a/lib/check.ml b/lib/check.ml index 9d7b1df..a8bf82a 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -707,6 +707,14 @@ and resolve_name env ~seen loc n = match n with | "bool" -> Types.Bool | "string" -> Types.String + (* Lowercase and concrete, which the rule three screens down says is a + type variable. It is spelled this way because it is a primitive and + every other primitive is lowercase — [dyn] beside [i64] and [bool] + reads as one of them, [Dyn] beside [Vec] and [Option] reads as a + container over something. The type-variable rule is reached by a + [when] guard below and this arm is before it, so the spelling costs + nothing but the note. *) + | "dyn" -> Types.Dyn | "Unit" -> Types.Unit | "Never" -> Types.Never (* A builtin opaque type, the way [string] is a builtin ptr+len. There is @@ -752,6 +760,127 @@ and array_len env loc = function fail loc "%s is not a compile-time integer constant, so it cannot be \ an array length" n) +(* ── Pairing a defn's parameter vector ────────────────────────────────── + + [(defn f [x y] ...)] is one parameter [x] of type [y] if [y] names a type, + and two parameters of type [dyn] if it does not. Parse could not tell — the + long argument is beside its [defn] case — so it handed over the slots + undecided and this is where they are paired, with every type name in hand: + every file loaded, every macro expanded, every C header imported. + + The walk is left to right and takes two slots or one. A name followed by + something that is a type takes two and is annotated; a name followed by + another name that is not a type, or by nothing, takes one and is [dyn]. That + is the whole rule, and it reads the way the vector reads. + + A name that *is* a type name is refused rather than paired. [(defn f [i64 x] + ...)] has no good reading: taken as written it is a parameter called [i64], + which shadows nothing but confuses everything, and the likelier intent is a + pair written backwards. Refusing here costs a rename in the one program that + meant it and closes the one place where this rule could still hand somebody + a signature they did not write. *) +let is_type_name env n = + Types.ikind_of_name n <> None + || Types.fkind_of_name n <> None + || List.mem n [ "bool"; "string"; "dyn"; "Unit"; "Never"; "Allocator" ] + || Hashtbl.mem env.aliases n + || Hashtbl.mem env.structs n + || Hashtbl.mem env.datas n + || Hashtbl.mem env.unions n + || Hashtbl.mem env.enums n + (* A type variable: [$t] in a signature is generics' binding site, and a + slot holding one is a type however few of them there are. *) + || (n <> "" && n.[0] = '$') + +(* Before a bare symbol is allowed to become an unannotated parameter, the two + ways it is more likely to be a type that went wrong. + + This is the cost dynamic-by-default puts on the parameter vector, and it is + worth naming plainly: a slot with no type used to be a syntax error, and now + it is a [dyn] parameter. So [(defn f [x f65] ())] — a typo for [f64] — no + longer reads as a mistyped type. It reads as two parameters, one of them + called [f65], and the function silently takes an argument nobody meant to + give it. An arity that changes because of a typo, with no diagnostic, is the + failure class Parse's [defn] comment calls the worst available, and the + feature reintroduces it in a new place. + + Two rules take most of it back. A name within one edit of a type's name is + the typo it looks like, and is refused with the same "did you mean" the + resolver gives — the near-miss table is already there and is exactly the + right question. And a capitalised name is a type by the convention the whole + corpus keeps: not one parameter in the language is capitalised, while [Form], + [Cursor], [Vector2] and the rest appear in these vectors constantly. So an + unknown capitalised name is an unknown *type*, reported as one, rather than + a parameter nobody would have spelled that way. + + What is left uncovered is a lowercase name that resembles no type: [(defn f + [x widget] ())] is two dyn parameters and there is no evidence in the text + that it was meant to be one. That case is the feature working as specified, + and it is the residual the parent owns. *) +let dyn_param_or_typo env n loc = + match near_miss env n with + | Some m -> + Loc.failk "check/unknown-type" loc + "unknown type %s — did you mean %s? A parameter with no type is dyn, so \ + this would otherwise be read as a second parameter called %s" + n m n + | None -> + if n <> "" && n.[0] = Char.uppercase_ascii n.[0] + && n.[0] <> Char.lowercase_ascii n.[0] + then + Loc.failk "check/unknown-type" loc + "unknown type %s. A capitalised name in a parameter vector is a type — \ + a parameter with no type is dyn, and parameters are lowercase" + n + +let pair_params env (items : Ast.pitem list) : Ast.field list = + let dyn loc = { Ast.t = Ast.Tname "dyn"; tloc = loc } in + let rec go = function + | [] -> [] + | Ast.Ptype t :: _ -> + Loc.failk "check/parameter-name-expected" t.Ast.tloc + "a parameter's name was expected here, and this is a type. \ + Parameters are [name Type ...], and a name with no type is dyn" + | Ast.Pname (n, loc) :: rest when is_type_name env n -> + ignore rest; + Loc.failk "check/parameter-named-type" loc + "%s names a type, so it cannot also be this parameter's name. If the \ + pair was written backwards it is [name %s]; otherwise rename the \ + parameter" n n + | Ast.Pname (n, loc) :: Ast.Ptype t :: rest -> + { Ast.fname = n; fty = t; floc = loc } :: go rest + | Ast.Pname (n, loc) :: Ast.Pname (t, tloc) :: rest when is_type_name env t -> + { Ast.fname = n; fty = { Ast.t = Ast.Tname t; tloc }; floc = loc } :: go rest + (* The slot after this one is not a type, so this one is a parameter with + no type written — unless the slot after it only *looks* unlike a type + because it was mistyped, which is what the check is for. The next slot + is the one interrogated, not this one: this one is a name either way. *) + | Ast.Pname (n, loc) :: (Ast.Pname (t, tloc) :: _ as rest) -> + dyn_param_or_typo env t tloc; + { Ast.fname = n; fty = dyn loc; floc = loc } :: go rest + | Ast.Pname (n, loc) :: rest -> + { Ast.fname = n; fty = dyn loc; floc = loc } :: go rest + in + go items + +(* Every [defn] in the program, with its parameter vector paired. Run as a pass + of its own, after the type names are registered and before any signature is + resolved, so that nothing downstream ever sees an unpaired one. *) +let pair_decls env (decls : Ast.decl list) : Ast.decl list = + let fn (f : Ast.fn) = + match f.Ast.praw with + | None -> f + | Some items -> { f with Ast.params = pair_params env items; praw = None } + in + List.map + (fun (d : Ast.decl) -> + match d.Ast.d with + | Ast.Defn f -> { d with Ast.d = Ast.Defn (fn f) } + | Ast.Declare (f, c) -> { d with Ast.d = Ast.Declare (fn f, c) } + | Ast.DeclareC (f, c) -> { d with Ast.d = Ast.DeclareC (fn f, c) } + | _ -> d) + decls + (* ── Generics: the four operations monomorphisation needs ─────────────── Naming a variable, binding one from an argument, substituting the binding back in, and spelling the result as a symbol. Everything else about the @@ -1235,10 +1364,131 @@ let type_id name = let restart_sig tys = "(" ^ String.concat " " (List.map Types.to_string tys) ^ ")" +(* ── The dyn boundary ─────────────────────────────────────────────────── + + Typed to dyn is implicit and dyn to typed is not. That asymmetry is the + whole of the design and it is worth saying why it is not arbitrary. + + Boxing loses nothing: the value goes in and the runtime records what it was. + It can happen anywhere a dyn is wanted without a reader being surprised, + because nothing about the program's meaning turns on it. Unboxing can fail, + at run time, on a value the compiler cannot inspect -- so it happens only + where somebody *wrote a type*: a typed parameter, a typed binding, a typed + field. Those are the places a reader already understands as a claim about + what a value is, and a claim that can be wrong is exactly what a trap is + for. Nowhere else does the compiler decide a dyn is an i64 on its own. + + Both directions go through [expect], because [expect] is already the one + place a wanted type meets a produced one. Every site that annotates -- and + only those sites -- calls it with [~want]. + + Milestone 1 boxes the scalars and refuses everything else by name. A typed + container crossing into dyn is the interesting refusal: [(Vec i64)] has a + representation the dyn runtime does not know how to walk, and heterogeneity + at milestone 1 is served by the runtime's own vector behind + [flan_dyn_vec_new] instead. That is a "not yet" and says so. *) + +let dyn_i64 = Types.Int Types.I64 +let dyn_f64 = Types.Float Types.F64 + +(* Widening to the one width the ABI carries. runtime/flan_dyn.h boxes integers + as [i64] and floats as [f64] and offers no other width, which is the + language's "dyn integers are i64" written where it is enforced. The cast is + explicit in the tree rather than left to the backend: a [Cast] is what the + language's own conversions emit, and a widening one loses nothing. *) +let widen loc (want : Types.t) (e : Tast.expr) = + if Types.equal want e.Tast.ty then e + else mk loc want (Tast.Prim (Tast.Cast want, [ e ])) + +let unboxable t = + match t with + | Types.Int Types.I64 | Types.Float Types.F64 | Types.Bool -> true + | _ -> false + +(* The sentence a refusal at this boundary gives. It names the type and says + which direction failed, because "expected dyn, found (Vec i64)" would read + as a type error the programmer could fix by writing something else, and + there is nothing else to write -- the feature is not there yet. *) +let no_dyn_yet loc ~into t extra = + Loc.failk "check/dyn-not-yet" loc + "%s does not cross into %s yet%s" + (Types.to_string t) (if into then "dyn" else "a written type") extra + +let box loc (e : Tast.expr) : Tast.expr = + let dyn sym args = rt loc Types.Dyn sym args in + match e.Tast.ty with + | Types.Dyn -> e + | Types.Int _ -> dyn "flan_dyn_from_i64" [ widen loc dyn_i64 e ] + | Types.Float _ -> dyn "flan_dyn_from_f64" [ widen loc dyn_f64 e ] + (* The ABI takes an [int32_t], because a C signature that says [_Bool] is a + width argument nobody wants to have. *) + | Types.Bool -> dyn "flan_dyn_from_bool" [ widen loc (Types.Int Types.I32) e ] + (* A string is ptr+len and arrives as two arguments, the way every other + (ptr, len) entry point in the runtime takes one. The runtime copies: the + bytes may be a literal or a slice of a buffer the program goes on to + write. *) + | Types.String -> dyn "flan_dyn_from_bytes" [ e ] + (* Unit does not box. A value of the zero-sized type carries nothing for a + dyn word to hold, and [nil] -- which is what an [if] with no else answers + in dyn context -- is a different thing with a different constructor. The + two get confused if unit is allowed to become one. *) + | Types.Unit -> + Loc.failk "check/dyn-unit" loc + "() does not box into dyn — a value of the zero-sized type carries \ + nothing a dyn could hold. The absent dyn value is nil, which is what an \ + if with no else branch answers here" + | Types.Never -> e + | Types.Vec _ | Types.Map _ | Types.Slice _ | Types.Array _ -> + no_dyn_yet loc ~into:true e.Tast.ty + ". The dyn container at this milestone is the runtime's own, from \ + (vec-new dyn); a typed container has a representation the dyn runtime \ + cannot walk" + | Types.Named _ | Types.Enum _ | Types.Option _ | Types.Ptr _ + | Types.Alloc | Types.Fn _ | Types.Var _ -> + no_dyn_yet loc ~into:true e.Tast.ty "" + +let unbox loc (want : Types.t) (e : Tast.expr) : Tast.expr = + let need sym ty = rt loc ty sym [ e ] in + match want with + | Types.Int Types.I64 -> need "flan_dyn_need_i64" dyn_i64 + | Types.Float Types.F64 -> need "flan_dyn_need_f64" dyn_f64 + | Types.Bool -> + (* The ABI answers an [int32_t]; [bool] is an [i1]. The narrowing is the + language's own cast and cannot fail — the runtime already decided the + value was a bool, so what comes back is 0 or 1. *) + widen loc Types.Bool (need "flan_dyn_need_bool" (Types.Int Types.I32)) + (* Every other width is refused rather than served by a need_i64 and a + truncation. This language has no implicit narrowing anywhere, and putting + one at the boundary where a value's type was *already* uncertain is the + worst place in the program to start: the annotation would read as a check + and would be a silent discard of the high bits. The ABI grows a per-width + entry point when there is a reason to; until then the spelling that works + is an i64 and an explicit conversion after it. *) + | Types.Int _ | Types.Float _ -> + no_dyn_yet loc ~into:false want + (Printf.sprintf + " — the dyn runtime carries integers as i64 and floats as f64, so \ + take it as %s and convert" + (if Types.is_numeric want && (match want with Types.Float _ -> true | _ -> false) + then "f64" else "i64")) + | _ -> no_dyn_yet loc ~into:false want "" + let expect loc ~want (got : Tast.expr) = match want with | None -> got | Some w -> + (* The boundary, and the only implicit conversion in the language. It runs + before [fits] rather than instead of it: what comes back is an ordinary + expression of the wanted type, and if the coercion did not produce one + the usual message is still the one that reports it. *) + let got = + match w, got.Tast.ty with + | Types.Dyn, Types.Dyn -> got + | Types.Dyn, _ -> box loc got + | _, Types.Dyn when Types.fits ~expected:w ~actual:Types.Dyn -> got + | _, Types.Dyn -> unbox loc w got + | _ -> got + in if Types.fits ~expected:w ~actual:got.Tast.ty then got else fail loc "expected %s, found %s" (Types.to_string w) @@ -1569,6 +1819,12 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = match e.Ast.e with | Ast.Int n -> int_literal loc ~want n | Ast.Byte b -> int_literal loc ~want ~default:Types.U8 (Int64.of_int b) + (* The float literal's own dyn case, for the reason the integer's has one: + the ABI carries one width and the literal is built at it. f64 is already + what an unconstrained float literal defaults to, so this only has to stop + the "expected dyn, found the float literal" arm below from firing. *) + | Ast.Float x when want = Some Types.Dyn -> + box loc (mk loc dyn_f64 (Tast.Float (x, Types.F64))) | Ast.Float x -> let k = match want with @@ -1716,12 +1972,38 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = let name = match c.Tast.ty with | Types.Named n -> n + (* Its own arm ahead of the general one, because "a condition is a + struct, not dyn" would read as a rule about shape when the answer is a + milestone. A condition crosses a handler boundary as a pointer to a + frame that is still alive, and a dyn payload has to stay rooted across + that transfer — which is the collector's question, not this one's, and + it is milestone 2's. *) + | Types.Dyn -> + no_dyn_yet c.Tast.loc ~into:false Types.Dyn + " — a condition crosses a handler boundary and a dyn payload has to \ + stay rooted across the transfer, which is milestone 2" | t -> fail c.Tast.loc "a condition is a struct, not %s — matching is by type and there is \ no condition hierarchy" (Types.to_string t) in + (* And the same refusal for a condition that merely *holds* one. The + payload is what crosses, so a dyn field is the dyn payload the note + above is about, whatever the struct around it is called. *) + (match Hashtbl.find_opt ctx.env.structs name with + | Some (s : Tast.structure) -> + List.iter + (fun (f : Tast.field) -> + if f.Tast.fty = Types.Dyn then + no_dyn_yet c.Tast.loc ~into:false Types.Dyn + (Printf.sprintf + " — the field %s of the condition %s is one, and a payload \ + has to stay rooted across a handler transfer, which is \ + milestone 2" + f.Tast.fname name)) + s.Tast.fields + | None -> ()); (* §1 and §2. [signal] is Unit whatever it finds; [error] is Never, because the only way past it is a handler that transfers — one that returns normally has not answered it, and the program stops. *) @@ -1803,6 +2085,16 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = and int_literal loc ~want ?(default = Types.I32) n = match want with | Some (Types.Int k) -> mk loc (Types.Int k) (Tast.Int (in_range loc k n, k)) + (* A literal in dyn position takes i64 and not the i32 an unconstrained one + defaults to. This is where "dyn integers are i64" stops being a statement + about the ABI and becomes one about the language: [(defvar x dyn 5)] holds + an i64 five, and the defaulting question a wider set of boxes would raise + never arises because there is only the one box. Handled here rather than + left to [expect] so the literal is *built* at the right width — the range + check below is the one that matters, and 3000000000 is a dyn integer even + though it is not an i32. *) + | Some Types.Dyn -> + box loc (mk loc dyn_i64 (Tast.Int (in_range loc Types.I64 n, Types.I64))) (* An untyped integer constant is usable where a float is wanted, as in Odin. A float literal is never usable where an integer is wanted. *) | Some (Types.Float k) -> @@ -3091,7 +3383,13 @@ and fold_left_prim ctx ~want loc name p ok what args = let x, y, rest = match args with x :: y :: rest -> x, y, rest | _ -> assert false in - let a, b = binary ctx name loc ~want:(numeric_want want) [ x; y ] in + let a, b = binary ctx ~dyn_ok:true name loc ~want:(numeric_want want) [ x; y ] in + (* One dyn operand makes the whole fold dyn, whichever side it is on. The + typed side is boxed by [dyn_fold]; a literal was already built at dyn by + [binary], so [(+ x 1)] over a dyn x folds an i64 one. *) + if a.Tast.ty = Types.Dyn || b.Tast.ty = Types.Dyn then + dyn_fold ctx ~want loc name [ a; b ] rest + else begin unconstrained ctx.env loc name ~needs:"numeric?" a.Tast.ty; (* Past [unconstrained] a variable here is one the [where] clause admitted, so the concrete predicate below has nothing to say about it — it is @@ -3107,6 +3405,37 @@ and fold_left_prim ctx ~want loc name p ok what args = rest in expect loc ~want acc + end + +(* The dyn lowering of a fold: one call per operator application, left to + right, each taking and answering a dyn word. The typed side of a mixed pair + is boxed on the way in — [box] is the identity on something already dyn, so + this needs no case analysis of its own. *) +and dyn_fold ctx ~want loc name first rest = + let sym = + match name with + | "+" -> "flan_dyn_add" | "-" -> "flan_dyn_sub" + | "*" -> "flan_dyn_mul" | "/" -> "flan_dyn_div" + | "%" -> "flan_dyn_rem" + | _ -> + (* Bitwise and shift operators land here if they ever admit a dyn + operand. They do not: the runtime carries no bitwise entry points, + and an integer operation on a value that might be a float is not + something to guess at. *) + no_dyn_yet loc ~into:false Types.Dyn + (Printf.sprintf " — %s has no dyn form" name) + in + let apply acc b = rt loc Types.Dyn sym [ acc; box loc b ] in + let acc = + match first with + | [ a; b ] -> apply (box loc a) b + | _ -> assert false + in + let acc = + List.fold_left (fun acc arg -> apply acc (check ctx ~want:Types.Dyn arg)) + acc rest + in + expect loc ~want acc (* ── Allocation failure, spec-memory.md ──────────────────────────────── No allocating operation returns an error and none can fail silently. When @@ -3390,18 +3719,51 @@ and named_call ctx ~want loc name args = nobody writes on purpose. *) | "%" -> arity loc name 2 args; - let a, b = binary ctx name loc ~want:(numeric_want want) args in + let a, b = binary ctx ~dyn_ok:true name loc ~want:(numeric_want want) args in + if a.Tast.ty = Types.Dyn || b.Tast.ty = Types.Dyn then + dyn_fold ctx ~want loc name [ a; b ] [] + else begin unconstrained ctx.env loc name ~needs:"numeric?" a.Tast.ty; if not (Types.is_numeric a.Tast.ty || generic_ty a.Tast.ty) then fail loc "%s takes numbers, found %s" name (Types.to_string a.Tast.ty); prim Tast.Rem a.Tast.ty [ a; b ] + end | "=" | "!=" | "<" | "<=" | ">" | ">=" -> let p = match name with | "=" -> Tast.Eq | "!=" -> Tast.Ne | "<" -> Tast.Lt | "<=" -> Tast.Le | ">" -> Tast.Gt | _ -> Tast.Ge in arity loc name 2 args; - let a, b = binary ctx name loc ~want:None args in + let a, b = binary ctx ~dyn_ok:true name loc ~want:None args in + (* A comparison with a dyn operand answers a *bool*, not a dyn, even though + the runtime's own entry point answers a dyn holding one. The reason is + where the result goes: a comparison is overwhelmingly the test of an + [if] or a [while], and those want an i1. So the need_bool is applied + here, once, and a program that really wants the comparison as a dyn + value boxes it again on the way into wherever it is going — which [box] + does for free at that boundary. + + [=] and [!=] are the pair that never traps: the runtime compares + structurally and answers false for values of unrelated types, because + two things being unalike is the answer to "are these equal", not an + error. The orderings do trap, and rightly — there is no true answer to + whether a string is less than a vector. *) + if a.Tast.ty = Types.Dyn || b.Tast.ty = Types.Dyn then begin + let sym = + match name with + | "=" | "!=" -> "flan_dyn_eq" + | "<" -> "flan_dyn_lt" | "<=" -> "flan_dyn_le" + | ">" -> "flan_dyn_gt" | _ -> "flan_dyn_ge" + in + let cmp = unbox loc Types.Bool (rt loc Types.Dyn sym [ box loc a; box loc b ]) in + (* [!=] has no entry point of its own: there is one structural equality + and the negation is an [i1] flip the backend folds away. *) + let r = + if String.equal name "!=" then mk loc Types.Bool (Tast.Prim (Tast.Not, [ cmp ])) + else cmp + in + expect loc ~want r + end else begin (* [=] and [!=] admit one type [<] does not: a handle, which is a pair of numbers in one word and where "the same entity" is the question the type exists to answer. Ordering handles would order a slot index, which @@ -3419,6 +3781,7 @@ and named_call ctx ~want loc name args = "%s compares machine numbers; %s has no built-in comparison \ (plan.org, Types)" name (Types.to_string a.Tast.ty); prim p Types.Bool [ a; b ] + end | "not" -> arity loc name 1 args; prim Tast.Not Types.Bool [ check ctx ~want:Types.Bool (List.hd args) ] @@ -3717,6 +4080,25 @@ and named_call ctx ~want loc name args = out. *) | "vec-new" -> let elem, args = vec_new_elem ctx ~want loc args in + (* [(vec-new dyn)] is not a [(Vec dyn)]. At milestone 1 the heterogeneous + container is the dyn runtime's own object, and its type is [dyn] like + everything else the runtime hands back — which is what lets [push], [at] + and [len] on it go through the dyn operations rather than through a + type-erased Vec over eight-byte elements. + + The two could be made to coincide later, and the reason not to now is + the collector: a Flan Vec's storage comes from an allocator the program + named, and the words in it would be roots the collector has to find + inside a block it does not own. The runtime's own vector is storage the + collector already knows about. *) + if elem = Types.Dyn then begin + if args <> [] then + fail loc + "(vec-new dyn) takes no allocator — the dyn container's storage is \ + the dyn runtime's, which is what lets the collector find the values \ + inside it"; + expect loc ~want (rt loc Types.Dyn "flan_dyn_vec_new" []) + end else begin let a = allocator_arg ctx loc args in let v = fresh_slot ctx (Types.Vec elem) in let attempt = @@ -3734,12 +4116,23 @@ and named_call ctx ~want loc name args = region_check ctx.env loc (mk loc (Types.Vec elem) (Tast.Local v)) (mk loc (Types.Vec elem) (Tast.Local v)) ]))) + end (* Unit, not a Result and not an ignorable error code: see [alloc_guard]. *) | "push" -> arity loc name 2 args; (match args with | [ target; x ] -> let target = check ctx target in + (* A push into a dyn container is a call and nothing else: no allocation + guard, no restart, no region check. The dyn runtime owns the storage + and answers a failure to grow it on its own terms — the guard and the + retry restart exist for an allocator the *program* named, and here + there is none to name. *) + if target.Tast.ty = Types.Dyn then + expect loc ~want + (rt loc Types.Unit "flan_dyn_push" + [ target; check ctx ~want:Types.Dyn x ]) + else begin let elem = vec_elem loc "push" target.Tast.ty in let x = check ctx ~want:elem x in (* The element is bound before the loop so that a [retry] re-attempts @@ -3762,6 +4155,7 @@ and named_call ctx ~want loc name args = (with_note loc (alloc_guard ctx loc attempt) (reg_note loc "flan_dev_reg_note_vec" target [ size_of loc elem ] elem)) ]))) + end | _ -> assert false) | "reserve" -> arity loc name 2 args; @@ -4485,6 +4879,14 @@ and named_call ctx ~want loc name args = | Types.Map _ -> let n = rt loc (Types.Int Types.I64) "flan_map_len" [ a; here loc ] in expect loc ~want (mk loc index_ty (Tast.Prim (Tast.Cast index_ty, [ n ]))) + (* A dyn length is an i32 like every other length here, not a dyn holding + one. [len] is what an index loop compares against, and handing back a + boxed number would make [(< i (len xs))] a dyn comparison and a pair of + allocations per iteration. The runtime answers a dyn; it is unboxed at + once and narrowed the way the Vec's i64 above is. *) + | Types.Dyn -> + let n = unbox loc (Types.Int Types.I64) (rt loc Types.Dyn "flan_dyn_len" [ a ]) in + expect loc ~want (mk loc index_ty (Tast.Prim (Tast.Cast index_ty, [ n ]))) | other -> fail loc "len takes an array, a slice, a string, a Vec or a Map, found %s" @@ -4497,6 +4899,19 @@ and named_call ctx ~want loc name args = | Types.Vec _ -> let p, elem = vec_at ctx loc target idx in expect loc ~want (mk loc elem (Tast.Deref p)) + (* One index, because a dyn container is one dimension: the nested + [(at grid r c)] spelling walks a type the compiler can see through, + and here it cannot. [(at (at g r) c)] is the spelling that works and + is what the refusal names. *) + | Types.Dyn -> + (match idx with + | [ i ] -> + expect loc ~want + (rt loc Types.Dyn "flan_dyn_at" [ target; check ctx ~want:Types.Dyn i ]) + | _ -> + fail loc + "(at ...) over a dyn takes one index — the compiler cannot see \ + the shape of a dyn container, so write (at (at x i) j)") | _ -> let idx, ty = indexed ctx target idx in prim Tast.At ty (target :: idx)) @@ -5127,7 +5542,7 @@ and numeric_want want = widening, so one side has to decide it. Check the side that carries the most information first: a non-literal over a literal, and a float literal over an integer one, since an integer constant converts to a float and not back. *) -and binary ctx name loc ~want args = +and binary ctx ?(dyn_ok = false) name loc ~want args = match args with | [ x; y ] -> let y_decides = @@ -5136,11 +5551,46 @@ and binary ctx name loc ~want args = | (Ast.Int _ | Ast.Byte _), Ast.Float _ -> true | _ -> false) in + (* A form that cannot be checked without being told what is wanted. A + literal takes its width from the expectation, and a keyword has no + meaning at all without one — [:lo] resolves against the enum the site + expects and there is no keyword type to fall back on. Everything else + checks on its own terms. *) + let needs_want (f : Ast.expr) = + is_literal f || (match f.Ast.e with Ast.Kw _ -> true | _ -> false) + in if y_decides then begin let b = check ctx ?want y in let a = check ctx ~want:b.Tast.ty x in a, b - end else begin + end + (* [dyn_ok] is set by the operators that have a dyn lowering, and it exists + to stop the second operand being coerced to the first's type before + anybody has asked whether the pair is a dyn one. + + Without it [(+ n x)] over an [i64] n and a dyn x threads [i64] into the + second check, [expect] does what an annotation site asked for and + unboxes, and the result is a *machine* add of a value the runtime was + never asked about: the program traps on a float instead of promoting, + and nothing in the source says why. The mirror image [(+ x n)] boxed + correctly, so the bug was visible only in one operand order. + + Both sides are checked on their own terms here and the caller decides. + That is safe exactly when neither operand needs an expectation, which is + what [needs_want] settles — a literal still gets the first operand's + type, so [(+ x 1)] over a dyn x goes on building an i64 one. *) + else if dyn_ok && not (needs_want y) then begin + let a = check ctx ?want x in + let b = check ctx y in + (* Nothing dyn about this pair after all, so it is put back the way the + typed path built it. Re-checking only when the types actually differ + keeps the common case to one check of each operand. *) + if a.Tast.ty = Types.Dyn || b.Tast.ty = Types.Dyn + || Types.equal a.Tast.ty b.Tast.ty + then a, b + else a, check ctx ~want:a.Tast.ty y + end + else begin let a = check ctx ?want x in let b = check ctx ~want:a.Tast.ty y in a, b @@ -5539,6 +5989,13 @@ let collect env (decls : Ast.decl list) = Hashtbl.replace env.locs n d.Ast.dloc | _ -> ()) decls; + (* Every type name is registered by here — structs, data types and unions by + the names-first pass, aliases with them, enums by the pass just above — so + this is the first point at which a [defn]'s parameter vector can be paired. + It is done before the signature loop below rather than inside it, because a + signature may name a type declared further down and pairing must not depend + on the order the file was written in. *) + let decls = pair_decls env decls in List.iter (fun (d : Ast.decl) -> let loc = d.Ast.dloc in @@ -5575,6 +6032,19 @@ let collect env (decls : Ast.decl list) = | Types.Int _ | Types.Float _ | Types.Bool | Types.Ptr _ | Types.Enum _ | Types.Unit -> () | Types.String | Types.Slice _ when what = "a parameter" -> () + (* Its own arm, because the general advice below is wrong for it and + dangerously so. A dyn is one machine word and would cross without + complaint — [(Ptr dyn)] is not the fix and there is nothing for a + shim to read: what the C side would receive is a word whose + meaning only the dyn runtime knows, and C has no way to ask. + Refused by name rather than let through as an integer. *) + | Types.Dyn -> + fail loc + "%s of %s is dyn, which does not cross to C. A dyn is one word \ + and would pass as an integer, but what the word means is the \ + dyn runtime's and there is nothing on the C side that can ask \ + — take the value at a written type and pass that" + what fn.Ast.name | _ -> fail loc "%s of %s is %s, which cannot cross to C directly — pass \ @@ -5742,7 +6212,13 @@ let collect env (decls : Ast.decl list) = if progressed && left <> [] then settle () in settle (); - List.iter (fun c -> ignore (infer c)) !pending + List.iter (fun c -> ignore (infer c)) !pending; + (* 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, + and a [defn] still carrying an unpaired vector would check as a function of + no parameters at all. *) + decls (* A type that contains itself by value has no finite size. [(Ptr T)] and a slice are indirections and break the cycle; a fixed array does not, because @@ -6460,7 +6936,7 @@ let build_program ~keep_going (decls : Ast.decl list) : Tast.program * env = time it runs every signature is sound, so a body that fails to check cannot make the next body fail — which is what makes a declaration a resync point that needs no resynchronising. *) - collect env decls; + let decls = collect env decls in check_finite env; check_union_members env; let s = Loc.sink ~on:keep_going in @@ -6604,3 +7080,70 @@ let expression env (e : Ast.expr) : let t = check ctx e in (t, Array.of_list (List.rev ctx.slot_tys), Array.of_list (List.rev ctx.slot_names)) + +(* ── --no-gc ──────────────────────────────────────────────────────────── + + The flag that says this program is to be compiled with no collector in it, + and the way to keep that promise is to refuse every dyn rather than to emit + a different program. A dyn value is a value the runtime allocates and the + collector owns; there is no smaller version of it to fall back to, and + quietly leaking instead would be a memory model nobody asked for. + + So this is a pass and not a flag. It runs between [Check] and [Emit], it + answers unit or it refuses, and nothing downstream of it is told the flag + exists — which is what makes a fully annotated program's output byte for + byte identical with the flag and without it. Emit has no [no_gc] field to + branch on, and that is deliberate: a field would be one more thing that + could change a comment, a name or an ordering, and the identity is worth + more than the branch would ever buy. + + Every site is named, the way the global cycle refusal names the whole ring + rather than one member of it. A reader who has to annotate their program + wants the list, not the first one and then another compile. *) + +let dyn_sites (p : Tast.program) : Loc.diag list = + let found = ref [] in + let add loc what = found := (loc, what) :: !found in + List.iter + (fun (g : Tast.global) -> + if g.Tast.gty = Types.Dyn then + add g.Tast.ginit.Tast.loc (Printf.sprintf "the global %s" g.Tast.gname)) + p.Tast.globals; + List.iter + (fun (fn : Tast.fn) -> + List.iteri + (fun i t -> + if t = Types.Dyn then + add fn.Tast.floc + (Printf.sprintf "parameter %d of %s" (i + 1) fn.Tast.name)) + fn.Tast.params; + if fn.Tast.ret = Types.Dyn then + add fn.Tast.floc (Printf.sprintf "the return type of %s" fn.Tast.name); + (* The body's own dyn values, which are the ones a signature does not + show: a let bound to a boxed literal, a (vec-new dyn) deep inside an + expression. Reported at the node, because that is the character to + change. *) + List.iter + (Tast.walk + (fun (e : Tast.expr) -> + match e.Tast.e with + | Tast.Prim (Tast.Rt sym, _) + when e.Tast.ty = Types.Dyn + && String.length sym > 8 + && String.sub sym 0 8 = "flan_dyn" -> + add e.Tast.loc (Printf.sprintf "this value in %s" fn.Tast.name) + | _ -> ())) + fn.Tast.body) + p.Tast.fns; + List.rev_map + (fun (loc, what) -> + Loc.diag ~kind:"check/no-gc" loc + (Printf.sprintf + "%s is dyn, and --no-gc says this program carries no collector. A \ + dyn value is one the runtime allocates and the collector owns, so \ + there is nothing smaller to compile it to — write the type" + what)) + !found + +let no_gc (p : Tast.program) = + match dyn_sites p with [] -> () | ds -> raise (Loc.Errors ds) diff --git a/lib/cimport.ml b/lib/cimport.ml index bc63572..e4dad44 100644 --- a/lib/cimport.ml +++ b/lib/cimport.ml @@ -813,7 +813,7 @@ let of_dump ~env ~taken ~bound_syms ~config (d : dump) : imported = decls := { Ast.d = Ast.DeclareC - ({ Ast.name = flan; params; ret; fwhere = []; fbody = []; nloc = f.cloc }, + ({ Ast.name = flan; params; praw = None; ret; fwhere = []; fbody = []; nloc = f.cloc }, f.csym); dloc = f.cloc } :: !decls) diff --git a/lib/emit.ml b/lib/emit.ml index bc82da5..0a704ba 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -125,6 +125,13 @@ let rec ll (t : Types.t) = and a copy in the IR are the right number of bytes. *) | Types.Map _ -> "%map" | Types.Option e -> Printf.sprintf "{ i8, %s }" (ll e) + (* One word, and [i64] rather than a pointer type: runtime/flan_dyn.h says + [typedef uint64_t flan_dyn], and the IR agreeing with that typedef is the + whole of what keeps the two sides linkable. Nothing here ever loads + through it — a dyn word is only ever passed to a flan_dyn_* call — so the + integer spelling costs no casts and keeps the emitter honest about not + knowing whether the bits are a pointer. *) + | Types.Dyn -> "i64" | Types.Var _ -> (* The checker rejects it by name — nothing reaches here. *) failwith ("no layout for " ^ Types.to_string t) @@ -318,6 +325,7 @@ let rec lay m (t : Types.t) : int * int = match Hashtbl.find_opt m.unions n with | Some u -> union_lay m u | None -> failwith ("no layout for struct " ^ n)) + | Types.Dyn -> 8, 8 | Types.Var _ -> failwith ("no layout for " ^ Types.to_string t) (* Size, alignment, and the offset of every member. *) @@ -543,6 +551,13 @@ let rec dty m d (t : Types.t) : int = "!DIDerivedType(tag: DW_TAG_pointer_type, name: \"%s\", \ baseType: null, size: 64)" (Types.to_string t)) + (* An unsigned word, which is what the typedef says it is. Telling lldb + it is a pointer would be a guess about the encoding the compiler has + deliberately not made, and telling it nothing would leave [p x] on a + dyn local with no answer at all. A raw word is the true and useful + reading: it prints, and the person reading it can hand it to the + runtime's own printer. *) + | Types.Dyn -> basic "dyn" 64 "DW_ATE_unsigned" | Types.Var _ -> failwith ("no debug type for " ^ Types.to_string t) in @@ -585,6 +600,30 @@ type f = { what makes the pop happen on the transfer path as well as the normal one. [None] in a release build, where there is no frame at all. *) mutable frame : string option; + (* How many dyn roots this function pushed at entry, and so how many one + [flan_dyn_root_pop] at each exit takes off. Zero for every function with + no dyn in it, which is every function in every program written so far — + and zero means *nothing is emitted at all*, neither push nor pop nor a + pop of zero. That is what keeps a fully annotated program's IR byte for + byte what it was before dyn existed, which is the thing [--no-gc] + promises and is tested for. + + It is a count and not a saved depth because the ABI offers + [flan_dyn_root_pop(n)] and no way to read the stack's height; it can be a + count, rather than needing one, because the number is a static property of + the function that [dyn_roots] works out before a line of the body is + emitted. That matters: [ret] runs *during* emission, and a count + accumulated as roots were discovered would be short at every early + return. *) + mutable droots : int; + (* The root slots' addresses, in push order: the dyn slots first and then one + per dyn-producing runtime call, minted by [dyn_tmp] as the body is + emitted. Both kinds are entry-block allocas, so the addresses are good for + the function's whole extent — which is why rooting is per function here + and not per scope. A slot that is not live any more holds a value the + collector keeps one cycle longer than it must, and that is the safe + direction to be wrong in. *) + mutable droot_ns : string list; (* Where a dev build records each slot's address, so that a stopped frame's locals can be read. [None] in a release build and in a function with no named slot at all. Only *named* slots are recorded: a slot the compiler @@ -651,10 +690,76 @@ let label f name = this frame, so a pop written only on the normal path leaves a dead frame on the stack after every handled error, and the next backtrace is a lie. Same lesson [emit_with_alloc] learned about the context allocator. *) +(* How many dyn roots a function will push, worked out before any of it is + emitted. One per dyn slot — a parameter or a local of that type — and one per + runtime call that answers a dyn, because the word a call hands back is live + from the moment it exists and the next allocation may be the one that + collects it. + + Rooting every dyn-producing call, rather than only the ones whose value + outlives a call, is conservative and is the only thing available: this file + has no liveness and no lexical scope, both of which the checker resolved + away into flat slot indices long before anything got here. The cost is real + and is the cost of a precise collector with an address-registration ABI + rather than stack maps — a rooted alloca has its address escape through + [flan_dyn_root_push], so mem2reg cannot promote it, and every dyn value + becomes a stack slot with a store at every optimisation level. + + A count rather than a running tally for the reason [droots] gives: [ret] is + reached while the body is still being emitted. *) +let dyn_roots (fn : Tast.fn) = + let slots = + Array.fold_left + (fun acc t -> if t = Types.Dyn then acc + 1 else acc) 0 fn.Tast.slots + in + let temps = ref 0 in + let count (e : Tast.expr) = + match e.Tast.e with + | Tast.Prim (Tast.Rt _, _) when e.Tast.ty = Types.Dyn -> incr temps + | _ -> () + in + List.iter (Tast.walk count) fn.Tast.body; + (* And the transfer path's copy of the defers, which is a second list of the + same expressions and is emitted as well — so it mints a second set of + temporaries, and counting only [body] left every one of them in a slot the + collector never heard of. The fallback in [dyn_tmp] meant that was silent: + the pushes and the pops still balanced, and four dyn values in a defer + reached on a handled condition were simply invisible. Found by emitting + one and counting [%dx] in the IR, which is the only thing that can see it + while the runtime is a stub that never collects. *) + List.iter (Tast.walk count) fn.Tast.fdefers; + slots + !temps + +(* The next pre-made root slot for a dyn temporary. They are all minted, zeroed + and pushed in the entry block before a line of the body is emitted, and this + only hands them out — which is what makes the pushes and the pops balance by + construction rather than by the body being walked the same way twice. + + [dyn_roots] counts the same nodes the emission visits, so the supply runs + out only if those two disagree. If it ever does, the fallback is an ordinary + unrooted slot: one temporary the collector cannot see is a bug to find, + where a root stack that pops more than it pushed is memory corruption. *) +let dyn_tmp f = + match f.droot_ns with + | n :: rest -> f.droot_ns <- rest; n + | [] -> + let name = Printf.sprintf "%%dx%d" f.n in + f.n <- f.n + 1; + Buffer.add_string f.allocas (Printf.sprintf " %s = alloca i64\n" name); + name + let ret f v = (match f.frame with | Some prev -> ins f "store ptr %s, ptr @flan_frame_head" prev | None -> ()); + (* The pop, on every path out, for exactly the reason the shadow stack's is + here: a condition handled further out unwinds through the landing block, + and a pop written only on the normal path would leave this function's + roots on the stack after every handled error. The [unreachable] + terminators emit none, and are right not to — each of them dies inside C + and the process does not come back. *) + if f.droots > 0 then + ins f "call void @flan_dyn_root_pop(i64 %d)" f.droots; term f "ret %s %s" (ll f.ret) v (* The store that says "this slot is bound now". Emitted at each binding of a @@ -2247,6 +2352,18 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) = let t = fresh f in ins f "%s = call %s @%s(%s)" t (ll e.Tast.ty) sym args'; if signals then guard f; + (* A dyn word is spilled into a rooted slot the instant it exists. It is + an SSA value otherwise, and an SSA value is invisible to a collector + that finds its roots by address — the next allocation could be the one + that frees what this is holding. [dyn_roots] counted this call, so the + slot below is one the entry block has already pushed. + + The value carries on being used as a register: the store is what the + collector reads, and reading it back would only make the IR longer. *) + if e.Tast.ty = Types.Dyn then begin + let slot = dyn_tmp f in + ins f "store i64 %s, ptr %s" t slot + end; t end | Tast.SizeOf t, [] -> Printf.sprintf "%d" (fst (lay f.md t)) @@ -2328,6 +2445,17 @@ and cast f ~guard (x : Tast.expr) target = runtime answers a pointer or NULL and the Option is built in the checker, so the null test is one integer compare on the address. *) | Types.Ptr _, Types.Int Types.I64 -> "ptrtoint" + (* Not written in the surface language either — this language has no + conversion between bool and a number, and deliberately. The dyn + boundary needs both halves: runtime/flan_dyn.h takes and answers a + bool as an [int32_t], because a C signature saying [_Bool] is a width + question nobody wants, and [bool] is an [i1] here. + + The truncation is safe in the one direction it runs: what comes back + from [flan_dyn_need_bool] is 0 or 1, because the runtime has already + decided the value was a bool, so the discarded bits are zero. *) + | Types.Bool, Types.Int _ -> "zext" + | Types.Int _, Types.Bool -> "trunc" | _ -> failwith "unsupported cast" in if op = "bitcast" then v @@ -2405,6 +2533,7 @@ let emit_fn m ?(hidden = false) ?(pnames = []) (fn : Tast.fn) = pads = []; loops = []; unwind = "unwind"; unwound = false; defers = fn.Tast.fdefers; frame = None; slotv = None; snames = fn.Tast.snames; + droots = 0; droot_ns = []; dsub; dline = (if fn.Tast.floc.Loc.line = 0 then 1 else fn.Tast.floc.Loc.line); dloc = ""; @@ -2423,6 +2552,54 @@ let emit_fn m ?(hidden = false) ?(pnames = []) (fn : Tast.fn) = Buffer.add_string f.allocas (Printf.sprintf " store %s %%p%d, ptr %s\n" (ll ty) i f.slots.(i))) fn.Tast.params; + (* The dyn roots, and this is not gated on [m.dev]: the shadow stack below is + a debugging convenience and a release build does without it, while a + collector that cannot find its roots is a collector that frees live + values. Every build pays this, and only a function that has a dyn in it + pays anything — [dyn_roots] is zero otherwise and not a line is emitted, + which is what makes an annotated program's IR identical with and without + --no-gc. + + The dyn *slots* are already allocas from the loop above, so they are + pushed where they are; the temporaries need slots of their own, and they + are minted here, in order, so that [dyn_tmp] only has to hand them out. + Zeroed because the push happens at entry and the call that fills one may + be inside a branch that never runs — runtime/flan_dyn.h says a rooted slot + holding 0 is not a value. *) + let nroots = dyn_roots fn in + if nroots > 0 then begin + let nparams = List.length fn.Tast.params in + let pushed = ref [] in + Array.iteri + (fun i t -> + if t = Types.Dyn then begin + (* A parameter's slot was filled from [%pN] a few lines above and + must not be zeroed over the top of it. Every other slot holds + whatever the stack held until its binding runs, and the binding + may be inside a branch that does not. *) + if i >= nparams then + Buffer.add_string f.allocas + (Printf.sprintf " store i64 0, ptr %s\n" f.slots.(i)); + pushed := f.slots.(i) :: !pushed + end) + fn.Tast.slots; + let ntemps = nroots - List.length !pushed in + let temps = + List.init ntemps (fun i -> + let name = Printf.sprintf "%%dr%d" i in + Buffer.add_string f.allocas (Printf.sprintf " %s = alloca i64\n" name); + Buffer.add_string f.allocas + (Printf.sprintf " store i64 0, ptr %s\n" name); + name) + in + List.iter + (fun n -> + Buffer.add_string f.allocas + (Printf.sprintf " call void @flan_dyn_root_push(ptr %s)\n" n)) + (List.rev !pushed @ temps); + f.droots <- nroots; + f.droot_ns <- temps + end; (* The shadow stack's push, in the entry block, and the pop is at every [ret] (see [ret]). plan.org has had *Frames: shadow stack* in the dev column since the beginning; this is it, and it is dev-only, so a shipped @@ -2818,6 +2995,36 @@ declare i64 @flan_alloc_fail_align() declare i64 @flan_alloc_fail_id() declare i64 @flan_alloc_budget(ptr) declare void @flan_alloc_set_budget(ptr, i64) +; The dynamic runtime, runtime/flan_dyn.h. A flan_dyn is one machine word and +; is spelled i64 here because the typedef says uint64_t; nothing in this file +; ever looks inside one, so every operation on a dyn value is one of these. +declare i64 @flan_dyn_nil() +declare i64 @flan_dyn_from_i64(i64) +declare i64 @flan_dyn_from_f64(double) +declare i64 @flan_dyn_from_bool(i32) +declare i64 @flan_dyn_from_bytes(ptr, i64) +declare i64 @flan_dyn_vec_new() +declare i64 @flan_dyn_add(i64, i64) +declare i64 @flan_dyn_sub(i64, i64) +declare i64 @flan_dyn_mul(i64, i64) +declare i64 @flan_dyn_div(i64, i64) +declare i64 @flan_dyn_rem(i64, i64) +declare i64 @flan_dyn_lt(i64, i64) +declare i64 @flan_dyn_le(i64, i64) +declare i64 @flan_dyn_gt(i64, i64) +declare i64 @flan_dyn_ge(i64, i64) +declare i64 @flan_dyn_eq(i64, i64) +declare i64 @flan_dyn_len(i64) +declare i64 @flan_dyn_at(i64, i64) +declare void @flan_dyn_set_at(i64, i64, i64) +declare void @flan_dyn_push(i64, i64) +declare void @flan_dyn_print(i64) +declare i64 @flan_dyn_need_i64(i64) +declare double @flan_dyn_need_f64(i64) +declare i32 @flan_dyn_need_bool(i64) +declare void @flan_dyn_root_push(ptr) +declare void @flan_dyn_root_pop(i64) +declare void @flan_gc_init() declare void @flan_dev_reg_enable() declare void @flan_dev_reg_note_vec(ptr, i64, ptr, i64) declare void @flan_dev_reg_note_map(ptr, i64, i64, ptr, i64) @@ -2879,14 +3086,53 @@ declare i64 @flan_file_fail_reason() declare i8 @flan_slurp_into(ptr, ptr, i64, i64, ptr, i64) |} +(* Whether the program has a dyn in it anywhere, which is the one question + [main] asks before calling [flan_gc_init]. Asked of the whole program rather + than assumed, so that a program with no dyn emits no call and its [main] is + byte for byte the [main] it was before any of this existed. + + Every shape a dyn can take is one of these: a global of that type, a + signature that mentions it, a slot that holds one, or an expression that + produces one. *) +let uses_dyn (p : Tast.program) = + let found = ref false in + let note t = if t = Types.Dyn then found := true in + List.iter (fun (g : Tast.global) -> note g.Tast.gty) p.Tast.globals; + List.iter + (fun (fn : Tast.fn) -> + List.iter note fn.Tast.params; + note fn.Tast.ret; + Array.iter note fn.Tast.slots; + List.iter (Tast.walk (fun (e : Tast.expr) -> note e.Tast.ty)) fn.Tast.body) + p.Tast.fns; + !found + (* C's main, adapting to whichever of the four shapes Flan's main has: argv and the i32 status are each optional (plan.org, Milestone-2 primitives). *) -let emit_main m ?(startup = false) (fn : Tast.fn) = +let emit_main m ?(startup = false) ?(gc = false) ?(dyn_globals = []) (fn : Tast.fn) = let b = Buffer.create 256 in Buffer.add_string b (Printf.sprintf "\ndefine i32 @main(i32 %%argc, ptr %%argv)%s {\nentry:\n" (attrs m)); Buffer.add_string b " call void @flan_rt_init(i32 %argc, ptr %argv)\n"; + (* Immediately after the host runtime and before anything that could box: a + dyn global's initialiser runs in the startup function below, and the very + first thing it does is allocate. *) + if gc then Buffer.add_string b " call void @flan_gc_init()\n"; + (* The dyn globals, rooted here and never popped, which is the whole of what + a global's extent means. They go on the stack *before* the startup + function runs, because that function is what fills them and its first + allocation may be the one that collects — and before any of it pushes a + root of its own, because every pop in the program takes the top of the + stack and these are the ones that must never be at the top. + + Zero is what a global holds until its initialiser has run: BSS gives that + for free, and runtime/flan_dyn.h says a rooted slot holding 0 is not a + value. *) + List.iter + (fun g -> Buffer.add_string b + (Printf.sprintf " call void @flan_dyn_root_push(ptr %s)\n" (gname g))) + dyn_globals; (* The program's own end of the transfer channel. Nothing can be transferring when [main] returns: a restart is found by name on the restart stack, and an [invoke-restart] that finds none fails at the invoke site rather than @@ -3191,7 +3437,14 @@ let program ?(checks = true) ?(dev = false) ?(debug = false) ?(pnames = []) p.Tast.fns; let startup = emit_startup m ~hidden p.Tast.globals in (match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = "main") p.Tast.fns with - | Some fn -> emit_main m ~startup fn + | Some fn -> + emit_main m ~startup ~gc:(uses_dyn p) + ~dyn_globals: + (List.filter_map + (fun (g : Tast.global) -> + if g.Tast.gty = Types.Dyn then Some g.Tast.gname else None) + p.Tast.globals) + fn (* A program with no [main] is linked into a C host that brings its own entry point, and then nothing calls the startup function — which is why the constant image is a constant image on both backends and not a diff --git a/lib/js.ml b/lib/js.ml index c2c8922..018977b 100644 --- a/lib/js.ml +++ b/lib/js.ml @@ -235,6 +235,16 @@ let rec refuse_ty loc (t : Types.t) = "(Map K V) is not in the JS dialect yet — Odin's open-addressed map is a \ type-erased runtime over raw bytes and the JS answer is a Map keyed by \ a structural key, which is its own lane" + (* The irony is not lost: JavaScript is the one target where a dyn value + needs no boxing at all, because every value there is already one. What is + missing is not the representation but the lowering — dyn ops are calls + into runtime/flan_dyn.h, and this dialect has no such runtime. It is a + lane, not a difficulty. *) + | Types.Dyn -> + at loc + "dyn is not in the JS dialect yet — every JavaScript value is already \ + dynamic, so this is a matter of lowering the dyn operations onto the \ + host's own, and that work has not been done" | Types.Var n -> at loc "a type variable (%s) reached the backend, which cannot happen" n diff --git a/lib/load.ml b/lib/load.ml index e95b073..aadf66a 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -302,6 +302,20 @@ and rename_place owned alias bound (p : Ast.place) : Ast.place = let rename_field owned alias (f : Ast.field) : Ast.field = { f with Ast.fty = rename_texpr owned alias f.Ast.fty } +(* An unpaired parameter vector, qualified. The slots are still undecided here + — [Check] is what pairs them — so a bare symbol might be a parameter's name + or a type's, and this cannot tell. It does not have to: [owned] holds the + package's *declared* names, a parameter's name is not one of them, and a + parameter named after a type of the same package is refused outright when + the vector is paired. So qualifying every owned name and leaving every other + alone is right for both readings, and stays right because that refusal is + what keeps the two sets apart. *) +let rename_pitem owned alias (p : Ast.pitem) : Ast.pitem = + match p with + | Ast.Pname (n, loc) when List.mem n owned -> Ast.Pname (qualify alias n, loc) + | Ast.Pname _ -> p + | Ast.Ptype t -> Ast.Ptype (rename_texpr owned alias t) + let qualify_decl owned alias (d : Ast.decl) : Ast.decl = let loc = d.Ast.dloc in let k = @@ -346,11 +360,26 @@ let qualify_decl owned alias (d : Ast.decl) : Ast.decl = | other -> other)) | Ast.Defn fn -> let params = List.map (rename_field owned alias) fn.Ast.params in - let bound = List.map (fun (p : Ast.field) -> p.Ast.fname) fn.Ast.params in + let praw = Option.map (List.map (rename_pitem owned alias)) fn.Ast.praw in + (* The names a body may shadow. With the vector still unpaired, every + bare symbol in it is a candidate — an owned one is a type and is + dropped, because it is a name the body should go on qualifying, and + what is left is the parameter names and at worst a type of some other + package, which no body of this one refers to as a value. *) + let bound = + match praw with + | Some items -> + List.filter_map + (function + | Ast.Pname (n, _) when not (List.mem n owned) -> Some n + | _ -> None) + items + | None -> List.map (fun (p : Ast.field) -> p.Ast.fname) fn.Ast.params + in Ast.Defn { fn with Ast.name = qualify alias fn.Ast.name; - params; + params; praw; ret = Option.map (rename_texpr owned alias) fn.Ast.ret; fbody = List.map (rename_expr owned alias bound) fn.Ast.fbody } | Ast.Package _ -> Ast.Package alias @@ -634,6 +663,16 @@ let decl_uses acc (d : Ast.decl) = let field (f : Ast.field) = texpr_uses acc f.Ast.fty in let fn (f : Ast.fn) = List.iter field f.Ast.params; + (* An unpaired vector names types too, and a bare symbol in it may be one. + Every such symbol is recorded as a use: a parameter's name recorded here + resolves to nothing and costs nothing, where a type's name left out + would drop a real dependency and the import would not be loaded. Over- + recording is the safe direction for a dependency set. *) + Option.iter + (List.iter (function + | Ast.Pname (n, loc) -> acc := (n, loc) :: !acc + | Ast.Ptype t -> texpr_uses acc t)) + f.Ast.praw; Option.iter (texpr_uses acc) f.Ast.ret; List.iter (expr_uses acc) f.Ast.fbody in diff --git a/lib/parse.ml b/lib/parse.ml index b1007c8..ab9d9d1 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -111,6 +111,29 @@ let rec fields (f : Form.t) (items : Form.t list) : Ast.field list = Loc.fail odd.loc "field %s has no type — these come in name/type pairs" (Form.to_string odd) +(* A [defn]'s parameter vector, left undecided — the long argument is beside + the [defn] case. A bare symbol could be either half of a pair and is carried + as one; everything else is a type by its shape alone, and is resolved now so + that a malformed type is still reported at the character that is wrong. + + [fields] applies [no_pattern] to the name half of each pair, and this cannot: + which half a slot is has not been decided. A map is the one shape that can be + settled here anyway — braces are not a type in any position ([texpr] refuses + them), so a map in this vector is a destructuring pattern and nothing else, + and it gets the sentence that says so rather than a complaint about map type + syntax. A bracket cannot be settled the same way, because [[a b]] is a + pattern in a name slot and a slice type in a type slot; one written in a name + slot comes back from [Check] as "a parameter's name was expected here", which + is true and is as close as this can get. *) +and pitems (items : Form.t list) : Ast.pitem list = + List.map + (fun (it : Form.t) -> + match it.v with + | Sym s -> Ast.Pname (s, it.loc) + | Map _ -> no_pattern it; assert false + | _ -> Ast.Ptype (texpr it)) + items + (* ── The constraint map at the head of a defn body ────────────────────── [(defn sort [s [$t]] () {:where (ordered? $t)} body ...)]. Clojure's [{:pre [...] :post [...]}] is the precedent and the reason it is a map @@ -914,7 +937,47 @@ let rec decl (f : Form.t) : Ast.decl = Mandatory removes the guess: nothing is consulted, [()] is what a function that returns nothing writes, and a mistyped type is a mistyped type -- [(defn f [] f65 0.0)] reaches the resolver's near-miss check and comes back - as *did you mean f64*, where it used to come back as an unknown name. *) + as *did you mean f64*, where it used to come back as an unknown name. + + The return slot stays mandatory now that parameters may be left + unannotated, and it is worth saying why the two do not move together. + Dynamic-by-default means a *parameter* with no type is [dyn]; the return + type could have been given the same rule, and was not, because the + ambiguity there has no syntactic resolution at all. [(defn f [] (Rune + {.code 65}) (bar))] is the case above: a capitalised head in a list is a + type application and also a struct literal -- see [Struct] in [expr] -- + and no rule separates them, so an optional return slot is a coin toss + between a type and the first form of a body. A parameter vector has no + such case: every slot in it is a name or a type and never an expression. + So [dyn] is written out in the return position, which costs one token and + keeps a decision this file paid for twice in one day. + + ── The parameter vector ────────────────────────────────────────────── + + [(defn f [x y])] is one parameter [x] of type [y], or two parameters [x] + and [y] of type [dyn], and which one it is depends on whether [y] names a + type. That is the lookup this comment's first half says was removed for + being brittle, and it is being asked for again -- so it is not done here. + The vector is carried undecided, as [Ast.pitem]s, and paired in [Check], + where the set of type names is complete. + + The move is not cosmetic. What the old rule got wrong was consulting a set + that was not finished being built: it ran per-file, at parse time, before + macros had generated their definitions, and macros generating definitions + is exactly what widened the failure. By the time [Check] pairs the vector, + every file is loaded, every macro has expanded and every C header has been + imported, so the set is not a guess about what might be a type -- it is + the types. That is strictly more than the parser could ever know, and it + is the whole of the argument for the placement. + + What deferring does not buy is immunity. The set is complete at a point in + time and not across time: [(defn f [x y] ...)] is two dyn parameters until + somebody writes [(defstruct y ...)] or imports a header that declares one, + and then it is one parameter of type [y], with no edit to [f]. The + signature changes under it. That residual is real, it is the dictated + rule's and not this file's, and [Session.compatible] is where it is felt -- + a redefinition that changes a signature is refused there, and this is a + way for a signature to change with nothing redefined. *) | List ({ v = Sym "defn"; _ } :: args) -> (match args with | n :: { v = Vec ps; _ } :: ret :: body -> @@ -930,7 +993,7 @@ let rec decl (f : Form.t) : Ast.decl = function that returns nothing writes ()" msg in let fwhere, body = constraints body in - mk (Ast.Defn { Ast.name = sym n; params = fields f ps; + mk (Ast.Defn { Ast.name = sym n; params = []; praw = Some (pitems ps); ret = Some rty; fwhere; fbody = body_of body; nloc = n.loc }) | _ -> @@ -961,10 +1024,10 @@ let rec decl (f : Form.t) : Ast.decl = | { v = Str csym; _ } :: rest -> (match List.rev rest with | [ n; { v = Form.Vec ps; _ } ] -> - mk (mkd { Ast.name = sym n; params = fields f ps; + mk (mkd { Ast.name = sym n; params = fields f ps; praw = None; ret = None; fwhere = []; fbody = []; nloc = n.loc } csym) | [ n; { v = Form.Vec ps; _ }; r ] -> - mk (mkd { Ast.name = sym n; params = fields f ps; + mk (mkd { Ast.name = sym n; params = fields f ps; praw = None; ret = Some (texpr r); fwhere = []; fbody = []; nloc = n.loc } csym) | _ -> fail f "%s" usage) @@ -1140,6 +1203,10 @@ let rec decl (f : Form.t) : Ast.decl = params = [ { Ast.fname = sym p; fty = { Ast.t = Ast.Tslice form_t; tloc = p.loc }; floc = p.loc } ]; + (* Written out, not deferred: a macro takes [[Form]] and + returns a [Form], and neither half of that is the user's to + leave off. *) + praw = None; ret = Some form_t; fwhere = []; fbody = body_of body; nloc = n.loc }) | _ :: { v = Form.Vec ps; _ } :: body when body <> [] -> diff --git a/lib/render.ml b/lib/render.ml index ae5a47d..c0022a3 100644 --- a/lib/render.ml +++ b/lib/render.ml @@ -352,5 +352,18 @@ let rec render c depth (e : Tast.expr) : Tast.expr list = (Tast.While (cond, lit " " :: render c (depth + 1) elem, [ step ])); lit "]" ])) ] + (* The one type this walk does not walk. Every other arm is here because a + Flan value carries no header and only the compiler knows what it is; a + dyn value is the exact opposite — the runtime knows and the compiler + does not — so the printing belongs on the side that can see the tag, and + the walk hands the whole value over. + + The cost is that it writes to stdout itself rather than through + [c.emit], so a dyn printed at the REPL arrives on the program's output + and not in the REPL's buffer. Fixing that means an emit-shaped dyn + printer in the runtime — a second entry point taking the sink — and it + is not milestone 1's. *) + | Types.Dyn -> + [ unit_ (Tast.Prim (Tast.Rt "flan_dyn_print", [ e ])) ] | t -> fail loc "no printer for %s" (Types.to_string t) diff --git a/lib/types.ml b/lib/types.ml index 6c93489..a780fa2 100644 --- a/lib/types.ml +++ b/lib/types.ml @@ -47,6 +47,17 @@ type t = | Option of t (* (Option T) *) | Fn of t list * t (* (Fn [T ...] R) *) | Var of string (* a type variable — milestone 5 *) + (* [dyn]: one machine word whose contents the runtime knows and this module + does not. It is a written type — [(defvar x dyn 5)] boxes the 5 — and it + is also what an unannotated [defn] parameter means, which is why it is a + case here and not a Named type the prelude declares: the checker has to + recognise it to choose the boxing and the dyn op lowering, and a name in a + table cannot be matched on. + + Nothing about the representation is stated here on purpose. The word is + opaque to the compiler — runtime/flan_dyn.h owns which bits are a tag — + so that milestone 2 can change the encoding without touching Emit. *) + | Dyn let signed = function | I8 | I16 | I32 | I64 -> true @@ -72,7 +83,7 @@ let fkind_of_name = function is spelled [()] in source, and [Parse.texpr] refuses the word. *) let primitive_names = [ "i8"; "i16"; "i32"; "i64"; "u8"; "u16"; "u32"; "u64"; - "f32"; "f64"; "bool"; "string"; "Unit"; "Never"; "Allocator" ] + "f32"; "f64"; "bool"; "string"; "dyn"; "Unit"; "Never"; "Allocator" ] let ikind_name k = (if signed k then "i" else "u") ^ string_of_int (bits k) @@ -86,7 +97,11 @@ let rec equal a b = match a, b with | Int x, Int y -> x = y | Float x, Float y -> x = y - | Bool, Bool | String, String | Unit, Unit | Never, Never -> true + (* [Dyn] is equal to itself and to nothing else. Two dyn values may hold + different things at run time, which is the point of the type and is not + this function's question: this is identity of *static* types, and there is + one dyn type the way there is one string type. *) + | Bool, Bool | String, String | Unit, Unit | Never, Never | Dyn, Dyn -> true | Named x, Named y | Enum x, Enum y -> String.equal x y | Slice x, Slice y -> equal x y | Array (n, x), Array (m, y) -> Int64.equal n m && equal x y @@ -121,6 +136,7 @@ let rec to_string = function Printf.sprintf "(Fn [%s] %s)" (String.concat " " (List.map to_string ps)) (to_string r) | Var n -> n + | Dyn -> "dyn" let is_numeric = function Int _ | Float _ -> true | _ -> false diff --git a/lib/x86.ml b/lib/x86.ml index 008ed21..9053482 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -475,6 +475,23 @@ let is_agg (t : Types.t) = | Types.Unit | Types.Never -> false | Types.String | Types.Slice _ | Types.Array _ | Types.Map _ | Types.Vec _ | Types.Option _ | Types.Named _ -> true + (* Refused by name rather than classified. A dyn word is one machine word and + would classify trivially — it is not the representation that is missing, + it is every operation on it, which is a call into runtime/flan_dyn.h that + this backend does not emit. Saying "a dyn value" here rather than letting + it through to fail at the first [+] means the reader is told the one true + thing about their program instead of something about an opcode. + + The sentence naming [--llvm] is not written here on purpose: both callers + add it, and each says it differently for a good reason — Session because + the daemon takes this backend by default and the reader chose a program + rather than a code generator, and main.ml only when [--x86] was not typed + out. Repeating it here would say it twice to the one reader and to the + wrong one. *) + | Types.Dyn -> + unsupported + "a dyn value. Every operation on one is a call into the dynamic runtime, \ + and this backend emits none of them" | Types.Var v -> unsupported "type variable %s" v let is_void (t : Types.t) = match t with Types.Unit | Types.Never -> true | _ -> false diff --git a/mix b/mix new file mode 100755 index 0000000..362c28d Binary files /dev/null and b/mix differ diff --git a/raylib-imported b/raylib-imported new file mode 100755 index 0000000..ab898b2 Binary files /dev/null and b/raylib-imported differ diff --git a/runtime/flan_dyn_stub.c b/runtime/flan_dyn_stub.c new file mode 100644 index 0000000..779f49f --- /dev/null +++ b/runtime/flan_dyn_stub.c @@ -0,0 +1,326 @@ +/* flan_dyn_stub — a standing-in implementation of the flan_dyn.h ABI. + * + * THE MERGE REPLACES THIS FILE WITH runtime/flan_dyn.c. It exists so that the + * compiler side of dynamic-by-default can be built and run against the fixed + * ABI before the real runtime lands; the real one is being written in parallel + * against the same header, and flan_dyn.h is the contract the two are diffed + * against. + * + * What it is not: it mallocs and never frees, it collects nothing, and + * flan_dyn_root_push / flan_dyn_root_pop record their arguments and do nothing + * with them. That last point matters for anyone reading a passing test here — + * root emission is *not* exercised by this file. A program with entirely wrong + * root discipline passes every test that runs against this stub. The check + * that does bite is the one over the emitted IR, counting pushes against pops + * per function; see the acceptance tests. + * + * The representation is the simplest thing that satisfies the header's rule + * that the word is opaque: every value is a pointer to a heap cell, including + * the small ones. The real runtime will not do this. + */ + +#include +#include +#include +#include +#include + +/* The compiler carries this file as one string with flan_dyn.h pasted in front + * of it (lib/dune), and in that form there is no header on disk to find. The + * probe keeps the file compilable both ways: standalone against the real + * header, and concatenated, where the declarations are already above. The + * header's own include guard makes the two agree. */ +#if defined(__has_include) +# if __has_include("flan_dyn.h") +# include "flan_dyn.h" +# endif +#endif + +/* flan_rt.c's own [rt_trap] is static, so this mirrors it rather than calling + * it: print the sentence, offer the name to the dev daemon's hook, and leave + * with flan_rt's exit code so that a dyn trap is indistinguishable from any + * other trap to whoever is watching. The hook is flan_rt.c's global, and a + * program links both files. */ +extern void (*flan_trap_hook)(const uint8_t *name, int64_t namelen); + +static _Noreturn void dyn_trap(const char *name, const char *sentence) { + fflush(stdout); + fprintf(stderr, "%s\n", sentence); + fflush(stderr); + if (flan_trap_hook != NULL) + flan_trap_hook((const uint8_t *)name, (int64_t)strlen(name)); + _exit(134); +} + +enum tag { T_NIL, T_I64, T_F64, T_BOOL, T_STR, T_VEC }; + +typedef struct cell { + enum tag tag; + union { + int64_t i; + double f; + int32_t b; + struct { uint8_t *ptr; int64_t len; } s; + struct { struct cell **items; int64_t len, cap; } v; + } u; +} cell; + +static cell *alloc(enum tag t) { + cell *c = calloc(1, sizeof *c); + if (c == NULL) dyn_trap("OutOfMemory", "the dyn runtime could not allocate"); + c->tag = t; + return c; +} + +static cell *as(flan_dyn d) { return (cell *)(uintptr_t)d; } +static flan_dyn word(cell *c) { return (flan_dyn)(uintptr_t)c; } + +/* ── Construction ──────────────────────────────────────────────────── */ + +flan_dyn flan_dyn_nil(void) { return word(alloc(T_NIL)); } + +flan_dyn flan_dyn_from_i64(int64_t v) { + cell *c = alloc(T_I64); c->u.i = v; return word(c); +} + +flan_dyn flan_dyn_from_f64(double v) { + cell *c = alloc(T_F64); c->u.f = v; return word(c); +} + +flan_dyn flan_dyn_from_bool(int32_t v) { + cell *c = alloc(T_BOOL); c->u.b = (v != 0); return word(c); +} + +flan_dyn flan_dyn_from_bytes(const uint8_t *ptr, int64_t len) { + cell *c = alloc(T_STR); + c->u.s.ptr = malloc((size_t)len + 1); + if (c->u.s.ptr == NULL) dyn_trap("OutOfMemory", "the dyn runtime could not allocate"); + if (len > 0) memcpy(c->u.s.ptr, ptr, (size_t)len); + c->u.s.ptr[len] = 0; + c->u.s.len = len; + return word(c); +} + +flan_dyn flan_dyn_vec_new(void) { + cell *c = alloc(T_VEC); + c->u.v.cap = 8; + c->u.v.items = calloc((size_t)c->u.v.cap, sizeof(cell *)); + if (c->u.v.items == NULL) dyn_trap("OutOfMemory", "the dyn runtime could not allocate"); + return word(c); +} + +/* ── Arithmetic ────────────────────────────────────────────────────── */ + +/* Two numbers promote to f64 when either is one, which is the rule a reader + * expects of a dynamic language and is not the rule the typed language uses. + * The typed language has no implicit widening at all; here there is no + * annotation to have been written, so refusing would leave (+ 1 2.5) with no + * spelling that works. */ +static int numeric(cell *c) { return c->tag == T_I64 || c->tag == T_F64; } +static double as_f(cell *c) { return c->tag == T_I64 ? (double)c->u.i : c->u.f; } + +static flan_dyn arith(flan_dyn a, flan_dyn b, char op) { + cell *x = as(a), *y = as(b); + if (!numeric(x) || !numeric(y)) dyn_trap("DynArithType", "this arithmetic needs two numbers, and one of the two values is not one"); + if (x->tag == T_I64 && y->tag == T_I64) { + int64_t p = x->u.i, q = y->u.i, r = 0; + switch (op) { + case '+': r = p + q; break; + case '-': r = p - q; break; + case '*': r = p * q; break; + case '/': if (q == 0) dyn_trap("DivideByZero", "division by zero"); r = p / q; break; + case '%': if (q == 0) dyn_trap("DivideByZero", "division by zero"); r = p % q; break; + } + return flan_dyn_from_i64(r); + } + { + double p = as_f(x), q = as_f(y), r = 0; + switch (op) { + case '+': r = p + q; break; + case '-': r = p - q; break; + case '*': r = p * q; break; + case '/': r = p / q; break; + /* fmod without math.h, to keep the stub's link line as short as the + * real runtime's is meant to be. */ + case '%': r = p - q * (double)(int64_t)(p / q); break; + } + return flan_dyn_from_f64(r); + } +} + +flan_dyn flan_dyn_add(flan_dyn a, flan_dyn b) { return arith(a, b, '+'); } +flan_dyn flan_dyn_sub(flan_dyn a, flan_dyn b) { return arith(a, b, '-'); } +flan_dyn flan_dyn_mul(flan_dyn a, flan_dyn b) { return arith(a, b, '*'); } +flan_dyn flan_dyn_div(flan_dyn a, flan_dyn b) { return arith(a, b, '/'); } +flan_dyn flan_dyn_rem(flan_dyn a, flan_dyn b) { return arith(a, b, '%'); } + +/* ── Ordering and equality ─────────────────────────────────────────── */ + +static int cmp(flan_dyn a, flan_dyn b) { + cell *x = as(a), *y = as(b); + if (x->tag == T_STR && y->tag == T_STR) { + int64_t n = x->u.s.len < y->u.s.len ? x->u.s.len : y->u.s.len; + int r = memcmp(x->u.s.ptr, y->u.s.ptr, (size_t)n); + if (r != 0) return r < 0 ? -1 : 1; + return x->u.s.len == y->u.s.len ? 0 : (x->u.s.len < y->u.s.len ? -1 : 1); + } + if (!numeric(x) || !numeric(y)) dyn_trap("DynCompareType", "these two values have no ordering between them"); + if (x->tag == T_I64 && y->tag == T_I64) + return x->u.i == y->u.i ? 0 : (x->u.i < y->u.i ? -1 : 1); + { + double p = as_f(x), q = as_f(y); + return p == q ? 0 : (p < q ? -1 : 1); + } +} + +flan_dyn flan_dyn_lt(flan_dyn a, flan_dyn b) { return flan_dyn_from_bool(cmp(a, b) < 0); } +flan_dyn flan_dyn_le(flan_dyn a, flan_dyn b) { return flan_dyn_from_bool(cmp(a, b) <= 0); } +flan_dyn flan_dyn_gt(flan_dyn a, flan_dyn b) { return flan_dyn_from_bool(cmp(a, b) > 0); } +flan_dyn flan_dyn_ge(flan_dyn a, flan_dyn b) { return flan_dyn_from_bool(cmp(a, b) >= 0); } + +/* Structural, and never traps — the header's one exception. */ +static int eq(cell *x, cell *y) { + if (numeric(x) && numeric(y)) { + if (x->tag == T_I64 && y->tag == T_I64) return x->u.i == y->u.i; + return as_f(x) == as_f(y); + } + if (x->tag != y->tag) return 0; + switch (x->tag) { + case T_NIL: return 1; + case T_BOOL: return x->u.b == y->u.b; + case T_STR: return x->u.s.len == y->u.s.len + && memcmp(x->u.s.ptr, y->u.s.ptr, (size_t)x->u.s.len) == 0; + case T_VEC: { + if (x->u.v.len != y->u.v.len) return 0; + for (int64_t i = 0; i < x->u.v.len; i++) + if (!eq(x->u.v.items[i], y->u.v.items[i])) return 0; + return 1; + } + default: return 0; + } +} + +flan_dyn flan_dyn_eq(flan_dyn a, flan_dyn b) { + return flan_dyn_from_bool(eq(as(a), as(b))); +} + +/* ── Containers ────────────────────────────────────────────────────── */ + +static cell *need_vec(flan_dyn v) { + cell *c = as(v); + if (c->tag != T_VEC) dyn_trap("DynNotAVec", "this value is not a vector, so it has no elements"); + return c; +} + +static int64_t need_index(flan_dyn i) { + cell *c = as(i); + if (c->tag != T_I64) dyn_trap("DynIndexType", "an index must be an integer"); + return c->u.i; +} + +flan_dyn flan_dyn_len(flan_dyn v) { + cell *c = as(v); + if (c->tag == T_STR) return flan_dyn_from_i64(c->u.s.len); + return flan_dyn_from_i64(need_vec(v)->u.v.len); +} + +flan_dyn flan_dyn_at(flan_dyn v, flan_dyn i) { + cell *c = need_vec(v); + int64_t k = need_index(i); + if (k < 0 || k >= c->u.v.len) dyn_trap("Bounds", "index out of bounds"); + return word(c->u.v.items[k]); +} + +void flan_dyn_set_at(flan_dyn v, flan_dyn i, flan_dyn x) { + cell *c = need_vec(v); + int64_t k = need_index(i); + if (k < 0 || k >= c->u.v.len) dyn_trap("Bounds", "index out of bounds"); + c->u.v.items[k] = as(x); +} + +void flan_dyn_push(flan_dyn v, flan_dyn x) { + cell *c = need_vec(v); + if (c->u.v.len == c->u.v.cap) { + int64_t cap = c->u.v.cap * 2; + cell **items = realloc(c->u.v.items, (size_t)cap * sizeof(cell *)); + if (items == NULL) dyn_trap("OutOfMemory", "the dyn runtime could not allocate"); + c->u.v.items = items; + c->u.v.cap = cap; + } + c->u.v.items[c->u.v.len++] = as(x); +} + +static void print_cell(cell *c) { + switch (c->tag) { + case T_NIL: fputs("nil", stdout); break; + case T_I64: printf("%lld", (long long)c->u.i); break; + /* %g, so that a whole-numbered f64 does not print as an i64 would and + * the two remain distinguishable in a test's expected output. */ + case T_F64: printf("%g", c->u.f); break; + case T_BOOL: fputs(c->u.b ? "true" : "false", stdout); break; + case T_STR: printf("%.*s", (int)c->u.s.len, (const char *)c->u.s.ptr); break; + case T_VEC: + fputc('[', stdout); + for (int64_t i = 0; i < c->u.v.len; i++) { + if (i > 0) fputc(' ', stdout); + print_cell(c->u.v.items[i]); + } + fputc(']', stdout); + break; + } +} + +void flan_dyn_print(flan_dyn v) { print_cell(as(v)); } + +/* ── Extraction ────────────────────────────────────────────────────── */ + +int64_t flan_dyn_need_i64(flan_dyn v) { + cell *c = as(v); + if (c->tag != T_I64) dyn_trap("DynExpectedI64", "this value was required to be an i64 and is not"); + return c->u.i; +} + +double flan_dyn_need_f64(flan_dyn v) { + cell *c = as(v); + /* An i64 satisfies an f64 slot, because a dyn integer literal is an i64 by + * the header's rule and (defvar x f64 (f 1)) would otherwise be unwritable + * for any f returning dyn. The reverse is not true: f64 to i64 loses. */ + if (c->tag == T_I64) return (double)c->u.i; + if (c->tag != T_F64) dyn_trap("DynExpectedF64", "this value was required to be an f64 and is not"); + return c->u.f; +} + +int32_t flan_dyn_need_bool(flan_dyn v) { + cell *c = as(v); + if (c->tag != T_BOOL) dyn_trap("DynExpectedBool", "this value was required to be a bool and is not"); + return c->u.b; +} + +/* ── Roots ───────────────────────────────────────────────────────────── + * + * Recorded and otherwise ignored. The shadow stack is kept, and its depth + * checked against the pops, only so that a badly unbalanced emission fails + * loudly here rather than silently: an over-pop is a compiler bug worth + * dying on even in a stub that collects nothing. Under-pushing is invisible, + * and stays invisible until the real collector lands. */ + +static flan_dyn **roots = NULL; +static int64_t roots_len = 0, roots_cap = 0; + +void flan_dyn_root_push(flan_dyn *slot) { + if (roots_len == roots_cap) { + int64_t cap = roots_cap == 0 ? 64 : roots_cap * 2; + flan_dyn **r = realloc(roots, (size_t)cap * sizeof(flan_dyn *)); + if (r == NULL) dyn_trap("OutOfMemory", "the dyn runtime could not allocate"); + roots = r; + roots_cap = cap; + } + roots[roots_len++] = slot; +} + +void flan_dyn_root_pop(int64_t n) { + if (n < 0 || n > roots_len) dyn_trap("DynRootUnderflow", "the dyn root stack was popped further than it was pushed - a compiler bug"); + roots_len -= n; +} + +void flan_gc_init(void) { /* nothing to initialise: this stub never collects */ } diff --git a/spike/x86/survey.sh b/spike/x86/survey.sh index 85ac83d..1b2cc7d 100755 --- a/spike/x86/survey.sh +++ b/spike/x86/survey.sh @@ -78,6 +78,15 @@ out=$(mktemp -d); trap 'rm -rf "$out"' EXIT # truncations are both empty. forever="dev-loop dev-watch dev-chatty" +# The dyn programs, which this backend refuses by name and is meant to: every +# operation on a dyn value is a call into the dynamic runtime and x86.ml emits +# none of them. They are listed rather than left to be counted as refusals +# because a REFUSED here means "a node this backend has stopped lowering", +# which is a regression, and this is the opposite -- a lane that has not +# started. Take a name off this list when the backend grows the lowering, and +# the survey will say whether it works. +llvmonly="dyn-basic dyn-vec dyn-global dyn-boundary dyn-defer" + TIMEOUT=${TIMEOUT:-20} # Extra flags, given to *both* sides. SURVEY_FLAGS=--dev is the one that has a @@ -101,6 +110,7 @@ for src in "$corpus"/test/programs/*.flan "$corpus"/spike/x86/*.flan \ [ $want = 1 ] || continue fi case " $forever " in *" $name "*) skip+=("$name:runs-forever"); continue;; esac + case " $llvmonly " in *" $name "*) skip+=("$name:dyn-is-llvm-only"); continue;; esac # LLVM first. A program that does not compile at all, or has no main, is not # this backend's business -- the frontend refused it either way. diff --git a/test/programs/dyn-basic.flan b/test/programs/dyn-basic.flan new file mode 100644 index 0000000..bbce010 --- /dev/null +++ b/test/programs/dyn-basic.flan @@ -0,0 +1,15 @@ +;;;; An unannotated defn, called at two different types. +;;;; +;;;; [(defn add [x y] dyn (+ x y))] states no type for either parameter, so both +;;;; are dyn, and the + in the body is the dyn one: a call into the runtime that +;;;; decides on what the two words actually hold. The same function serves the +;;;; integer call and the float call, which is the whole of what the feature +;;;; buys and is not something the typed language could express at all. + +(defn add [x y] dyn (+ x y)) + +(defn main [] () + (print (add 2 3)) + (print "\n") + (print (add 1.5 2.25)) + (print "\n")) diff --git a/test/programs/dyn-boundary.flan b/test/programs/dyn-boundary.flan new file mode 100644 index 0000000..9556c0e --- /dev/null +++ b/test/programs/dyn-boundary.flan @@ -0,0 +1,42 @@ +;;;; The boundary in both directions, and the trap when a claim is wrong. +;;;; +;;;; Typed to dyn is implicit: take-dyn is called with an i64 and the boxing is +;;;; written nowhere. Dyn to typed is not: take-i64's parameter says i64, and +;;;; that annotation is the whole of why the unboxing is allowed to happen — +;;;; and the whole of why it may fail, which the last line of main proves by +;;;; handing it a float. +;;;; +;;;; A let carries no type in this language, so the annotation sites a dyn can +;;;; be unboxed at are the ones that do: a parameter, a return type, and a +;;;; global's declared type. All three are here. + +(defvar seven i64 7) +(defvar boxed dyn 21) +;; The other direction at a global: a dyn initialiser meeting a written type. +(defvar unboxed i64 boxed) + +(defn take-dyn [d dyn] dyn + (+ d 100)) + +(defn take-i64 [n i64] i64 + (* n 2)) + +(defn identity-dyn [d] dyn d) + +;; A dyn value answered at a written return type, which is the third site. +(defn as-i64 [d] i64 d) + +(defn main [] () + ;; Typed in: the i64 is boxed at the call with nothing written. + (print (take-dyn seven)) + (print "\n") + ;; Dyn out: the parameter is typed, so the word is unboxed at the call. + (print (take-i64 boxed)) + (print "\n") + (print unboxed) + (print "\n") + (print (as-i64 (identity-dyn 5))) + (print "\n") + ;; And the claim that is wrong. The runtime owns the message. + (print (take-i64 (identity-dyn 1.5))) + (print "\n")) diff --git a/test/programs/dyn-defer.flan b/test/programs/dyn-defer.flan new file mode 100644 index 0000000..af4e495 --- /dev/null +++ b/test/programs/dyn-defer.flan @@ -0,0 +1,28 @@ +;;;; A dyn value produced inside a defer, on a function a transfer leaves +;;;; through rather than returns from. +;;;; +;;;; This is here for the root count and not for the arithmetic. A defer appears +;;;; twice in the typed IR — spliced into the body for the normal path, and +;;;; again in fdefers for the path a handled condition unwinds along — so the +;;;; emitter produces two copies of every dyn temporary inside one. Counting +;;;; only the body left the second copy's temporaries in slots the collector had +;;;; never been told about: the pushes and the pops still balanced, so nothing +;;;; failed, and the values were simply invisible. +;;;; +;;;; Nothing the stub does can show that, because it never collects. What shows +;;;; it is the emitted IR — a fallback slot is spelled %dx and a rooted one %dr, +;;;; and the fix is the absence of the former. + +(defstruct Boom [n i64]) + +(defn inner [x] dyn + (defer (print (+ x 1000)) (print "\n")) + (restart-case + (error (Boom {.n 1})) + (give [] 0)) + (+ x 1)) + +(defn main [] () + (handler-bind [(Boom [b] (invoke-restart 'give))] + (print (inner 5)) + (print "\n"))) diff --git a/test/programs/dyn-global.flan b/test/programs/dyn-global.flan new file mode 100644 index 0000000..e16f16d --- /dev/null +++ b/test/programs/dyn-global.flan @@ -0,0 +1,21 @@ +;;;; A dyn global, which is the case that needs the startup function. +;;;; +;;;; A dyn value is made by a call into the runtime, and a call is not a +;;;; constant, so the initialiser cannot be a constant image the way a typed +;;;; global's is. It runs in flan..init-globals, which main calls after +;;;; flan_gc_init and before anything the programmer wrote — the same machinery +;;;; the computed globals already use, which is the point: a dyn global is a +;;;; computed global and needed no new mechanism. + +(defvar counter dyn 0) +(defvar label dyn "start") + +(defn bump [] () + (set counter (+ counter 1))) + +(defn main [] () + (print counter) (print " ") (print label) (print "\n") + (bump) + (bump) + (set label "done") + (print counter) (print " ") (print label) (print "\n")) diff --git a/test/programs/dyn-vec.flan b/test/programs/dyn-vec.flan new file mode 100644 index 0000000..6d74b5a --- /dev/null +++ b/test/programs/dyn-vec.flan @@ -0,0 +1,24 @@ +;;;; A container holding four different types at once. +;;;; +;;;; (vec-new dyn) is not a (Vec dyn) — it is the dyn runtime's own vector, and +;;;; its type is dyn like everything else the runtime hands back. That is what +;;;; lets push, at and len on it be the dyn operations rather than a +;;;; type-erased Vec over eight-byte elements, and it is why no allocator is +;;;; named: the storage is the collector's to walk. + +(defn main [] () + (let [xs (vec-new dyn)] + (push xs 1) + (push xs 2.5) + (push xs "three") + (push xs true) + (print (len xs)) + (print "\n") + (print xs) + (print "\n") + ;; Read back out one at a time, to show that at answers a dyn and that the + ;; four of them are still four different things. + (dotimes [i (len xs)] + (print (at xs i)) + (print " ")) + (print "\n"))) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 78aab49..b697342 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -2967,6 +2967,175 @@ level "1" outputs ~opt:"-O0" "unions, -O0" "programs/unions.flan" unions_out; outputs ~dev:true "unions, dev" "programs/unions.flan" unions_out; + (* ── dyn, milestone 1 ──────────────────────────────────────────── + Four programs, and between them every claim the feature makes that can + be run rather than argued. + + [dyn-basic] is the one the feature exists for: a defn that annotates + nothing, called at two types, answering correctly to both. Nothing the + typed language can express does that. + + [dyn-vec] is the heterogeneous container, which is where a dynamic + language stops being a convenience and starts being a different data + model — four types in one vector, read back out one at a time. + + [dyn-global] is the case that needed the startup function: a call is not + a constant, so a dyn global is a computed global, and it turned out to + need no new machinery at all. + + [dyn-boundary] is the one with a trap in it, and it is asserted on its + exit status and its message: the boundary is only interesting because it + can fail, and a test that only showed it working would be testing the + easy half. It is at -O2 and -O0 like the rest, because the unboxing is a + call whose result feeds a machine instruction and that is exactly the + shape the optimiser could launder away. + + They are LLVM-only, and the [@x86] survey skips them by name — see + [llvmonly] in spike/x86/survey.sh. Not compiled by the dev backend, so + not run as dev builds either. *) + let dyn_basic_out = "5\n3.75\n" in + outputs "dyn: an unannotated defn at two types" + "programs/dyn-basic.flan" dyn_basic_out; + outputs ~opt:"-O0" "dyn: an unannotated defn at two types, -O0" + "programs/dyn-basic.flan" dyn_basic_out; + let dyn_vec_out = "4\n[1 2.5 three true]\n1 2.5 three true \n" in + outputs "dyn: a heterogeneous vector" + "programs/dyn-vec.flan" dyn_vec_out; + outputs ~opt:"-O0" "dyn: a heterogeneous vector, -O0" + "programs/dyn-vec.flan" dyn_vec_out; + let dyn_global_out = "0 start\n2 done\n" in + outputs "dyn: a global" "programs/dyn-global.flan" dyn_global_out; + outputs ~opt:"-O0" "dyn: a global, -O0" + "programs/dyn-global.flan" dyn_global_out; + + (* The boundary, both directions, and then the claim that is wrong. The + first four lines are the conversions; the trap is the fifth, and the + runtime owns its wording — the compiler could only have said that two + dyns did not agree, which is what they are for. *) + let dyn_boundary ?opt () = + let exe = compile ?opt "programs/dyn-boundary.flan" in + let code, text = run exe None in + let want = "107\n42\n21\n5\n" in + let name = + "dyn: the boundary both ways, and the trap" + ^ (match opt with Some o -> ", " ^ o | None -> "") + in + if code <> 134 + || not (contains text want) + || not (contains text "required to be an i64") + then begin + incr failures; + Printf.printf + "FAIL %s\n got: %S (exit %d)\n wanted: %S then a trap \ + (exit 134)\n" + name text code want + end; + (try Sys.remove exe with Sys_error _ -> ()) + in + dyn_boundary (); + dyn_boundary ~opt:"-O0" (); + + (* The root count, which is the one part of this feature no run can check: + the stub never collects, so a program whose roots are entirely wrong + passes every test above. What can be checked is the IR, and this is the + assertion that found a real hole — a defer appears twice in the typed IR, + spliced into the body for the normal path and again in [fdefers] for the + path a transfer leaves through, so a dyn temporary inside one is emitted + twice. Counting only the body left the second copy unrooted, silently: + the pushes and the pops balanced because [dyn_tmp] falls back to a plain + slot rather than unbalancing them, and four dyn values were invisible. + + [%dr] is a rooted slot and [%dx] is the fallback, so the claim is that + the emitted IR contains none of the latter. It is worth stating as a + property of the whole corpus and not only of this file: any dyn program + that mints one has a temporary the collector cannot see. *) + let no_fallback_slots path = + let l = Load.program ~file:path (Reader.read_file path) in + let ir = Emit.program (Check.program_all l.Load.decls) in + if contains ir "%dx" then begin + incr failures; + Printf.printf + "FAIL %s emits an unrooted dyn temporary (%%dx) — dyn_roots counted \ + fewer than the emission minted\n" + path + end + in + List.iter no_fallback_slots + [ "programs/dyn-basic.flan"; "programs/dyn-vec.flan"; + "programs/dyn-global.flan"; "programs/dyn-boundary.flan"; + "programs/dyn-defer.flan" ]; + (* And that the defer program still runs and still runs its defer: the + count being right is not much use if the transfer path broke getting + there. 1005 is the defer, 6 is the value the restart produced. *) + outputs "dyn: a defer on the transfer path" "programs/dyn-defer.flan" + "1005\n6\n"; + outputs ~opt:"-O0" "dyn: a defer on the transfer path, -O0" + "programs/dyn-defer.flan" "1005\n6\n"; + + (* ── --no-gc ───────────────────────────────────────────────────── + The flag is a pass between checking and emission that answers unit or + refuses, and these are its two halves. + + Every dyn is named. Not the first one and then another compile: a reader + who has to annotate their program wants the list, which is why the pass + collects and raises [Loc.Errors] the way the global cycle refusal does. + Asserted on the count as well as on the text, because "it refused" would + pass just as well if it named one site and stopped. *) + let no_gc_sites path least = + let l = Load.program ~file:path (Reader.read_file path) in + let p = Check.program_all l.Load.decls in + match Check.no_gc p with + | () -> + incr failures; + Printf.printf "FAIL --no-gc on %s: it was accepted\n" path + | exception Loc.Errors ds -> + if List.length ds < least then begin + incr failures; + Printf.printf + "FAIL --no-gc on %s: named %d sites, wanted at least %d\n" + path (List.length ds) least + end; + List.iter + (fun (d : Loc.diag) -> + if not (contains d.Loc.dmsg "carries no collector") then begin + incr failures; + Printf.printf "FAIL --no-gc on %s: said %S\n" path d.Loc.dmsg + end) + ds + in + (* The vec file reports nine: a vec-new, four boxed pushes, a len, an at + and the dotimes bound. The floor is under that rather than equal to it + so an added line does not fail the test, and well over one so that a + pass which named the first site and stopped would. *) + no_gc_sites "programs/dyn-vec.flan" 8; + (* The global file reports nine too, and the point of it is the mix: two + [the global ...] sites and two [the return type of ...] ones, which a + walk over function bodies alone would never have found. *) + no_gc_sites "programs/dyn-global.flan" 6; + + (* The other half, and the reason the flag is a pass and not a parameter of + [Emit]: a program with nothing to refuse compiles to the same bytes with + the flag and without it. If [--no-gc] were ever plumbed into the emitter + — a field, a mode, a comment that mentioned it — this is what would + start failing, and it would fail on something incidental rather than on + anything to do with dyn. *) + let identical path = + let l = Load.program ~file:path (Reader.read_file path) in + let p = Check.program_all l.Load.decls in + let a = Emit.program p in + Check.no_gc p; + let b = Emit.program p in + if a <> b then begin + incr failures; + Printf.printf + "FAIL --no-gc changed the IR of %s (%d bytes vs %d)\n" + path (String.length a) (String.length b) + end + in + identical "programs/algorithms.flan"; + identical "programs/conditions.flan"; + identical "programs/unions.flan"; + (* The refusals, each by name. The first is the diagnostics bug NEXT.md listed and this lane fixed: a case name written as if it were a struct reported "unknown struct A", because nothing in the environment could diff --git a/test/test_flan.ml b/test/test_flan.ml index 5d46e1e..cd0041d 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -399,9 +399,15 @@ let () = | Arr [ _; _; _ ] -> () | _ -> check "array literal" false); (* ── Types: brackets mean different things by position ─────────── *) + (* Read out of [praw], not [params]: a defn's parameter vector is carried + undecided until Check pairs it, so the parser no longer fills [params] at + all. Every type spelled here is one the parser still resolves on sight — + brackets and lists are types by their shape whatever the environment says + — so [Ptype] is the shape under test and a [Pname] here would mean the + spelling stopped being recognised as a type. *) let ty src = match parse_decl (Printf.sprintf "(defn f [x %s] ())" src) with - | { d = Defn { params = [ { fty; _ } ]; _ }; _ } -> fty.t + | { d = Defn { praw = Some [ Pname ("x", _); Ptype t ]; _ }; _ } -> t.t | _ -> failwith "bad type test" in (match ty "[u8]" with Tslice _ -> () | _ -> check "[T] is a slice" false); @@ -421,7 +427,7 @@ let () = (* ── Declarations ──────────────────────────────────────────────── *) (match (parse_decl "(defn f [x i32] bool x)").d with - | Defn { ret = Some _; params = [ _ ]; fbody = [ _ ]; _ } -> () + | Defn { ret = Some _; praw = Some [ _; _ ]; fbody = [ _ ]; _ } -> () | _ -> check "defn with return type" false); (* () is the unit return type, and the body is what follows it. *) (match (parse_decl "(defn f [x i32] () (g x))").d with @@ -840,13 +846,73 @@ let () = rejects_check "a mistyped struct" "(defstruct Cursor [x i32]) (defn f [c Curser] ())" ~needle:"did you mean Cursor?"; - (* Nothing close: the type-variable rule still applies, and still names the - milestone. *) - rejects_check "a real type variable" "(defn f [x t] ())" + (* [(defn f [x t] ())] used to be one parameter of an unimplemented generic + type and is now two parameters of type dyn — a lowercase name resembling + no type is a parameter, which is the whole of dynamic-by-default. The + milestone-5 reading is still reachable, by writing the type variable with + the sigil the signature binds it with. *) + (match checked "(defn f [x t] ())" with + | p -> + (match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = "f") p.Tast.fns with + | Some { Tast.params = [ Types.Dyn; Types.Dyn ]; _ } -> () + | _ -> check "an unannotated pair is two dyn parameters" false) + | exception _ -> check "an unannotated pair is two dyn parameters" false); + (* A bare lowercase name is still an unimplemented type variable everywhere a + type is the only thing a slot can hold. A defn's parameter vector stopped + being such a place — a slot there may be a parameter instead — so the rule + is exercised where it still decides, at a field. *) + rejects_check "a real type variable" "(defstruct Holder [x elem])" ~needle:"milestone 5"; rejects_check "an unknown concrete type" "(defn f [x Widget] ())" ~needle:"unknown type Widget"; + (* ── dyn, and what it does not do yet ──────────────────────────── *) + + (* The pairing rule's own refusal. A name that is also a type's has no good + reading — taken as written it is a parameter called [i64] — and the + likelier intent is a pair the wrong way round, which the message names. *) + rejects_check "a parameter named after a type" "(defn f [i64 x] ())" + ~needle:"cannot also be this parameter's name"; + + (* The three "not yet" refusals, each by name and each for its own reason. + + A typed container does not box: [(Vec i64)] has a representation the dyn + runtime cannot walk, and the heterogeneous container at this milestone is + the runtime's own from [(vec-new dyn)]. *) + rejects_check "a typed container boxed into dyn" + "(defn take [d dyn] i32 1)\n\ + (defn main [] i32 (take [1 2 3]))" + ~needle:"does not cross into dyn yet"; + (* A condition crosses a handler boundary as a pointer to a live frame, and + a dyn payload has to stay rooted across that transfer — the collector's + question, and milestone 2's. *) + rejects_check "a dyn in a condition's payload" + "(defstruct Boom [what dyn])\n\ + (defn main [] () (signal (Boom {.what 1})))" + ~needle:"milestone 2"; + (* And the C boundary, which is the one that would otherwise pass silently: + a dyn is one word and would cross as an integer, and nothing on the other + side can ask what the word means. *) + rejects_check "a dyn crossing to C" + "(declare c-take [d dyn] () \"c_take\")" + ~needle:"does not cross to C"; + + (* The x86 backend refuses dyn by name, and the sentence has to be good: the + dev daemon takes that backend by default, so this is the first thing a + user of dyn sees. Neither half of the message names [--llvm] — Session and + main.ml each add that, differently and for their own reasons — so what is + pinned here is the half this file owns. *) + (match + X86.program ~checks:true + (Check.program_all + (program "(defn add [x y] dyn (+ x y))\n\ + (defn main [] () (print (add 1 2)))")) + with + | _ -> check "the x86 backend refuses dyn" false + | exception X86.Unsupported m -> + check "the x86 backend refuses dyn by name" + (contains m "a dyn value" && contains m "dynamic runtime")); + (* ── Static bounds ─────────────────────────────────────────────── *) (* A literal index into a fixed array is known now, so it is an error now rather than a trap later; everything else is the emitted bounds check's @@ -1327,7 +1393,7 @@ let () = defn's body that just answers one says nothing about them. *) rejects_check "an fn with nothing to say what it takes" "(defn f [] () (fn [x] x))" ~needle:"nothing here says what this fn"; - rejects_check "type variables are milestone 5" "(defn f [x a] ())" + rejects_check "type variables are milestone 5" "(defn f [] a 0)" ~needle:"milestone 5"; (* The other half: a name in value position now *works*, and the arity is checked against the function it names. *) diff --git a/test/test_session.ml b/test/test_session.ml index 8cc38fb..e32b55e 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -51,6 +51,20 @@ let () = refuses "a changed arity" "(defn outer [a i64 b i64] i64 (bump))" "changes signature"; + (* Dyn-ness is part of a signature like anything else, and this falls out of + [compatible] rather than being added to it: the comparison is + [Types.equal] over the parameters and the return, and dyn is equal to + itself and to nothing else. Pinned anyway, because it is the one place the + word "signature" covers a change the source does not spell out — the + return type here went from [i64] to [dyn] by being written differently, + and a parameter can change the same way by a *type* being declared + elsewhere in the program. *) + refuses "a return type that became dyn" + "(defn outer [] dyn (bump))" + "changes signature"; + refuses "a parameter that became dyn" + "(defn outer [x] i64 (bump))" + "changes signature"; (* The storage exists and has a shape: reusing it reads at the wrong offsets, and replacing it discards the state the reload exists to preserve. *) refuses "a retyped global"