Merge master into the bit operators lane
This commit is contained in:
commit
c4452fc500
4
TODO.org
4
TODO.org
@ -683,6 +683,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
|
more bindings of the same let; anything else there stays refused. flan convert writes
|
||||||
consecutive lets this way.
|
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
|
** 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
|
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
|
text — =(Ptr %s)=, =(clone v)=, =(the T x)= in most of =check.ml= and =parse.ml=, the
|
||||||
|
|||||||
@ -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
|
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
|
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
|
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
|
- 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
|
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
|
needed because the next call at the same depth lands at the same address. A block is alive when the registry probe
|
||||||
|
|||||||
@ -1205,7 +1205,7 @@ Use `C-c C-g` if you need frames.
|
|||||||
| `M-a` / `M-e` | `(` / `)` | statement: start / end (`)`: start of the next) |
|
| `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-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 |
|
| `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 |
|
| `DEL` in indentation | same | drop one level |
|
||||||
| `C-c <` / `C-c >` | `<` / `>` | shift the region's lines a level |
|
| `C-c <` / `C-c >` | `<` / `>` | shift the region's lines a level |
|
||||||
| `M-<up>` / `M-<down>` | same | move the statement past its neighbour |
|
| `M-<up>` / `M-<down>` | same | move the statement past its neighbour |
|
||||||
|
|||||||
@ -105,8 +105,7 @@ fine here. Brackets and strings are still paired."
|
|||||||
'("fn" "fn-" "def" "once" "const" "struct" "union" "data" "enum" "import"
|
'("fn" "fn-" "def" "once" "const" "struct" "union" "data" "enum" "import"
|
||||||
"if" "elif" "else" "while" "until" "for" "match" "let" "return" "break"
|
"if" "elif" "else" "while" "until" "for" "match" "let" "return" "break"
|
||||||
"continue" "defer" "handler-case" "handler-bind" "restart-case" "on"
|
"continue" "defer" "handler-case" "handler-bind" "restart-case" "on"
|
||||||
"restart" "quote" "macro" "loop" "type" "class" "generic" "multi"
|
"restart" "quote" "macro" "type" "class" "generic" "multi" "method"))
|
||||||
"method"))
|
|
||||||
|
|
||||||
;; The headers whose block follows on the lines under them. `defer' and
|
;; 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
|
;; `quote' open one only when nothing follows them on the line; `fn' does not
|
||||||
@ -115,8 +114,7 @@ fine here. Brackets and strings are still paired."
|
|||||||
(defconst flan-fln--opener-words
|
(defconst flan-fln--opener-words
|
||||||
'("fn" "fn-" "struct" "union" "data" "enum" "if" "elif" "else" "while"
|
'("fn" "fn-" "struct" "union" "data" "enum" "if" "elif" "else" "while"
|
||||||
"until" "for" "match" "defer" "handler-case" "handler-bind"
|
"until" "for" "match" "defer" "handler-case" "handler-bind"
|
||||||
"restart-case" "on" "restart" "quote" "macro" "loop" "class" "multi"
|
"restart-case" "on" "restart" "quote" "macro" "class" "multi" "method"))
|
||||||
"method"))
|
|
||||||
|
|
||||||
(defconst flan-fln--declaration-words
|
(defconst flan-fln--declaration-words
|
||||||
'(("fn" . "defn") ("fn-" . "defn-") ("def" . "def") ("once" . "defonce")
|
'(("fn" . "defn") ("fn-" . "defn-") ("def" . "def") ("once" . "defonce")
|
||||||
@ -403,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)
|
(defun flan-fln--value-opens-p (l)
|
||||||
"Non-nil if the value the joined line L binds or assigns goes on under it:
|
"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',
|
`= 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 `='
|
lib/indent_reader.ml's `value_line' reads a block for, besides a bare `='
|
||||||
and a call ending in `:'."
|
and a call ending in `:'."
|
||||||
(let ((v (flan-fln--value-start l))
|
(let ((v (flan-fln--value-start l))
|
||||||
@ -411,7 +409,7 @@ and a call ending in `:'."
|
|||||||
(and v (< v end)
|
(and v (< v end)
|
||||||
(save-excursion
|
(save-excursion
|
||||||
(goto-char v)
|
(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)))
|
(and (looking-at "if[ \t]") (not (flan-fln--then l)))
|
||||||
(flan-fln--lambda-header-p v end))))))
|
(flan-fln--lambda-header-p v end))))))
|
||||||
|
|
||||||
|
|||||||
@ -137,13 +137,21 @@ macro dbl-of(x, & more)
|
|||||||
fn use-mac(k: i64) -> i64 = dbl-of(k)
|
fn use-mac(k: i64) -> i64 = dbl-of(k)
|
||||||
|
|
||||||
fn gcd(a: i64, b: i64) -> i64
|
fn gcd(a: i64, b: i64) -> i64
|
||||||
loop x = a, y = b
|
let x = a
|
||||||
if y == 0 then x else recur(y, x % y)
|
let y = b
|
||||||
|
while y != 0
|
||||||
|
let r = x % y
|
||||||
|
x = y
|
||||||
|
y = r
|
||||||
|
x
|
||||||
|
|
||||||
fn sum-to(n: i64) -> i64
|
fn sum-to(n: i64) -> i64
|
||||||
let r = loop i = 0, acc = 0
|
let i = 0
|
||||||
if i > n then acc else recur(i + 1, acc + i)
|
let acc = 0
|
||||||
r
|
until i > n
|
||||||
|
acc += i
|
||||||
|
i += 1
|
||||||
|
acc
|
||||||
|
|
||||||
comment():
|
comment():
|
||||||
if 1 < 2 and
|
if 1 < 2 and
|
||||||
@ -400,10 +408,10 @@ comment():
|
|||||||
("Dir.north" "an enum member's arm, at its value")
|
("Dir.north" "an enum member's arm, at its value")
|
||||||
("let b = 2" "a let the let above takes in, 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")
|
("let c: i64" "a typed one, at its value")
|
||||||
("loop x = a" "a loop, at its word")
|
("while y != 0" "a while, at its word")
|
||||||
("if y == 0" "a loop's block")
|
("let r = x % y" "a while's block")
|
||||||
("let r = loop" "a let-bound loop, at its let")
|
("until i > n" "an until, at its word")
|
||||||
("if i > n" "a let-bound loop's block")))
|
("acc += i" "an until's block")))
|
||||||
(funcall goto (car c))
|
(funcall goto (car c))
|
||||||
(let ((reply (flan-fln-eval-defun '(4))))
|
(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"
|
(test-flan--check (funcall name (format "C-u C-c C-c marks %s where the reader starts it"
|
||||||
|
|||||||
@ -737,8 +737,13 @@ macro repeat(i, n, & body)
|
|||||||
~@body
|
~@body
|
||||||
|
|
||||||
fn gcd(a: i32, b: i32) -> i32
|
fn gcd(a: i32, b: i32) -> i32
|
||||||
loop x = a, y = b
|
let x = a
|
||||||
if y == 0 then x else recur(y, x % y)
|
let y = b
|
||||||
|
while y != 0
|
||||||
|
let r = x % y
|
||||||
|
x = y
|
||||||
|
y = r
|
||||||
|
x
|
||||||
"
|
"
|
||||||
(font-lock-ensure)
|
(font-lock-ensure)
|
||||||
(let ((face (lambda (needle)
|
(let ((face (lambda (needle)
|
||||||
@ -748,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 "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 "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 "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 "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 "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))
|
(test-flan-fln--is "and so is what it names" (funcall face "Vec(i64)") 'font-lock-type-face))
|
||||||
@ -767,15 +771,13 @@ fn gcd(a: i32, b: i32) -> i32
|
|||||||
(test-flan-fln--is "installed as a defmacro"
|
(test-flan-fln--is "installed as a defmacro"
|
||||||
(flan-fln--declaration-head-at (car (flan-fln--toplevel-bounds (point))))
|
(flan-fln--declaration-head-at (car (flan-fln--toplevel-bounds (point))))
|
||||||
"defmacro")
|
"defmacro")
|
||||||
(search-forward "recur")
|
(search-forward "while y")
|
||||||
(test-flan-fln--is "a loop's statement is its header and block"
|
(test-flan-fln--is "a while's statement is its header and block"
|
||||||
(progn (forward-line -1)
|
(test-flan-fln--thing 'flan-fln-statement)
|
||||||
(test-flan-fln--thing 'flan-fln-statement))
|
"while y != 0
|
||||||
"loop x = a, y = b
|
let r = x % y
|
||||||
if y == 0 then x else recur(y, x % y)")
|
x = y
|
||||||
(test-flan-fln--is "and its body the block"
|
y = r")
|
||||||
(test-flan-fln--thing 'flan-fln-body)
|
|
||||||
"if y == 0 then x else recur(y, x % y)")
|
|
||||||
(goto-char (point-min))
|
(goto-char (point-min))
|
||||||
(test-flan-fln--is "the struct's head is defstruct"
|
(test-flan-fln--is "the struct's head is defstruct"
|
||||||
(flan-fln--declaration-head-at (point)) "defstruct")
|
(flan-fln--declaration-head-at (point)) "defstruct")
|
||||||
@ -894,13 +896,13 @@ defconst(k, 3)
|
|||||||
("let f = fn(a, b) =>" "a lambda header")
|
("let f = fn(a, b) =>" "a lambda header")
|
||||||
("let f = fn(a: i64, b) -> i64 =>" "a typed 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 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")))
|
("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--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--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--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--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--is "a header word being assigned opens nothing"
|
||||||
(test-flan-fln--tabs "fn f()\n for = 1\n|" 1) 2)
|
(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"
|
(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"
|
||||||
|
|||||||
@ -596,12 +596,12 @@ let body_guess (h : Form.t) args =
|
|||||||
match a.v with Form.List _ -> false | _ -> true) args) in
|
match a.v with Form.List _ -> false | _ -> true) args) in
|
||||||
(match base with
|
(match base with
|
||||||
| "comment" | "do" -> Some 0
|
| "comment" | "do" -> Some 0
|
||||||
| "unless" | "loop" -> Some 1
|
| "unless" -> Some 1
|
||||||
| "defmacro" -> Some 2
|
| "defmacro" -> Some 2
|
||||||
| "defmethod" -> Some 3
|
| "defmethod" -> Some 3
|
||||||
| _ ->
|
| _ ->
|
||||||
(* A with- macro, or any call whose last argument is a statement —
|
(* 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. *)
|
lists goes in the block. *)
|
||||||
let stmt_like (a : Form.t) =
|
let stmt_like (a : Form.t) =
|
||||||
match a.v with
|
match a.v with
|
||||||
@ -933,9 +933,6 @@ and value_lines n prefix (v : Form.t) =
|
|||||||
| _ -> false
|
| _ -> false
|
||||||
in
|
in
|
||||||
if is_do then [ ind n ^ prefix ^ " =" ] @ block (n + 2) (stmts_of v)
|
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
|
else
|
||||||
match lambda_value n prefix v with
|
match lambda_value n prefix v with
|
||||||
| Some ls -> ls
|
| Some ls -> ls
|
||||||
@ -952,23 +949,6 @@ and value_lines n prefix (v : Form.t) =
|
|||||||
|
|
||||||
and slot n (f : Form.t) = block n (stmts_of f)
|
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
|
and label_of = function
|
||||||
| ({ Form.v = Form.Kw k; _ }) :: rest when kw_ok k -> (":" ^ k ^ " ", rest)
|
| ({ Form.v = Form.Kw k; _ }) :: rest when kw_ok k -> (":" ^ k ^ " ", rest)
|
||||||
| rest -> ("", rest)
|
| rest -> ("", rest)
|
||||||
@ -1177,9 +1157,6 @@ and sugar n (f : Form.t) : string list option =
|
|||||||
| _, [ t ] when type_shaped t -> Some [ pre ^ ": " ^ ty t ]
|
| _, [ t ] when type_shaped t -> Some [ pre ^ ": " ^ ty t ]
|
||||||
| _, [ t; v ] -> Some (value_lines n (w ^ " " ^ name ^ ": " ^ ty t) v)
|
| _, [ t; v ] -> Some (value_lines n (w ^ " " ^ name ^ ": " ^ ty t) v)
|
||||||
| _ -> None)
|
| _ -> 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; _ }
|
| Form.List ({ v = Form.Sym "defmacro"; _ } :: { v = Form.Sym name; _ }
|
||||||
:: { v = Form.Vec ps; _ } :: (_ :: _ as body))
|
:: { v = Form.Vec ps; _ } :: (_ :: _ as body))
|
||||||
when def_name name ->
|
when def_name name ->
|
||||||
@ -1378,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
|
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
|
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]
|
(** 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
|
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. *)
|
file's own macros are known and no imported package's. *)
|
||||||
let program ?source ?macros:m (fs : Form.t list) : string =
|
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);
|
macros := (match m with Some m -> m | None -> Body_macros.table fs);
|
||||||
classes :=
|
classes :=
|
||||||
List.filter_map
|
List.filter_map
|
||||||
|
|||||||
@ -665,6 +665,17 @@ let refuse_ws ?(brace = false) loc e =
|
|||||||
(if brace then "entries" else "elements")
|
(if brace then "entries" else "elements")
|
||||||
(if brace then "{.x a + 1, .y 2}" else "[a - 1, b]")
|
(if brace then "{.x a + 1, .y 2}" else "[a - 1, b]")
|
||||||
|
|
||||||
|
(* [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,
|
(* 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
|
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
|
level, 3 a [not], 0 a one-line [if] or a lambda. Anything under 11 is
|
||||||
@ -780,6 +791,21 @@ and primary p : Form.t * int =
|
|||||||
let glued_lp = nxt.tok = LP && not nxt.sp in
|
let glued_lp = nxt.tok = LP && not nxt.sp in
|
||||||
if s = "if" && nxt.sp && starts_value nxt.tok then if_expr p
|
if s = "if" && nxt.sp && starts_value nxt.tok then if_expr p
|
||||||
else if s = "fn" && glued_lp then fn_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
|
else if is_op_word s then begin
|
||||||
if glued_lp || ends_value nxt.tok then begin
|
if glued_lp || ends_value nxt.tok then begin
|
||||||
ignore (advance p);
|
ignore (advance p);
|
||||||
@ -1237,13 +1263,6 @@ let header_follow p s =
|
|||||||
&& (let a = peek_at p 2 in a.tok = LP && not a.sp)
|
&& (let a = peek_at p 2 in a.tok = LP && not a.sp)
|
||||||
(* [type Row = Vec(i32)]: a name and its [=]. *)
|
(* [type Row = Vec(i32)]: a name and its [=]. *)
|
||||||
| "type" -> n.sp && plain_name n.tok && (peek_at p 2).tok = NAME "="
|
| "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)
|
| "return" -> n.tok = NEWLINE || (n.sp && starts_value n.tok)
|
||||||
| "break" | "continue" ->
|
| "break" | "continue" ->
|
||||||
n.tok = NEWLINE || (n.sp && (match n.tok with KW _ -> true | _ -> false))
|
n.tok = NEWLINE || (n.sp && (match n.tok with KW _ -> true | _ -> false))
|
||||||
@ -1407,7 +1426,7 @@ and value_line ?(block_ok = false) (s : st) ~after : Form.t =
|
|||||||
match (peek p).tok with
|
match (peek p).tok with
|
||||||
(* [let r = match a] with its arms under it, and [let r = if c] with its
|
(* [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. *)
|
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 ->
|
when header_follow p w ->
|
||||||
header s w
|
header s w
|
||||||
| NAME "if" when header_follow p "if" && not (then_on_line p) -> header s "if"
|
| NAME "if" when header_follow p "if" && not (then_on_line p) -> header s "if"
|
||||||
@ -1907,31 +1926,6 @@ and header (s : st) w : Form.t =
|
|||||||
expect_line_end p ~after:")";
|
expect_line_end p ~after:")";
|
||||||
let body = block s ~after:("macro " ^ text_of name ^ "(...)") in
|
let body = block s ~after:("macro " ^ text_of name ^ "(...)") in
|
||||||
named "defmacro" (name :: pv :: body)
|
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" ->
|
| "data" ->
|
||||||
let name = name_tok p ~what:"the type's name" in
|
let name = name_tok p ~what:"the type's name" in
|
||||||
expect_eol_block p ~after:("data " ^ text_of name);
|
expect_eol_block p ~after:("data " ^ text_of name);
|
||||||
@ -2272,6 +2266,29 @@ and lines (s : st) (one : unit -> Form.t list) : Form.t list =
|
|||||||
|
|
||||||
let () = block_of := fun p -> block { p; lets = [] } ~after:"=>"
|
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
|
(** All top-level forms in a [.fln] source string. [col] is the column the
|
||||||
text's top level starts at, 1 for a file. *)
|
text's top level starts at, 1 for a file. *)
|
||||||
let read_all ?(line = 1) ?col ?indent ?(global_let = true) ~file src =
|
let read_all ?(line = 1) ?col ?indent ?(global_let = true) ~file src =
|
||||||
@ -2302,6 +2319,7 @@ let read_all ?(line = 1) ?col ?indent ?(global_let = true) ~file src =
|
|||||||
(match (peek s.p).tok with
|
(match (peek s.p).tok with
|
||||||
| EOF -> ()
|
| EOF -> ()
|
||||||
| tk -> failk "unexpected-token" (where_ s.p) "unexpected %s" (show tk));
|
| tk -> failk "unexpected-token" (where_ s.p) "unexpected %s" (show tk));
|
||||||
|
refuse_loops fs;
|
||||||
fs)
|
fs)
|
||||||
|
|
||||||
let read_file path =
|
let read_file path =
|
||||||
|
|||||||
@ -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.
|
* 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 —
|
/* A power of two: the probe wraps with a mask. The table starts here and
|
||||||
* see flan_dev_reg_note. */
|
* doubles when three quarters of it is live ([flan_reg_grow]): a dyn view's
|
||||||
#define FLAN_REG_CAP 4096
|
* 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
|
/* 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
|
* 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
|
/* 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
|
* out: a compaction between the two moved entries, so the scan saw some of
|
||||||
* them twice and some not at all. */
|
* 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) {
|
static int flan_reg_scan_open(uint64_t *at) {
|
||||||
uint64_t g = __atomic_load_n(&flan_reg_epoch, __ATOMIC_ACQUIRE);
|
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;
|
if (g & 1) return 0;
|
||||||
*at = g;
|
*at = g;
|
||||||
return 1;
|
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) {
|
static int flan_reg_scan_ok(uint64_t at) {
|
||||||
__atomic_thread_fence(__ATOMIC_ACQUIRE);
|
__atomic_thread_fence(__ATOMIC_ACQUIRE);
|
||||||
return __atomic_load_n(&flan_reg_epoch, __ATOMIC_ACQUIRE) == at;
|
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;
|
if (flan_reg_full) return;
|
||||||
flan_reg_full = 1;
|
flan_reg_full = 1;
|
||||||
fprintf(stderr,
|
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 "
|
"noted from here on are dropped, so every listing is a floor and "
|
||||||
"not a count.\n",
|
"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
|
/* 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. */
|
* repeating the claim that a release build carries nothing. */
|
||||||
static void flan_reg_report(void); /* the exit report, at the bottom */
|
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) {
|
void flan_dev_reg_enable(void) {
|
||||||
if (flan_reg_on) return;
|
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
|
/* 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",
|
off and every question about an address answers "never heard of it",
|
||||||
which is what a release build answers too. */
|
which is what a release build answers too. */
|
||||||
if (flan_reg == NULL) return;
|
if (flan_reg == NULL) return;
|
||||||
flan_reg_on = 1;
|
flan_reg_on = 1;
|
||||||
|
flan_dev_views_checked = 1;
|
||||||
/* Here and not at file scope: a destructor attribute would run in every
|
/* 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
|
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
|
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; }
|
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
|
/* 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
|
* 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
|
* 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
|
* 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
|
* move live entries around and hold the epoch odd while it does — see
|
||||||
* FLAN_REG_RECLAIM for the wrong answers that bought. */
|
* 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) {
|
static void flan_reg_compact(void) {
|
||||||
size_t bytes = FLAN_REG_CAP * sizeof(flan_reg_entry);
|
size_t bytes = FLAN_REG_CAP * sizeof(flan_reg_entry);
|
||||||
flan_reg_entry *old = (flan_reg_entry *)malloc(bytes);
|
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
|
if (flan_reg_used * 4 > (int64_t)FLAN_REG_CAP * 3
|
||||||
&& flan_reg_dead >= FLAN_REG_RECLAIM)
|
&& flan_reg_dead >= FLAN_REG_RECLAIM)
|
||||||
flan_reg_compact();
|
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);
|
s = flan_reg_slot(a);
|
||||||
for (probe = 0; probe < FLAN_REG_CAP; probe++) {
|
for (probe = 0; probe < FLAN_REG_CAP; probe++) {
|
||||||
size_t j = (s + (size_t)probe) & (FLAN_REG_CAP - 1);
|
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. */
|
* block handed out as a slice. */
|
||||||
static flan_reg_entry *flan_reg_find(uintptr_t a);
|
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,
|
int32_t flan_dev_reg_owner_check(const void *p, const void *owner,
|
||||||
const void **found) {
|
const void **found) {
|
||||||
flan_reg_entry *e;
|
flan_reg_entry *e;
|
||||||
if (!flan_reg_on) return 0;
|
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 == NULL) return flan_reg_full ? 0 : 1;
|
||||||
if (e->base != (uintptr_t)p) return 1;
|
if (e->base != (uintptr_t)p) return 1;
|
||||||
if (e->died != 0) return 3;
|
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
|
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
|
file next to the note explaining why they are wrong is how the next
|
||||||
person learns the rule has exceptions it does not have. */
|
person learns the rule has exceptions it does not have. */
|
||||||
|
int regrown = 0;
|
||||||
for (attempt = 0; attempt < 8; attempt++) {
|
for (attempt = 0; attempt < 8; attempt++) {
|
||||||
uint64_t at;
|
uint64_t at, grows0 = __atomic_load_n(&flan_reg_grows, __ATOMIC_ACQUIRE);
|
||||||
int64_t i;
|
int64_t i;
|
||||||
have = 0;
|
have = 0;
|
||||||
if (!flan_reg_scan_open(&at)) { flan_reg_wait(); continue; }
|
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;
|
if (flan_reg_scan_ok(at)) break;
|
||||||
have = 0;
|
have = 0;
|
||||||
|
if (flan_reg_grew(grows0) && regrown++ < 64) attempt--;
|
||||||
flan_reg_wait();
|
flan_reg_wait();
|
||||||
}
|
}
|
||||||
if (!have) return 0;
|
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
|
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
|
ran through the middle of it, since entries moved and the counts would
|
||||||
hold some blocks twice and some not at all. */
|
hold some blocks twice and some not at all. */
|
||||||
|
int regrown = 0;
|
||||||
for (attempt = 0; attempt < 8; attempt++) {
|
for (attempt = 0; attempt < 8; attempt++) {
|
||||||
uint64_t at;
|
uint64_t at, grows0 = __atomic_load_n(&flan_reg_grows, __ATOMIC_ACQUIRE);
|
||||||
n = 0;
|
n = 0;
|
||||||
missed = 0;
|
missed = 0;
|
||||||
if (!flan_reg_scan_open(&at)) { flan_reg_wait(); continue; }
|
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++;
|
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. */
|
/* A stable epoch and every slot copied: this is a table that existed. */
|
||||||
if (missed == 0) return n;
|
if (missed == 0) return n;
|
||||||
/* A stable epoch but slots that would not hold still. Worth another walk —
|
/* A stable epoch but slots that would not hold still. Worth another walk —
|
||||||
|
|||||||
@ -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
|
* 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. */
|
* 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);
|
_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
|
/* 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). */
|
* shows it beside the trap's name (flan_rt.c). */
|
||||||
void flan_say(const uint8_t *loc, int64_t loclen, const char *fmt, ...);
|
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;
|
case OBJ_VEC: return FLAN_DYN_TAG_VEC;
|
||||||
/* ...and a struct's view answers a map's, [gen] being its shape
|
/* ...and a struct's view answers a map's, [gen] being its shape
|
||||||
(VIEW_STRUCT, below). */
|
(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;
|
case OBJ_MAP: return FLAN_DYN_TAG_MAP;
|
||||||
default: return FLAN_DYN_TAG_INT;
|
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 */
|
* they are defined, alongside the container operations below */
|
||||||
static int64_t view_len(const uint8_t *loc, int64_t loclen, const char *op,
|
static int64_t view_len(const uint8_t *loc, int64_t loclen, const char *op,
|
||||||
flan_obj *o);
|
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);
|
const char *op, flan_obj *o);
|
||||||
/* A struct view's fields, for the map arms of the printers. */
|
/* A struct view's fields, for the map arms of the printers. */
|
||||||
static int64_t view_nfields(flan_obj *o);
|
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 int64_t vecish_len(flan_obj *o);
|
||||||
static flan_dyn vecish_at(flan_obj *o, int64_t i);
|
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) {
|
static void render(dyn_sink w, flan_dyn v, int depth, int nested) {
|
||||||
char buf[64];
|
char buf[64];
|
||||||
@ -1022,7 +1038,7 @@ static _Noreturn void trap2(const uint8_t *loc, int64_t loclen,
|
|||||||
say(sb, SAY_MAX, b);
|
say(sb, SAY_MAX, b);
|
||||||
flan_say(loc, loclen, "dyn %s: %s and %s, and %s — (%s %s %s)", op,
|
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);
|
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,
|
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);
|
say(sa, SAY_MAX, a);
|
||||||
flan_say(loc, loclen, "dyn %s: %s, and %s — (%s %s)", op, tag_of(a), why, op,
|
flan_say(loc, loclen, "dyn %s: %s, and %s — (%s %s)", op, tag_of(a), why, op,
|
||||||
sa);
|
sa);
|
||||||
flan_trap((const uint8_t *)name, namelen);
|
dyn_trap((const uint8_t *)name, namelen);
|
||||||
}
|
}
|
||||||
|
|
||||||
#define TYPE_TRAP "DynType", 7
|
#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,
|
flan_say(loc, loclen,
|
||||||
"dyn %s: index %lld is out of bounds for %s of length %lld — %s", op,
|
"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);
|
(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 ─────────────────────────────────────────
|
/* ── Allocation and collection ─────────────────────────────────────────
|
||||||
@ -1120,7 +1136,7 @@ static _Noreturn void trap_oom(const uint8_t *loc, int64_t loclen,
|
|||||||
flan_say(loc, loclen,
|
flan_say(loc, loclen,
|
||||||
"dyn heap: %lld bytes could not be allocated, with %lld live",
|
"dyn heap: %lld bytes could not be allocated, with %lld live",
|
||||||
(long long)want, (long long)gc_bytes);
|
(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) {
|
static flan_obj *gc_alloc(uint8_t kind, int64_t extra) {
|
||||||
@ -1541,7 +1557,8 @@ static void gc_sweep(void) {
|
|||||||
} else {
|
} else {
|
||||||
int64_t held = (int64_t)sizeof(flan_obj);
|
int64_t held = (int64_t)sizeof(flan_obj);
|
||||||
if (o->kind == OBJ_TEXT || o->kind == OBJ_ENV) held += o->len;
|
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_ENV) envset_del((uintptr_t)(o + 1));
|
||||||
if (o->kind == OBJ_VEC || o->kind == OBJ_MAP) {
|
if (o->kind == OBJ_VEC || o->kind == OBJ_MAP) {
|
||||||
int64_t per = o->kind == OBJ_MAP ? 2 : 1;
|
int64_t per = o->kind == OBJ_MAP ? 2 : 1;
|
||||||
@ -2143,7 +2160,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 "
|
"slots matched by name. Take migrate-by-name, or handle the "
|
||||||
"condition inside the method",
|
"condition inside the method",
|
||||||
(int)c->len, (const char *)(c + 1));
|
(int)c->len, (const char *)(c + 1));
|
||||||
flan_trap((const uint8_t *)"DynMigrate", 10);
|
dyn_trap((const uint8_t *)"DynMigrate", 10);
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -2981,9 +2998,85 @@ flan_dyn flan_dyn_ge(flan_dyn a, flan_dyn b, const uint8_t *loc,
|
|||||||
|
|
||||||
#define EQ_DEPTH 64
|
#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) {
|
static int dyn_equal(flan_dyn a, flan_dyn b, int depth) {
|
||||||
int32_t ta = flan_dyn_tag(a), tb = flan_dyn_tag(b);
|
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 (is_num(a) && is_num(b)) {
|
||||||
if (ta == FLAN_DYN_TAG_INT && tb == FLAN_DYN_TAG_INT)
|
if (ta == FLAN_DYN_TAG_INT && tb == FLAN_DYN_TAG_INT)
|
||||||
return dyn_int_value(a) == dyn_int_value(b);
|
return dyn_int_value(a) == dyn_int_value(b);
|
||||||
@ -2999,7 +3092,10 @@ static int dyn_equal(flan_dyn a, flan_dyn b, int depth) {
|
|||||||
if (ta == FLAN_DYN_TAG_VEC) {
|
if (ta == FLAN_DYN_TAG_VEC) {
|
||||||
flan_obj *x = dyn_obj(a), *y = dyn_obj(b);
|
flan_obj *x = dyn_obj(a), *y = dyn_obj(b);
|
||||||
int64_t i, xn, yn;
|
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;
|
if (depth >= EQ_DEPTH) return 0;
|
||||||
/* [x]/[y] may each be an ordinary heap vec or a view (M2 item 3) — the
|
/* [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
|
tag does not say which, so [vecish_len]/[vecish_at] below read either
|
||||||
@ -3027,7 +3123,10 @@ static int dyn_equal(flan_dyn a, flan_dyn b, int depth) {
|
|||||||
if (ta == FLAN_DYN_TAG_MAP) {
|
if (ta == FLAN_DYN_TAG_MAP) {
|
||||||
flan_obj *x = dyn_obj(a), *y = dyn_obj(b);
|
flan_obj *x = dyn_obj(a), *y = dyn_obj(b);
|
||||||
int64_t i, j;
|
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;
|
if (depth >= EQ_DEPTH) return 0;
|
||||||
/* A struct's view is equal to another view of the same struct type with
|
/* 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
|
equal fields, and to nothing else — the answer an instance gets beside
|
||||||
@ -3195,8 +3294,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;
|
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);
|
desc_lay(d, &s, &a);
|
||||||
return s;
|
return s;
|
||||||
}
|
}
|
||||||
@ -3322,8 +3428,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_VEC 1 /* [base] is a Vec's header, read live */
|
||||||
#define VIEW_STRUCT 2 /* [base] is the struct, [desc] the struct's own */
|
#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); }
|
/* A view carries a guard only when the dev registry is on: a release build
|
||||||
static inline int view_shape(flan_obj *o) { return (int)o->gen; }
|
* 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);
|
void *flan_dev_frame_owner(const void *p);
|
||||||
|
|
||||||
@ -3346,22 +3462,45 @@ static void guard_storage(view_guard *g, const void *p) {
|
|||||||
|
|
||||||
|
|
||||||
/* A new view record, its guard empty. */
|
/* 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) {
|
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.base = base;
|
||||||
o->u.view.desc = desc;
|
o->u.view.desc = desc;
|
||||||
o->u.view.nul = NULL;
|
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;
|
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;
|
return o;
|
||||||
}
|
}
|
||||||
|
|
||||||
/* The stale-storage check. The sentence never renders the view: it has just
|
/* 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. */
|
* 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) {
|
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);
|
view_guard *g = view_g(o);
|
||||||
if (g->frame != NULL && !flan_dev_frame_alive(g->frame, g->serial)) {
|
if (g->frame != NULL && !flan_dev_frame_alive(g->frame, g->serial)) {
|
||||||
flan_say(loc, loclen,
|
flan_say(loc, loclen,
|
||||||
@ -3369,7 +3508,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 "
|
"has returned. A view of a local lasts as long as the call that "
|
||||||
"made it",
|
"made it",
|
||||||
op, (int)g->fnamelen, g->fname);
|
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)) {
|
if (g->rbase != 0 && !flan_dev_reg_alive(g->rbase, g->rseq)) {
|
||||||
flan_say(loc, loclen,
|
flan_say(loc, loclen,
|
||||||
@ -3377,7 +3516,7 @@ static void view_guard_check(const uint8_t *loc, int64_t loclen,
|
|||||||
"released — freed, cleared by free-all, or left behind when a "
|
"released — freed, cleared by free-all, or left behind when a "
|
||||||
"Vec grew. Take the view again after the change",
|
"Vec grew. Take the view again after the change",
|
||||||
op, (int)g->rtypelen, g->rtype);
|
op, (int)g->rtypelen, g->rtype);
|
||||||
flan_trap((const uint8_t *)"DynStale", 8);
|
dyn_trap((const uint8_t *)"DynStale", 8);
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -3397,7 +3536,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 "
|
"dyn %s: this view's container's allocator was released — the "
|
||||||
"Vec was made at epoch %lld and the allocator is at %lld now",
|
"Vec was made at epoch %lld and the allocator is at %lld now",
|
||||||
op, (long long)h->epoch, (long long)(int64_t)a->epoch);
|
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);
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
@ -3435,7 +3574,7 @@ static flan_dyn view_child(flan_obj *parent, const uint8_t *d, uint8_t *p) {
|
|||||||
memcpy(&data, p, 8);
|
memcpy(&data, p, 8);
|
||||||
memcpy(&n, p + 8, 8);
|
memcpy(&n, p + 8, 8);
|
||||||
c = view_new(data, n, d + 1, VIEW_FLAT);
|
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);
|
return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)c);
|
||||||
}
|
}
|
||||||
case 'a': {
|
case 'a': {
|
||||||
@ -3447,8 +3586,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;
|
case 'v': c = view_new(p, 0, d + 1, VIEW_VEC); break;
|
||||||
default: c = view_new(p, 0, d, VIEW_STRUCT); break;
|
default: c = view_new(p, 0, d, VIEW_STRUCT); break;
|
||||||
}
|
}
|
||||||
if (view_shape(parent) == VIEW_VEC) guard_storage(view_g(c), p);
|
if (view_g(c) == NULL) {}
|
||||||
else *view_g(c) = *view_g(parent);
|
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);
|
return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)c);
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -3472,7 +3612,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 "
|
"dyn %s: this u64 element is %llu, above the largest dyn int "
|
||||||
"(9223372036854775807), so it has no dyn value",
|
"(9223372036854775807), so it has no dyn value",
|
||||||
op, (unsigned long long)x);
|
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);
|
return flan_dyn_from_i64((int64_t)x);
|
||||||
}
|
}
|
||||||
@ -3547,7 +3687,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),
|
said_add("(put %s :%.*s %s)", sv, (int)k->len, (const char *)kw_bytes(k),
|
||||||
sx);
|
sx);
|
||||||
flan_say(loc, loclen, "%s", said_buf);
|
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. */
|
/* ", and 1.5 is a float": what the refused value is, for a field's sentence. */
|
||||||
@ -3609,7 +3749,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 "
|
"dyn %s: %lld does not fit %s %s element, which holds %lld "
|
||||||
"to %lld", op, (long long)n, an(ty), ty, (long long)lo,
|
"to %lld", op, (long long)n, an(ty), ty, (long long)lo,
|
||||||
(long long)hi);
|
(long long)hi);
|
||||||
flan_trap((const uint8_t *)"DynRange", 8);
|
dyn_trap((const uint8_t *)"DynRange", 8);
|
||||||
}
|
}
|
||||||
switch (*d) {
|
switch (*d) {
|
||||||
case 'b': case 'B': { uint8_t b = (uint8_t)n; memcpy(p, &b, 1); return; }
|
case 'b': case 'B': { uint8_t b = (uint8_t)n; memcpy(p, &b, 1); return; }
|
||||||
@ -3638,7 +3778,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 "
|
"dyn %s: %lld has no exact %s, so it does not go into this "
|
||||||
"element. Write it as a float, as in %lld.0",
|
"element. Write it as a float, as in %lld.0",
|
||||||
op, (long long)n, ty, (long long)n);
|
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)
|
} else if (flan_dyn_tag(x) == FLAN_DYN_TAG_FLOAT)
|
||||||
f = dyn_num_value(x);
|
f = dyn_num_value(x);
|
||||||
@ -3681,14 +3821,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 "
|
"it whole — write into its own elements or fields instead of "
|
||||||
"storing %s",
|
"storing %s",
|
||||||
op, an(ty), ty, sx);
|
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. */
|
/* 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) {
|
static inline uint8_t *view_elem_at(flan_obj *o, int64_t i) {
|
||||||
return (uint8_t *)view_base(o) + i * desc_size(o->u.view.desc);
|
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
|
/* A length and an element reader that answer correctly whether [o] is an
|
||||||
@ -3727,7 +3869,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))
|
while (desc_next(&at, &o2, &name, &namelen, &foff, &t))
|
||||||
said_add(" :%.*s", (int)namelen, (const char *)name);
|
said_add(" :%.*s", (int)namelen, (const char *)name);
|
||||||
flan_say(loc, loclen, "%s", said_buf);
|
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;
|
return (uint8_t *)o->u.view.base + off;
|
||||||
}
|
}
|
||||||
@ -3738,11 +3880,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
|
* 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
|
* 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. */
|
* 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) {
|
int shape, int32_t here) {
|
||||||
flan_obj *o = view_new(base, len, desc, shape);
|
flan_obj *o = view_new(base, len, desc, shape);
|
||||||
view_guard *g = view_g(o);
|
view_guard *g = view_g(o);
|
||||||
if (here) {
|
if (g == NULL) {}
|
||||||
|
else if (here) {
|
||||||
if (flan_frame_head != NULL) {
|
if (flan_frame_head != NULL) {
|
||||||
g->frame = flan_frame_head;
|
g->frame = flan_frame_head;
|
||||||
g->serial =
|
g->serial =
|
||||||
@ -3932,7 +4076,15 @@ flan_dyn flan_dyn_at(flan_dyn v, flan_dyn i, const uint8_t *loc,
|
|||||||
if (o->kind == OBJ_VIEW) {
|
if (o->kind == OBJ_VIEW) {
|
||||||
int64_t len = view_len(loc, loclen, "at", o);
|
int64_t len = view_len(loc, loclen, "at", o);
|
||||||
if (k < 0 || k >= len) trap_range(loc, loclen, "at", v, k, len);
|
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 (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]);
|
if (o->kind == OBJ_TEXT) return flan_dyn_from_i64(obj_text_bytes(o)[k]);
|
||||||
@ -3961,7 +4113,7 @@ flan_dyn flan_dyn_slice(flan_dyn v, flan_dyn lo, flan_dyn hi,
|
|||||||
flan_say(loc, loclen,
|
flan_say(loc, loclen,
|
||||||
"dyn slice: [%lld %lld) is out of bounds for text of length %lld "
|
"dyn slice: [%lld %lld) is out of bounds for text of length %lld "
|
||||||
"— %s", (long long)a, (long long)b, (long long)len, sv);
|
"— %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);
|
return flan_dyn_from_bytes(obj_text_bytes(o) + a, b - a);
|
||||||
}
|
}
|
||||||
@ -4069,9 +4221,10 @@ static int64_t map_find(flan_obj *o, flan_dyn k) {
|
|||||||
return -1;
|
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;
|
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);
|
o = dyn_obj(m);
|
||||||
/* The lazy half of the redefinition protocol: [get], [put] and [has-key?]
|
/* 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
|
all arrive here, and CLHS 4.3.6 asks for the update to happen no later
|
||||||
@ -4082,7 +4235,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_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) {
|
if (o->kind == OBJ_VIEW) {
|
||||||
const uint8_t *fty;
|
const uint8_t *fty;
|
||||||
uint8_t *p = view_field(NULL, 0, "get", o, k, &fty);
|
uint8_t *p = view_field(NULL, 0, "get", o, k, &fty);
|
||||||
@ -4117,7 +4270,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) {
|
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) {
|
if (o->kind == OBJ_VIEW) {
|
||||||
int64_t off;
|
int64_t off;
|
||||||
view_guard_check(walk_loc, walk_len, walk_op, o);
|
view_guard_check(walk_loc, walk_len, walk_op, o);
|
||||||
@ -4181,7 +4334,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,
|
flan_say(by == BY_NEW && site_building != NULL ? site_building : loc,
|
||||||
by == BY_NEW && site_building != NULL ? site_building_len : loclen,
|
by == BY_NEW && site_building != NULL ? site_building_len : loclen,
|
||||||
"%s", said_buf);
|
"%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
|
/* The value a store into [o] under [k] actually stores: [v], or the float an
|
||||||
@ -4222,7 +4375,7 @@ static _Noreturn void trap_no_slot(const uint8_t *loc, int64_t loclen,
|
|||||||
said_add(" :%.*s", (int)e->slots[i]->len,
|
said_add(" :%.*s", (int)e->slots[i]->len,
|
||||||
(const char *)(e->slots[i] + 1));
|
(const char *)(e->slots[i] + 1));
|
||||||
flan_say(loc, loclen, "%s", said_buf);
|
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
|
/* A constructor's stores: [flan_dyn_map_set]'s, with the refusal worded for
|
||||||
@ -4230,7 +4383,7 @@ static _Noreturn void trap_no_slot(const uint8_t *loc, int64_t loclen,
|
|||||||
* wrote, and placed at the slot's declaration. */
|
* wrote, and placed at the slot's declaration. */
|
||||||
void flan_dyn_slot_init(flan_dyn m, flan_dyn k, flan_dyn v,
|
void flan_dyn_slot_init(flan_dyn m, flan_dyn k, flan_dyn v,
|
||||||
const uint8_t *loc, int64_t loclen) {
|
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);
|
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));
|
map_store(o, k, check_slot(loc, loclen, BY_NEW, o, e, m, k, v));
|
||||||
}
|
}
|
||||||
@ -4260,7 +4413,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",
|
"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) ? "a map with no class" : "a ",
|
||||||
is_map(m) ? "" : tag_of(m), sm);
|
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);
|
o = dyn_obj(m);
|
||||||
e = class_sync(o);
|
e = class_sync(o);
|
||||||
|
|||||||
@ -362,6 +362,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,
|
flan_dyn flan_dyn_view_at(void *addr, int64_t len, const uint8_t *desc,
|
||||||
int64_t desclen, int32_t shape, int32_t here);
|
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 ─────────────────────────────────────────────────────
|
/* ── The collector ─────────────────────────────────────────────────────
|
||||||
*
|
*
|
||||||
* Mark-sweep, precise, and never moving. [flan_gc_init] is idempotent, and the
|
* Mark-sweep, precise, and never moving. [flan_gc_init] is idempotent, and the
|
||||||
|
|||||||
@ -198,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
|
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
|
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
|
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
|
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
|
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
|
at the top level, among a call's other arguments and in a quasiquote, the
|
||||||
@ -329,9 +329,12 @@ Each item: the proposal, then the reason in one line.
|
|||||||
- `macro repeat(i, n, & body)` plus a block reads
|
- `macro repeat(i, n, & body)` plus a block reads
|
||||||
`(defmacro repeat [i n & body] …)`. A parameter is a bare name, a
|
`(defmacro repeat [i n & body] …)`. A parameter is a bare name, a
|
||||||
destructuring vector `[a b]`, or `& rest`, last. **Built.**
|
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
|
- There is no `loop` or `recur`. A loop is `while`, `until`, `dotimes` or
|
||||||
or as a value, `let r = loop i = 0`. `recur(y, x % y)` is a call. A loop with
|
`for`, over `let` variables it changes, with `break` and `continue`. The
|
||||||
no variables is the fallback, `loop([]):`. **Built.**
|
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,
|
- `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`
|
reads `(defclass lambda [param body env])`; a typed slot is `pause: bool`
|
||||||
and its type follows its name in the vector. **Built.**
|
and its type follows its name in the vector. **Built.**
|
||||||
|
|||||||
@ -264,12 +264,9 @@ static int regchurn(void) {
|
|||||||
return 0;
|
return 0;
|
||||||
}
|
}
|
||||||
|
|
||||||
/* And a table that really is full, which is the case the trigger above must
|
/* A live set larger than the table's first size: 4096 live blocks and
|
||||||
* not paper over: 4096 live blocks and nothing dead anywhere, then one more.
|
* nothing dead anywhere, then three more. The table grows, so none is
|
||||||
* The note is dropped — that is the standing decision, and dying because a
|
* dropped and the overflow flag stays clear. */
|
||||||
* 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. */
|
|
||||||
static int regoverflow(void) {
|
static int regoverflow(void) {
|
||||||
flan_dev_reg_enable();
|
flan_dev_reg_enable();
|
||||||
for (int i = 0; i < CAP; i++)
|
for (int i = 0; i < CAP; i++)
|
||||||
|
|||||||
@ -32,6 +32,7 @@
|
|||||||
#include <stdlib.h>
|
#include <stdlib.h>
|
||||||
#include <string.h>
|
#include <string.h>
|
||||||
#include <unistd.h>
|
#include <unistd.h>
|
||||||
|
#include <setjmp.h>
|
||||||
|
|
||||||
/* Resolved because [Build] drops runtime/flan_dyn.h into the directory it
|
/* 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
|
* 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");
|
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) {
|
int main(int argc, char **argv) {
|
||||||
flan_rt_init(argc, argv);
|
flan_rt_init(argc, argv);
|
||||||
if (argc < 2) {
|
if (argc < 2) {
|
||||||
@ -1401,6 +1437,7 @@ int main(int argc, char **argv) {
|
|||||||
view();
|
view();
|
||||||
return failures == 0 ? 0 : 1;
|
return failures == 0 ? 0 : 1;
|
||||||
}
|
}
|
||||||
|
if (strcmp(argv[1], "walkreset") == 0) { walkreset(); return 0; }
|
||||||
if (strcmp(argv[1], "layout") == 0) {
|
if (strcmp(argv[1], "layout") == 0) {
|
||||||
layout();
|
layout();
|
||||||
return failures == 0 ? 0 : 1;
|
return failures == 0 ? 0 : 1;
|
||||||
|
|||||||
@ -60,6 +60,11 @@
|
|||||||
(let [a [(i64 5) 6 7]]
|
(let [a [(i64 5) 6 7]]
|
||||||
(via-slice (slice a 0 3))))
|
(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
|
(defn clobber [] i64
|
||||||
(let [b [(i64 7) 8 9 10 11 12]]
|
(let [b [(i64 7) 8 9 10 11 12]]
|
||||||
(+ (at b 0) (at b 5))))
|
(+ (at b 0) (at b 5))))
|
||||||
@ -289,4 +294,54 @@
|
|||||||
;; An element's range, with its article.
|
;; An element's range, with its article.
|
||||||
(= n 20)
|
(= n 20)
|
||||||
(let [a [(i8 1)]] (set (at (keep a) 0) 200) 0)
|
(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))))
|
:else (do (println "?") 1))))
|
||||||
|
|||||||
@ -91,15 +91,15 @@
|
|||||||
(set total (+ total (call0 (fn [] i)))))
|
(set total (+ total (call0 (fn [] i)))))
|
||||||
(println total))
|
(println total))
|
||||||
|
|
||||||
;; And the same again where the loop variable is rebound by a recur rather
|
;; And the same again where the loop variable is stepped by a set in a
|
||||||
;; than stepped by a dotimes, which is a store into the slot the copy is
|
;; while rather than by a dotimes, which is a store into the slot the copy
|
||||||
;; taken from: 100 + 101 + 102.
|
;; is taken from: 100 + 101 + 102.
|
||||||
(println
|
(println
|
||||||
(let [base 100]
|
(let [base 100 i 0 acc 0]
|
||||||
(loop [i 0 acc 0]
|
(while (< i 3)
|
||||||
(if (< i 3)
|
(set acc (+ acc (call0 (fn [] (+ base i)))))
|
||||||
(recur (+ i 1) (+ acc (call0 (fn [] (+ base i)))))
|
(set i (+ i 1)))
|
||||||
acc))))
|
acc))
|
||||||
|
|
||||||
;; Called twice, so the environment is read more than once and a body that
|
;; Called twice, so the environment is read more than once and a body that
|
||||||
;; consumed it would show.
|
;; consumed it would show.
|
||||||
|
|||||||
@ -49,11 +49,13 @@
|
|||||||
(defstruct Node [v $t next (Option (Ptr (Node $t)))])
|
(defstruct Node [v $t next (Option (Ptr (Node $t)))])
|
||||||
|
|
||||||
(defn sum-list [n (Ptr (Node i64))] i64
|
(defn sum-list [n (Ptr (Node i64))] i64
|
||||||
(loop [at n acc (the i64 0)]
|
(let [at n acc (the i64 0)]
|
||||||
(let [acc (+ acc (.v at))]
|
(while true
|
||||||
|
(set acc (+ acc (.v at)))
|
||||||
(match (.next at)
|
(match (.next at)
|
||||||
(Some p) (recur p acc)
|
(Some p) (set at p)
|
||||||
None acc))))
|
None (break)))
|
||||||
|
acc))
|
||||||
|
|
||||||
;; A template naming another at its own parameters.
|
;; A template naming another at its own parameters.
|
||||||
(defstruct Twice [x (Small $m $u) y (Small $m $u)])
|
(defstruct Twice [x (Small $m $u) y (Small $m $u)])
|
||||||
|
|||||||
@ -25,12 +25,14 @@
|
|||||||
(calls)
|
(calls)
|
||||||
:west)
|
: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
|
(defn steps-to-west [from Dir] i32
|
||||||
(loop [d from n 0]
|
(let [d from n 0]
|
||||||
(match d
|
(while true
|
||||||
:west n
|
(match d
|
||||||
_ (recur (turn d) (+ n 1)))))
|
:west (break)
|
||||||
|
_ (do (set d (turn d)) (set n (+ n 1)))))
|
||||||
|
n))
|
||||||
|
|
||||||
(defn main [] i32
|
(defn main [] i32
|
||||||
(print (steps-to-west :north)) (println "")
|
(print (steps-to-west :north)) (println "")
|
||||||
|
|||||||
@ -44,12 +44,14 @@
|
|||||||
(print "(called) ")
|
(print "(called) ")
|
||||||
7)
|
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
|
(defn count-down [from i32] i32
|
||||||
(loop [n from steps 0]
|
(let [n from steps 0]
|
||||||
(match n
|
(while true
|
||||||
0 steps
|
(match n
|
||||||
_ (recur (- n 1) (+ steps 1)))))
|
0 (break)
|
||||||
|
_ (do (set n (- n 1)) (set steps (+ steps 1)))))
|
||||||
|
steps))
|
||||||
|
|
||||||
(defn main [] i32
|
(defn main [] i32
|
||||||
(println (small 5))
|
(println (small 5))
|
||||||
|
|||||||
@ -8,8 +8,10 @@
|
|||||||
;;;;
|
;;;;
|
||||||
;;;; The argument is the frame count. A negative one runs that many frames and
|
;;;; 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
|
;;;; 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.
|
;;;; build's registry fills. The last line is whether more blocks are live
|
||||||
(declare-c reg-overflowed [] i32 "flan_dev_reg_overflowed")
|
;;;; 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
|
(defn main [args [str]] i32
|
||||||
(let [arg (bytes->i64 (bytes-view (at args 1)))
|
(let [arg (bytes->i64 (bytes-view (at args 1)))
|
||||||
@ -26,5 +28,5 @@
|
|||||||
(free-temp)))
|
(free-temp)))
|
||||||
(println total)
|
(println total)
|
||||||
(println (str kept))
|
(println (str kept))
|
||||||
(println (reg-overflowed)))
|
(println (if (> (reg-live 1) 4096) 1 0)))
|
||||||
0)
|
0)
|
||||||
|
|||||||
@ -29,10 +29,14 @@
|
|||||||
(println i))))
|
(println i))))
|
||||||
|
|
||||||
(defn loopr [] i32
|
(defn loopr [] i32
|
||||||
(loop [n 0 acc 0]
|
(let [n 0 acc 0]
|
||||||
(let [n (* n 2)]
|
(while true
|
||||||
(println n))
|
(let [n (* n 2)]
|
||||||
(if (< n 4) (recur (+ n 1) (+ acc n)) acc)))
|
(println n))
|
||||||
|
(if (< n 4)
|
||||||
|
(do (set acc (+ acc n)) (set n (+ n 1)))
|
||||||
|
(break)))
|
||||||
|
acc))
|
||||||
|
|
||||||
(defn ret [a i32] i32
|
(defn ret [a i32] i32
|
||||||
(let [a (+ a 1)]
|
(let [a (+ a 1)]
|
||||||
|
|||||||
@ -25,8 +25,13 @@ macro expect(test, message)
|
|||||||
println("expected:", ~message)
|
println("expected:", ~message)
|
||||||
|
|
||||||
fn gcd(a: i32, b: i32) -> i32
|
fn gcd(a: i32, b: i32) -> i32
|
||||||
loop x = a, y = b
|
let x = a
|
||||||
if y == 0 then x else recur(y, x % y)
|
let y = b
|
||||||
|
while y != 0
|
||||||
|
let r = x % y
|
||||||
|
x = y
|
||||||
|
y = r
|
||||||
|
x
|
||||||
|
|
||||||
fn line(it: stock/Item) -> ()
|
fn line(it: stock/Item) -> ()
|
||||||
let price = stock/money(stock/value(it))
|
let price = stock/money(stock/value(it))
|
||||||
|
|||||||
@ -6012,16 +6012,17 @@ level "1"
|
|||||||
a dyn view");
|
a dyn view");
|
||||||
("9", "16777217 has no exact f32");
|
("9", "16777217 has no exact f32");
|
||||||
("10", "dyn put: a Point has no field :z. Its fields are :x :y");
|
("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)");
|
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 \
|
("15", "dyn put: field :z of a Small is a bool, and the value is nil \
|
||||||
— (put #Small{:x 1 :z true} :z nil)");
|
— (put #Small{:x 1 :z true} :z nil)");
|
||||||
("16", "dyn put: field :x of a Small is an i8, which holds -128 to \
|
("16", "dyn put: field :x of a Small is an i8, which holds -128 to \
|
||||||
127, and 200 does not fit");
|
127, and 200 does not fit");
|
||||||
("19", "#Wide{:a 18000000000000000000 :b 1}\n");
|
("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");
|
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 =
|
and any_stale =
|
||||||
[ ("4", "this view points into a local of leak-local, and that call \
|
[ ("4", "this view points into a local of leak-local, and that call \
|
||||||
has returned");
|
has returned");
|
||||||
@ -6032,10 +6033,13 @@ level "1"
|
|||||||
call has returned");
|
call has returned");
|
||||||
("13", "this view points into a local of leak-slice-param, and that \
|
("13", "this view points into a local of leak-slice-param, and that \
|
||||||
call has returned");
|
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");
|
local of leak-local");
|
||||||
("18", "dyn-view-any.flan:281:53: dyn length: this view points into \
|
("18", "dyn-view-any.flan:286:53: dyn length: this view points into \
|
||||||
a local of leak-local") ]
|
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
|
in
|
||||||
let dyn_view_any ?opt ?(x86 = false) ?(dev = false) () =
|
let dyn_view_any ?opt ?(x86 = false) ?(dev = false) () =
|
||||||
let exe = compile ?opt ~x86 ~dev "programs/dyn-view-any.flan" in
|
let exe = compile ?opt ~x86 ~dev "programs/dyn-view-any.flan" in
|
||||||
@ -6060,6 +6064,24 @@ level "1"
|
|||||||
saying %S\n" (name (", mode " ^ mode)) text code needle
|
saying %S\n" (name (", mode " ^ mode)) text code needle
|
||||||
end)
|
end)
|
||||||
(any_traps @ if dev then any_stale else []);
|
(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
|
(* The collector takes back what it charged for a view: a leak here
|
||||||
once doubled the heap's trigger forever. *)
|
once doubled the heap's trigger forever. *)
|
||||||
let code, text = run exe (Some "11") in
|
let code, text = run exe (Some "11") in
|
||||||
|
|||||||
@ -197,6 +197,26 @@ let () =
|
|||||||
(* The three restatements of flan_vec's layout, compared field by field —
|
(* 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
|
see dyn_ops.c's [layout] and [hand_vec]'s comment for what ties them
|
||||||
together and why nothing at compile time otherwise does. *)
|
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
|
let code, out, err = run "layout" in
|
||||||
if code <> 0 || out <> "layout ok\n" then
|
if code <> 0 || out <> "layout ok\n" then
|
||||||
fail "flan_vec's three restatements\n got: %S (exit %d, err %S)"
|
fail "flan_vec's three restatements\n got: %S (exit %d, err %S)"
|
||||||
|
|||||||
@ -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"
|
"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;
|
out code err;
|
||||||
|
|
||||||
(* And a table that is genuinely full, which is the state the trigger above
|
(* And a table whose live set outgrows it: 4096 live blocks and nothing
|
||||||
must not paper over. The note is dropped — a diagnostic that killed the
|
dead, then three more. The table grows rather than dropping them — a
|
||||||
program because it ran out of room would be the diagnostic shooting the
|
dyn view's dev check asks it whether a block is alive, and a dropped
|
||||||
patient — and the decision this pins is that the drop is *said*, once.
|
note would stop that check without a word — so nothing overflows and
|
||||||
Once matters: this is the game thread inside the allocation hook, and a
|
every block is counted. *)
|
||||||
line per dropped note would be sixty a second down a pipe nobody drains
|
|
||||||
while a request is being served. *)
|
|
||||||
let code, out, err = mode "regoverflow" in
|
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
|
if code <> 0 || out <> want_over then
|
||||||
fail "a full registry\n got: %S (exit %d)\n wanted: %S" out
|
fail "a registry past its first size\n got: %S (exit %d)\n wanted: %S"
|
||||||
code want_over;
|
out code want_over;
|
||||||
let said_full =
|
if has err "the allocation registry is full" then
|
||||||
let needle = "the allocation registry is full" in
|
fail "a registry that grows said it was full: %S" err;
|
||||||
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;
|
|
||||||
|
|
||||||
Printf.printf
|
Printf.printf
|
||||||
"reload: emit %.1fms llc %.1fms ld %.1fms (v2: emit %.1fms llc %.1fms ld %.1fms) host run %.1fms\n"
|
"reload: emit %.1fms llc %.1fms ld %.1fms (v2: emit %.1fms llc %.1fms ld %.1fms) host run %.1fms\n"
|
||||||
|
|||||||
@ -363,13 +363,17 @@ let attached_ok ~what path (src, forms) (out, back) =
|
|||||||
(* Every .flan the build tree holds. [..] is the workspace root from here;
|
(* Every .flan the build tree holds. [..] is the workspace root from here;
|
||||||
the deps in test/dune decide what is in it. *)
|
the deps in test/dune decide what is in it. *)
|
||||||
let corpus () =
|
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 =
|
let rec walk dir acc =
|
||||||
Array.fold_left
|
Array.fold_left
|
||||||
(fun acc name ->
|
(fun acc name ->
|
||||||
let path = Filename.concat dir name in
|
let path = Filename.concat dir name in
|
||||||
if name <> "" && (name.[0] = '.' || name.[0] = '_') then acc
|
if name <> "" && (name.[0] = '.' || name.[0] = '_') then acc
|
||||||
else if Sys.is_directory path then walk path 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)
|
else acc)
|
||||||
acc (Sys.readdir dir)
|
acc (Sys.readdir dir)
|
||||||
in
|
in
|
||||||
@ -631,12 +635,26 @@ let () =
|
|||||||
reads "macro with no parameters" "macro m()\n a" "(defmacro m [] a)";
|
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"
|
refuses "a rest parameter not last" "macro m(& a, b)\n a" "indent/macro-rest-last"
|
||||||
"comes last: macro m(b, & a)";
|
"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))";
|
(* No loop and no recur: a .fln loop is a while, until, dotimes or for. *)
|
||||||
reads ~global:false "a let-bound loop" "let r = loop i = 0\n recur(i)\nr" "(let [r (loop [i 0] (recur i))] r)";
|
refuses "a loop header" "loop x = a, y = b + 1\n recur(y, x)" "indent/no-loop"
|
||||||
reads "the loop call stays a call" "loop([x 1]):\n x" "(loop [x 1] x)";
|
"while i < 10";
|
||||||
refuses "a loop with no values" "loop\n g()" "indent/loop-bindings" "loop([]):";
|
refuses ~global:false "a let-bound loop" "let r = loop i = 0\n i\nr" "indent/no-loop"
|
||||||
refuses "a loop variable with no value" "loop x, y = 1\n g()" "indent/loop-bindings"
|
"loop is not part of the indented syntax";
|
||||||
"loop x = 0";
|
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)";
|
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. *)
|
(* 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"
|
reads "arm statements" "match s\n 1 -> break\n 2 -> continue :outer\n _ -> x += 1"
|
||||||
@ -1018,12 +1036,24 @@ let () =
|
|||||||
prints "a parent with no fields" "(defstruct D :parent Io)" "struct D :parent Io";
|
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"
|
prints "an empty field vector under a parent keeps the fallback"
|
||||||
"(defstruct D :parent Io [])" "defstruct(D, :parent, Io, [])";
|
"(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)))))"
|
(* A .flan file with loop or recur is refused, every line named. *)
|
||||||
" loop x = a, y = 0\n if x == 0 then y";
|
(match
|
||||||
prints "a let-bound loop" "(defn f [] i32 (let [r (loop [i 0] (recur i))] r))"
|
Reader.read_all ~file:"<p>"
|
||||||
" let r = loop i = 0\n recur(i)";
|
"(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))"
|
||||||
prints "a lambda as a loop's value is parenthesised"
|
with
|
||||||
"(defn f [] () (loop [g (fn [x] x) n 0] (recur g n)))" "loop g = (fn(x) => x), n = 0"
|
| 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 ──────────────────────── *)
|
(* ── Spans, for pause marks and error overlays ──────────────────────── *)
|
||||||
|
|
||||||
|
|||||||
Loading…
x
Reference in New Issue
Block a user