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

Merge branch 'master' into worktree-agent-a26dff0627201f77b

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-26 12:07:11 +07:00
commit 5cc661d6ab
36 changed files with 1619 additions and 371 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
TODO.org
View File

@ -10,6 +10,15 @@ pointing at it. A CANCELLED entry carries the one-line reason, because an idea
rejected without a record is an idea that gets re-proposed.
* Language surface
** NEXT if let
Decided 2026-09-26 (126), Rust's spelling: =if let Some(g) = left= plus a block tests
the pattern and binds =g= in that block only; =elif=/=else= follow as for =if=. Any
=match= pattern may stand where =Some(g)= is. Reads to a two-arm =match=.
** NEXT when as a value, and get as a checked lookup
Decided 2026-09-26 (125): a =when= whose value is used gives =Option(T)=, =Some= of its
body when the test holds and =None= otherwise; as a statement it is unchanged.
=get(xs, i, …)= on an array, slice or Vec gives =Option(T)= instead of trapping on an
index out of range (negative included), one index per dimension. Both typed and dyn.
** NEXT str and String
Decided 2026-09-25: the typed read-only text is =str= (the rename from =string= is
@ -134,6 +143,14 @@ expansion that defines a macro re-runs the expander, in a build and in a session
no =,',x=, since =quote= takes a symbol, and a macro defined by an expansion is
not exported from a package. docs/BUILT.md, "Quasiquote runs before the walk".
** DONE Bit operators are && || ^^ ~~ in .fln (decision 123)
CLOSED: [2026-09-26]
Tighter than a comparison, looser than a shift, =&&= then =^^= then =||=
(Python and Rust), so =x && mask == 0= tests the masked bits. Integers only, a
bool refused toward =and=/=or=/=not=; a dyn shift count outside 0..63 traps.
=~~= is one token, so a nested .fln unquote is =~(~x)=; the paren reader keeps
=~~x= as unquote twice and reads =^^= as a name. Rules out C's precedence.
** DONE A form the prelude relies on is built in; a form only programs use is a macro
CLOSED: [2026-09-25]
=cond=, =when= and =dotimes= are special forms in parse.ml; =inc=, =++=, =into=,
@ -681,6 +698,10 @@ Decided 2026-09-26: lines indented under a ~let~ that are ~name = v~ or ~name: T
more bindings of the same let; anything else there stays refused. flan convert writes
consecutive lets this way.
** DONE .fln has no loop or recur (decision 122)
Rules out ~loop~/~recur~ anywhere the .fln reader reads, ~quote~ included; loops are
~while~/~until~/~dotimes~/~for~. The Lisp syntax and its macros' expansions keep them.
** TODO Hard-coded code in messages is still paren syntax in a .fln file
Types follow the code's syntax now (=Types.spell=). Hints written into a message's
text — =(Ptr %s)=, =(clone v)=, =(the T x)= in most of =check.ml= and =parse.ml=, the
@ -723,6 +744,9 @@ One spelling for one operation; != stays, and not= is refused with a suggestion
of !=.
* Checker
** TODO Checking a wide fold of let operands is slow
A 2000-operand (bit-and (let …) …) takes 32 s to check (37 s before the bit operators);
2000 plain names take 0.03 s. Something per operand is quadratic or worse.
** DONE A dyn value takes .field and [:key]
CLOSED: [2026-09-26]

4
docs/BUILT.md
View File

@ -3084,7 +3084,9 @@ A typed container crosses into dyn as a view of its storage wherever that storag
and above everything its callees push, so the owner is the innermost frame whose address is above it. That is how a
slice of a local, or a slice parameter over a caller's array, is tied to the right activation. Otherwise it asks
the allocation registry, through its address index (64 KiB chunks to the bases that overlap them), for the
smallest live block holding the address and keeps that block's base and note sequence.
smallest live block holding the address and keeps that block's base and note sequence. The registry grows when three
quarters of it is live rather than dropping notes, since a dropped note would stop this check without a word; the
old table is kept, because a listing on the agent's thread may still be reading it.
- Every read or write checks first. A frame is alive when it is still on the chain from `flan_frame_head` *and* has
the same serial: the walk is needed because dead stack keeps its old bytes, serial included, and the serial is
needed because the next call at the same depth lands at the same address. A block is alive when the registry probe

2
emacs/MANUAL.md
View File

@ -1205,7 +1205,7 @@ Use `C-c C-g` if you need frames.
| `M-a` / `M-e` | `(` / `)` | statement: start / end (`)`: start of the next) |
| `C-M-u` | same | up to the enclosing bracket, or the line that owns the block |
| `C-M-f` / `C-M-b` | same | brackets and terms, as everywhere |
| `TAB` | same | a line at a valid column stays; an empty or misplaced line goes deepest; each repeat steps out a level. One level deeper only after a line that opens a block: never after a `let`, unless its value goes on under it (`= match x`, `= if c`, `= loop i = 0`, a lambda header). After a line ending in `=>`, one level in from that line, inside brackets too; a line of that block keeps to the block's columns |
| `TAB` | same | a line at a valid column stays; an empty or misplaced line goes deepest; each repeat steps out a level. One level deeper only after a line that opens a block: never after a `let`, unless its value goes on under it (`= match x`, `= if c`, a lambda header). After a line ending in `=>`, one level in from that line, inside brackets too; a line of that block keeps to the block's columns |
| `DEL` in indentation | same | drop one level |
| `C-c <` / `C-c >` | `<` / `>` | shift the region's lines a level |
| `M-<up>` / `M-<down>` | same | move the statement past its neighbour |

13
emacs/flan-fln-mode.el
View File

@ -77,7 +77,8 @@ fine here. Brackets and strings are still paired."
;; that starts with one, or follows a line that ends with one, continues the
;; line above.
(defconst flan-fln--binops
'("or" "and" "==" "!=" "<" "<=" ">" ">=" "<<" ">>" "+" "-" "*" "/" "%"))
'("or" "and" "==" "!=" "<" "<=" ">" ">=" "||" "^^" "&&" "<<" ">>" "+" "-" "*"
"/" "%"))
(defconst flan-fln--binop-re (regexp-opt flan-fln--binops))
@ -104,8 +105,7 @@ fine here. Brackets and strings are still paired."
'("fn" "fn-" "def" "once" "const" "struct" "union" "data" "enum" "import"
"if" "elif" "else" "while" "until" "for" "match" "let" "return" "break"
"continue" "defer" "handler-case" "handler-bind" "restart-case" "on"
"restart" "quote" "macro" "loop" "type" "class" "generic" "multi"
"method"))
"restart" "quote" "macro" "type" "class" "generic" "multi" "method"))
;; The headers whose block follows on the lines under them. `defer' and
;; `quote' open one only when nothing follows them on the line; `fn' does not
@ -114,8 +114,7 @@ fine here. Brackets and strings are still paired."
(defconst flan-fln--opener-words
'("fn" "fn-" "struct" "union" "data" "enum" "if" "elif" "else" "while"
"until" "for" "match" "defer" "handler-case" "handler-bind"
"restart-case" "on" "restart" "quote" "macro" "loop" "class" "multi"
"method"))
"restart-case" "on" "restart" "quote" "macro" "class" "multi" "method"))
(defconst flan-fln--declaration-words
'(("fn" . "defn") ("fn-" . "defn-") ("def" . "def") ("once" . "defonce")
@ -402,7 +401,7 @@ or, when the line ends in `=>', at the end of the lambda's block under it."
(defun flan-fln--value-opens-p (l)
"Non-nil if the value the joined line L binds or assigns goes on under it:
`= match x', `= if c' with no `then', `= handler-case', `= restart-case',
`= loop i = 0', or a lambda header. These are the values
or a lambda header. These are the values
lib/indent_reader.ml's `value_line' reads a block for, besides a bare `='
and a call ending in `:'."
(let ((v (flan-fln--value-start l))
@ -410,7 +409,7 @@ and a call ending in `:'."
(and v (< v end)
(save-excursion
(goto-char v)
(or (looking-at "\\(?:match\\|handler-case\\|handler-bind\\|restart-case\\|loop\\)\\(?:[ \t]\\|$\\)")
(or (looking-at "\\(?:match\\|handler-case\\|handler-bind\\|restart-case\\)\\(?:[ \t]\\|$\\)")
(and (looking-at "if[ \t]") (not (flan-fln--then l)))
(flan-fln--lambda-header-p v end))))))

4
emacs/flan-mode.el
View File

@ -154,7 +154,9 @@ face says.")
(defconst flan--builtins
'(;; arithmetic, comparison, bits
"+" "-" "*" "/" "%" "=" "!=" "<" "<=" ">" ">=" "not"
"bit-and" "bit-or" "bit-xor" "<<" ">>" "min" "max"
"bit-and" "bit-or" "bit-xor" "bit-not" "&&" "||" "^^" "<<" ">>"
"rotate-left" "rotate-right" "popcount" "leading-zeros" "trailing-zeros"
"min" "max"
;; the fill patterns
"zeroed" "filled" "dead-beef"
;; allocators

26
emacs/test-flan-fln-live.el
View File

@ -137,13 +137,21 @@ macro dbl-of(x, & more)
fn use-mac(k: i64) -> i64 = dbl-of(k)
fn gcd(a: i64, b: i64) -> i64
loop x = a, y = b
if y == 0 then x else recur(y, x % y)
let x = a
let y = b
while y != 0
let r = x % y
x = y
y = r
x
fn sum-to(n: i64) -> i64
let r = loop i = 0, acc = 0
if i > n then acc else recur(i + 1, acc + i)
r
let i = 0
let acc = 0
until i > n
acc += i
i += 1
acc
comment():
if 1 < 2 and
@ -400,10 +408,10 @@ comment():
("Dir.north" "an enum member's arm, at its value")
("let b = 2" "a let the let above takes in, at its value")
("let c: i64" "a typed one, at its value")
("loop x = a" "a loop, at its word")
("if y == 0" "a loop's block")
("let r = loop" "a let-bound loop, at its let")
("if i > n" "a let-bound loop's block")))
("while y != 0" "a while, at its word")
("let r = x % y" "a while's block")
("until i > n" "an until, at its word")
("acc += i" "an until's block")))
(funcall goto (car c))
(let ((reply (flan-fln-eval-defun '(4))))
(test-flan--check (funcall name (format "C-u C-c C-c marks %s where the reader starts it"

45
emacs/test-flan-fln.el
View File

@ -188,6 +188,21 @@ fn step() -> ()
(test-flan-fln--is "and not the start of the body"
(test-flan-fln--thing 'flan-fln-body) "grid[r, c] = 1"))
;; The bit operators continue a line as the other spaced operators do.
;; Not through `test-flan-fln--in', whose `|' marks point and would eat one
;; half of `||'.
(dolist (op '("&&" "||" "^^"))
(with-temp-buffer
(insert "x = a " op "\n b\ny = a\n " op " b\n")
(flan-fln-mode)
(goto-char (point-min))
(forward-line 1)
(test-flan--check (concat "a line after a trailing " op " continues it")
(flan-fln--continuation-p (point)))
(forward-line 2)
(test-flan--check (concat "a line starting with " op " continues")
(flan-fln--continuation-p (point)))))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--settle "velocity[row, col] = 0.0")
(test-flan-fln--is "a top-level form ends before trailing comment lines"
(test-flan-fln--thing 'flan-fln-toplevel)
@ -722,8 +737,13 @@ macro repeat(i, n, & body)
~@body
fn gcd(a: i32, b: i32) -> i32
loop x = a, y = b
if y == 0 then x else recur(y, x % y)
let x = a
let y = b
while y != 0
let r = x % y
x = y
y = r
x
"
(font-lock-ensure)
(let ((face (lambda (needle)
@ -733,7 +753,6 @@ fn gcd(a: i32, b: i32) -> i32
(test-flan-fln--is "and :parent a keyword" (funcall face ":parent") 'font-lock-constant-face)
(test-flan-fln--is "macro is a keyword" (funcall face "macro") 'font-lock-keyword-face)
(test-flan-fln--is "and its name a function's" (funcall face "repeat") 'font-lock-function-name-face)
(test-flan-fln--is "loop is a keyword" (funcall face "loop") 'font-lock-keyword-face)
(test-flan-fln--is "type is a keyword" (funcall face "type") 'font-lock-keyword-face)
(test-flan-fln--is "an alias's name is a type" (funcall face "Row") 'font-lock-type-face)
(test-flan-fln--is "and so is what it names" (funcall face "Vec(i64)") 'font-lock-type-face))
@ -752,15 +771,13 @@ fn gcd(a: i32, b: i32) -> i32
(test-flan-fln--is "installed as a defmacro"
(flan-fln--declaration-head-at (car (flan-fln--toplevel-bounds (point))))
"defmacro")
(search-forward "recur")
(test-flan-fln--is "a loop's statement is its header and block"
(progn (forward-line -1)
(test-flan-fln--thing 'flan-fln-statement))
"loop x = a, y = b
if y == 0 then x else recur(y, x % y)")
(test-flan-fln--is "and its body the block"
(test-flan-fln--thing 'flan-fln-body)
"if y == 0 then x else recur(y, x % y)")
(search-forward "while y")
(test-flan-fln--is "a while's statement is its header and block"
(test-flan-fln--thing 'flan-fln-statement)
"while y != 0
let r = x % y
x = y
y = r")
(goto-char (point-min))
(test-flan-fln--is "the struct's head is defstruct"
(flan-fln--declaration-head-at (point)) "defstruct")
@ -879,13 +896,13 @@ defconst(k, 3)
("let f = fn(a, b) =>" "a lambda header")
("let f = fn(a: i64, b) -> i64 =>" "a typed lambda header")
("let f = fn(g: Fn(i64) -> i64) -> Option(i64) =>" "one with a function type in it")
("let r = loop i = 0, acc = 1" "a let's loop")
("loop i = 0, acc = 1" "a loop")
("fn(a: i64) -> i64 =>" "a typed lambda as a statement")))
(test-flan-fln--is (format "unless its value goes on under it: %s" (cadr c))
(test-flan-fln--tabs (concat "fn f()\n " (car c) "\n|") 1) 4))
(test-flan-fln--is "but not a typed lambda with its body on the line"
(test-flan-fln--tabs "fn f()\n let f = fn(a: i64) -> i64 => a\n|" 1) 2)
(test-flan-fln--is "loop is no header in .fln, and opens nothing"
(test-flan-fln--tabs "fn f()\n let r = loop i = 0\n|" 1) 2)
(test-flan-fln--is "a header word being assigned opens nothing"
(test-flan-fln--tabs "fn f()\n for = 1\n|" 1) 2)
(test-flan-fln--in "fn f()\n handler-case\n g()\n on E(c)\n h(c)\n on = 2\n data += 1\n"

226
lib/check.ml
View File

@ -606,6 +606,9 @@ let builtin_names : string list ref = ref []
twenty thousand calls. Filled beside the list. *)
let builtin_set : (string, unit) Hashtbl.t = Hashtbl.create 128
(* Set while [bool_operands] asks an operand its type; see there. *)
let probing = ref false
(* ── builtin/, the reserved qualifier ──────────────────────────────────
[builtin/length] is the builtin [length], whatever else the program has
decided [length] means. It is the way out of the dead end shadowing used to leave: a
@ -677,12 +680,13 @@ let spell_arg stand_for (a : Ast.expr) =
(* Operators other languages spell differently, each mapped to the Flan
builtin that computes the same thing. Only exact equivalents: [mod] is left
out because Clojure's is floored and [%] is not. *)
out because Clojure's is floored and [%] is not. [&&] and [||] are not
here: they are the bit operators, and a bool reaching one is told which
logical operator it wanted there. *)
let operator_aliases =
[ ("not=", ("!=", "Not-equal")); ("=/=", ("!=", "Not-equal"));
("/=", ("!=", "Not-equal")); ("<>", ("!=", "Not-equal"));
("==", ("=", "Equality")); ("===", ("=", "Equality"));
("&&", ("and", "Logical and")); ("||", ("or", "Logical or"));
("!", ("not", "Logical not")) ]
(* The fix, as the sentence that ends the refusal. The reader's call is
@ -10121,7 +10125,9 @@ and not_numeric name what (a : Tast.expr) =
| _ -> false
in
let where = a.Tast.loc in
if text then
if a.Tast.ty = Types.Bool && String.equal what "integers" then
bool_bits where name
else if text then
fail where
"%s takes %s, and this is %s — there is no %s on text. The prelude \
concatenates with concat and join"
@ -10241,14 +10247,16 @@ and dyn_fold ctx ~want loc name first rest =
| "+" -> "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)
| _ -> dyn_bits_sym name
in
(* A bitwise fold takes integers on both sides, and the typed side of a
mixed pair can be asked now rather than at run time. *)
let bitwise = not (List.mem name [ "+"; "-"; "*"; "/"; "%" ]) in
if bitwise then
List.iter
(fun (v : Tast.expr) ->
if v.Tast.ty <> Types.Dyn then bits_operand ctx v.Tast.loc name v)
first;
(* The site travels with the operands. A dyn arithmetic trap is this
language's type error, and until now it printed with no file, no line and
no column — [here loc] is the same string literal [cast_dyn] hands the
@ -10259,12 +10267,100 @@ and dyn_fold ctx ~want loc name first rest =
| [ 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
let operand arg =
if bitwise then begin
let v = check ctx arg in
if v.Tast.ty <> Types.Dyn then bits_operand ctx v.Tast.loc name v;
v
end
else check ctx ~want:Types.Dyn arg
in
let acc = List.fold_left (fun acc arg -> apply acc (operand arg)) acc rest in
expect ctx loc ~want acc
(* The runtime's entry point for each bit operation on a dyn int. *)
and dyn_bits_sym name =
match name with
| "bit-and" -> "flan_dyn_bitand" | "bit-or" -> "flan_dyn_bitor"
| "bit-xor" -> "flan_dyn_bitxor" | "bit-not" -> "flan_dyn_bitnot"
| "<<" -> "flan_dyn_shl" | ">>" -> "flan_dyn_shr"
| "rotate-left" -> "flan_dyn_rotl" | "rotate-right" -> "flan_dyn_rotr"
| "popcount" -> "flan_dyn_popcount" | "leading-zeros" -> "flan_dyn_clz"
| "trailing-zeros" -> "flan_dyn_ctz"
| _ -> invalid_arg ("dyn_bits_sym " ^ name)
(* An operand of a bit operation, once it is known not to be dyn: an integer,
or a type variable the where clause bounds by [integer?]. A bool is the
likeliest thing to arrive here — [a && b] is logical and in C — so it is
answered with the operator that does what was meant. *)
and bits_operand ctx loc name (v : Tast.expr) =
match v.Tast.ty with
| Types.Int _ -> ()
| t when generic_ty t -> unconstrained ctx.env loc name ~needs:"integer?" t
| Types.Bool -> bool_bits v.Tast.loc name
| other -> fail loc "%s takes integers, found %s" name (tyname loc other)
(* A bool operand is refused before the operands are joined, and not left to
[bits_operand]: the join sees a bool beside an integer as a plain mismatch,
"expected i32, found bool", which says nothing of [and]. Each operand's own
type is asked in a trial that is always abandoned, so the check leaves no
trace — no slot, no lifted lambda, no recorded refusal — and the real check
below is the only one that counts. A literal is never a bool, and a call to
an arithmetic or bit operator answers a number or a dyn, so neither is
asked. Nor is anything asked while a probe is running: the probe wants a
type, and asking again inside it would check a nest of these once per
level for every level above it, which doubles with each level. *)
and bool_operands ctx name (args : Ast.expr list) =
if not !probing then
let never_bool (a : Ast.expr) =
match a.Ast.e with
| Ast.Int _ | Ast.UInt _ | Ast.Float _ | Ast.Byte _ | Ast.Str _ | Ast.Kw _ ->
true
| Ast.Call ({ Ast.e = Ast.Var h; _ }, _) ->
List.mem h
[ "+"; "-"; "*"; "/"; "%"; "bit-and"; "bit-or"; "bit-xor"; "bit-not";
"&&"; "||"; "^^"; "~~"; "<<"; ">>"; "rotate-left"; "rotate-right";
"popcount"; "leading-zeros"; "trailing-zeros" ]
&& not (shadows_builtin ctx a.Ast.loc h)
| _ -> false
in
let is_bool (a : Ast.expr) =
(not (never_bool a))
&&
let ty = ref None in
probing := true;
Fun.protect ~finally:(fun () -> probing := false) (fun () ->
ignore
(trial ctx (fun () ->
let v = check ctx a in
ty := Some v.Tast.ty;
Loc.failk "check/probe" a.Ast.loc "abandoned")));
!ty = Some Types.Bool
in
List.iter (fun a -> if is_bool a then bool_bits a.Ast.loc name) args
and bool_bits loc name =
let fln = fln_source loc in
let shown =
if not fln then name
else match name with
| "bit-and" -> "&&" | "bit-or" -> "||" | "bit-xor" -> "^^"
| "bit-not" -> "~~" | n -> n
in
let logic =
match name with
| "bit-and" -> Some (if fln then "a and b" else "(and a b)")
| "bit-or" -> Some (if fln then "a or b" else "(or a b)")
| "bit-xor" -> Some (if fln then "a != b" else "(!= a b)")
| "bit-not" -> Some (if fln then "not a" else "(not a)")
| _ -> None
in
Loc.failk "check/bits-of-bool" loc
"%s works on the bits of an integer, and this is a bool. %s" shown
(match logic with
| Some l -> Printf.sprintf "For true and false, write %s" l
| None -> "True and false are combined with and, or and not")
(* A comparison over three operands or more asks about more than one pair, and
every operand is bound to a slot before any pair is looked at. That is what
makes "left to right, exactly once" true of the lowering and not only of
@ -11382,8 +11478,33 @@ and named_call ?(qualified = false) ctx ~want loc name args =
| _ -> Tast.BitXor
in
fold_arity loc name args;
bool_operands ctx name args;
fold_left_prim ctx ~want loc name p ~needs:"integer?" Types.is_integer
"integers" args
(* The .fln operators, which the indented reader already spells as the words
above; a form built some other way may still carry them. [~qualified]
skips the shadowing arm, because a program that means its own [&&] has
been answered by that arm already under this name. *)
| "&&" | "||" | "^^" | "~~" ->
let canon = match name with
| "&&" -> "bit-and" | "||" -> "bit-or" | "^^" -> "bit-xor"
| _ -> "bit-not"
in
named_call ~qualified:true ctx ~want loc canon args
| "bit-not" | "popcount" | "leading-zeros" | "trailing-zeros" ->
arity ctx loc name 1 args;
bool_operands ctx name args;
let v = check ctx ?want:(numeric_want want) (List.hd args) in
if v.Tast.ty = Types.Dyn then
expect ctx loc ~want (rt loc Types.Dyn (dyn_bits_sym name) [ v; here loc ])
else begin
bits_operand ctx loc name v;
let p = match name with
| "bit-not" -> Tast.BitNot | "popcount" -> Tast.Popcount
| "leading-zeros" -> Tast.Clz | _ -> Tast.Ctz
in
prim p v.Tast.ty [ v ]
end
(* The shifts stay at two, and not only because a shift chain reads badly:
each count would be checked against the same width below, so (<< x 30 30)
would pass two legal shifts and still shift the value away entirely.
@ -11395,22 +11516,32 @@ and named_call ?(qualified = false) ctx ~want loc name args =
type and the width the shift wraps at would be taken from a number that is
only saying how far, and the range check just below, along with [emit]'s
mask, is keyed to the *value's* width. A count wider than the value is
refused and is told to write the cast. *)
| "<<" | ">>" ->
let p = if String.equal name "<<" then Tast.Shl else Tast.Shr in
refused and is told to write the cast.
The rotations share the rule and not the range check: a rotation by the
width is the value unchanged, so every count means something and is taken
modulo the width. *)
| "<<" | ">>" | "rotate-left" | "rotate-right" ->
let p = match name with
| "<<" -> Tast.Shl | ">>" -> Tast.Shr | "rotate-left" -> Tast.Rotl
| _ -> Tast.Rotr
in
arity ctx loc name 2 args;
let a, b = binary ctx ~join:false name loc ~want:(numeric_want want) args in
(match a.Tast.ty with
| Types.Int _ -> ()
(* A type variable under {:where (integer? $t)}: every type the bound
admits has a width to shift within, so the abstract pass lets the
body through and each instantiation meets the concrete checks below
at its own width. Anything weaker — [numeric?] included — is refused
here, at the definition, because a shift at f32 means nothing. *)
| t when generic_ty t ->
unconstrained ctx.env loc name ~needs:"integer?" t
| other -> fail loc "%s takes integers, found %s" name
(tyname loc other));
bool_operands ctx name args;
let a, b =
binary ctx ~dyn_ok:true ~join:false name loc ~want:(numeric_want want) args
in
if a.Tast.ty = Types.Dyn || b.Tast.ty = Types.Dyn then begin
(* The typed side of a mixed pair still has to be an integer: the dyn
half is asked at run time, and this half can be asked now. *)
List.iter
(fun (v : Tast.expr) ->
if v.Tast.ty <> Types.Dyn then bits_operand ctx v.Tast.loc name v)
[ a; b ];
expect ctx loc ~want
(rt loc Types.Dyn (dyn_bits_sym name) [ box loc a; box loc b; here loc ])
end else begin
bits_operand ctx loc name a;
(* A shift by the operand's own width or more is poison in LLVM, which at
-O2 turns the whole function into an undefined value rather than into a
wrong number. A literal count is rejected here — that is the typo — and
@ -11425,6 +11556,7 @@ and named_call ?(qualified = false) ctx ~want loc name args =
(tyname loc a.Tast.ty) (Types.bits k)
| _ -> ());
prim p a.Tast.ty [ a; b ]
end
(* (min a b) and (max a b) evaluate each operand once — hence the slots —
because a min over two calls must not call either of them twice.
@ -14892,19 +15024,41 @@ let builtins : (string * string * string) list =
("not", "not [bool] bool",
"Negates a bool. Nothing else in this language is a truth value.");
("bit-and", "bit-and [int ...] int",
"Bitwise and, folded left. Integers only; operands of different widths \
meet at the wider one, the way + does.");
("bit-or", "bit-or [int ...] int", "Bitwise or, folded left over integers.");
"Bitwise and, folded left; a && b in a .fln file. Integers only; operands \
of different widths meet at the wider one, the way + does.");
("bit-or", "bit-or [int ...] int",
"Bitwise or, folded left over integers; a || b in a .fln file.");
("bit-xor", "bit-xor [int ...] int",
"Bitwise exclusive or, folded left over integers.");
"Bitwise exclusive or, folded left over integers; a ^^ b in a .fln file.");
("bit-not", "bit-not [int] int",
"Every bit of an integer flipped; ~~a in a .fln file.");
("&&", "&& [int ...] int", "bit-and, by its .fln spelling.");
("||", "|| [int ...] int", "bit-or, by its .fln spelling.");
("^^", "^^ [int ...] int", "bit-xor, by its .fln spelling.");
("~~", "~~ [int] int", "bit-not, by its .fln spelling.");
("<<", "<< [int int] int",
"Left shift. The value's type decides — a narrower count widens to it, a \
wider one is refused — and a literal count at or past the value's width \
is refused too, because LLVM calls that poison.");
is refused too. On a dyn int, a count outside 0 to 63 traps.");
(">>", ">> [int int] int",
"Right shift. The value's type decides and the count widens to it, never \
the reverse; a literal count at or past the width is refused, as it is \
for <<.");
"Right shift, arithmetic on a signed type and logical on an unsigned one. \
The value's type decides and the count widens to it; a literal count at \
or past the width is refused, as it is for <<.");
("rotate-left", "rotate-left [int int] int",
"The bits of the value moved left by the count, the ones that fall off \
the top coming back in at the bottom. The count is taken modulo the \
width.");
("rotate-right", "rotate-right [int int] int",
"The bits of the value moved right by the count, wrapping round to the \
top. The count is taken modulo the width.");
("popcount", "popcount [int] int",
"How many bits of the integer are set. The answer has the operand's \
type.");
("leading-zeros", "leading-zeros [int] int",
"How many zero bits come before the highest set bit, counted within the \
operand's width: the width itself for 0.");
("trailing-zeros", "trailing-zeros [int] int",
"How many zero bits come after the lowest set bit: the width for 0.");
("min", "min [ordered? ...] ordered?",
"The smallest of two or more operands, each of them evaluated exactly \
once however many there are. Two widths meet at the wider: (min i8-x \

59
lib/emit.ml
View File

@ -1478,6 +1478,7 @@ let settled_prim (p : Tast.prim) =
| Tast.Add | Tast.Sub | Tast.Mul
| Tast.Eq | Tast.Ne | Tast.Lt | Tast.Le | Tast.Gt | Tast.Ge | Tast.Not
| Tast.BitAnd | Tast.BitOr | Tast.BitXor | Tast.Shl | Tast.Shr
| Tast.BitNot | Tast.Popcount | Tast.Clz | Tast.Ctz | Tast.Rotl | Tast.Rotr
(* Questions about a value's shape, answered from the layout tables. *)
| Tast.Len | Tast.SizeOf _ | Tast.AlignOf _ | Tast.AddrOf -> true
(* Everything else reaches C, signals, or both: an index and a slice are
@ -3873,6 +3874,33 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) =
let t = fresh f in
ins f "%s = xor i1 %s, true" t a;
t
| Tast.BitNot, [ x ] ->
let a = value f x in
let t = fresh f in
ins f "%s = xor %s %s, -1" t (ll x.Tast.ty) a;
t
(* [i1 false] says a zero operand is defined — the width — rather than
poison, which is the language's answer for 0. *)
| (Tast.Popcount | Tast.Clz | Tast.Ctz), [ x ] ->
let a = value f x in
let ty = ll x.Tast.ty in
let t = fresh f in
(match p with
| Tast.Popcount -> ins f "%s = call %s @llvm.ctpop.%s(%s %s)" t ty ty ty a
| Tast.Clz ->
ins f "%s = call %s @llvm.ctlz.%s(%s %s, i1 false)" t ty ty ty a
| _ -> ins f "%s = call %s @llvm.cttz.%s(%s %s, i1 false)" t ty ty ty a);
t
(* A funnel shift of a value with itself is a rotation, and the funnel
shifts take their count modulo the width, which is the rotation's rule. *)
| (Tast.Rotl | Tast.Rotr), [ x; y ] ->
let a = value f x in
let b = value f y in
let ty = ll x.Tast.ty in
let t = fresh f in
ins f "%s = call %s @llvm.%s.%s(%s %s, %s %s, %s %s)" t ty
(if p = Tast.Rotl then "fshl" else "fshr") ty ty a ty a ty b;
t
| Tast.Len, [ x ] ->
(match x.Tast.ty with
| Types.Array (n, _) -> Int64.to_string n
@ -4932,6 +4960,26 @@ let header = {|; Generated by flan. The layout is C's: no object headers anywher
declare void @llvm.memset.p0.i64(ptr nocapture writeonly, i8, i64, i1 immarg)
declare i32 @llvm.bswap.i32(i32)
declare i8 @llvm.ctpop.i8(i8)
declare i8 @llvm.ctlz.i8(i8, i1 immarg)
declare i8 @llvm.cttz.i8(i8, i1 immarg)
declare i8 @llvm.fshl.i8(i8, i8, i8)
declare i8 @llvm.fshr.i8(i8, i8, i8)
declare i16 @llvm.ctpop.i16(i16)
declare i16 @llvm.ctlz.i16(i16, i1 immarg)
declare i16 @llvm.cttz.i16(i16, i1 immarg)
declare i16 @llvm.fshl.i16(i16, i16, i16)
declare i16 @llvm.fshr.i16(i16, i16, i16)
declare i32 @llvm.ctpop.i32(i32)
declare i32 @llvm.ctlz.i32(i32, i1 immarg)
declare i32 @llvm.cttz.i32(i32, i1 immarg)
declare i32 @llvm.fshl.i32(i32, i32, i32)
declare i32 @llvm.fshr.i32(i32, i32, i32)
declare i64 @llvm.ctpop.i64(i64)
declare i64 @llvm.ctlz.i64(i64, i1 immarg)
declare i64 @llvm.cttz.i64(i64, i1 immarg)
declare i64 @llvm.fshl.i64(i64, i64, i64)
declare i64 @llvm.fshr.i64(i64, i64, i64)
declare ptr @llvm.frameaddress.p0(i32 immarg)
declare void @flan_rt_init(i32, ptr)
declare void @flan_argv(ptr)
@ -5036,6 +5084,17 @@ declare i64 @flan_dyn_mul(i64, i64, ptr, i64)
declare i64 @flan_dyn_div(i64, i64, ptr, i64)
declare i64 @flan_dyn_rem(i64, i64, ptr, i64)
declare i64 @flan_dyn_neg(i64, ptr, i64)
declare i64 @flan_dyn_bitand(i64, i64, ptr, i64)
declare i64 @flan_dyn_bitor(i64, i64, ptr, i64)
declare i64 @flan_dyn_bitxor(i64, i64, ptr, i64)
declare i64 @flan_dyn_bitnot(i64, ptr, i64)
declare i64 @flan_dyn_shl(i64, i64, ptr, i64)
declare i64 @flan_dyn_shr(i64, i64, ptr, i64)
declare i64 @flan_dyn_rotl(i64, i64, ptr, i64)
declare i64 @flan_dyn_rotr(i64, i64, ptr, i64)
declare i64 @flan_dyn_popcount(i64, ptr, i64)
declare i64 @flan_dyn_clz(i64, ptr, i64)
declare i64 @flan_dyn_ctz(i64, ptr, i64)
declare i64 @flan_dyn_lt(i64, i64, ptr, i64)
declare i64 @flan_dyn_le(i64, i64, ptr, i64)
declare i64 @flan_dyn_gt(i64, i64, ptr, i64)

153
lib/indent_printer.ml
View File

@ -296,36 +296,42 @@ let flatten (f : Form.t) (rest : Form.t list) =
(* ── Expressions ───────────────────────────────────────────────────── *)
(* Text and syntactic level, the same scale [Indent_reader] reads: 10 an atom
or bracket, 9 a postfix chain, 8 a unary minus, 1-7 binary, 3 [not], 0 a
one-line [if] or a lambda. *)
(* Text and syntactic level, the same scale [Indent_reader] reads: 13 an atom
or bracket, 12 a postfix chain, 11 a prefix [-] or [~~], 1-10 binary, 3
[not], 0 a one-line [if] or a lambda. *)
(* The operator a head prints as: [=] is [==], and the bit words are the
operators the reader turns into them. *)
let infix_op = function
| "=" -> "==" | "bit-and" -> "&&" | "bit-or" -> "||" | "bit-xor" -> "^^"
| s -> s
let rec expr (f : Form.t) : string * int =
match f.v with
| Form.Sym s when !hole && s = hole_sym -> (s, 0)
| Form.Sym s -> sym f s
| Form.Kw k ->
if kw_ok k then (":" ^ k, 10) else unprintable f "a keyword with no spelling"
if kw_ok k then (":" ^ k, 13) else unprintable f "a keyword with no spelling"
| Form.Int i ->
let t = Option.value (!spelling f) ~default:(Int64.to_string i) in
(t, if t.[0] = '-' then 8 else 10)
| Form.UInt (_, s) -> (s, 10)
(t, if t.[0] = '-' then 11 else 13)
| Form.UInt (_, s) -> (s, 13)
| Form.Float x ->
let s = Option.value (!spelling f) ~default:(Form.float_repr x) in
if not (Reader.is_digit s.[0] || (s.[0] = '-' && String.length s > 1
&& Reader.is_digit s.[1]))
then unprintable f "a float with no literal";
(s, if s.[0] = '-' then 8 else 10)
| Form.Str s -> ("\"" ^ Form.escape s ^ "\"", 10)
| Form.Byte b -> (Form.byte_repr b, 10)
| Form.Vec xs -> ("[" ^ vec_text xs ^ "]", 10)
| Form.Map xs -> ("{" ^ map_text xs ^ "}", 10)
| Form.List [] -> ("()", 10)
(s, if s.[0] = '-' then 11 else 13)
| Form.Str s -> ("\"" ^ Form.escape s ^ "\"", 13)
| Form.Byte b -> (Form.byte_repr b, 13)
| Form.Vec xs -> ("[" ^ vec_text xs ^ "]", 13)
| Form.Map xs -> ("{" ^ map_text xs ^ "}", 13)
| Form.List [] -> ("()", 13)
| Form.List (h :: args) -> in_quasi f (fun () -> list f h args)
and sym f s =
if s = "==" then unprintable f "the name == (it reads as =)"
else if R.is_op_word s || s = "if" then (paren s, 10)
else if name_ok s then (s, 10)
else if R.is_op_word s || s = "if" then (paren s, 13)
else if name_ok s then (s, 13)
else unprintable f (Printf.sprintf "the name %s" s)
and at lvl f =
@ -347,16 +353,16 @@ and commas xs = String.concat ", " (comma_items xs)
as soon as one element has an operator in it. *)
and vec_text xs =
let ts = List.map expr xs in
if List.for_all (fun (_, l) -> l >= 8) ts then String.concat " " (List.map fst ts)
if List.for_all (fun (_, l) -> l >= 11) ts then String.concat " " (List.map fst ts)
else String.concat ", " (List.map (fun (t, _) -> t) ts)
and map_text xs =
let ts = List.map expr xs in
if List.for_all (fun (_, l) -> l >= 8) ts then String.concat " " (List.map fst ts)
if List.for_all (fun (_, l) -> l >= 11) ts then String.concat " " (List.map fst ts)
else
let rec pairs = function
| (k, kl) :: (v, _) :: rest ->
((if kl < 8 then paren k else k) ^ " " ^ v) :: pairs rest
((if kl < 11 then paren k else k) ^ " " ^ v) :: pairs rest
| [ (k, _) ] -> [ k ]
| [] -> []
in
@ -367,22 +373,26 @@ and head_text (h : Form.t) =
| Form.Sym "==" -> unprintable h "the name =="
| Form.Sym s when R.is_op_word s -> s
| Form.Sym s -> fst (sym h s)
| _ -> at 9 h
| _ -> at 12 h
and list f h args =
let call () = (head_text h ^ "(" ^ commas args ^ ")", 9) in
let call () = (head_text h ^ "(" ^ commas args ^ ")", 12) in
match h.v, args with
| Form.Sym "quote", [ x ] -> ("'" ^ Form.to_source x, 10)
| Form.Sym "unquote", [ x ] -> ("~" ^ at 10 x, 10)
| Form.Sym "unquote-splicing", [ x ] -> ("~@" ^ at 10 x, 10)
| Form.Sym "quote", [ x ] -> ("'" ^ Form.to_source x, 13)
(* [~~] is bit-not, so an unquote of anything that starts with [~] is
parenthesised: [~(~x)]. *)
| Form.Sym "unquote", [ x ] ->
let t = at 13 x in
((if t <> "" && t.[0] = '~' then "~(" ^ t ^ ")" else "~" ^ t), 13)
| Form.Sym "unquote-splicing", [ x ] -> ("~@" ^ at 13 x, 13)
| Form.Sym s, _ :: _ :: _
when (R.is_binop s || s = "=") && s <> "==" && not (s = "!=" && List.length args > 2) ->
let op = if s = "=" then "==" else s in
when R.is_binop (infix_op s) && s <> "==" && not (s = "!=" && List.length args > 2) ->
let op = infix_op s in
let lvl = Option.get (R.binop_level op) in
let first = List.hd args and rest = List.tl args in
let ft, fl = expr first in
let same = match first.v with
| Form.List (h' :: _ :: _ :: _) -> is_sym s h' || lvl = 4
| Form.List (h' :: _ :: _ :: _) -> (match h'.v with Form.Sym s' -> infix_op s' = op | _ -> false) || lvl = 4
| _ -> false
in
let ft = if fl < lvl || (fl = lvl && same) then paren ft else ft in
@ -398,18 +408,19 @@ and list f h args =
(ft :: List.map (fun x -> and_in_or x (at (lvl + 1) x)) rest), lvl)
| Form.Sym "-", [ x ] ->
let t, l = expr x in
if l >= 9 && t <> "" && R.is_neg_char t.[0] then ("-" ^ t, 8)
else ("-(" ^ at 0 x ^ ")", 9)
if l >= 12 && t <> "" && R.is_neg_char t.[0] then ("-" ^ t, 11)
else ("-(" ^ at 0 x ^ ")", 12)
| Form.Sym "not", [ x ] -> ("not " ^ at 3 x, 3)
| Form.Sym ("bit-not" | "~~"), [ x ] -> ("~~" ^ at 11 x, 11)
(* [and] or [or] of one value is that value. *)
| Form.Sym ("and" | "or"), [ x ] when !quasi = 0 -> expr x
| Form.Sym "at", t :: (_ :: _ as idx) -> (at 9 t ^ "[" ^ commas idx ^ "]", 9)
| Form.Sym "at", t :: (_ :: _ as idx) -> (at 12 t ^ "[" ^ commas idx ^ "]", 12)
| Form.Sym s, [ t ]
when String.length s > 1 && s.[0] = '.' && name_ok s
&& not (String.contains (String.sub s 1 (String.length s - 1)) '.') ->
let tt, tl = expr t in
let glued =
tl >= 9
tl >= 12
&& (match t.v with
| Form.Byte _ -> false
| Form.Sym x -> name_ok x && not (String.contains x '.') && not (R.capitalised x)
@ -421,9 +432,9 @@ and list f h args =
let c = tt.[String.length tt - 1] in
c = ')' || c = ']' || c = '}' || c = '"')
in
if glued then (tt ^ s, 9) else call ()
if glued then (tt ^ s, 12) else call ()
| Form.Sym s, [ ({ v = Form.Map _; _ } as m) ] when name_ok s && R.capitalised s ->
(s ^ fst (expr m), 9)
(s ^ fst (expr m), 12)
| Form.Sym "the", _ when (match typed_lambda f with Some (_, [ _ ]) -> true | _ -> false) ->
(match typed_lambda f with
| Some (head, [ body ]) -> (head ^ " => " ^ unit_text body, 0)
@ -451,7 +462,7 @@ and inline_text ?(lvl = 0) (f : Form.t) =
| Form.List [ { v = Form.Sym "set"; _ }; t; v ] -> assign_text ~lvl t v
| Form.List [ { v = Form.Sym "update"; _ }; t; { v = Form.Sym (("+" | "-" | "*" | "/") as op); _ }; w ]
when not (R.simple_place t) ->
at 9 t ^ " " ^ op ^ "= " ^ at (max lvl 1) w
at 12 t ^ " " ^ op ^ "= " ^ at (max lvl 1) w
| _ -> at lvl f
(* A body after [=]: [()] there reads as [(do)]. *)
@ -463,7 +474,7 @@ and unit_text (f : Form.t) =
(* [t = v], or [t += w] when [v] is [(+ t w)]. *)
and assign_text ?(lvl = 0) t v =
let tt = at 9 t in
let tt = at 12 t in
match v.v with
| Form.List [ { v = Form.Sym (("+" | "-" | "*" | "/") as op); _ }; a; w ]
when same a t && R.simple_place t ->
@ -480,7 +491,7 @@ and typed_lambda (f : Form.t) =
match t.v with
| Form.List [ { v = Form.Sym (("Fn" | "CFn") as h); _ }; { v = Form.Vec ps; _ }; r ] ->
h ^ "(" ^ String.concat ", " (List.map tyt ps) ^ ") -> " ^ tyt r
| _ -> at 9 t
| _ -> at 12 t
in
match f.v with
| Form.List [ { v = Form.Sym "the"; _ };
@ -499,7 +510,7 @@ let rec ty (f : Form.t) =
match f.v with
| Form.List [ { v = Form.Sym (("Fn" | "CFn") as h); _ }; { v = Form.Vec ps; _ }; r ] ->
h ^ "(" ^ commas ps ^ ") -> " ^ ty r
| _ -> at 9 f
| _ -> at 12 f
(* A [defn]'s parameter type the reader could not mistake for a name: a
primitive, a capitalised or [$] name, or a bracket. [[x y]] with a
@ -585,12 +596,12 @@ let body_guess (h : Form.t) args =
match a.v with Form.List _ -> false | _ -> true) args) in
(match base with
| "comment" | "do" -> Some 0
| "unless" | "loop" -> Some 1
| "unless" -> Some 1
| "defmacro" -> Some 2
| "defmethod" -> Some 3
| _ ->
(* A with- macro, or any call whose last argument is a statement —
a let, a loop, an assignment — has a body: the trailing run of
a let, a while, an assignment — has a body: the trailing run of
lists goes in the block. *)
let stmt_like (a : Form.t) =
match a.v with
@ -739,7 +750,9 @@ and wrapped n prefix (f : Form.t) =
match f.v with
| Form.List (h :: (_ :: _ as args)) when (match h.v with
| Form.Sym ("at" | "quote" | "unquote" | "unquote-splicing") -> false
| Form.Sym s -> not (R.is_op_word s) && not (String.length s > 1 && s.[0] = '.')
| Form.Sym s ->
not (R.is_op_word (infix_op s)) && s <> "bit-not"
&& not (String.length s > 1 && s.[0] = '.')
| _ -> false) ->
let open_ = prefix ^ head_text h ^ "(" in
let col = n + String.length open_ in
@ -771,7 +784,7 @@ and wrapped n prefix (f : Form.t) =
let open_ = prefix ^ "[" in
let col = n + String.length open_ in
let ts = List.map expr xs in
let sep = if List.for_all (fun (_, l) -> l >= 8) ts then "" else "," in
let sep = if List.for_all (fun (_, l) -> l >= 11) ts then "" else "," in
let rec go line acc = function
| [] -> List.rev ((line ^ "]") :: acc)
| (t, _) :: rest ->
@ -920,9 +933,6 @@ and value_lines n prefix (v : Form.t) =
| _ -> false
in
if is_do then [ ind n ^ prefix ^ " =" ] @ block (n + 2) (stmts_of v)
else if loop_head v <> None then
let head, body = Option.get (loop_head v) in
[ ind n ^ prefix ^ " = " ^ head ] @ block (n + 2) body
else
match lambda_value n prefix v with
| Some ls -> ls
@ -939,23 +949,6 @@ and value_lines n prefix (v : Form.t) =
and slot n (f : Form.t) = block n (stmts_of f)
(* [(loop [x a y b] body ...)] as the header [loop x = a, y = b] and its
body, when every binding is a plain name. A lambda or one-line if as a
value is parenthesised, so its else cannot run on into the next binding. *)
and loop_head (f : Form.t) =
match f.v with
| Form.List ({ v = Form.Sym "loop"; _ } :: { v = Form.Vec bs; _ } :: (_ :: _ as body)) ->
(match pairs bs with
| Some (_ :: _ as prs)
when List.for_all (fun ((x : Form.t), _) ->
match x.v with Form.Sym x -> def_name x | _ -> false) prs ->
Some
("loop "
^ String.concat ", " (List.map (fun (x, v) -> fst (expr x) ^ " = " ^ at 1 v) prs),
body)
| _ -> None)
| _ -> None
and label_of = function
| ({ Form.v = Form.Kw k; _ }) :: rest when kw_ok k -> (":" ^ k ^ " ", rest)
| rest -> ("", rest)
@ -972,9 +965,9 @@ and sugar n (f : Form.t) : string list option =
Some [ i ^ guard (inline_text f) ]
| Form.List [ { v = Form.Sym "set"; _ }; t; v ] ->
let line = i ^ guard (assign_text t v) in
if String.length line <= width && lambda_value n (guard (at 9 t)) v = None
if String.length line <= width && lambda_value n (guard (at 12 t)) v = None
then Some [ line ]
else Some (value_lines n (guard (at 9 t)) v)
else Some (value_lines n (guard (at 12 t)) v)
| Form.List [ { v = Form.Sym "if"; _ }; c; a; b ] ->
let simple (x : Form.t) =
match x.v with
@ -1068,7 +1061,7 @@ and sugar n (f : Form.t) : string list option =
:: List.concat_map
(fun ((pat : Form.t), body) ->
List.mapi (fun k l -> if k = 0 then Source_text.tag pat.loc.Loc.line l else l) @@
let pt = at 8 pat in
let pt = at 11 pat in
let line = ind (n + 2) ^ pt ^ " -> " ^ inline_text body in
match body.v with
| Form.List ({ v = Form.Sym "do"; _ } :: _ :: _ :: _) ->
@ -1164,9 +1157,6 @@ and sugar n (f : Form.t) : string list option =
| _, [ t ] when type_shaped t -> Some [ pre ^ ": " ^ ty t ]
| _, [ t; v ] -> Some (value_lines n (w ^ " " ^ name ^ ": " ^ ty t) v)
| _ -> None)
| Form.List ({ v = Form.Sym "loop"; _ } :: _) when loop_head f <> None ->
let head, body = Option.get (loop_head f) in
Some ((i ^ head) :: block (n + 2) body)
| Form.List ({ v = Form.Sym "defmacro"; _ } :: { v = Form.Sym name; _ }
:: { v = Form.Vec ps; _ } :: (_ :: _ as body))
when def_name name ->
@ -1274,7 +1264,7 @@ and sugar n (f : Form.t) : string list option =
Some ("(" ^ fst (expr p0) ^ ": " ^ ty key
^ String.concat "" (List.map (fun p -> ", " ^ fst (expr p)) rest) ^ ")")
| (Form.Kw _ | Form.Str _ | Form.Int _ | Form.Sym _), _ ->
Some ("(" ^ commas ps ^ ") when " ^ at 9 key)
Some ("(" ^ commas ps ^ ") when " ^ at 12 key)
| _ -> None
in
Option.map (fun h -> fn_like n f (i ^ "method " ^ name ^ h) body) head
@ -1339,7 +1329,7 @@ and handler_clauses n cls =
match c.v with
| Form.List (t :: { v = Form.Vec [ { v = Form.Sym v; _ } ]; _ } :: (_ :: _ as b))
when def_name v ->
Some ((ind n ^ "on " ^ at 9 t ^ "(" ^ v ^ ")") :: block (n + 2) b)
Some ((ind n ^ "on " ^ at 12 t ^ "(" ^ v ^ ")") :: block (n + 2) b)
| _ -> None
in
let cs = List.map clause cls in
@ -1354,7 +1344,7 @@ and let_lines n prs body =
| Form.Sym x, Form.List [ { v = Form.Sym "the"; _ }; ty_; w ]
when def_name x && typed_lambda v = None ->
("let " ^ x ^ ": " ^ ty ty_, w)
| _ -> ("let " ^ guard (at 8 t), v)
| _ -> ("let " ^ guard (at 11 t), v)
in
(* Each binding line carries its own source line, so a comment written
after a binding stays on it. *)
@ -1365,10 +1355,37 @@ and let_lines n prs body =
let lines n b = let p, v = bind b in tagged b (value_lines n p v) in
List.concat_map (lines n) prs @ block n body
(* A .flan file that uses [loop] or [recur] has no indented spelling: the
indented syntax loops with [while], [until], [dotimes] and [for]. The
refusal names every line, so the file is rewritten in one pass. *)
let refuse_loops (fs : Form.t list) =
match R.loop_forms fs with
| [] -> ()
| (first : Form.t) :: rest as uses ->
let word (f : Form.t) =
match f.v with Form.List ({ v = Form.Sym w; _ } :: _) -> w | _ -> "loop"
in
let lines = List.sort_uniq compare (List.map (fun (f : Form.t) -> f.loc.Loc.line) uses) in
let notes = List.map (fun (f : Form.t) -> Loc.note f.loc (word f ^ " is here")) rest in
Loc.failk ~notes "convert/no-loop" first.loc
"this file uses loop or recur on line%s %s. The indented syntax \
has neither. Rewrite each one in the .flan file as a while or until \
over let variables it changes, then convert again:\n\n\
\ (let [i 0 total 0]\n\
\ (while (< i 10)\n\
\ (set total (+ total i))\n\
\ (set i (+ i 1))))"
(if List.length lines = 1 then "" else "s")
(match List.rev_map string_of_int lines with
| last :: (_ :: _ as before) ->
String.concat ", " (List.rev before) ^ " and " ^ last
| ls -> String.concat "" ls)
(** A whole file: top-level forms with a blank line between them. [macros]
is [Body_macros.table] of the file; without it, the prelude's and the
file's own macros are known and no imported package's. *)
let program ?source ?macros:m (fs : Form.t list) : string =
refuse_loops fs;
macros := (match m with Some m -> m | None -> Body_macros.table fs);
classes :=
List.filter_map

165
lib/indent_reader.ml
View File

@ -23,6 +23,7 @@ type tok =
| COMMA
| COLON (* x: T, and the trailing : of a call's block *)
| UNQ | SPLICE (* ~ and ~@ *)
| BNOT (* ~~, bit-not; a nested unquote is ~(~x) *)
| NEG (* the - glued to the front of a name *)
| NEWLINE | INDENT | DEDENT | EOF
@ -36,7 +37,7 @@ let show = function
| ATOM v -> Form.to_source (Form.make v Loc.unknown)
| DATUM f -> Form.to_source f
| LP -> "(" | RP -> ")" | LB -> "[" | RB -> "]" | LC -> "{" | RC -> "}"
| COMMA -> "," | COLON -> ":" | UNQ -> "~" | SPLICE -> "~@" | NEG -> "-"
| COMMA -> "," | COLON -> ":" | UNQ -> "~" | SPLICE -> "~@" | BNOT -> "~~" | NEG -> "-"
| NEWLINE -> "the end of the line"
| INDENT -> "an indented line"
| DEDENT -> "the end of the block"
@ -45,17 +46,23 @@ let show = function
(* ── Names ─────────────────────────────────────────────────────────── *)
(* Binary operators and their levels, low to high (spec §2 "Precedence").
[not] sits at 3 and unary minus at 8; neither is binary. *)
[not] sits at 3 and the prefix [-] and [~~] at 11; neither is binary. The
bit operators sit between the comparisons and the shifts, Python's and
Rust's order, so [x && mask == 0] is [(x && mask) == 0]. *)
let binops =
[ ("or", 1); ("and", 2);
("==", 4); ("!=", 4); ("<", 4); ("<=", 4); (">", 4); (">=", 4);
("<<", 5); (">>", 5); ("+", 6); ("-", 6); ("*", 7); ("/", 7); ("%", 7) ]
("||", 5); ("^^", 6); ("&&", 7);
("<<", 8); (">>", 8); ("+", 9); ("-", 9); ("*", 10); ("/", 10); ("%", 10) ]
let binop_level s = List.assoc_opt s binops
let is_binop s = binop_level s <> None
(* [==] is Flan's [=]; every other operator is its own name. *)
let op_sym = function "==" -> "=" | s -> s
(* [==] is Flan's [=], and the bit operators are the words the Lisp side
writes; every other operator is its own name. *)
let op_sym = function
| "==" -> "=" | "&&" -> "bit-and" | "||" -> "bit-or" | "^^" -> "bit-xor"
| s -> s
(* Words that are operators rather than names wherever a value is read. Alone
before a comma or a closer they are the symbol itself, [reduce(+, 0, xs)];
@ -185,7 +192,11 @@ let lex ?(line = 1) ?(col = 1) ~file src : token list =
indented block, or quasiquote(x) on one line"
| '~' ->
Reader.advance st;
if Reader.peek st = '@' then begin
if Reader.peek st = '~' then begin
Reader.advance st;
emit BNOT (Loc.upto l0 (Reader.here st))
end
else if Reader.peek st = '@' then begin
Reader.advance st;
emit SPLICE (Loc.upto l0 (Reader.here st))
end
@ -521,7 +532,7 @@ let where_ p =
| _ -> t.loc
let starts_value = function
| NAME _ | KW _ | ATOM _ | DATUM _ | LP | LB | LC | UNQ | SPLICE | NEG -> true
| NAME _ | KW _ | ATOM _ | DATUM _ | LP | LB | LC | UNQ | SPLICE | BNOT | NEG -> true
| _ -> false
let ends_value = function
@ -654,16 +665,27 @@ let refuse_ws ?(brace = false) loc e =
(if brace then "entries" else "elements")
(if brace then "{.x a + 1, .y 2}" else "[a - 1, b]")
(* Expressions come back with their syntactic level: 10 an atom or a bracket,
9 a postfix chain, 8 a unary minus, 1-7 a binary operator's level, 3 a
[not], 0 a one-line [if] or a lambda. Anything under 8 is "compound": it
has an operator at its top, so it cannot sit in a list separated only by
whitespace. *)
(* [loop] and [recur] are Lisp-syntax forms. A .fln loop is a [while],
[until], [dotimes] or [for]; [read_all] refuses any that gets past the
parser, in a [quote] or a quoted datum too. *)
let no_loop loc word =
failk "no-loop" loc
"%s is not part of the indented syntax. A loop here is a while, until, \
dotimes or for, with let variables it changes:\n\n\
\ let i = 0\n let total = 0\n while i < 10\n total += i\n i += 1\n\n\
break leaves the loop early, and continue goes on to the next round."
word
(* Expressions come back with their syntactic level: 13 an atom or a bracket,
12 a postfix chain, 11 a prefix [-] or [~~], 1-10 a binary operator's
level, 3 a [not], 0 a one-line [if] or a lambda. Anything under 11 is
"compound": it has an operator at its top, so it cannot sit in a list
separated only by whitespace. *)
let rec expr p : Form.t * int = binary p 1
and binary p lvl : Form.t * int =
if lvl = 3 then not_ p
else if lvl > 7 then unary p
else if lvl > 10 then unary p
else
let l0 = (peek p).loc in
let ((first, _) as fst_) = binary p (lvl + 1) in
@ -727,7 +749,11 @@ and unary p =
| NEG ->
ignore (advance p);
let x, _ = postfix p in
(mk p t.loc (Form.List [ sym t.loc "-"; x ]), 8)
(mk p t.loc (Form.List [ sym t.loc "-"; x ]), 11)
| BNOT ->
ignore (advance p);
let x, _ = unary p in
(mk p t.loc (Form.List [ sym t.loc "bit-not"; x ]), 11)
| _ -> postfix p
and postfix p =
@ -740,18 +766,18 @@ and postfix p =
| LP ->
ignore (advance p);
let args = items p RP t.loc ~what:"arguments" in
loop (mk p l0 (Form.List (f :: args)), 9)
loop (mk p l0 (Form.List (f :: args)), 12)
| LB ->
ignore (advance p);
let idx = items p RB t.loc ~what:"indices" ~head:(text_of f) in
loop (mk p l0 (Form.List (sym t.loc "at" :: f :: idx)), 9)
loop (mk p l0 (Form.List (sym t.loc "at" :: f :: idx)), 12)
| NAME s when String.length s > 1 && s.[0] = '.' ->
ignore (advance p);
loop (mk p l0 (Form.List [ sym t.loc s; f ]), 9)
loop (mk p l0 (Form.List [ sym t.loc s; f ]), 12)
| LC ->
ignore (advance p);
let m = map_items p t.loc in
loop (mk p l0 (Form.List [ f; Form.make (Form.Map m) (span p t.loc) ]), 9)
loop (mk p l0 (Form.List [ f; Form.make (Form.Map m) (span p t.loc) ]), 12)
| _ -> fp
in
loop (primary p)
@ -765,10 +791,25 @@ and primary p : Form.t * int =
let glued_lp = nxt.tok = LP && not nxt.sp in
if s = "if" && nxt.sp && starts_value nxt.tok then if_expr p
else if s = "fn" && glued_lp then fn_expr p
(* Only the Lisp loop's spellings are refused here, for a message at the
word: [loop x = a, ...], [loop([...]):], a bare [loop] over a block
where a statement or a let's value starts, and [recur(...)]. Anywhere
else [loop] and [recur] are names; [refuse_loops] catches the rest. *)
else if glued_lp && (s = "loop" || s = "recur") then no_loop l0 s
else if s = "loop"
&& ((nxt.sp
&& (match nxt.tok with NAME x -> not (is_op_word x) | _ -> false)
&& (match (peek_at p 2).tok with NAME "=" | COMMA -> true | _ -> false))
|| (nxt.tok = NEWLINE && (peek_at p 2).tok = INDENT
&& (p.i = 0
|| (match (last p).tok with
| NEWLINE | INDENT | DEDENT | NAME "=" -> true
| _ -> false)))) then
no_loop l0 s
else if is_op_word s then begin
if glued_lp || ends_value nxt.tok then begin
ignore (advance p);
(sym l0 (op_sym s), 10)
(sym l0 (op_sym s), 13)
end
else
failk "operator-operand" l0
@ -780,18 +821,18 @@ and primary p : Form.t * int =
else begin
ignore (advance p);
check_name t s;
(sym l0 s, 10)
(sym l0 s, 13)
end
| KW k -> ignore (advance p); (Form.make (Form.Kw k) l0, 10)
| KW k -> ignore (advance p); (Form.make (Form.Kw k) l0, 13)
| ATOM v ->
ignore (advance p);
(Form.make v l0, if negative_literal t.tok then 8 else 10)
| DATUM f -> ignore (advance p); (f, 10)
(Form.make v l0, if negative_literal t.tok then 11 else 13)
| DATUM f -> ignore (advance p); (f, 13)
| LP ->
ignore (advance p);
if (peek p).tok = RP then begin
ignore (advance p);
(mk p l0 (Form.List []), 10)
(mk p l0 (Form.List []), 13)
end
else
let e, _ = expr p in
@ -804,21 +845,21 @@ and primary p : Form.t * int =
Several values in a list are written in brackets, [a, b]; \
arguments go glued to a name, f(a, b)"
| _ -> stray p ~after:(text_of e));
(e, 10)
(e, 13)
| LB ->
ignore (advance p);
let xs = vec_items p l0 in
(mk p l0 (Form.Vec xs), 10)
(mk p l0 (Form.Vec xs), 13)
| LC ->
ignore (advance p);
let xs = map_items p l0 in
(mk p l0 (Form.Map xs), 10)
(mk p l0 (Form.Map xs), 13)
| UNQ | SPLICE ->
ignore (advance p);
let x, _ = primary p in
let name = if t.tok = UNQ then "unquote" else "unquote-splicing" in
(mk p l0 (Form.List [ sym l0 name; x ]), 10)
| NEG -> unary p
(mk p l0 (Form.List [ sym l0 name; x ]), 13)
| NEG | BNOT -> unary p
| tk ->
failk "expected-value" (where_ p) "expected a value here, and found %s"
(show tk)
@ -919,7 +960,7 @@ and fn_expr p =
is what follows. *)
| tk when names && n.loc.Loc.line > rp.loc.Loc.eline && starts_value tk ->
lambda_arrow n.loc (header ())
| _ -> (mk p t.loc (Form.List (sym t.loc "fn" :: args)), 9)
| _ -> (mk p t.loc (Form.List (sym t.loc "fn" :: args)), 12)
(* What follows a lambda's [=>]: a value on the line, or the indented block
under it. [header] is the lambda's header as written, for a message. *)
@ -1063,7 +1104,7 @@ and vec_items p open_loc =
| EOF -> unclosed p '[' open_loc
| _ ->
let e, lvl = expr p in
if lvl < 8 && prev_ws then refuse_ws t.loc e;
if lvl < 11 && prev_ws then refuse_ws t.loc e;
(match (peek p).tok with
| COMMA ->
if !spaces then mixed (peek p).loc;
@ -1072,7 +1113,7 @@ and vec_items p open_loc =
| RB -> ignore (advance p); List.rev (e :: acc)
| EOF -> unclosed p '[' open_loc
| tk when starts_value tk && (peek p).sp ->
if lvl < 8 then refuse_ws t.loc e;
if lvl < 11 then refuse_ws t.loc e;
if !commas then mixed (peek p).loc;
spaces := true;
go (e :: acc) true
@ -1103,7 +1144,7 @@ and map_items p open_loc =
and no %s between it and the value"
n (if tk = COLON then "colon" else "= sign")
| tk when starts_value tk && (peek p).sp ->
if lvl < 8 then refuse_ws ~brace:true t.loc e;
if lvl < 11 then refuse_ws ~brace:true t.loc e;
go (e :: acc)
| _ -> stray p ~after:(text_of e))
in
@ -1222,13 +1263,6 @@ let header_follow p s =
&& (let a = peek_at p 2 in a.tok = LP && not a.sp)
(* [type Row = Vec(i32)]: a name and its [=]. *)
| "type" -> n.sp && plain_name n.tok && (peek_at p 2).tok = NAME "="
(* [loop x = a, ...]: a name and its [=]. A name and a comma or the end
of the line, or [loop] alone over a block, is a loop missing its first
values, which [header] answers. *)
| "loop" ->
(n.sp && plain_name n.tok
&& (match (peek_at p 2).tok with NAME "=" | COMMA | NEWLINE -> true | _ -> false))
|| (n.tok = NEWLINE && (peek_at p 2).tok = INDENT)
| "return" -> n.tok = NEWLINE || (n.sp && starts_value n.tok)
| "break" | "continue" ->
n.tok = NEWLINE || (n.sp && (match n.tok with KW _ -> true | _ -> false))
@ -1392,7 +1426,7 @@ and value_line ?(block_ok = false) (s : st) ~after : Form.t =
match (peek p).tok with
(* [let r = match a] with its arms under it, and [let r = if c] with its
branches: a header read as the value, block and all. *)
| NAME (("match" | "handler-case" | "handler-bind" | "restart-case" | "loop") as w)
| NAME (("match" | "handler-case" | "handler-bind" | "restart-case") as w)
when header_follow p w ->
header s w
| NAME "if" when header_follow p "if" && not (then_on_line p) -> header s "if"
@ -1892,31 +1926,6 @@ and header (s : st) w : Form.t =
expect_line_end p ~after:")";
let body = block s ~after:("macro " ^ text_of name ^ "(...)") in
named "defmacro" (name :: pv :: body)
| "loop" ->
let missing () =
failk "loop-bindings" l0
"loop names each variable with its first value: loop i = 0, acc = 1. \
A loop with no variables is written loop([]):"
in
if (peek p).tok = NEWLINE then missing ();
let rec binds acc =
let n = name_tok p ~what:"a loop variable's name" in
(match (peek p).tok with
| NAME "=" -> ignore (advance p)
| _ ->
failk "loop-bindings" n.loc
"%s needs its first value: loop %s = 0. Each variable of a loop \
takes one, separated by commas: loop i = 0, acc = 1"
(text_of n) (text_of n));
let v, _ = expr p in
match (peek p).tok with
| COMMA -> ignore (advance p); binds (v :: n :: acc)
| _ -> List.rev (v :: n :: acc)
in
let bs = binds [] in
expect_line_end p ~after:(text_of (List.nth bs (List.length bs - 1)));
let body = block s ~after:"loop" in
form (Form.make (Form.Vec bs) (span_of_list (List.hd bs).loc bs) :: body)
| "data" ->
let name = name_tok p ~what:"the type's name" in
expect_eol_block p ~after:("data " ^ text_of name);
@ -2257,6 +2266,29 @@ and lines (s : st) (one : unit -> Form.t list) : Form.t list =
let () = block_of := fun p -> block { p; lets = [] } ~after:"=>"
(* Every [(loop ...)] and [(recur ...)] in [fs], at any depth and inside
quoted code too, in source order. The indented syntax has neither: its
loops are [while], [until], [dotimes] and [for]. The printer asks the same
question before it converts a .flan file. *)
let loop_forms (fs : Form.t list) =
let out = ref [] in
let rec walk (f : Form.t) =
match f.v with
| Form.List ({ v = Form.Sym ("loop" | "recur"); _ } :: _) ->
out := f :: !out;
(match f.v with Form.List l -> List.iter walk l | _ -> ())
| Form.List l | Form.Vec l | Form.Map l -> List.iter walk l
| _ -> ()
in
List.iter walk fs;
List.rev !out
let refuse_loops fs =
match loop_forms fs with
| [] -> ()
| (f : Form.t) :: _ ->
no_loop f.loc (match f.v with Form.List ({ v = Form.Sym w; _ } :: _) -> w | _ -> "loop")
(** All top-level forms in a [.fln] source string. [col] is the column the
text's top level starts at, 1 for a file. *)
let read_all ?(line = 1) ?col ?indent ?(global_let = true) ~file src =
@ -2287,6 +2319,7 @@ let read_all ?(line = 1) ?col ?indent ?(global_let = true) ~file src =
(match (peek s.p).tok with
| EOF -> ()
| tk -> failk "unexpected-token" (where_ s.p) "unexpected %s" (show tk));
refuse_loops fs;
fs)
let read_file path =

6
lib/js.ml
View File

@ -889,6 +889,12 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) =
| Tast.Not, [ x ] -> Printf.sprintf "(!%s)" (value f x)
| (Tast.BitAnd | Tast.BitOr | Tast.BitXor | Tast.Shl | Tast.Shr), [ x; y ]
-> bitwise f e p x y
| Tast.BitNot, [ x ] -> (
match x.Tast.ty with
| Types.Int k -> norm k (Printf.sprintf "~(%s)" (value f x))
| t -> at loc "a bitwise operation on %s" (Types.to_string t))
| (Tast.Popcount | Tast.Clz | Tast.Ctz | Tast.Rotl | Tast.Rotr), _ ->
at loc "the bit counts and rotations are not in the JS dialect"
| Tast.Len, [ x ] -> (
match x.Tast.ty with
| Types.Array (n, _) -> Printf.sprintf "%Ld" n

3
lib/reader.ml
View File

@ -209,6 +209,9 @@ let rec read_form st =
advance st;
if peek st = '@' then (advance st; read_wrapped st loc "unquote-splicing")
else read_wrapped st loc "unquote"
(* [^^] is bit-xor's other name, and metadata on a form that starts with
[^] would mean nothing, so the two cannot collide. *)
| '^' when peek2 st = '^' -> read_symbol_or_keyword st
| '^' ->
Loc.failk "reader/metadata" loc "metadata (^) is not supported yet"

4
lib/tast.ml
View File

@ -23,6 +23,10 @@ type prim =
(* bitwise, integers only. [Shr] is arithmetic on a signed type and logical
on an unsigned one, which is what the operand's own kind already says. *)
| BitAnd | BitOr | BitXor | Shl | Shr
(* One operand each, and the answer has the operand's type. [Clz] and [Ctz]
answer the width for zero. [Rotl] and [Rotr] take the count modulo the
width, so no count is out of range. *)
| BitNot | Popcount | Clz | Ctz | Rotl | Rotr
(* containers: fixed arrays and slices only at milestone 2 *)
| Len | At | Slice
(* (slice-from p n): a [T] made out of a (Ptr T) and a length the caller

87
lib/x86.ml
View File

@ -386,6 +386,32 @@ let shift_cl b ~ext ~dst = rex b ~w:true ~r:0 ~x:0 ~m:dst; u8 b 0xd3; modrm_r b
let shl_cl b ~dst = shift_cl b ~ext:4 ~dst
let shr_cl b ~dst = shift_cl b ~ext:5 ~dst
let sar_cl b ~dst = shift_cl b ~ext:7 ~dst
let shift_imm b ~ext ~dst n =
rex b ~w:true ~r:0 ~x:0 ~m:dst; u8 b 0xc1; modrm_r b ~r:ext ~m:dst; u8 b n
(* bsf (0xbc) and bsr (0xbd): the index of the lowest or highest set bit, with
ZF set and the destination undefined when the source is zero. Both are in
every x86-64 CPU, which tzcnt, lzcnt and popcnt are not. *)
let bitscan b ~op ~dst ~src =
rex b ~w:true ~r:dst ~x:0 ~m:src; u8 b 0x0f; u8 b op; modrm_r b ~r:dst ~m:src
let cmovz_rr b ~dst ~src =
rex b ~w:true ~r:dst ~x:0 ~m:src; u8 b 0x0f; u8 b 0x44; modrm_r b ~r:dst ~m:src
(* rol (ext 0) and ror (ext 1) by cl at the operand's own width, unlike the
shifts above: a rotation at 64 bits of a value that is 8 wide would bring
the wrong bits round. The hardware masks cl to 5 bits (6 at 64) and then
rotates modulo the width, which is the language's rule for every width. *)
let rot_cl b ~ext ~bits ~dst =
match bits with
| 8 ->
rex ~force:(dst >= 4) b ~w:false ~r:0 ~x:0 ~m:dst; u8 b 0xd2;
modrm_r b ~r:ext ~m:dst
| 16 ->
u8 b 0x66; rex b ~w:false ~r:0 ~x:0 ~m:dst; u8 b 0xd3;
modrm_r b ~r:ext ~m:dst
| 32 -> rex b ~w:false ~r:0 ~x:0 ~m:dst; u8 b 0xd3; modrm_r b ~r:ext ~m:dst
| _ -> rex b ~w:true ~r:0 ~x:0 ~m:dst; u8 b 0xd3; modrm_r b ~r:ext ~m:dst
let setcc b ~cc ~dst =
rex ~force:(dst >= 4) b ~w:false ~r:0 ~x:0 ~m:dst;
@ -3403,7 +3429,66 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) dst =
end;
movzx8 f.b ~dst:rax ~src:rax;
store_loc f ~reg:rax dst Types.Bool
| Tast.Not, [ a ] ->
(* Zero-extended to 64 bits first, so a negative i8 counts eight bits and
not sixty-four. Every sequence below is baseline x86-64, the target LLVM
is given too: popcount is the SWAR sum LLVM writes for [ctpop] without
popcnt, and the two scans answer the width for zero through a cmov on the
flag bsr and bsf set. *)
| (Tast.Popcount | Tast.Clz | Tast.Ctz), [ a ] ->
let la = eval f a in
let w =
match a.Tast.ty with
| Types.Int k -> Types.bits k
| t -> unsupported "a bit count of %s" (Types.to_string t)
in
load_int f.b ~dst:rax ~mm:(lmem f la ~scratch:r11) ~size:(w / 8)
~signed:false;
(match p with
| Tast.Popcount ->
mov_rr f.b ~dst:rcx ~src:rax;
shift_imm f.b ~ext:5 ~dst:rcx 1;
imm_into f ~reg:rdx 0x5555555555555555L;
and_rr f.b ~dst:rcx ~src:rdx;
sub_rr f.b ~dst:rax ~src:rcx;
imm_into f ~reg:rdx 0x3333333333333333L;
mov_rr f.b ~dst:rcx ~src:rax;
and_rr f.b ~dst:rcx ~src:rdx;
shift_imm f.b ~ext:5 ~dst:rax 2;
and_rr f.b ~dst:rax ~src:rdx;
add_rr f.b ~dst:rax ~src:rcx;
mov_rr f.b ~dst:rcx ~src:rax;
shift_imm f.b ~ext:5 ~dst:rcx 4;
add_rr f.b ~dst:rax ~src:rcx;
imm_into f ~reg:rdx 0x0f0f0f0f0f0f0f0fL;
and_rr f.b ~dst:rax ~src:rdx;
imm_into f ~reg:rdx 0x0101010101010101L;
imul_rr f.b ~dst:rax ~src:rdx;
shift_imm f.b ~ext:5 ~dst:rax 56
| Tast.Clz ->
bitscan f.b ~op:0xbd ~dst:rcx ~src:rax;
imm_into f ~reg:rdx (-1L);
cmovz_rr f.b ~dst:rcx ~src:rdx;
imm_into f ~reg:rax (Int64.of_int (w - 1));
sub_rr f.b ~dst:rax ~src:rcx
| _ ->
bitscan f.b ~op:0xbc ~dst:rcx ~src:rax;
imm_into f ~reg:rdx (Int64.of_int w);
cmovz_rr f.b ~dst:rcx ~src:rdx;
mov_rr f.b ~dst:rax ~src:rcx);
store_loc f ~reg:rax dst t
| (Tast.Rotl | Tast.Rotr), [ a; b ] ->
let la = eval f a in
let lb = eval f b in
let w =
match a.Tast.ty with
| Types.Int k -> Types.bits k
| t -> unsupported "a rotation of %s" (Types.to_string t)
in
load_loc f ~reg:rax la a.Tast.ty;
load_loc f ~reg:rcx lb b.Tast.ty;
rot_cl f.b ~ext:(if p = Tast.Rotl then 0 else 1) ~bits:w ~dst:rax;
store_loc f ~reg:rax dst t
| (Tast.Not | Tast.BitNot), [ a ] ->
let la = eval f a in
if Types.equal a.Tast.ty Types.Bool then begin
load_loc f ~reg:rax la Types.Bool;

108
runtime/flan_dev.c
View File

@ -1293,9 +1293,17 @@ void *flan_dev_frame_slot(const void *frame, int32_t i) {
* header says a module is never dlclose'd, so they outlive the table.
*/
/* A power of two: the probe wraps with a mask. Fixed, and full is not fatal —
* see flan_dev_reg_note. */
#define FLAN_REG_CAP 4096
/* A power of two: the probe wraps with a mask. The table starts here and
* doubles when three quarters of it is live ([flan_reg_grow]): a dyn view's
* dev check asks it whether a block is still alive, and a table that dropped
* notes would answer "never heard of it" for a block that has since been
* freed, which is the check silently stopping. Read as [FLAN_REG_CAP]: the
* capacity is loaded before the table's address, and [flan_reg_grow] stores
* them the other way round, so a reader never pairs the larger capacity with
* the smaller table. */
#define FLAN_REG_CAP0 4096
static int64_t flan_reg_capv = FLAN_REG_CAP0;
#define FLAN_REG_CAP (__atomic_load_n(&flan_reg_capv, __ATOMIC_ACQUIRE))
/* How many dead entries make a compaction worth running. Not a tuning knob: it
* is the difference between a diagnostic that works on a big program and one
@ -1467,13 +1475,30 @@ static int flan_reg_snap(flan_reg_entry *e, flan_reg_entry *out) {
/* The table-wide counter, read on the way into a scan and again on the way
* out: a compaction between the two moved entries, so the scan saw some of
* them twice and some not at all. */
static uint64_t flan_reg_grows; /* how many times the table has grown */
static void flan_reg_wait(void);
static int flan_reg_scan_open(uint64_t *at) {
uint64_t g = __atomic_load_n(&flan_reg_epoch, __ATOMIC_ACQUIRE);
/* A growth copies the whole table and takes longer than a compaction, long
enough to use up a listing's attempts one wait at a time. So a listing
that meets one waits it out, up to a tenth of a second, rather than
counting each look as a lost attempt. */
for (int w = 0; (g & 1) && w < 400; w++) {
flan_reg_wait();
g = __atomic_load_n(&flan_reg_epoch, __ATOMIC_ACQUIRE);
}
if (g & 1) return 0;
*at = g;
return 1;
}
/* Did the table grow since [grows0]? A walk that a growth overlapped is
retried without counting against its attempts: a growth ends. */
static int flan_reg_grew(uint64_t grows0) {
return __atomic_load_n(&flan_reg_grows, __ATOMIC_ACQUIRE) != grows0;
}
static int flan_reg_scan_ok(uint64_t at) {
__atomic_thread_fence(__ATOMIC_ACQUIRE);
return __atomic_load_n(&flan_reg_epoch, __ATOMIC_ACQUIRE) == at;
@ -1523,10 +1548,10 @@ static void flan_reg_say_full(const char *why) {
if (flan_reg_full) return;
flan_reg_full = 1;
fprintf(stderr,
"flan: the allocation registry is full (%d blocks) — %s. Blocks "
"flan: the allocation registry is full (%lld blocks) — %s. Blocks "
"noted from here on are dropped, so every listing is a floor and "
"not a count.\n",
FLAN_REG_CAP, why);
(long long)FLAN_REG_CAP, why);
}
/* Armed by the program's entry in a dev build. The free-side hooks in
@ -1537,14 +1562,17 @@ static void flan_reg_say_full(const char *why) {
* repeating the claim that a release build carries nothing. */
static void flan_reg_report(void); /* the exit report, at the bottom */
extern int flan_dev_views_checked; /* defined below */
void flan_dev_reg_enable(void) {
if (flan_reg_on) return;
flan_reg = (flan_reg_entry *)calloc(FLAN_REG_CAP, sizeof *flan_reg);
flan_reg = (flan_reg_entry *)calloc((size_t)FLAN_REG_CAP, sizeof *flan_reg);
/* A registry that could not be made is not worth dying over; the flag stays
off and every question about an address answers "never heard of it",
which is what a release build answers too. */
if (flan_reg == NULL) return;
flan_reg_on = 1;
flan_dev_views_checked = 1;
/* Here and not at file scope: a destructor attribute would run in every
build, since this file is linked into every build, and that would be a
third place a release build is not free. Registered from inside the one
@ -1555,6 +1583,10 @@ void flan_dev_reg_enable(void) {
int flan_dev_reg_enabled(void) { return flan_reg_on; }
/* The same flag as a word flan_dyn.c reads on every view's crossing: a dyn
* view carries its dev record only when this is set. */
int flan_dev_views_checked;
/* A block a resize moved away from, filled with 0xDEADBEEF words in a dev
* build. A slice is a pointer and a length and carries nothing that could say
* the Vec under it grew, so a slice taken before a push that moved the storage
@ -1700,6 +1732,34 @@ static flan_reg_entry *flan_reg_live_at(uintptr_t base) {
* losing the live half. When they are not the bulk of it this does nothing but
* move live entries around and hold the epoch odd while it does — see
* FLAN_REG_RECLAIM for the wrong answers that bought. */
/* Twice the room, every entry carried over, live and dead alike (a dead one
* still names what died). Under the table-wide counter, as a compaction is,
* so a listing that overlapped it starts again. The old table is not freed:
* a listing on the listener thread may still be reading it, and a dev build
* can afford the half it keeps. 0 when the memory could not be had, and the
* table stays as it was. */
static int flan_reg_grow(void) {
int64_t cap = FLAN_REG_CAP, ncap = cap * 2, i;
flan_reg_entry *n = (flan_reg_entry *)calloc((size_t)ncap, sizeof *n);
if (n == NULL) return 0;
__atomic_store_n(&flan_reg_epoch, flan_reg_epoch | 1, __ATOMIC_RELAXED);
__atomic_thread_fence(__ATOMIC_RELEASE);
for (i = 0; i < cap; i++) {
size_t j;
if (flan_reg[i].base == 0) continue;
j = (size_t)(((flan_reg[i].base >> 3) * 11400714819323198485ULL) >> 40)
& (size_t)(ncap - 1);
while (n[j].base != 0) j = (j + 1) & (size_t)(ncap - 1);
n[j] = flan_reg[i];
n[j].gen = 0;
}
__atomic_store_n(&flan_reg, n, __ATOMIC_RELEASE);
__atomic_store_n(&flan_reg_capv, ncap, __ATOMIC_RELEASE);
__atomic_store_n(&flan_reg_grows, flan_reg_grows + 1, __ATOMIC_RELEASE);
__atomic_store_n(&flan_reg_epoch, (flan_reg_epoch | 1) + 1, __ATOMIC_RELEASE);
return 1;
}
static void flan_reg_compact(void) {
size_t bytes = FLAN_REG_CAP * sizeof(flan_reg_entry);
flan_reg_entry *old = (flan_reg_entry *)malloc(bytes);
@ -1793,6 +1853,9 @@ static void flan_reg_note_full(void *base, int64_t bytes, int64_t elem,
if (flan_reg_used * 4 > (int64_t)FLAN_REG_CAP * 3
&& flan_reg_dead >= FLAN_REG_RECLAIM)
flan_reg_compact();
/* Still three quarters full once the dead are gone: the live set outgrew
the table, so the table grows rather than drop what comes next. */
if (flan_reg_used * 4 > (int64_t)FLAN_REG_CAP * 3) flan_reg_grow();
s = flan_reg_slot(a);
for (probe = 0; probe < FLAN_REG_CAP; probe++) {
size_t j = (s + (size_t)probe) & (FLAN_REG_CAP - 1);
@ -1851,11 +1914,29 @@ int flan_dev_reg_overflowed(void) { return flan_reg_full; }
* block handed out as a slice. */
static flan_reg_entry *flan_reg_find(uintptr_t a);
/* The entry for a block that starts at [base], live before dead, by the
* probe a free takes: (free s) always hands over a block's start, so the
* question is equality and a scan of the whole table — which grows — would
* make every free cost the table's size. NULL when no block starts there. */
static flan_reg_entry *flan_reg_at_base(uintptr_t base) {
flan_reg_entry *dead = NULL;
int64_t cap = FLAN_REG_CAP, probe;
size_t s0 = flan_reg_slot(base);
for (probe = 0; probe < cap; probe++) {
size_t j = (s0 + (size_t)probe) & (size_t)(cap - 1);
if (flan_reg[j].base == 0) break;
if (flan_reg[j].base != base) continue;
if (flan_reg[j].died == 0) return &flan_reg[j];
if (dead == NULL) dead = &flan_reg[j];
}
return dead;
}
int32_t flan_dev_reg_owner_check(const void *p, const void *owner,
const void **found) {
flan_reg_entry *e;
if (!flan_reg_on) return 0;
e = flan_reg_find((uintptr_t)p);
e = flan_reg_at_base((uintptr_t)p);
if (e == NULL) return flan_reg_full ? 0 : 1;
if (e->base != (uintptr_t)p) return 1;
if (e->died != 0) return 3;
@ -2108,8 +2189,9 @@ int32_t flan_dev_reg_at(const void *p, const char **type, int64_t *typelen,
rearrangement they are all losing to — and leaving one bare retry in the
file next to the note explaining why they are wrong is how the next
person learns the rule has exceptions it does not have. */
int regrown = 0;
for (attempt = 0; attempt < 8; attempt++) {
uint64_t at;
uint64_t at, grows0 = __atomic_load_n(&flan_reg_grows, __ATOMIC_ACQUIRE);
int64_t i;
have = 0;
if (!flan_reg_scan_open(&at)) { flan_reg_wait(); continue; }
@ -2123,6 +2205,7 @@ int32_t flan_dev_reg_at(const void *p, const char **type, int64_t *typelen,
}
if (flan_reg_scan_ok(at)) break;
have = 0;
if (flan_reg_grew(grows0) && regrown++ < 64) attempt--;
flan_reg_wait();
}
if (!have) return 0;
@ -2193,8 +2276,9 @@ int64_t flan_dev_reg_by_type(int32_t live_only, int64_t *counts,
the end of a string literal. The whole walk is retried when a compaction
ran through the middle of it, since entries moved and the counts would
hold some blocks twice and some not at all. */
int regrown = 0;
for (attempt = 0; attempt < 8; attempt++) {
uint64_t at;
uint64_t at, grows0 = __atomic_load_n(&flan_reg_grows, __ATOMIC_ACQUIRE);
n = 0;
missed = 0;
if (!flan_reg_scan_open(&at)) { flan_reg_wait(); continue; }
@ -2225,7 +2309,11 @@ int64_t flan_dev_reg_by_type(int32_t live_only, int64_t *counts,
}
n++;
}
if (!flan_reg_scan_ok(at)) { flan_reg_wait(); continue; }
if (!flan_reg_scan_ok(at)) {
if (flan_reg_grew(grows0) && regrown++ < 64) attempt--;
flan_reg_wait();
continue;
}
/* A stable epoch and every slot copied: this is a table that existed. */
if (missed == 0) return n;
/* A stable epoch but slots that would not hold still. Worth another walk —

393
runtime/flan_dyn.c
View File

@ -63,6 +63,41 @@ void flan_dev_watch_emit(const uint8_t *bytes, int64_t len);
* program die where it stands", which that file went to some trouble to have
* only one of. So flan_rt.c exports a thin wrapper and this calls it. */
_Noreturn void flan_trap(const uint8_t *name, int64_t namelen);
/* The site and operation a walk over a view reports a trap at — a print, an
* equality, a length — set by the entry point that has them and read by the
* element readers the walk calls. NULL when the entry point has no site.
* Every trap in this file goes through [dyn_trap], which clears them first:
* a trap does not return to the [walk_leave] that would have, and a later
* walk must not name the site of one that was abandoned. */
static const uint8_t *walk_loc;
static int64_t walk_len;
static const char *walk_op = "print";
typedef struct { const uint8_t *loc; int64_t len; const char *op; } walk_site;
static walk_site walk_enter(const uint8_t *loc, int64_t len, const char *op) {
walk_site was;
was.loc = walk_loc; was.len = walk_len; was.op = walk_op;
walk_loc = loc; walk_len = loc != NULL ? len : 0; walk_op = op;
return was;
}
static void walk_leave(walk_site was) {
walk_loc = was.loc; walk_len = was.len; walk_op = was.op;
}
int flan_dev_reg_enabled(void);
/* runtime/flan_dev.c: set with the registry, so a view's crossing reads a
* word rather than making a call to learn it is in a release build. */
extern int flan_dev_views_checked;
static _Noreturn void dyn_trap(const uint8_t *name, int64_t namelen) {
walk_loc = NULL;
walk_len = 0;
walk_op = "print";
flan_trap(name, namelen);
}
/* A trap's sentence, printed after its site and kept for the break loop, which
* shows it beside the trap's name (flan_rt.c). */
void flan_say(const uint8_t *loc, int64_t loclen, const char *fmt, ...);
@ -538,7 +573,7 @@ int32_t flan_dyn_tag(flan_dyn v) {
case OBJ_VEC: return FLAN_DYN_TAG_VEC;
/* ...and a struct's view answers a map's, [gen] being its shape
(VIEW_STRUCT, below). */
case OBJ_VIEW: return o->gen == 2 ? FLAN_DYN_TAG_MAP : FLAN_DYN_TAG_VEC;
case OBJ_VIEW: return (o->gen & 0xff) == 2 ? FLAN_DYN_TAG_MAP : FLAN_DYN_TAG_VEC;
case OBJ_MAP: return FLAN_DYN_TAG_MAP;
default: return FLAN_DYN_TAG_INT;
}
@ -649,7 +684,7 @@ static double dyn_num_value(flan_dyn v);
* they are defined, alongside the container operations below */
static int64_t view_len(const uint8_t *loc, int64_t loclen, const char *op,
flan_obj *o);
static void view_guard_check(const uint8_t *loc, int64_t loclen,
static inline void view_guard_check(const uint8_t *loc, int64_t loclen,
const char *op, flan_obj *o);
/* A struct view's fields, for the map arms of the printers. */
static int64_t view_nfields(flan_obj *o);
@ -668,25 +703,6 @@ static int view_big_u64(flan_obj *o, int64_t i, int field,
static int64_t vecish_len(flan_obj *o);
static flan_dyn vecish_at(flan_obj *o, int64_t i);
/* The site and operation a walk over a view reports a trap at — a print, an
* equality, a length — set by the entry point that has them and read by the
* element readers the walk calls. NULL when the entry point has no site. */
static const uint8_t *walk_loc;
static int64_t walk_len;
static const char *walk_op = "print";
typedef struct { const uint8_t *loc; int64_t len; const char *op; } walk_site;
static walk_site walk_enter(const uint8_t *loc, int64_t len, const char *op) {
walk_site was;
was.loc = walk_loc; was.len = walk_len; was.op = walk_op;
walk_loc = loc; walk_len = loc != NULL ? len : 0; walk_op = op;
return was;
}
static void walk_leave(walk_site was) {
walk_loc = was.loc; walk_len = was.len; walk_op = was.op;
}
static void render(dyn_sink w, flan_dyn v, int depth, int nested) {
char buf[64];
@ -1022,7 +1038,7 @@ static _Noreturn void trap2(const uint8_t *loc, int64_t loclen,
say(sb, SAY_MAX, b);
flan_say(loc, loclen, "dyn %s: %s and %s, and %s — (%s %s %s)", op,
tag_of(a), tag_of(b), why, op, sa, sb);
flan_trap((const uint8_t *)name, namelen);
dyn_trap((const uint8_t *)name, namelen);
}
static _Noreturn void trap1(const uint8_t *loc, int64_t loclen,
@ -1032,7 +1048,7 @@ static _Noreturn void trap1(const uint8_t *loc, int64_t loclen,
say(sa, SAY_MAX, a);
flan_say(loc, loclen, "dyn %s: %s, and %s — (%s %s)", op, tag_of(a), why, op,
sa);
flan_trap((const uint8_t *)name, namelen);
dyn_trap((const uint8_t *)name, namelen);
}
#define TYPE_TRAP "DynType", 7
@ -1047,7 +1063,7 @@ static _Noreturn void trap_range(const uint8_t *loc, int64_t loclen,
flan_say(loc, loclen,
"dyn %s: index %lld is out of bounds for %s of length %lld — %s", op,
(long long)i, tag_of(v), (long long)len, sv);
flan_trap((const uint8_t *)"DynRange", 8);
dyn_trap((const uint8_t *)"DynRange", 8);
}
/* ── Allocation and collection ─────────────────────────────────────────
@ -1120,7 +1136,7 @@ static _Noreturn void trap_oom(const uint8_t *loc, int64_t loclen,
flan_say(loc, loclen,
"dyn heap: %lld bytes could not be allocated, with %lld live",
(long long)want, (long long)gc_bytes);
flan_trap((const uint8_t *)"DynHeap", 7);
dyn_trap((const uint8_t *)"DynHeap", 7);
}
static flan_obj *gc_alloc(uint8_t kind, int64_t extra) {
@ -1541,7 +1557,8 @@ static void gc_sweep(void) {
} else {
int64_t held = (int64_t)sizeof(flan_obj);
if (o->kind == OBJ_TEXT || o->kind == OBJ_ENV) held += o->len;
if (o->kind == OBJ_VIEW) held += (int64_t)sizeof(view_guard);
if (o->kind == OBJ_VIEW && (o->gen & 0x100))
held += (int64_t)sizeof(view_guard);
if (o->kind == OBJ_ENV) envset_del((uintptr_t)(o + 1));
if (o->kind == OBJ_VEC || o->kind == OBJ_MAP) {
int64_t per = o->kind == OBJ_MAP ? 2 : 1;
@ -2150,7 +2167,7 @@ static void class_hook(flan_obj *o, flan_dyn inst, flan_dyn added,
"slots matched by name. Take migrate-by-name, or handle the "
"condition inside the method",
(int)c->len, (const char *)(c + 1));
flan_trap((const uint8_t *)"DynMigrate", 10);
dyn_trap((const uint8_t *)"DynMigrate", 10);
}
}
@ -2792,6 +2809,118 @@ flan_dyn flan_dyn_rem(flan_dyn a, flan_dyn b, const uint8_t *loc,
return arith(loc, loclen, "%", a, b);
}
/* ── Bits ──────────────────────────────────────────────────────────────
*
* Ints only: a float has no bits a program means, and a bool is most likely
* a reach for logical and from C, so its trap says which operator that is.
* Every answer is the one typed i64 code gives for the same operands. A shift
* count outside 0..63 traps rather than being masked as typed code masks it:
* there is no width here to have been chosen, and a count out of range is a
* mistake the value cannot show. */
#define BITS_INT "it takes integers"
#define BITS_BOOL "it takes integers; true and false are combined with and, or and not"
static int is_int(flan_dyn v) { return flan_dyn_tag(v) == FLAN_DYN_TAG_INT; }
static int is_bool(flan_dyn v) { return flan_dyn_tag(v) == FLAN_DYN_TAG_BOOL; }
static void want_ints(const uint8_t *loc, int64_t loclen, const char *op,
flan_dyn a, flan_dyn b) {
if (!is_int(a) || !is_int(b))
trap2(loc, loclen, TYPE_TRAP, op,
is_bool(a) || is_bool(b) ? BITS_BOOL : BITS_INT, a, b);
}
static void want_int(const uint8_t *loc, int64_t loclen, const char *op,
flan_dyn a) {
if (!is_int(a))
trap1(loc, loclen, TYPE_TRAP, op, is_bool(a) ? BITS_BOOL : BITS_INT, a);
}
flan_dyn flan_dyn_bitand(flan_dyn a, flan_dyn b, const uint8_t *loc,
int64_t loclen) {
want_ints(loc, loclen, "bit-and", a, b);
return flan_dyn_from_i64(dyn_int_value(a) & dyn_int_value(b));
}
flan_dyn flan_dyn_bitor(flan_dyn a, flan_dyn b, const uint8_t *loc,
int64_t loclen) {
want_ints(loc, loclen, "bit-or", a, b);
return flan_dyn_from_i64(dyn_int_value(a) | dyn_int_value(b));
}
flan_dyn flan_dyn_bitxor(flan_dyn a, flan_dyn b, const uint8_t *loc,
int64_t loclen) {
want_ints(loc, loclen, "bit-xor", a, b);
return flan_dyn_from_i64(dyn_int_value(a) ^ dyn_int_value(b));
}
flan_dyn flan_dyn_bitnot(flan_dyn a, const uint8_t *loc, int64_t loclen) {
want_int(loc, loclen, "bit-not", a);
return flan_dyn_from_i64(~dyn_int_value(a));
}
static uint64_t shift_count(const uint8_t *loc, int64_t loclen, const char *op,
flan_dyn a, flan_dyn b) {
int64_t n;
want_ints(loc, loclen, op, a, b);
n = dyn_int_value(b);
if (n < 0 || n > 63)
trap2(loc, loclen, ARITH_TRAP, op,
"the count is outside 0 to 63, the bits an int has", a, b);
return (uint64_t)n;
}
flan_dyn flan_dyn_shl(flan_dyn a, flan_dyn b, const uint8_t *loc,
int64_t loclen) {
uint64_t n = shift_count(loc, loclen, "<<", a, b);
return flan_dyn_from_i64((int64_t)((uint64_t)dyn_int_value(a) << n));
}
/* Arithmetic, as >> on a typed i64 is. */
flan_dyn flan_dyn_shr(flan_dyn a, flan_dyn b, const uint8_t *loc,
int64_t loclen) {
uint64_t n = shift_count(loc, loclen, ">>", a, b);
int64_t x = dyn_int_value(a);
/* >> on a negative int64_t is implementation-defined in C before C23;
* the complement trick is arithmetic on every compiler. */
if (x < 0) return flan_dyn_from_i64(~(int64_t)(~(uint64_t)x >> n));
return flan_dyn_from_i64((int64_t)((uint64_t)x >> n));
}
static uint64_t rot(uint64_t x, uint64_t n, int left) {
n &= 63;
if (n == 0) return x;
return left ? (x << n) | (x >> (64 - n)) : (x >> n) | (x << (64 - n));
}
flan_dyn flan_dyn_rotl(flan_dyn a, flan_dyn b, const uint8_t *loc,
int64_t loclen) {
want_ints(loc, loclen, "rotate-left", a, b);
return flan_dyn_from_i64((int64_t)rot((uint64_t)dyn_int_value(a),
(uint64_t)dyn_int_value(b), 1));
}
flan_dyn flan_dyn_rotr(flan_dyn a, flan_dyn b, const uint8_t *loc,
int64_t loclen) {
want_ints(loc, loclen, "rotate-right", a, b);
return flan_dyn_from_i64((int64_t)rot((uint64_t)dyn_int_value(a),
(uint64_t)dyn_int_value(b), 0));
}
flan_dyn flan_dyn_popcount(flan_dyn a, const uint8_t *loc, int64_t loclen) {
want_int(loc, loclen, "popcount", a);
return flan_dyn_from_i64(__builtin_popcountll((uint64_t)dyn_int_value(a)));
}
/* 64 for zero, which the builtins leave undefined. */
flan_dyn flan_dyn_clz(flan_dyn a, const uint8_t *loc, int64_t loclen) {
uint64_t x;
want_int(loc, loclen, "leading-zeros", a);
x = (uint64_t)dyn_int_value(a);
return flan_dyn_from_i64(x == 0 ? 64 : __builtin_clzll(x));
}
flan_dyn flan_dyn_ctz(flan_dyn a, const uint8_t *loc, int64_t loclen) {
uint64_t x;
want_int(loc, loclen, "trailing-zeros", a);
x = (uint64_t)dyn_int_value(a);
return flan_dyn_from_i64(x == 0 ? 64 : __builtin_ctzll(x));
}
/* ── Ordering ──────────────────────────────────────────────────────────
*
* Numbers against numbers, text against text, and nothing else. Text orders
@ -2876,9 +3005,85 @@ flan_dyn flan_dyn_ge(flan_dyn a, flan_dyn b, const uint8_t *loc,
#define EQ_DEPTH 64
/* A container compared with itself is equal without reading an element, but
* in a dev build that shortcut would let a view inside it that has gone
* stale pass unremarked, where comparing any other container holding it
* traps. So a dev build walks the one container, as deep as equality would,
* and checks every view it holds — the same rule [eq_walk] applies at the
* top. A release build keeps no guards, and takes the shortcut. */
/* The containers one scan has already walked. A container reached twice —
* shared, or holding itself — is walked once, so a scan is linear in what it
* can reach rather than exponential, and a cycle ends. Open addressing over
* the object's address, each slot stamped with the scan that filled it. */
typedef struct { flan_obj *o; uint64_t stamp; } scan_slot;
static scan_slot *scan_seen;
static size_t scan_cap, scan_n;
/* The scan a slot was filled by. A slot from an earlier scan reads as empty,
* so starting a scan costs a counter bump rather than clearing a table that
* one large scan left large. */
static uint64_t scan_stamp;
static int scan_first_visit(flan_obj *o) {
size_t i, mask;
if (scan_n * 2 >= scan_cap) {
size_t ncap = scan_cap ? scan_cap * 2 : 64, j;
scan_slot *n = (scan_slot *)calloc(ncap, sizeof *n);
if (n == NULL) return 0; /* no room to remember: stop descending */
for (j = 0; j < scan_cap; j++) {
size_t k;
if (scan_seen[j].stamp != scan_stamp) continue;
for (k = ((uintptr_t)scan_seen[j].o >> 4) & (ncap - 1);
n[k].stamp == scan_stamp; k = (k + 1) & (ncap - 1)) {}
n[k] = scan_seen[j];
}
free(scan_seen);
scan_seen = n;
scan_cap = ncap;
}
mask = scan_cap - 1;
for (i = ((uintptr_t)o >> 4) & mask; scan_seen[i].stamp == scan_stamp;
i = (i + 1) & mask)
if (scan_seen[i].o == o) return 0;
scan_seen[i].o = o;
scan_seen[i].stamp = scan_stamp;
scan_n++;
return 1;
}
static void stale_walk(flan_dyn v, int depth) {
flan_obj *o;
int64_t i, n;
if (!dyn_boxed(v) || dyn_box(v) != BOX_OBJ || depth >= EQ_DEPTH) return;
o = dyn_obj(v);
if (o == NULL) return;
if (o->kind == OBJ_VIEW) {
view_guard_check(walk_loc, walk_len, walk_op, o);
return;
}
if (o->kind != OBJ_VEC && o->kind != OBJ_MAP) return;
if (!scan_first_visit(o)) return;
n = o->kind == OBJ_MAP ? o->len * 2 : o->len;
for (i = 0; i < n; i++) stale_walk(o->u.v.items[i], depth + 1);
}
/* Only when some guarded view has ever been made: until then there is
* nothing a scan could find, and a program that never crosses a typed value
* into dyn pays nothing for it. */
static int64_t views_guarded;
static void stale_scan(flan_dyn v, int depth) {
if (views_guarded == 0) return;
scan_stamp++; /* never 0, which is what a fresh slot holds */
scan_n = 0;
stale_walk(v, depth);
}
static int dyn_equal(flan_dyn a, flan_dyn b, int depth) {
int32_t ta = flan_dyn_tag(a), tb = flan_dyn_tag(b);
if (a == b && ta != FLAN_DYN_TAG_FLOAT) return 1;
if (a == b && ta != FLAN_DYN_TAG_FLOAT) {
if (flan_dev_views_checked) stale_scan(a, depth);
return 1;
}
if (is_num(a) && is_num(b)) {
if (ta == FLAN_DYN_TAG_INT && tb == FLAN_DYN_TAG_INT)
return dyn_int_value(a) == dyn_int_value(b);
@ -2894,7 +3099,10 @@ static int dyn_equal(flan_dyn a, flan_dyn b, int depth) {
if (ta == FLAN_DYN_TAG_VEC) {
flan_obj *x = dyn_obj(a), *y = dyn_obj(b);
int64_t i, xn, yn;
if (x == y) return 1;
if (x == y) {
if (flan_dev_views_checked) stale_scan(a, depth);
return 1;
}
if (depth >= EQ_DEPTH) return 0;
/* [x]/[y] may each be an ordinary heap vec or a view (M2 item 3) — the
tag does not say which, so [vecish_len]/[vecish_at] below read either
@ -2922,7 +3130,10 @@ static int dyn_equal(flan_dyn a, flan_dyn b, int depth) {
if (ta == FLAN_DYN_TAG_MAP) {
flan_obj *x = dyn_obj(a), *y = dyn_obj(b);
int64_t i, j;
if (x == y) return 1;
if (x == y) {
if (flan_dev_views_checked) stale_scan(a, depth);
return 1;
}
if (depth >= EQ_DEPTH) return 0;
/* A struct's view is equal to another view of the same struct type with
equal fields, and to nothing else — the answer an instance gets beside
@ -3090,8 +3301,15 @@ static void desc_lay(const uint8_t *d, int64_t *size, int64_t *align) {
}
}
static int64_t desc_size(const uint8_t *d) {
static inline int64_t desc_size(const uint8_t *d) {
int64_t s, a;
switch (*d) { /* the scalars, without the walk */
case 'b': case 'B': case '?': return 1;
case 'h': case 'H': return 2;
case 'i': case 'I': case 'f': return 4;
case 'l': case 'L': case 'd': return 8;
default: break;
}
desc_lay(d, &s, &a);
return s;
}
@ -3217,8 +3435,18 @@ extern struct flan_frame *flan_frame_head; /* runtime/flan_dev.c */
#define VIEW_VEC 1 /* [base] is a Vec's header, read live */
#define VIEW_STRUCT 2 /* [base] is the struct, [desc] the struct's own */
static inline view_guard *view_g(flan_obj *o) { return (view_guard *)(o + 1); }
static inline int view_shape(flan_obj *o) { return (int)o->gen; }
/* A view carries a guard only when the dev registry is on: a release build
* would allocate and zero it for nothing, and a crossing is on the hot path.
* VIEW_GUARDED in [gen] says the guard is there. */
#define VIEW_GUARDED 0x100 /* bits 16-31 hold the element size */
/* Bits 9-10: an element kind [flan_dyn_at] boxes inline. */
#define VIEW_FAST_I64 1
#define VIEW_FAST_F64 2
#define VIEW_FAST_BOOL 3
static inline view_guard *view_g(flan_obj *o) {
return (o->gen & VIEW_GUARDED) ? (view_guard *)(o + 1) : NULL;
}
static inline int view_shape(flan_obj *o) { return (int)(o->gen & 0xff); }
void *flan_dev_frame_owner(const void *p);
@ -3241,22 +3469,45 @@ static void guard_storage(view_guard *g, const void *p) {
/* A new view record, its guard empty. */
static flan_obj *view_new(void *base, int64_t len, const uint8_t *desc,
static inline __attribute__((always_inline)) flan_obj *
view_new(void *base, int64_t len, const uint8_t *desc,
int shape) {
flan_obj *o = gc_alloc(OBJ_VIEW, (int64_t)sizeof(view_guard));
int dev = flan_dev_views_checked;
flan_obj *o =
gc_alloc(OBJ_VIEW, dev ? (int64_t)sizeof(view_guard) : 0);
o->u.view.base = base;
o->u.view.desc = desc;
o->u.view.nul = NULL;
o->gen = (uint32_t)shape;
o->gen = (uint32_t)shape | (dev ? VIEW_GUARDED : 0);
/* A flat or Vec view's element size, kept so an access does not read the
descriptor again; 0 when it does not fit the 16 bits, and then it does. */
if (shape != VIEW_STRUCT) {
int64_t sz = desc_size(desc);
if (sz > 0 && sz < 0x10000) o->gen |= (uint32_t)sz << 16;
/* The three element kinds [flan_dyn_at] reads without a call. */
o->gen |= (uint32_t)(*desc == 'l' ? VIEW_FAST_I64
: *desc == 'd' ? VIEW_FAST_F64
: *desc == '?' ? VIEW_FAST_BOOL : 0) << 9;
}
o->len = len;
memset(view_g(o), 0, sizeof(view_guard));
if (dev) {
memset(view_g(o), 0, sizeof(view_guard));
views_guarded++;
}
return o;
}
/* The stale-storage check. The sentence never renders the view: it has just
* been found to point at storage that is gone, and rendering reads it. */
static void view_guard_check(const uint8_t *loc, int64_t loclen,
static __attribute__((noinline)) void view_guard_slow(const uint8_t *loc, int64_t loclen,
const char *op, flan_obj *o);
static inline __attribute__((always_inline)) void view_guard_check(const uint8_t *loc, int64_t loclen,
const char *op, flan_obj *o) {
if (o->gen & VIEW_GUARDED) view_guard_slow(loc, loclen, op, o);
}
static __attribute__((noinline)) void view_guard_slow(const uint8_t *loc, int64_t loclen,
const char *op, flan_obj *o) {
view_guard *g = view_g(o);
if (g->frame != NULL && !flan_dev_frame_alive(g->frame, g->serial)) {
flan_say(loc, loclen,
@ -3264,7 +3515,7 @@ static void view_guard_check(const uint8_t *loc, int64_t loclen,
"has returned. A view of a local lasts as long as the call that "
"made it",
op, (int)g->fnamelen, g->fname);
flan_trap((const uint8_t *)"DynStale", 8);
dyn_trap((const uint8_t *)"DynStale", 8);
}
if (g->rbase != 0 && !flan_dev_reg_alive(g->rbase, g->rseq)) {
flan_say(loc, loclen,
@ -3272,7 +3523,7 @@ static void view_guard_check(const uint8_t *loc, int64_t loclen,
"released — freed, cleared by free-all, or left behind when a "
"Vec grew. Take the view again after the change",
op, (int)g->rtypelen, g->rtype);
flan_trap((const uint8_t *)"DynStale", 8);
dyn_trap((const uint8_t *)"DynStale", 8);
}
}
@ -3292,7 +3543,7 @@ static void view_vec_check(const uint8_t *loc, int64_t loclen, const char *op,
"dyn %s: this view's container's allocator was released — the "
"Vec was made at epoch %lld and the allocator is at %lld now",
op, (long long)h->epoch, (long long)(int64_t)a->epoch);
flan_trap((const uint8_t *)"DynRange", 8);
dyn_trap((const uint8_t *)"DynRange", 8);
}
}
}
@ -3330,7 +3581,7 @@ static flan_dyn view_child(flan_obj *parent, const uint8_t *d, uint8_t *p) {
memcpy(&data, p, 8);
memcpy(&n, p + 8, 8);
c = view_new(data, n, d + 1, VIEW_FLAT);
guard_storage(view_g(c), data);
if (view_g(c) != NULL) guard_storage(view_g(c), data);
return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)c);
}
case 'a': {
@ -3342,8 +3593,9 @@ static flan_dyn view_child(flan_obj *parent, const uint8_t *d, uint8_t *p) {
case 'v': c = view_new(p, 0, d + 1, VIEW_VEC); break;
default: c = view_new(p, 0, d, VIEW_STRUCT); break;
}
if (view_shape(parent) == VIEW_VEC) guard_storage(view_g(c), p);
else *view_g(c) = *view_g(parent);
if (view_g(c) == NULL) {}
else if (view_shape(parent) == VIEW_VEC) guard_storage(view_g(c), p);
else if (view_g(parent) != NULL) *view_g(c) = *view_g(parent);
return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)c);
}
@ -3367,7 +3619,7 @@ static flan_dyn view_read(const uint8_t *loc, int64_t loclen, const char *op,
"dyn %s: this u64 element is %llu, above the largest dyn int "
"(9223372036854775807), so it has no dyn value",
op, (unsigned long long)x);
flan_trap((const uint8_t *)"DynRange", 8);
dyn_trap((const uint8_t *)"DynRange", 8);
}
return flan_dyn_from_i64((int64_t)x);
}
@ -3442,7 +3694,7 @@ static _Noreturn void field_refuse(const uint8_t *loc, int64_t loclen,
said_add("(put %s :%.*s %s)", sv, (int)k->len, (const char *)kw_bytes(k),
sx);
flan_say(loc, loclen, "%s", said_buf);
flan_trap((const uint8_t *)trap, (int64_t)strlen(trap));
dyn_trap((const uint8_t *)trap, (int64_t)strlen(trap));
}
/* ", and 1.5 is a float": what the refused value is, for a field's sentence. */
@ -3504,7 +3756,7 @@ static void view_write(const uint8_t *loc, int64_t loclen, const char *op,
"dyn %s: %lld does not fit %s %s element, which holds %lld "
"to %lld", op, (long long)n, an(ty), ty, (long long)lo,
(long long)hi);
flan_trap((const uint8_t *)"DynRange", 8);
dyn_trap((const uint8_t *)"DynRange", 8);
}
switch (*d) {
case 'b': case 'B': { uint8_t b = (uint8_t)n; memcpy(p, &b, 1); return; }
@ -3533,7 +3785,7 @@ static void view_write(const uint8_t *loc, int64_t loclen, const char *op,
"dyn %s: %lld has no exact %s, so it does not go into this "
"element. Write it as a float, as in %lld.0",
op, (long long)n, ty, (long long)n);
flan_trap((const uint8_t *)"DynRange", 8);
dyn_trap((const uint8_t *)"DynRange", 8);
}
} else if (flan_dyn_tag(x) == FLAN_DYN_TAG_FLOAT)
f = dyn_num_value(x);
@ -3576,14 +3828,16 @@ static void view_write(const uint8_t *loc, int64_t loclen, const char *op,
"it whole — write into its own elements or fields instead of "
"storing %s",
op, an(ty), ty, sx);
flan_trap((const uint8_t *)"DynType", 7);
dyn_trap((const uint8_t *)"DynType", 7);
}
}
}
/* Element [i] of a vec-shaped view. The caller has checked the bounds. */
static uint8_t *view_elem_at(flan_obj *o, int64_t i) {
return (uint8_t *)view_base(o) + i * desc_size(o->u.view.desc);
static inline uint8_t *view_elem_at(flan_obj *o, int64_t i) {
int64_t sz = (int64_t)(o->gen >> 16);
if (sz == 0) sz = desc_size(o->u.view.desc);
return (uint8_t *)view_base(o) + i * sz;
}
/* A length and an element reader that answer correctly whether [o] is an
@ -3622,7 +3876,7 @@ static uint8_t *view_field(const uint8_t *loc, int64_t loclen, const char *op,
while (desc_next(&at, &o2, &name, &namelen, &foff, &t))
said_add(" :%.*s", (int)namelen, (const char *)name);
flan_say(loc, loclen, "%s", said_buf);
flan_trap((const uint8_t *)"DynType", 7);
dyn_trap((const uint8_t *)"DynType", 7);
}
return (uint8_t *)o->u.view.base + off;
}
@ -3633,11 +3887,13 @@ static uint8_t *view_field(const uint8_t *loc, int64_t loclen, const char *op,
* for a struct view). [here] is the checker's word that the storage is the
* calling function's own frame; otherwise a dev build finds the frame that
* owns a stack address, or the registry block that holds a heap one. */
static flan_dyn view_make(void *base, int64_t len, const uint8_t *desc,
static inline __attribute__((always_inline)) flan_dyn
view_make(void *base, int64_t len, const uint8_t *desc,
int shape, int32_t here) {
flan_obj *o = view_new(base, len, desc, shape);
view_guard *g = view_g(o);
if (here) {
if (g == NULL) {}
else if (here) {
if (flan_frame_head != NULL) {
g->frame = flan_frame_head;
g->serial =
@ -3827,7 +4083,15 @@ flan_dyn flan_dyn_at(flan_dyn v, flan_dyn i, const uint8_t *loc,
if (o->kind == OBJ_VIEW) {
int64_t len = view_len(loc, loclen, "at", o);
if (k < 0 || k >= len) trap_range(loc, loclen, "at", v, k, len);
return view_read(loc, loclen, "at", o, o->u.view.desc, view_elem_at(o, k));
{
uint8_t *p = view_elem_at(o, k);
switch ((o->gen >> 9) & 3) {
case VIEW_FAST_I64: { int64_t x; memcpy(&x, p, 8); return flan_dyn_from_i64(x); }
case VIEW_FAST_F64: { double x; memcpy(&x, p, 8); return flan_dyn_from_f64(x); }
case VIEW_FAST_BOOL: return flan_dyn_from_bool(*p ? 1 : 0);
default: return view_read(loc, loclen, "at", o, o->u.view.desc, p);
}
}
}
if (k < 0 || k >= o->len) trap_range(loc, loclen, "at", v, k, o->len);
if (o->kind == OBJ_TEXT) return flan_dyn_from_i64(obj_text_bytes(o)[k]);
@ -3856,7 +4120,7 @@ flan_dyn flan_dyn_slice(flan_dyn v, flan_dyn lo, flan_dyn hi,
flan_say(loc, loclen,
"dyn slice: [%lld %lld) is out of bounds for text of length %lld "
"— %s", (long long)a, (long long)b, (long long)len, sv);
flan_trap((const uint8_t *)"DynRange", 8);
dyn_trap((const uint8_t *)"DynRange", 8);
}
return flan_dyn_from_bytes(obj_text_bytes(o) + a, b - a);
}
@ -3964,9 +4228,10 @@ static int64_t map_find(flan_obj *o, flan_dyn k) {
return -1;
}
static flan_obj *want_map(const char *op, flan_dyn m, flan_dyn k) {
static flan_obj *want_map(const uint8_t *loc, int64_t loclen, const char *op,
flan_dyn m, flan_dyn k) {
flan_obj *o;
if (!is_map(m)) trap2(NULL, 0, TYPE_TRAP, op, "only a map answers it", m, k);
if (!is_map(m)) trap2(loc, loclen, TYPE_TRAP, op, "only a map answers it", m, k);
o = dyn_obj(m);
/* The lazy half of the redefinition protocol: [get], [put] and [has-key?]
all arrive here, and CLHS 4.3.6 asks for the update to happen no later
@ -3977,7 +4242,7 @@ static flan_obj *want_map(const char *op, flan_dyn m, flan_dyn k) {
}
flan_dyn flan_dyn_map_get(flan_dyn m, flan_dyn k) {
flan_obj *o = want_map("get", m, k);
flan_obj *o = want_map(NULL, 0, "get", m, k);
if (o->kind == OBJ_VIEW) {
const uint8_t *fty;
uint8_t *p = view_field(NULL, 0, "get", o, k, &fty);
@ -4012,7 +4277,7 @@ flan_dyn flan_dyn_get(flan_dyn m, flan_dyn k, const uint8_t *loc,
}
static flan_dyn contains_walk(flan_dyn m, flan_dyn k) {
flan_obj *o = want_map("has-key?", m, k);
flan_obj *o = want_map(walk_loc, walk_len, walk_op, m, k);
if (o->kind == OBJ_VIEW) {
int64_t off;
view_guard_check(walk_loc, walk_len, walk_op, o);
@ -4076,7 +4341,7 @@ static _Noreturn void trap_slot_type(const uint8_t *loc, int64_t loclen,
flan_say(by == BY_NEW && site_building != NULL ? site_building : loc,
by == BY_NEW && site_building != NULL ? site_building_len : loclen,
"%s", said_buf);
flan_trap((const uint8_t *)"DynType", 7);
dyn_trap((const uint8_t *)"DynType", 7);
}
/* The value a store into [o] under [k] actually stores: [v], or the float an
@ -4117,7 +4382,7 @@ static _Noreturn void trap_no_slot(const uint8_t *loc, int64_t loclen,
said_add(" :%.*s", (int)e->slots[i]->len,
(const char *)(e->slots[i] + 1));
flan_say(loc, loclen, "%s", said_buf);
flan_trap((const uint8_t *)"DynType", 7);
dyn_trap((const uint8_t *)"DynType", 7);
}
/* A constructor's stores: [flan_dyn_map_set]'s, with the refusal worded for
@ -4125,7 +4390,7 @@ static _Noreturn void trap_no_slot(const uint8_t *loc, int64_t loclen,
* wrote, and placed at the slot's declaration. */
void flan_dyn_slot_init(flan_dyn m, flan_dyn k, flan_dyn v,
const uint8_t *loc, int64_t loclen) {
flan_obj *o = want_map("construct", m, k);
flan_obj *o = want_map(loc, loclen, "construct", m, k);
class_entry *e = o->u.v.klass == NULL ? NULL : class_find(o->u.v.klass);
map_store(o, k, check_slot(loc, loclen, BY_NEW, o, e, m, k, v));
}
@ -4155,7 +4420,7 @@ void flan_dyn_slot_set(flan_dyn m, flan_dyn k, flan_dyn v,
"this is %s%s — %s. A map's entries are written with put",
is_map(m) ? "a map with no class" : "a ",
is_map(m) ? "" : tag_of(m), sm);
flan_trap((const uint8_t *)"DynType", 7);
dyn_trap((const uint8_t *)"DynType", 7);
}
o = dyn_obj(m);
e = class_sync(o);

23
runtime/flan_dyn.h
View File

@ -207,6 +207,20 @@ flan_dyn flan_dyn_div(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen
flan_dyn flan_dyn_rem(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen);
flan_dyn flan_dyn_neg(flan_dyn a, const uint8_t *loc, int64_t loclen);
/* The bit operations, on ints only. A shift count outside 0..63 traps, where
* typed code masks it; a rotation takes its count modulo 64. */
flan_dyn flan_dyn_bitand(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen);
flan_dyn flan_dyn_bitor(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen);
flan_dyn flan_dyn_bitxor(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen);
flan_dyn flan_dyn_bitnot(flan_dyn a, const uint8_t *loc, int64_t loclen);
flan_dyn flan_dyn_shl(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen);
flan_dyn flan_dyn_shr(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen);
flan_dyn flan_dyn_rotl(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen);
flan_dyn flan_dyn_rotr(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen);
flan_dyn flan_dyn_popcount(flan_dyn a, const uint8_t *loc, int64_t loclen);
flan_dyn flan_dyn_clz(flan_dyn a, const uint8_t *loc, int64_t loclen);
flan_dyn flan_dyn_ctz(flan_dyn a, const uint8_t *loc, int64_t loclen);
/* Answer a bool dyn. Numbers compare as numbers and text compares bytewise;
* a mixture of the two, or anything else, traps. */
flan_dyn flan_dyn_lt(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen);
@ -350,6 +364,15 @@ flan_dyn flan_dyn_view_slice(void *data, int64_t len, const uint8_t *desc,
flan_dyn flan_dyn_view_at(void *addr, int64_t len, const uint8_t *desc,
int64_t desclen, int32_t shape, int32_t here);
/* print, =, length and has-key? with the site they were written at: a view
* that traps inside one names it. */
void flan_dyn_print_at(flan_dyn v, const uint8_t *loc, int64_t loclen);
flan_dyn flan_dyn_eq_at(flan_dyn a, flan_dyn b, const uint8_t *loc,
int64_t loclen);
flan_dyn flan_dyn_len_at(flan_dyn v, const uint8_t *loc, int64_t loclen);
flan_dyn flan_dyn_map_contains_at(flan_dyn m, flan_dyn k, const uint8_t *loc,
int64_t loclen);
/* ── The collector ─────────────────────────────────────────────────────
*
* Mark-sweep, precise, and never moving. [flan_gc_init] is idempotent, and the

23
spec-syntax.md
View File

@ -155,9 +155,15 @@ Each item: the proposal, then the reason in one line.
### Expressions
- **Precedence**, low to high: `or` < `and` < `not` < comparisons
(`== != < <= > >=`) < `<< >>` < `+ -` < `* / %` < unary `-` < postfix (call,
index, field). **Built.** Mixing comparison operators in one chain,
`a < b <= c`, is refused. An operator glued to `(` is always a call.
(`== != < <= > >=`) < `||` < `^^` < `&&` < `<< >>` < `+ -` < `* / %` <
prefix `-` and `~~` < postfix (call, index, field). **Built.** Mixing
comparison operators in one chain, `a < b <= c`, is refused. An operator
glued to `(` is always a call. The bit operators sit where Python and Rust
put them, so `x && mask == 0` is `(x && mask) == 0`.
- **The bit operators** are `a && b`, `a || b`, `a ^^ b` and `~~a`, reading
`(bit-and a b)`, `(bit-or a b)`, `(bit-xor a b)` and `(bit-not a)`. They take
integers; `and`, `or` and `not` are the logical ones. `~~` is one token, so a
nested unquote is written `~(~x)`. **Built.**
- **`==` is `=`; `=` is assignment.** `x = v` reads `(set x v)`, `a[i] = v`
reads `(set (at a i) v)`, `p.x = v` reads `(set (.x p) v)`. `x += v` reads
`(set x (+ x v))` where every part of the place is a name or a literal, and
@ -192,7 +198,7 @@ Each item: the proposal, then the reason in one line.
rebinds, the `let`'s is renamed (`x` to `x-2`, a name the top-level form
does not use; a struct pattern is written as `{x-2 .x}` pairs). A macro's
body counts as statements run in order when its definition splices its
rest parameter only into a `do`, a `let`/`fn`/`when`/`while`/`loop` body or
rest parameter only into a `do`, a `let`/`fn`/`when`/`while` body or
another such macro's body; `comment` counts too. Where a rename cannot be
trusted (the name quoted, qualified as `x/y`, or called as `x(...)`), and
at the top level, among a call's other arguments and in a quasiquote, the
@ -323,9 +329,12 @@ Each item: the proposal, then the reason in one line.
- `macro repeat(i, n, & body)` plus a block reads
`(defmacro repeat [i n & body] …)`. A parameter is a bare name, a
destructuring vector `[a b]`, or `& rest`, last. **Built.**
- `loop x = a, y = b` plus a block reads `(loop [x a y b] …)`, as a statement
or as a value, `let r = loop i = 0`. `recur(y, x % y)` is a call. A loop with
no variables is the fallback, `loop([]):`. **Built.**
- There is no `loop` or `recur`. A loop is `while`, `until`, `dotimes` or
`for`, over `let` variables it changes, with `break` and `continue`. The
reader refuses `loop` and `recur` in any spelling, inside `quote` too
(`indent/no-loop`), and `flan convert` refuses a .flan file that uses them,
naming each line (`convert/no-loop`). A macro defined in a .flan file may
still expand to them. **Built.**
- `class lambda(param, body, env)`, or `class lambda` with a slot per line,
reads `(defclass lambda [param body env])`; a typed slot is `pause: bool`
and its type follows its name in the vector. **Built.**

9
test/dev_limits.c
View File

@ -264,12 +264,9 @@ static int regchurn(void) {
return 0;
}
/* And a table that really is full, which is the case the trigger above must
* not paper over: 4096 live blocks and nothing dead anywhere, then one more.
* The note is dropped — that is the standing decision, and dying because a
* diagnostic ran out of room would be worse — and what is checked here is that
* the drop is *said*, once, rather than only being discoverable by asking the
* flag. A second and third dropped note must add nothing. */
/* A live set larger than the table's first size: 4096 live blocks and
* nothing dead anywhere, then three more. The table grows, so none is
* dropped and the overflow flag stays clear. */
static int regoverflow(void) {
flan_dev_reg_enable();
for (int i = 0; i < CAP; i++)

37
test/dyn_ops.c
View File

@ -32,6 +32,7 @@
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
#include <setjmp.h>
/* Resolved because [Build] drops runtime/flan_dyn.h into the directory it
* compiles each translation unit in, beside the .c it writes there. That is
@ -1372,6 +1373,41 @@ static void hook_reentry(void) {
printf(failures == 0 ? "hook ok\n" : "hook failed\n");
}
/* A trap inside a walk that a trap hook leaves by longjmp — what the dev
* agent does when it abandons an evaluation — must not leave that walk's site
* behind for the next walk that has none. The first comparison traps at
* "walk-site:1:1" reading a u64 too wide for a dyn int; the map lookup after
* it compares the same two views with no site of its own, and traps again.
* The site may appear once, in the first sentence, and not in the second. */
extern void (*flan_trap_hook)(const uint8_t *name, int64_t namelen);
static jmp_buf walk_out;
static void walk_hook(const uint8_t *name, int64_t namelen) {
(void)name; (void)namelen;
longjmp(walk_out, 1);
}
static void walkreset(void) {
static uint64_t big[1] = { UINT64_MAX };
flan_dyn v, w, m;
flan_gc_init();
v = flan_dyn_view_at(big, 1, (const uint8_t *)"L", 1, 0, 0);
flan_dyn_root_push(&v);
w = flan_dyn_view_at(big, 1, (const uint8_t *)"L", 1, 0, 0);
flan_dyn_root_push(&w);
m = flan_dyn_map_new();
flan_dyn_root_push(&m);
flan_dyn_map_set(m, v, flan_dyn_from_i64(1));
flan_trap_hook = walk_hook;
if (setjmp(walk_out) == 0)
(void)flan_dyn_eq_at(v, w, (const uint8_t *)"walk-site:1:1", 13);
fflush(stderr);
fprintf(stderr, "--\n");
if (setjmp(walk_out) == 0) (void)flan_dyn_map_get(m, w);
flan_trap_hook = NULL;
flan_dyn_root_pop(3);
printf("walkreset done\n");
}
int main(int argc, char **argv) {
flan_rt_init(argc, argv);
if (argc < 2) {
@ -1401,6 +1437,7 @@ int main(int argc, char **argv) {
view();
return failures == 0 ? 0 : 1;
}
if (strcmp(argv[1], "walkreset") == 0) { walkreset(); return 0; }
if (strcmp(argv[1], "layout") == 0) {
layout();
return failures == 0 ? 0 : 1;

51
test/programs/bits-dyn.flan Normal file
View File

@ -0,0 +1,51 @@
;;;; The bit operators on dyn ints, beside the same operations on typed i64:
;;;; each line prints the dyn answer, the typed one, and whether they agree.
;;;; A dyn int is an i64, so the two must be the same number for every count
;;;; in 0..63. With an argument, the program traps instead: 1 a shift count
;;;; out of range, 2 a bool operand, 3 a float operand, 4 a negative count to >>.
(defn dyn-ops [a b n] dyn
[(bit-and a b) (bit-or a b) (bit-xor a b) (bit-not a) (<< a n) (>> a n)
(rotate-left a n) (rotate-right a n) (popcount a) (leading-zeros a)
(trailing-zeros a) (bit-xor a b n) (&& a b) (|| a b)])
(defn typed-ops [a i64 b i64 n i64] [14 i64]
[(bit-and a b) (bit-or a b) (bit-xor a b) (bit-not a) (<< a n) (>> a n)
(rotate-left a n) (rotate-right a n) (popcount a) (leading-zeros a)
(trailing-zeros a) (bit-xor a b n) (&& a b) (|| a b)])
(defn compare [a i64 b i64 n i64] ()
(let [d (dyn-ops a b n)
t (typed-ops a b n)]
(dotimes [i 14]
(print (at d i) " ")
(when (!= (i64 (at d i)) (at t i))
(print "DIFFER at " i " typed " (at t i) " ")))
(println)))
;; A typed operand beside a dyn one makes the whole operation dyn.
(defonce mask i32 255)
(defn mixed [x] dyn (bit-and x mask))
(defn shift [a n] dyn (<< a n))
(defn sar [a n] dyn (>> a n))
(defn band [a b] dyn (bit-and a b))
(defn main [args [str]] i32
(let [k (if (> (length args) 1) (bytes->i64 (bytes-view (at args 1))) 0)]
(cond
(= k 0)
(do
(compare 0 0 0)
(compare -1 12345 63)
(compare -9000000000000000000 1234567890123 13)
(compare 9223372036854775807 -9223372036854775807 1)
(compare 281474976710656 -281474976710657 47)
(compare 1 3 62)
(println (mixed 4660) (mixed -1))
(println (leading-zeros 0) (trailing-zeros 0) (popcount -1))
0)
(= k 1) (do (println "before") (println (shift 1 64)) 0)
(= k 2) (do (println "before") (println (band true 1)) 0)
(= k 3) (do (println "before") (println (band 1.5 1)) 0)
:else (do (println "before") (println (sar 1 -1)) 0))))

46
test/programs/bits.flan Normal file
View File

@ -0,0 +1,46 @@
;;;; The bit operators at every integer width, typed. Every operand is a
;;;; global or a parameter, so -O2 folds nothing and the x86 backend lowers
;;;; each one; the three builds must print the same lines. One generic body
;;;; covers the widths, which also walks the integer? bound.
(defn bits [a $t b $t n $t] ()
{:where (integer? $t)}
(println (bit-and a b) (bit-or a b) (bit-xor a b) (bit-not a)
(bit-and a b n) (&& a b) (|| a b) (^^ a b))
(println (<< a n) (>> a n) (rotate-left a n) (rotate-right a n))
(println (popcount a) (leading-zeros a) (trailing-zeros a)
(popcount b) (leading-zeros b) (trailing-zeros b)))
(defonce i8a i8 -100) (defonce i8b i8 45) (defonce i8n i8 3)
(defonce i16a i16 -30000) (defonce i16b i16 12345) (defonce i16n i16 5)
(defonce i32a i32 -2000000000) (defonce i32b i32 123456789) (defonce i32n i32 7)
(defonce i64a i64 -9000000000000000000) (defonce i64b i64 1234567890123) (defonce i64n i64 13)
(defonce u8a u8 200) (defonce u8b u8 45) (defonce u8n u8 3)
(defonce u16a u16 60000) (defonce u16b u16 12345) (defonce u16n u16 5)
(defonce u32a u32 4000000000) (defonce u32b u32 123456789) (defonce u32n u32 7)
(defonce u64a u64 18000000000000000000) (defonce u64b u64 1234567890123) (defonce u64n u64 13)
;; Zero, for the counts: leading-zeros and trailing-zeros answer the width.
(defonce z8 i8 0) (defonce z16 u16 0) (defonce z32 i32 0) (defonce z64 u64 0)
;; A rotation count past the width, and a negative one: both modulo the width.
(defonce big32 i32 35) (defonce neg32 i32 -1) (defonce big8 u8 11)
(defn main [] i32
(bits i8a i8b i8n)
(bits i16a i16b i16n)
(bits i32a i32b i32n)
(bits i64a i64b i64n)
(bits u8a u8b u8n)
(bits u16a u16b u16n)
(bits u32a u32b u32n)
(bits u64a u64b u64n)
(println (leading-zeros z8) (trailing-zeros z8)
(leading-zeros z16) (trailing-zeros z16)
(leading-zeros z32) (trailing-zeros z32)
(leading-zeros z64) (trailing-zeros z64) (popcount z64))
(println (rotate-left i32b big32) (rotate-right i32b big32)
(rotate-left i32b neg32) (rotate-left u8a big8)
(rotate-right u8a big8))
;; A narrower count widens to the value's type.
(println (<< i64b u8n) (rotate-left u64b u8n))
0)

55
test/programs/dyn-view-any.flan
View File

@ -60,6 +60,11 @@
(let [a [(i64 5) 6 7]]
(via-slice (slice a 0 3))))
(defn doubled [n i32] dyn
(let [v (the dyn [1 2])]
(dotimes [i n] (set v (the dyn [v v])))
v))
(defn clobber [] i64
(let [b [(i64 7) 8 9 10 11 12]]
(+ (at b 0) (at b 5))))
@ -289,4 +294,54 @@
;; An element's range, with its article.
(= n 20)
(let [a [(i8 1)]] (set (at (keep a) 0) 200) 0)
;; More live blocks than the registry's first size, then a free: the
;; registry grows rather than dropping notes, so the check still holds.
(= n 21)
(let [hold (vec-new [i64])]
(dotimes [i 6000] (push hold (clone (slice [(i64 i) 1] 0 2))))
(let [c (at hold 5999)
d (keep c)]
(println (at d 0))
(free c)
(println (at d 0)))
0)
;; A container holding a stale view, compared with itself.
(= n 22)
(do (leak-local)
(println (clobber))
(let [box (the dyn [held 1])]
(println (= box box)))
0)
;; has-key? on a value that is not a map, at its site.
(= n 23)
(do (println (has-key? (keep 5) :x)) 0)
;; A container compared with itself, once a view exists: shared thirty
;; levels deep, and holding itself. Each must answer at once.
(= n 24)
(let [a [(i64 1)]
k (keep a)
v (doubled 30)]
(println (= v v))
0)
(= n 25)
(let [a [(i64 1)]
k (keep a)
c (the dyn [1])]
(push c c)
(push c c)
(println (= c c))
0)
;; One self-compare over 300000 containers, then twenty thousand
;; small ones: a large scan must not make every later one pay for it.
(= n 26)
(let [a [(i64 1)]
k (keep a)
big (the dyn [])
small (the dyn [1])
hits (i64 0)]
(dotimes [i 300000] (push big (the dyn [i])))
(println (= big big))
(dotimes [i 20000] (when (= small small) (set hits (+ hits 1))))
(println hits)
0)
:else (do (println "?") 1))))

16
test/programs/fn-capture.flan
View File

@ -91,15 +91,15 @@
(set total (+ total (call0 (fn [] i)))))
(println total))
;; And the same again where the loop variable is rebound by a recur rather
;; than stepped by a dotimes, which is a store into the slot the copy is
;; taken from: 100 + 101 + 102.
;; And the same again where the loop variable is stepped by a set in a
;; while rather than by a dotimes, which is a store into the slot the copy
;; is taken from: 100 + 101 + 102.
(println
(let [base 100]
(loop [i 0 acc 0]
(if (< i 3)
(recur (+ i 1) (+ acc (call0 (fn [] (+ base i)))))
acc))))
(let [base 100 i 0 acc 0]
(while (< i 3)
(set acc (+ acc (call0 (fn [] (+ base i)))))
(set i (+ i 1)))
acc))
;; Called twice, so the environment is read more than once and a body that
;; consumed it would show.

10
test/programs/generic-struct.flan
View File

@ -49,11 +49,13 @@
(defstruct Node [v $t next (Option (Ptr (Node $t)))])
(defn sum-list [n (Ptr (Node i64))] i64
(loop [at n acc (the i64 0)]
(let [acc (+ acc (.v at))]
(let [at n acc (the i64 0)]
(while true
(set acc (+ acc (.v at)))
(match (.next at)
(Some p) (recur p acc)
None acc))))
(Some p) (set at p)
None (break)))
acc))
;; A template naming another at its own parameters.
(defstruct Twice [x (Small $m $u) y (Small $m $u)])

12
test/programs/match-enum.flan
View File

@ -25,12 +25,14 @@
(calls)
:west)
;; recur from inside an arm: the arm is the loop's tail.
;; break from inside an arm leaves the while around the match.
(defn steps-to-west [from Dir] i32
(loop [d from n 0]
(match d
:west n
_ (recur (turn d) (+ n 1)))))
(let [d from n 0]
(while true
(match d
:west (break)
_ (do (set d (turn d)) (set n (+ n 1)))))
n))
(defn main [] i32
(print (steps-to-west :north)) (println "")

12
test/programs/match-literal.flan
View File

@ -44,12 +44,14 @@
(print "(called) ")
7)
;; recur from inside an arm: the arm is the loop's tail.
;; break from inside an arm leaves the while around the match.
(defn count-down [from i32] i32
(loop [n from steps 0]
(match n
0 steps
_ (recur (- n 1) (+ steps 1)))))
(let [n from steps 0]
(while true
(match n
0 (break)
_ (do (set n (- n 1)) (set steps (+ steps 1)))))
steps))
(defn main [] i32
(println (small 5))

8
test/programs/temp-frame.flan
View File

@ -8,8 +8,10 @@
;;;;
;;;; The argument is the frame count. A negative one runs that many frames and
;;;; never calls free-temp, which is the control: memory grows and a dev
;;;; build's registry fills. The last line is whether the registry overflowed.
(declare-c reg-overflowed [] i32 "flan_dev_reg_overflowed")
;;;; build's registry fills. The last line is whether more blocks are live
;;;; than the registry's first size, 4096 — it grows past that rather than
;;;; drop notes, so the live count is what says it filled.
(declare-c reg-live [live-only i32] i64 "flan_dev_reg_count")
(defn main [args [str]] i32
(let [arg (bytes->i64 (bytes-view (at args 1)))
@ -26,5 +28,5 @@
(free-temp)))
(println total)
(println (str kept))
(println (reg-overflowed)))
(println (if (> (reg-live 1) 4096) 1 0)))
0)

12
test/syntax/flat/shadows.flan
View File

@ -29,10 +29,14 @@
(println i))))
(defn loopr [] i32
(loop [n 0 acc 0]
(let [n (* n 2)]
(println n))
(if (< n 4) (recur (+ n 1) (+ acc n)) acc)))
(let [n 0 acc 0]
(while true
(let [n (* n 2)]
(println n))
(if (< n 4)
(do (set acc (+ acc n)) (set n (+ n 1)))
(break)))
acc))
(defn ret [a i32] i32
(let [a (+ a 1)]

9
test/syntax/handwritten/inventory.fln
View File

@ -25,8 +25,13 @@ macro expect(test, message)
println("expected:", ~message)
fn gcd(a: i32, b: i32) -> i32
loop x = a, y = b
if y == 0 then x else recur(y, x % y)
let x = a
let y = b
while y != 0
let r = x % y
x = y
y = r
x
fn line(it: stock/Item) -> ()
let price = stock/money(stock/value(it))

109
test/test_acceptance.ml
View File

@ -669,6 +669,81 @@ let () =
outputs "unary minus" "programs/negate.flan" neg_out;
outputs ~opt:"-O0" "unary minus, -O0" "programs/negate.flan" neg_out;
outputs ~x86:true "unary minus, x86" "programs/negate.flan" neg_out;
(* The bit operators at every width, and on dyn ints beside typed i64:
both backends and both optimisation levels print the same numbers. *)
let bits_out =
"12 -67 -79 99 0 12 -67 -79\n\
-32 -13 -28 -109\n\
4 0 2 4 2 0\n\
16 -17671 -17687 29999 0 16 -17671 -17687\n\
23040 -938 23057 -31658\n\
6 0 4 6 2 0\n\
4869120 -1881412331 -1886281451 1999999999 0 4869120 -1881412331 -1886281451\n\
1698037760 -15625000 1698037828 17929432\n\
10 0 10 16 5 0\n\
1164229214208 -8999999929661324085 -9000001093890538293 8999999999999999999 0 1164229214208 -8999999929661324085 -9000001093890538293\n\
3636062617077809152 -1098632812500000 3636062617077813347 1153167001185248\n\
25 0 18 23 23 0\n\
8 237 229 55 0 8 237 229\n\
64 25 70 25\n\
3 0 3 4 2 0\n\
8224 64121 55897 5535 0 8224 64121 55897\n\
19456 1875 19485 1875\n\
7 0 5 6 2 0\n\
105580544 4017876245 3912295701 294967295 0 105580544 4017876245 3912295701\n\
898891776 31250000 898891895 31250000\n\
13 0 11 16 5 0\n\
5386010624 18000001229181879499 18000001223795868875 446744073709551615 0 5386010624 18000001229181879499 18000001223795868875\n\
11174618839553933312 2197265625000000 11174618839553941305 2197265625000000\n\
22 0 19 23 23 0\n\
8 8 16 16 32 32 64 64 0\n\
987654312 -1595180638 -2085755254 70 25\n\
9876543120984 9876543120984\n\
" in
outputs "bit operators" "programs/bits.flan" bits_out;
outputs ~opt:"-O0" "bit operators, -O0" "programs/bits.flan" bits_out;
outputs ~x86:true "bit operators, x86" "programs/bits.flan" bits_out;
let bits_dyn_out =
"0 0 0 -1 0 0 0 0 0 64 64 0 0 0 \n\
12345 -1 -12346 0 -9223372036854775808 -1 -1 -1 64 0 0 -12295 12345 -1 \n\
1164229214208 -8999999929661324085 -9000001093890538293 8999999999999999999 3636062617077809152 -1098632812500000 3636062617077813347 1153167001185248 25 0 18 -9000001093890538298 1164229214208 -8999999929661324085 \n\
1 -1 -2 -9223372036854775808 -2 4611686018427387903 -2 -4611686018427387905 63 1 0 -1 1 -1 \n\
0 -1 -1 -281474976710657 0 2 2147483648 2 1 15 48 -48 0 -1 \n\
1 3 2 -2 4611686018427387904 0 4611686018427387904 4 1 63 0 60 1 3 \n\
52 255\n\
32 32 32\n\
" in
outputs "dyn bit operators" "programs/bits-dyn.flan" bits_dyn_out;
outputs ~opt:"-O0" "dyn bit operators, -O0" "programs/bits-dyn.flan"
bits_dyn_out;
outputs ~x86:true "dyn bit operators, x86" "programs/bits-dyn.flan"
bits_dyn_out;
(* A dyn bit operation traps at its own site: a shift count out of range
either way, a bool, a float. *)
let bits_traps ?opt ?x86 () =
let exe = compile ?opt ?x86 "programs/bits-dyn.flan" in
let traps arg reason =
let code, text = run exe (Some arg) in
if code <> 134 || not (contains text "before\n")
|| not (contains text "programs/bits-dyn.flan:")
|| not (contains text reason)
then begin
incr failures;
Printf.printf
"FAIL dyn bit trap %s\n got: %S (exit %d)\n wanted: %S (exit 134)\n"
arg text code reason
end
in
traps "1" "dyn <<: int and int, and the count is outside 0 to 63";
traps "2" "dyn bit-and: bool and int, and it takes integers; true and \
false are combined with and, or and not";
traps "3" "dyn bit-and: float and int, and it takes integers —";
traps "4" "dyn >>: int and int, and the count is outside 0 to 63";
(try Sys.remove exe with Sys_error _ -> ())
in
bits_traps ();
bits_traps ~opt:"-O0" ();
bits_traps ~x86:true ();
(* A literal arm takes the other arm's type. *)
let arm_out =
"4000000\n9000000000\n5000000000\n7\n9000000000\n3\n9000000000\n2.5\n" in
@ -6005,16 +6080,17 @@ level "1"
a dyn view");
("9", "16777217 has no exact f32");
("10", "dyn put: a Point has no field :z. Its fields are :x :y");
("14", "dyn-view-any.flan:272:39: dyn put: field :x of a Small is an \
("14", "dyn-view-any.flan:277:39: dyn put: field :x of a Small is an \
i8, and 1.5 is a float — (put #Small{:x 1 :z true} :x 1.5)");
("15", "dyn put: field :z of a Small is a bool, and the value is nil \
— (put #Small{:x 1 :z true} :z nil)");
("16", "dyn put: field :x of a Small is an i8, which holds -128 to \
127, and 200 does not fit");
("19", "#Wide{:a 18000000000000000000 :b 1}\n");
("19", "dyn-view-any.flan:287:18: dyn get: this u64 element is \
("19", "dyn-view-any.flan:292:18: dyn get: this u64 element is \
18000000000000000000");
("20", "200 does not fit an i8 element, which holds -128 to 127") ]
("20", "200 does not fit an i8 element, which holds -128 to 127");
("23", "dyn-view-any.flan:317:20: dyn has-key?: int and keyword") ]
and any_stale =
[ ("4", "this view points into a local of leak-local, and that call \
has returned");
@ -6025,10 +6101,13 @@ level "1"
call has returned");
("13", "this view points into a local of leak-slice-param, and that \
call has returned");
("17", "dyn-view-any.flan:279:44: dyn print: this view points into a \
("17", "dyn-view-any.flan:284:44: dyn print: this view points into a \
local of leak-local");
("18", "dyn-view-any.flan:281:53: dyn length: this view points into \
a local of leak-local") ]
("18", "dyn-view-any.flan:286:53: dyn length: this view points into \
a local of leak-local");
("21", "5999\n");
("21", "this view's storage, a block of i64, has been released");
("22", "dyn =: this view points into a local of leak-local") ]
in
let dyn_view_any ?opt ?(x86 = false) ?(dev = false) () =
let exe = compile ?opt ~x86 ~dev "programs/dyn-view-any.flan" in
@ -6053,6 +6132,24 @@ level "1"
saying %S\n" (name (", mode " ^ mode)) text code needle
end)
(any_traps @ if dev then any_stale else []);
(* A container compared with itself walks what it holds for stale
views in a dev build; shared and cyclic containers are walked once
each, so both answer in well under a second rather than in time
exponential in the sharing, or never. *)
List.iter
(fun (mode, want) ->
let t0 = Unix.gettimeofday () in
let code, text = run exe (Some mode) in
let dt = Unix.gettimeofday () -. t0 in
if code <> 0 || text <> want || dt > 1.0 then begin
incr failures;
Printf.printf "FAIL %s\n got: %S (exit %d) in %.2fs\n"
(name (", self-equality, mode " ^ mode)) text code dt
end)
[ ("24", "true\n"); ("25", "true\n");
(* And a scan that visited 300000 containers leaves nothing for
the next twenty thousand small ones to clear. *)
("26", "true\n20000\n") ];
(* The collector takes back what it charged for a view: a leak here
once doubled the heap's trigger forever. *)
let code, text = run exe (Some "11") in

20
test/test_dyn.ml
View File

@ -197,6 +197,26 @@ let () =
(* The three restatements of flan_vec's layout, compared field by field —
see dyn_ops.c's [layout] and [hand_vec]'s comment for what ties them
together and why nothing at compile time otherwise does. *)
(* A walk's site does not outlive a trap that leaves the walk: the second
sentence, from a lookup with no site, must not carry the first's. *)
let code, out, err = run "walkreset" in
(match String.split_on_char '-' err with
| _ when code <> 0 || out <> "walkreset done\n" ->
fail "a walk left by a trap\n got: %S (exit %d, err %S)" out
code err
| _ ->
let after =
match String.index_opt err '\n' with
| Some i -> String.sub err i (String.length err - i)
| None -> ""
in
if not (has err "walk-site:1:1") then
fail "the first walk's trap did not name its site: %S" err
else if has after "walk-site" then
fail "a later walk named an abandoned walk's site: %S" err
else if not (has after "above the largest dyn int") then
fail "the second walk did not trap: %S" err);
let code, out, err = run "layout" in
if code <> 0 || out <> "layout ok\n" then
fail "flan_vec's three restatements\n got: %S (exit %d, err %S)"

97
test/test_flan.ml
View File

@ -1375,6 +1375,91 @@ let () =
~needle:"bit-or takes two arguments or more, given 0";
rejects_check "one operand is not a min"
"(defn f [] i32 (min 7))" ~needle:"min takes two arguments or more, given 1";
(* The bit operators take integers, and a bool is answered with the logical
operator a C programmer meant. *)
infers "bit-not keeps its operand's type" "(bit-not (u16 5))" "u16";
infers "popcount keeps its operand's type" "(popcount (i64 5))" "i64";
infers "a rotation takes the value's type" "(rotate-left (u8 5) (u8 1))" "u8";
infers "&& is bit-and" "(&& 6 3)" "i32";
infers "a bit operation with a dyn operand is dyn"
"(bit-and (the dyn 6) (i32 3))" "dyn";
infers "a shift with a dyn operand is dyn" "(<< (the dyn 1) 3)" "dyn";
(* Through the whole-file check [flan check] and the editor run, which
records a refusal and goes on rather than raising at the first: a hint
that only a raised refusal could give would be lost there. [.fln] text is
checked from a file, since the operator's spelling follows the syntax. *)
let refuses_all name ?(fln = false) src needle =
let diags =
match
if fln then begin
let path = Test_support.tmp "bits-" (string_of_int (Hashtbl.hash name) ^ ".fln") in
Out_channel.with_open_bin path (fun oc -> output_string oc src);
let r = snd (Front.checked ~all:true path) in
Sys.remove path; r
end
else Check.program_all (Parse.program_all (read src))
with
| _ -> []
| exception Loc.Errors ds -> List.map (fun (d : Loc.diag) -> d.Loc.dmsg) ds
| exception Loc.Error d -> [ d.Loc.dmsg ]
in
if not (List.exists (fun m -> contains m needle) diags) then begin
incr failures;
Printf.printf "FAIL %s\n wanted: %s\n got: %s\n" name needle
(String.concat " | " diags)
end
in
refuses_all "bit-and over bools points at and"
"(defn f [a bool b bool] bool (= (bit-and a b) 0))"
"bit-and works on the bits of an integer, and this is a bool. \
For true and false, write (and a b)";
refuses_all "bit-not over a bool points at not"
"(defn f [a bool] i32 (bit-not a) 0)" "write (not a)";
refuses_all "bit-xor over bools points at !="
"(defn f [a bool b bool] i32 (bit-xor a b) 0)" "write (!= a b)";
refuses_all "a typed bool beside a dyn is refused before it runs"
"(defn f [a bool d dyn] dyn (bit-or a d))" "write (or a b)";
refuses_all "a shift of a bool"
"(defn f [a bool] i32 (<< a 1) 0)" "combined with and, or and not";
refuses_all "a bool shift count" "(defn f [flag bool] i32 (<< 1 flag))"
"combined with and, or and not";
refuses_all "a bool beside an integer, an integer wanted"
"(defn f [flag bool x i32] i32 (bit-and flag x))" "write (and a b)";
refuses_all "a bool beside a literal, an integer wanted"
"(defn f [flag bool] i32 (bit-or flag 1))" "write (or a b)";
refuses_all "a literal beside a bool" "(defn f [flag bool] i32 (bit-or 1 flag))"
"write (or a b)";
refuses_all "a bool third" "(defn f [x i32 flag bool] i32 (bit-and x x flag))"
"write (and a b)";
refuses_all "a comparison as an operand"
"(defn f [x i32 y i32] i32 (bit-and x (= x y)))" "write (and a b)";
refuses_all "a bool field" "(defstruct S [on bool]) (defn f [s S] i32 (bit-or 1 (.on s)))"
"write (or a b)";
refuses_all "a call that answers a bool"
"(defn p? [x i32] bool (> x 0)) (defn f [x i32] i32 (bit-and x (p? x)))"
"write (and a b)";
refuses_all "an if whose type is bool"
"(defn f [x i32 c bool] i32 (bit-or 1 (if c true false)))" "write (or a b)";
refuses_all "a dyn function's typed bool result"
"(defn p? [x] bool (> x 0)) (defn f [d dyn] i32 (<< 1 (p? d)))"
"combined with and, or and not";
refuses_all "a bool inside a nest of bit operations"
"(defn p? [x i32] bool (> x 0)) \
(defn f [x i32] i32 (bit-and x (bit-or x (bit-xor x (p? x)))))"
"write (!= a b)";
refuses_all ~fln:true "&& in .fln, the bool first"
"fn f(flag: bool, x: i32) -> i32\n flag && x\n" "For true and false, write a and b";
refuses_all ~fln:true "&& in .fln, a literal first"
"fn f(flag: bool) -> i32\n 1 && flag\n" "write a and b";
refuses_all ~fln:true "&& in .fln, the bool last of three"
"fn f(flag: bool, x: i32) -> i32\n x && x && flag\n" "write a and b";
refuses_all ~fln:true "~~ in .fln" "fn f(a: bool) -> i32\n ~~a\n" "~~ works on the bits";
refuses_all ~fln:true "^^ in .fln" "fn f(a: bool, b: bool) -> bool\n a ^^ b == 0\n"
"write a != b";
rejects_check "popcount of a float"
"(defn f [a f64] f64 (popcount a))" ~needle:"popcount takes integers, found f64";
rejects_check "a rotation's count does not widen the value"
"(defn f [a u8 n i32] u8 (rotate-left a n))" ~needle:"i32";
(* ── Chained comparisons ───────────────────────────────────────── *)
(* (< a b c) is a < b and b < c. The left fold — ((a < b) < c) — would be
@ -2776,18 +2861,16 @@ let () =
"(defn f [a i32 b i32] bool (=/= a b))" ~needle:"Write (!= a b)";
rejects_check "== names ="
"(defn f [a i32 b i32] bool (== a b))" ~needle:"Write (= a b)";
rejects_check "&& names and"
"(defn f [a bool b bool] bool (&& a b))" ~needle:"Write (and a b)";
rejects_check "&& over bools names and"
"(defn f [a bool b bool] bool (&& a b))" ~needle:"write (and a b)";
accepts "and that call compiles" "(defn f [a bool b bool] bool (and a b))";
rejects_check "|| names or"
"(defn f [a bool b bool] bool (|| a b))" ~needle:"Write (or a b)";
rejects_check "|| over bools names or"
"(defn f [a bool b bool] bool (|| a b))" ~needle:"write (or a b)";
rejects_check "! names not"
"(defn f [a bool] bool (! a))" ~needle:"Write (not a)";
rejects_check "a ! at an arity not does not take gets not's shape"
"(defn f [a bool b bool] bool (! a b))" ~needle:"called as (not x)";
rejects_check "a bare && is written back as the and that compiles"
"(defn f [] bool (&&))" ~needle:"Write (and)";
accepts "and it does" "(defn f [] bool (and))";
accepts "a bare and compiles" "(defn f [] bool (and))";
accepts "a program's own not= is its own"
"(defn not= [a i32 b i32] bool (!= a b)) \
(defn f [a i32 b i32] bool (not= a b))";

32
test/test_reload.ml
View File

@ -640,30 +640,18 @@ let () =
"a listing taken during a compaction\n got: %S (exit %d, err %S)\n wanted no zero-row and no wrong-count answers"
out code err;
(* And a table that is genuinely full, which is the state the trigger above
must not paper over. The note is dropped — a diagnostic that killed the
program because it ran out of room would be the diagnostic shooting the
patient — and the decision this pins is that the drop is *said*, once.
Once matters: this is the game thread inside the allocation hook, and a
line per dropped note would be sixty a second down a pipe nobody drains
while a request is being served. *)
(* And a table whose live set outgrows it: 4096 live blocks and nothing
dead, then three more. The table grows rather than dropping them — a
dyn view's dev check asks it whether a block is alive, and a dropped
note would stop that check without a word — so nothing overflows and
every block is counted. *)
let code, out, err = mode "regoverflow" in
let want_over = "live 4096\noverflowed 0\noverflowed 1\nlive 4096\n" in
let want_over = "live 4096\noverflowed 0\noverflowed 0\nlive 4099\n" in
if code <> 0 || out <> want_over then
fail "a full registry\n got: %S (exit %d)\n wanted: %S" out
code want_over;
let said_full =
let needle = "the allocation registry is full" in
let rec go i n =
if i + String.length needle > String.length err then n
else if String.sub err i (String.length needle) = needle then
go (i + 1) (n + 1)
else go (i + 1) n
in
go 0 0
in
if said_full <> 1 then
fail "a full registry said so %d times, not once: %S" said_full err;
fail "a registry past its first size\n got: %S (exit %d)\n wanted: %S"
out code want_over;
if has err "the allocation registry is full" then
fail "a registry that grows said it was full: %S" err;
Printf.printf
"reload: emit %.1fms llc %.1fms ld %.1fms (v2: emit %.1fms llc %.1fms ld %.1fms) host run %.1fms\n"

87
test/test_syntax.ml
View File

@ -111,6 +111,10 @@ let canon (f : Form.t) : Form.t =
let rec go env (f : Form.t) =
let v =
match f.v with
(* The Lisp side may write the bit operators' .fln spellings, which read
back as their words: the same builtin by two names. *)
| Form.Sym ("&&" | "||" | "^^" as s) ->
Form.Sym (match s with "&&" -> "bit-and" | "||" -> "bit-or" | _ -> "bit-xor")
| Form.Sym s -> Form.Sym (look env s)
(* Quoted data keeps its names: renaming them would hide a printer
that renamed them too. *)
@ -359,13 +363,17 @@ let attached_ok ~what path (src, forms) (out, back) =
(* Every .flan the build tree holds. [..] is the workspace root from here;
the deps in test/dune decide what is in it. *)
let corpus () =
(* recur.flan is about the Lisp loop form, which the indented syntax does
not have. *)
let lisp_only = [ "recur.flan" ] in
let rec walk dir acc =
Array.fold_left
(fun acc name ->
let path = Filename.concat dir name in
if name <> "" && (name.[0] = '.' || name.[0] = '_') then acc
else if Sys.is_directory path then walk path acc
else if Filename.check_suffix name ".flan" then path :: acc
else if Filename.check_suffix name ".flan" && not (List.mem name lisp_only) then
path :: acc
else acc)
acc (Sys.readdir dir)
in
@ -524,6 +532,21 @@ let () =
reads "chain" "x = a < b < c" "(set x (< a b c))";
reads "left to right" "x = a - b + c" "(set x (+ (- a b) c))";
reads "precedence" "x = a or b and not c == d" "(set x (or a (and b (not (= c d)))))";
(* The bit operators: tighter than a comparison, looser than a shift, and
among themselves && then ^^ then ||. *)
reads "bit and under a comparison" "x = a && mask == 0"
"(set x (= (bit-and a mask) 0))";
reads "bit operator order" "x = a || b ^^ c && d << 2 + 1"
"(set x (bit-or a (bit-xor b (bit-and c (<< d (+ 2 1))))))";
reads "bit operators left to right" "x = a && b && c || d"
"(set x (bit-or (bit-and a b c) d))";
reads "bit-not" "x = ~~a && ~~f(b)" "(set x (bit-and (bit-not a) (bit-not (f b))))";
reads "bit-not of a negation" "x = ~~-a" "(set x (bit-not (- a)))";
reads "bit operator values" "x = reduce(^^, 0, xs)" "(set x (reduce bit-xor 0 xs))";
reads "bit-not in a spaced vector" "x = [~~a b]" "(set x [(bit-not a) b])";
reads "a nested unquote" "quote\n f(~(~x))" "(quasiquote (f (unquote (unquote x))))";
reads "bit-not in a template" "quote\n f(~~x, ~(~~y))"
"(quasiquote (f (bit-not x) (unquote (bit-not y))))";
refuses "not-equal chain" "x = a != b != c" "indent/chained-not-equal" "!=(a, b, c)";
reads "not-equal call" "x = !=(a, b, c)" "(set x (!= a b c))";
refuses "mixed comparison" "x = a < b <= c" "indent/mixed-comparison" "and";
@ -612,12 +635,26 @@ let () =
reads "macro with no parameters" "macro m()\n a" "(defmacro m [] a)";
refuses "a rest parameter not last" "macro m(& a, b)\n a" "indent/macro-rest-last"
"comes last: macro m(b, & a)";
reads "loop" "loop x = a, y = b + 1\n recur(y, x)" "(loop [x a y (+ b 1)] (recur y x))";
reads ~global:false "a let-bound loop" "let r = loop i = 0\n recur(i)\nr" "(let [r (loop [i 0] (recur i))] r)";
reads "the loop call stays a call" "loop([x 1]):\n x" "(loop [x 1] x)";
refuses "a loop with no values" "loop\n g()" "indent/loop-bindings" "loop([]):";
refuses "a loop variable with no value" "loop x, y = 1\n g()" "indent/loop-bindings"
"loop x = 0";
(* No loop and no recur: a .fln loop is a while, until, dotimes or for. *)
refuses "a loop header" "loop x = a, y = b + 1\n recur(y, x)" "indent/no-loop"
"while i < 10";
refuses ~global:false "a let-bound loop" "let r = loop i = 0\n i\nr" "indent/no-loop"
"loop is not part of the indented syntax";
refuses "a loop call" "loop([x 1]):\n x" "indent/no-loop" "while, until, dotimes or for";
refuses "a loop over a block" "loop\n g()" "indent/no-loop" "loop is not";
refuses "a recur call" "f(recur(1))" "indent/no-loop" "recur is not part of the indented syntax";
refuses "a loop in a macro's quote" "macro m(a)\n quote\n loop([i ~a]):\n i"
"indent/no-loop" "loop is not";
refuses "a quoted loop" "f('(loop [i 0] (recur i)))" "indent/no-loop" "loop is not";
reads "loop as a name" "loop = 4" "(set loop 4)";
reads "if over loop" "if loop\n 1" "(when loop 1)";
reads "while over loop" "while loop\n g()" "(while loop (g))";
reads "until over loop" "until loop\n g()" "(until loop (g))";
reads "elif over loop" "if recur\n 1\nelif loop\n 2" "(cond recur 1 loop 2)";
reads "a one-line if over loop" "if loop then 1 else 2" "(if loop 1 2)";
reads "a one-line if over recur" "if recur > 0 then recur else 0" "(if (> recur 0) recur 0)";
reads ~global:false "a typed let of loop" "let loop: i32 = 1\nloop" "(let [loop (the i32 1)] loop)";
reads "a match over loop, and an arm of it" "match loop\n loop -> loop" "(match loop loop loop)";
reads "read-only pointer" "let p: Ptr(const u8) = uninit" "(def p (Ptr const u8) uninit)";
(* Statements that fit on a line, in one-line slots. *)
reads "arm statements" "match s\n 1 -> break\n 2 -> continue :outer\n _ -> x += 1"
@ -909,7 +946,17 @@ let () =
fail "%s: read back %s from %S" name (describe_diff forms back) text
| exception e -> fail "%s: its text is refused: %s\n%s" name (diag_text e) text
in
round "a one-line lambda" "(defn f [] () (h (fn [a] (+ a 1)) 2))" "= h(fn(a) => a + 1, 2)";
round "bit operators print infix"
"(defn f [a i32 m i32] bool (= (bit-and a (bit-not m)) (bit-or (bit-xor a 1) (<< m 2))))"
"a && ~~m == a ^^ 1 || m << 2";
round "bit operators parenthesise against precedence"
"(defn f [a i32 b i32 c i32] i32 (bit-and (bit-or a b) (+ c 1) (bit-not (bit-xor a b))))"
"= (a || b) && c + 1 && ~~(a ^^ b)";
round "a nested unquote prints with parentheses"
"(defmacro m [x] `(defmacro n [] `(g ~~x ~(bit-not x))))" "~(~x)";
prints "the Lisp spellings print as the operators"
"(defn f [a i32 b i32] i32 (^^ (&& a b) (|| a b)))" "a && b ^^ (a || b)";
round "a one-line lambda""(defn f [] () (h (fn [a] (+ a 1)) 2))" "= h(fn(a) => a + 1, 2)";
round "a block lambda as a call's last argument"
"(defn f [] () (sort-by xs (fn [a b] (g a) (< a b))))"
" sort-by(xs, fn(a, b) =>\n g(a)\n a < b)";
@ -989,12 +1036,24 @@ let () =
prints "a parent with no fields" "(defstruct D :parent Io)" "struct D :parent Io";
prints "an empty field vector under a parent keeps the fallback"
"(defstruct D :parent Io [])" "defstruct(D, :parent, Io, [])";
prints "a loop" "(defn f [a i32] i32 (loop [x a y 0] (if (= x 0) y (recur (- x 1) (+ y 1)))))"
" loop x = a, y = 0\n if x == 0 then y";
prints "a let-bound loop" "(defn f [] i32 (let [r (loop [i 0] (recur i))] r))"
" let r = loop i = 0\n recur(i)";
prints "a lambda as a loop's value is parenthesised"
"(defn f [] () (loop [g (fn [x] x) n 0] (recur g n)))" "loop g = (fn(x) => x), n = 0"
(* A .flan file with loop or recur is refused, every line named. *)
(match
Reader.read_all ~file:"<p>"
"(defn f [a i32] i32\n (loop [x a y 0]\n (if (= x 0) y (recur (- x 1) (+ y 1)))))\n\n(defn g [] i32 (loop [i 0] i))"
with
| forms ->
(match Indent_printer.program forms with
| text -> fail "a loop printed: %s" text
| exception Loc.Error d ->
if d.Loc.kind <> "convert/no-loop" then fail "a loop refused as %s" d.Loc.kind;
List.iter
(fun n ->
if not (Test_support.contains d.Loc.dmsg n) then
fail "the loop refusal does not say %S: %s" n d.Loc.dmsg)
[ "on lines 2, 3 and 5. The indented syntax"; "(while (< i 10)" ];
if List.length d.Loc.notes <> 2 then
fail "the loop refusal points at %d more places, wanted 2" (List.length d.Loc.notes))
| exception e -> fail "a loop: %s" (diag_text e))
(* ── Spans, for pause marks and error overlays ──────────────────────── *)