From d7016f91c7f971833116bbafc6630c23e851c9ad Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:04:32 +0700 Subject: [PATCH 01/15] A .fln file is read by an indented reader that yields the paren reader's forms, every program entry point picks the reader by extension, and flan convert prints either syntax as the other --- bin/main.ml | 35 +- lib/front.ml | 2 +- lib/indent_printer.ml | 597 ++++++++++++ lib/indent_reader.ml | 1310 +++++++++++++++++++++++++++ lib/load.ml | 22 +- lib/session.ml | 4 +- lib/source.ml | 20 + spec-syntax.md | 92 +- test/dune | 21 + test/syntax/algorithms.flan | 51 ++ test/syntax/algorithms.fln | 52 ++ test/syntax/mixed/geo/geo.flan | 10 + test/syntax/mixed/main.flan | 11 + test/syntax/mixed/main.fln | 21 + test/syntax/mixed/shapes/shapes.fln | 20 + test/syntax/sand.fln | 143 +++ test/test_syntax.ml | 285 ++++++ 17 files changed, 2646 insertions(+), 50 deletions(-) create mode 100644 lib/indent_printer.ml create mode 100644 lib/indent_reader.ml create mode 100644 lib/source.ml create mode 100644 test/syntax/algorithms.flan create mode 100644 test/syntax/algorithms.fln create mode 100644 test/syntax/mixed/geo/geo.flan create mode 100644 test/syntax/mixed/main.flan create mode 100644 test/syntax/mixed/main.fln create mode 100644 test/syntax/mixed/shapes/shapes.fln create mode 100644 test/syntax/sand.fln create mode 100644 test/test_syntax.ml diff --git a/bin/main.ml b/bin/main.ml index 0f1db3e2..7fb8306d 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -324,14 +324,32 @@ let () = List.iter (fun path -> with_errors path (fun () -> - Flan.Reader.read_file path + Flan.Source.read_file path |> List.iter (fun f -> print_endline (Flan.Form.to_string f)))) files + (* The other syntax, on stdout: a .flan file printed indented, a .fln file + printed with parentheses. Comments are not forms, so they do not carry + over. *) + | [ _; "convert"; path ] -> + with_errors path (fun () -> + let forms = Flan.Source.read_file path in + if Flan.Source.is_indented path then + print_string + (String.concat "\n\n" (List.map (fun f -> Flan.Form.pretty f) forms) + ^ "\n") + else + match Flan.Indent_printer.program forms with + | text -> print_string text + | exception Flan.Indent_printer.Unprintable (f, why) -> + Flan.Loc.failk "convert/unprintable" f.Flan.Form.loc + "%s has no spelling in the indented syntax, so this file cannot \ + be converted. Rename it in the .flan file and convert again" + why) | _ :: "parse" :: files when files <> [] -> List.iter (fun path -> with_errors path (fun () -> - Flan.Reader.read_file path + Flan.Source.read_file path |> Flan.Parse.program_all |> List.iter (fun d -> print_endline (summarise d)))) files @@ -390,13 +408,13 @@ let () = the header's records. *) | _ :: "import-c" :: header :: rest -> with_errors header (fun () -> - let pkg = List.filter (fun a -> Filename.check_suffix a ".flan") rest in + let pkg = List.filter Flan.Source.is_source rest in let flags = - List.filter (fun a -> not (Filename.check_suffix a ".flan")) rest + List.filter (fun a -> not (Flan.Source.is_source a)) rest in let ds = List.concat_map - (fun f -> Flan.Parse.program (Flan.Reader.read_file f)) pkg + (fun f -> Flan.Parse.program (Flan.Source.read_file f)) pkg in let structs = List.filter_map @@ -554,10 +572,10 @@ let () = let out = Filename.concat dir "generated.flan" in let ds = List.concat_map - (fun f -> Flan.Parse.program (Flan.Reader.read_file f)) + (fun f -> Flan.Parse.program (Flan.Source.read_file f)) (List.filter (fun f -> not (String.equal f out)) - (Flan.Load.entries dir ".flan")) + (Flan.Load.source_entries dir)) in let config = Flan.Load.binding_config dir in match Flan.Load.header_specs ~loc dir with @@ -944,5 +962,6 @@ let () = [--debug] [--sanitize] [--x86] [--warn-memory] [--target=wasm32-wasi|web|js]\n\ \ flan run [build flags...] [--] [program args...]\n\ \ flan reload [-o out.so] [--x86]\n\ - \ flan dev [-s socket] [--x86]"; + \ flan dev [-s socket] [--x86]\n\ + \ flan convert "; exit 2 diff --git a/lib/front.ml b/lib/front.ml index fee00c6f..6ee0ad30 100644 --- a/lib/front.ml +++ b/lib/front.ml @@ -13,7 +13,7 @@ let load ?(all = false) path : Load.t = Load.program ~file:path ~parse:(if all then Parse.program_all else Parse.program) - (Reader.read_file path) + (Source.read_file path) let check ?(all = false) (l : Load.t) : Tast.program = (if all then Check.program_all else Check.program) l.Load.decls diff --git a/lib/indent_printer.ml b/lib/indent_printer.ml new file mode 100644 index 00000000..9132c1f3 --- /dev/null +++ b/lib/indent_printer.ml @@ -0,0 +1,597 @@ +(** [Form.t] to indented text: the inverse of [Indent_reader], and what + [flan convert] writes. + + The one rule that keeps the round trip exact: a piece of sugar is printed + only when the form has exactly the shape that sugar reads back to, and + everything else goes through the fallback, [head(arg, ...)], or + [head(arg, ...):] with the trailing arguments as an indented block. The + fallback reads any form, so a form this printer cannot sweeten still + prints; what it cannot print at all is a name with no spelling in the + indented syntax, and that raises [Unprintable]. + + Comments are not in a [Form.t], so a converted file has none. *) + +module R = Indent_reader + +exception Unprintable of Form.t * string + +let width = 80 + +let unprintable (f : Form.t) why = raise (Unprintable (f, why)) + +(* Words a statement may start with that the reader takes as a header. A + statement whose text would lead with one is wrapped in parentheses, which + the reader takes as grouping and so as the plain name. *) +let reserved = + [ "fn"; "fn-"; "def"; "once"; "const"; "struct"; "union"; "data"; "enum"; + "import"; "if"; "elif"; "else"; "while"; "until"; "match"; "let"; "for"; + "return"; "break"; "continue"; "defer"; "handler-case"; "handler-bind"; + "restart-case"; "quote"; "on"; "restart" ] + +(* A symbol the reader gives back as itself when it is written bare. *) +let name_ok s = + let n = String.length s in + n > 0 + && (not (String.exists Reader.is_delimiter s)) + && (not (String.contains s ':')) + && s.[0] <> '\'' && s.[0] <> '\\' + && (not (Reader.is_digit s.[0])) + && (not ((s.[0] = '-' || s.[0] = '+') && n > 1 && Reader.is_digit s.[1])) + && (not (n > 1 && s.[0] = '-' && R.is_neg_char s.[1])) + && R.split_fields s = [ s ] + && (not (R.is_op_word s)) + && not (n >= 2 && s.[0] = '#' && s.[1] = '_') + +let kw_ok k = k <> "" && not (String.exists Reader.is_delimiter k) + +(* A name a definition's header can take: the reader reads a leading dot + there as a field access, so [.init-once.counter] keeps the fallback. *) +let def_name s = name_ok s && s.[0] <> '.' + +let paren s = "(" ^ s ^ ")" + +let is_sym s (f : Form.t) = match f.v with Form.Sym x -> x = s | _ -> false + +(* ── Expressions ───────────────────────────────────────────────────── *) + +(* Text and syntactic level, the same scale [Indent_reader] reads: 10 an atom + or bracket, 9 a postfix chain, 8 a unary minus, 1-7 binary, 3 [not], 0 a + one-line [if] or a lambda. *) +let rec expr (f : Form.t) : string * int = + match f.v with + | Form.Sym s -> sym f s + | Form.Kw k -> + if kw_ok k then (":" ^ k, 10) else unprintable f "a keyword with no spelling" + | Form.Int i -> (Int64.to_string i, if Int64.compare i 0L < 0 then 8 else 10) + | Form.UInt (_, s) -> (s, 10) + | Form.Float x -> + let s = Form.float_repr x in + if not (Reader.is_digit s.[0] || (s.[0] = '-' && String.length s > 1 + && Reader.is_digit s.[1])) + then unprintable f "a float with no literal"; + (s, if s.[0] = '-' then 8 else 10) + | Form.Str s -> ("\"" ^ Form.escape s ^ "\"", 10) + | Form.Byte b -> (Form.byte_repr b, 10) + | Form.Vec xs -> ("[" ^ vec_text xs ^ "]", 10) + | Form.Map xs -> ("{" ^ map_text xs ^ "}", 10) + | Form.List [] -> ("()", 10) + | Form.List (h :: args) -> list f h args + +and sym f s = + if s = "==" then unprintable f "the name == (it reads as =)" + else if R.is_op_word s || s = "if" then (paren s, 10) + else if name_ok s then (s, 10) + else unprintable f (Printf.sprintf "the name %s" s) + +and at lvl f = + let t, l = expr f in + if l < lvl then paren t else t + +and comma_items xs = + let rec go = function + | [] -> [] + | ({ Form.v = Form.Sym "const"; _ }) :: y :: rest -> + ("const " ^ at 0 y) :: go rest + | x :: rest -> at 0 x :: go rest + in + go xs + +and commas xs = String.concat ", " (comma_items xs) + +(* Whitespace between single terms, as [[1 2 3]] and [[4 f32]] read; commas + as soon as one element has an operator in it. *) +and vec_text xs = + let ts = List.map expr xs in + if List.for_all (fun (_, l) -> l >= 8) ts then String.concat " " (List.map fst ts) + else String.concat ", " (List.map (fun (t, _) -> t) ts) + +and map_text xs = + let ts = List.map expr xs in + if List.for_all (fun (_, l) -> l >= 8) ts then String.concat " " (List.map fst ts) + else + let rec pairs = function + | (k, kl) :: (v, _) :: rest -> + ((if kl < 8 then paren k else k) ^ " " ^ v) :: pairs rest + | [ (k, _) ] -> [ k ] + | [] -> [] + in + String.concat ", " (pairs ts) + +and head_text (h : Form.t) = + match h.v with + | Form.Sym "==" -> unprintable h "the name ==" + | Form.Sym s when R.is_op_word s -> s + | Form.Sym s -> fst (sym h s) + | _ -> at 9 h + +and list _f h args = + let call () = (head_text h ^ "(" ^ commas args ^ ")", 9) in + match h.v, args with + | Form.Sym "quote", [ x ] -> ("'" ^ Form.to_source x, 10) + | Form.Sym "unquote", [ x ] -> ("~" ^ at 10 x, 10) + | Form.Sym "unquote-splicing", [ x ] -> ("~@" ^ at 10 x, 10) + | Form.Sym s, _ :: _ :: _ + when (R.is_binop s || s = "=") && s <> "==" && not (s = "!=" && List.length args > 2) -> + let op = if s = "=" then "==" else s in + let lvl = Option.get (R.binop_level op) in + let first = List.hd args and rest = List.tl args in + let ft, fl = expr first in + let same = match first.v with + | Form.List (h' :: _ :: _ :: _) -> is_sym s h' || lvl = 4 + | _ -> false + in + let ft = if fl < lvl || (fl = lvl && same) then paren ft else ft in + (String.concat (" " ^ op ^ " ") (ft :: List.map (at (lvl + 1)) rest), lvl) + | Form.Sym "-", [ x ] -> + let t, l = expr x in + if l >= 9 && t <> "" && R.is_neg_char t.[0] then ("-" ^ t, 8) + else ("-(" ^ at 0 x ^ ")", 9) + | Form.Sym "not", [ x ] -> ("not " ^ at 3 x, 3) + | Form.Sym "at", t :: (_ :: _ as idx) -> (at 9 t ^ "[" ^ commas idx ^ "]", 9) + | Form.Sym s, [ t ] + when String.length s > 1 && s.[0] = '.' && name_ok s + && not (String.contains (String.sub s 1 (String.length s - 1)) '.') -> + let tt, tl = expr t in + let glued = + tl >= 9 + && (match t.v with + | Form.Byte _ -> false + | Form.Sym x -> name_ok x && not (String.contains x '.') && not (R.capitalised x) + | _ -> + let c = tt.[String.length tt - 1] in + c = ')' || c = ']' || c = '}' || c = '"') + in + if glued then (tt ^ s, 9) else call () + | Form.Sym s, [ ({ v = Form.Map _; _ } as m) ] when name_ok s && R.capitalised s -> + (s ^ fst (expr m), 9) + | Form.Sym "fn", [ { v = Form.Vec ps; _ }; body ] when List.for_all sym_param ps -> + ("fn(" ^ commas ps ^ ") = " ^ at 0 body, 0) + | Form.Sym "if", [ c; a; b ] -> + ("if " ^ at 1 c ^ " then " ^ at 1 a ^ " else " ^ at 0 b, 0) + | _ -> call () + +and sym_param (p : Form.t) = + match p.v with Form.Sym s -> name_ok s | _ -> false + +(* A type after [:] or [->]: the function-type arrow at the top, a postfix + term below it. *) +let rec ty (f : Form.t) = + match f.v with + | Form.List [ { v = Form.Sym (("Fn" | "CFn") as h); _ }; { v = Form.Vec ps; _ }; r ] -> + h ^ "(" ^ commas ps ^ ") -> " ^ ty r + | _ -> at 9 f + +(* A [defn]'s parameter type the reader could not mistake for a name: a + primitive, a capitalised or [$] name, or a bracket. [[x y]] with a + lowercase [y] keeps the fallback, because what it means depends on + whether [y] names a type. *) +let type_shaped (f : Form.t) = + match f.v with + | Form.Sym t -> + List.mem t Types.primitive_names || (t <> "" && t.[0] = '$') || R.capitalised t + | Form.List [] | Form.List ({ v = Form.Sym _; _ } :: _) | Form.Vec _ -> true + | _ -> false + +let rec pairs = function + | a :: b :: rest -> Option.map (fun r -> (a, b) :: r) (pairs rest) + | [] -> Some [] + | [ _ ] -> None + +(* [(a: i32, b)] from [[a i32 b dyn]], when every name is a plain name. *) +let params_text ?(shaped = false) (ps : Form.t list) = + match pairs ps with + | None -> None + | Some prs -> + if List.for_all + (fun ((n : Form.t), t) -> + (match n.v with Form.Sym x -> def_name x | _ -> false) + && ((not shaped) || is_sym "dyn" t || type_shaped t)) + prs + then + Some + (String.concat ", " + (List.map + (fun ((n : Form.t), t) -> + let n = fst (expr n) in + if is_sym "dyn" t then n else n ^ ": " ^ ty t) + prs)) + else None + +(* ── Statements ────────────────────────────────────────────────────── *) + +let ind n = String.make n ' ' + +let lead_word text = + let n = String.length text in + let rec go i = if i < n && not (Reader.is_delimiter text.[i]) then go (i + 1) else i in + let i = go 0 in + (String.sub text 0 i, i = n || text.[i] = ' ') + +(* A statement whose text leads with a reserved word, parenthesised. *) +let guard text = + let w, spaced = lead_word text in + if spaced && List.mem w reserved then paren text else text + +let stmts_of (f : Form.t) = + match f.v with + | Form.List ({ v = Form.Sym "do"; _ } :: (_ :: _ :: _ as ss)) -> ss + | _ -> [ f ] + +(* Heads whose trailing arguments are a body, and how many come before it. *) +let body_split (h : Form.t) args = + match h.v with + | Form.Sym s -> + let base = + match String.rindex_opt s '/' with + | Some i -> String.sub s (i + 1) (String.length s - i - 1) + | None -> s + in + let lead = List.length (List.filter (fun (a : Form.t) -> + match a.v with Form.List _ -> false | _ -> true) args) in + (match base with + | "comment" | "do" -> Some 0 + | "unless" | "loop" -> Some 1 + | "defmacro" -> Some 2 + | "defmethod" -> Some 3 + | _ when String.length base > 5 && String.sub base 0 5 = "with-" -> + let rec leading n = function + | ({ Form.v = Form.List _; _ }) :: _ -> n + | _ :: rest -> leading (n + 1) rest + | [] -> n + in + ignore lead; + Some (leading 0 args) + | _ -> None) + | _ -> None + +let sugar_heads = + [ "let"; "set"; "if"; "when"; "cond"; "while"; "until"; "dotimes"; "match"; + "handler-case"; "handler-bind"; "restart-case"; "return"; "defer"; "do"; + "quasiquote" ] + +let rec block n (fs : Form.t list) : string list = + let rec go = function + | [] -> [] + | [ x ] -> stmt n ~last:true x + | x :: rest -> stmt n ~last:false x @ go rest + in + go fs + +and stmt n ~last (f : Form.t) : string list = + match sugar n ~last f with + | Some ls -> ls + | None -> plain n f + +and plain n (f : Form.t) : string list = + let text = + match f.v with + | Form.List [] -> "(())" + | Form.List [ { v = Form.Sym "do"; _ } ] -> "()" + | Form.Sym s when List.mem s reserved -> paren s + | _ -> guard (fst (expr f)) + in + let one = [ ind n ^ text ] in + match f.v with + | Form.List (h :: args) when args <> [] -> + (match body_split h args with + | Some k when k < List.length args -> + let fixed = List.filteri (fun i _ -> i < k) args in + let rest = List.filteri (fun i _ -> i >= k) args in + [ ind n ^ guard (head_text h ^ "(" ^ commas fixed ^ "):") ] @ block (n + 2) rest + | _ when n + String.length text > width && fst (expr f) = text -> + wrapped n "" f + | _ -> one) + | _ -> one + +(* A call too long for its line, broken after commas inside its + parentheses, where a line break is only whitespace. [prefix] is what + comes before the call on the first line. *) +and wrapped n prefix (f : Form.t) = + match f.v with + | Form.List (h :: (_ :: _ as args)) when (match h.v with + | Form.Sym ("at" | "quote" | "unquote" | "unquote-splicing") -> false + | Form.Sym s -> not (R.is_op_word s) && not (String.length s > 1 && s.[0] = '.') + | _ -> false) -> + let open_ = prefix ^ head_text h ^ "(" in + let col = n + String.length open_ in + let items = comma_items args in + let rec go line acc = function + | [] -> List.rev ((line ^ ")") :: acc) + | [ t ] -> + if String.length line = col || String.length line + String.length t + 1 <= width + then go (line ^ t) acc [] + else + let line = String.sub line 0 (String.length line - 1) in + go (ind col ^ t) (line :: acc) [] + | t :: rest -> + let piece = t ^ "," in + if String.length line = col || String.length line + String.length piece <= width + then go (line ^ piece ^ " ") acc rest + else + let line = String.sub line 0 (String.length line - 1) in + go (ind col ^ piece ^ " ") (line :: acc) rest + in + (* The last item on a line carries a trailing space; the break drops it. *) + let lines = go (ind n ^ open_) [] items in + List.map (fun l -> + let k = String.length l in + if k > 0 && l.[k - 1] = ' ' then String.sub l 0 (k - 1) else l) lines + | _ -> [ ind n ^ prefix ^ at 0 f ] + +(* [prefix = v], or [prefix =] and the value as an indented block when it is + too long for the line. *) +and value_lines n prefix (v : Form.t) = + let inline = prefix ^ " = " ^ at 0 v in + if n + String.length inline <= width then [ ind n ^ inline ] + else + match v.v with + | Form.List ({ v = Form.Sym "fn"; _ } :: { v = Form.Vec ps; _ } :: (_ :: _ as body)) + when List.for_all sym_param ps -> + [ ind n ^ prefix ^ " = fn(" ^ commas ps ^ ")" ] @ block (n + 2) body + | Form.List ({ v = Form.Sym h; _ } :: _) + when not (List.mem h sugar_heads || h = "fn" || h = "if") -> + wrapped n (prefix ^ " = ") v + | Form.List (_ :: _) -> [ ind n ^ prefix ^ " =" ] @ block (n + 2) (stmts_of v) + | _ -> [ ind n ^ inline ] + +and slot n (f : Form.t) = block n (stmts_of f) + +and label_of = function + | ({ Form.v = Form.Kw k; _ }) :: rest when kw_ok k -> (":" ^ k ^ " ", rest) + | rest -> ("", rest) + +and sugar n ~last (f : Form.t) : string list option = + let i = ind n in + match f.v with + | Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bs; _ } :: (_ :: _ as body)) -> + (match pairs bs with + | None | Some [] -> None + | Some prs -> Some (let_lines n ~last prs body)) + | Form.List [ { v = Form.Sym "set"; _ }; t; v ] -> + Some (value_lines n (guard (at 9 t)) v) + | Form.List [ { v = Form.Sym "if"; _ }; c; a; b ] -> + let simple (x : Form.t) = + match x.v with + | Form.List ({ v = Form.Sym h; _ } :: _) -> not (List.mem h sugar_heads) + | _ -> true + in + let line = i ^ fst (expr f) in + if simple a && simple b && String.length line <= width then Some [ line ] + else + Some + ([ i ^ "if " ^ at 1 c ] @ slot (n + 2) a @ [ i ^ "else" ] @ slot (n + 2) b) + | Form.List ({ v = Form.Sym "when"; _ } :: c :: (_ :: _ as body)) -> + Some ((i ^ "if " ^ at 1 c) :: block (n + 2) body) + | Form.List ({ v = Form.Sym "cond"; _ } :: args) -> + (match pairs args with + | None -> None + | Some prs -> + let tests, else_ = + match List.rev prs with + | (k, e) :: rest when is_else k -> (List.rev rest, Some e) + | _ -> (prs, None) + in + if List.length tests < 2 then None + else + Some + (List.concat + (List.mapi + (fun j (c, b) -> + (i ^ (if j = 0 then "if " else "elif ") ^ at 1 c) :: slot (n + 2) b) + tests) + @ (match else_ with + | Some e -> (i ^ "else") :: slot (n + 2) e + | None -> []))) + | Form.List ({ v = Form.Sym (("while" | "until") as w); _ } :: rest) -> + let lbl, rest = label_of rest in + (match rest with + | c :: (_ :: _ as body) -> Some ((i ^ w ^ " " ^ lbl ^ at 0 c) :: block (n + 2) body) + | _ -> None) + | Form.List ({ v = Form.Sym "dotimes"; _ } :: rest) -> + let lbl, rest = label_of rest in + (match rest with + | { v = Form.Vec ({ v = Form.Sym v; _ } :: bs); _ } :: (_ :: _ as body) + when def_name v && bs <> [] && List.length bs <= 3 && v <> "in" -> + Some + ((i ^ "for " ^ lbl ^ v ^ " in range(" ^ commas bs ^ ")") :: block (n + 2) body) + | _ -> None) + | Form.List [ { v = Form.Sym "return"; _ } ] -> Some [ i ^ "return" ] + | Form.List [ { v = Form.Sym "return"; _ }; v ] -> Some [ i ^ "return " ^ at 0 v ] + | Form.List [ { v = Form.Sym (("break" | "continue") as w); _ } ] -> Some [ i ^ w ] + | Form.List [ { v = Form.Sym (("break" | "continue") as w); _ }; { v = Form.Kw k; _ } ] + when kw_ok k -> + Some [ i ^ w ^ " :" ^ k ] + | Form.List [ { v = Form.Sym "defer"; _ }; x ] -> + let line = i ^ "defer " ^ at 0 x in + if String.length line <= width then Some [ line ] + else Some ((i ^ "defer") :: block (n + 2) [ x ]) + | Form.List ({ v = Form.Sym "defer"; _ } :: (_ :: _ :: _ as body)) -> + Some ((i ^ "defer") :: block (n + 2) body) + | Form.List ({ v = Form.Sym "match"; _ } :: s :: (_ :: _ as arms)) -> + (match pairs arms with + | None -> None + | Some prs -> + Some + ((i ^ "match " ^ at 0 s) + :: List.concat_map + (fun (pat, body) -> + let pt = at 8 pat in + let line = ind (n + 2) ^ pt ^ " -> " ^ at 0 body in + match body.v with + | Form.List (_ :: _) when String.length line > width -> + (ind (n + 2) ^ pt ^ " ->") :: slot (n + 4) body + | _ -> [ line ]) + prs)) + | Form.List [ { v = Form.Sym "handler-case"; _ }; body; { v = Form.Vec cls; _ } ] + when cls <> [] -> + Option.map + (fun cl -> ((i ^ "handler-case") :: slot (n + 2) body) @ cl) + (handler_clauses n cls) + | Form.List ({ v = Form.Sym "handler-bind"; _ } :: { v = Form.Vec cls; _ } :: (_ :: _ as body)) + when cls <> [] -> + Option.map + (fun cl -> ((i ^ "handler-bind") :: block (n + 2) body) @ cl) + (handler_clauses n cls) + | Form.List ({ v = Form.Sym "restart-case"; _ } :: body :: (_ :: _ as cls)) -> + let clause (c : Form.t) = + match c.v with + | Form.List ({ v = Form.Sym r; _ } :: { v = Form.Vec ps; _ } :: (_ :: _ as b)) + when def_name r -> + Option.map + (fun pt -> (i ^ "restart " ^ r ^ "(" ^ pt ^ ")") :: block (n + 2) b) + (params_text ps) + | _ -> None + in + let cs = List.map clause cls in + if List.mem None cs then None + else + Some (((i ^ "restart-case") :: slot (n + 2) body) + @ List.concat_map Option.get cs) + | Form.List [ { v = Form.Sym "quasiquote"; _ }; x ] -> + Some ((i ^ "quote") :: slot (n + 2) x) + | Form.List ({ v = Form.Sym "fn"; _ } :: { v = Form.Vec ps; _ } :: (_ :: _ :: _ as body)) + when List.for_all sym_param ps -> + Some ((guard (i ^ "fn(" ^ commas ps ^ ")")) :: block (n + 2) body) + | Form.List ({ v = Form.Sym (("defn" | "defn-") as d); _ } :: { v = Form.Sym name; _ } + :: { v = Form.Vec ps; _ } :: ret :: body) + when def_name name -> + (match params_text ~shaped:true ps with + | None -> None + | Some pt -> + let where_, body = + match body with + | { v = Form.Map [ { v = Form.Kw "where"; _ }; x ]; _ } :: rest -> + let preds = + match x.v with + | Form.Vec (_ :: _ :: _ as xs) -> commas xs + | _ -> at 0 x + in + (" where " ^ preds, rest) + | _ -> ("", body) + in + let head = + i ^ (if d = "defn" then "fn " else "fn- ") ^ name ^ "(" ^ pt ^ ") -> " + ^ ty ret ^ where_ + in + (match body with + | [] -> Some [ head ] + | [ x ] when (match x.v with + | Form.List ({ v = Form.Sym h; _ } :: _) -> not (List.mem h sugar_heads) + | _ -> true) + && String.length head + 3 + String.length (at 0 x) <= width -> + Some [ head ^ " = " ^ at 0 x ] + | _ -> Some (head :: block (n + 2) body))) + | Form.List ({ v = Form.Sym (("def" | "defonce" | "defconst") as d); _ } + :: { v = Form.Sym name; _ } :: rest) + when def_name name -> + let w = match d with "def" -> "def" | "defonce" -> "once" | _ -> "const" in + let pre = i ^ w ^ " " ^ name in + (match d, rest with + | "defconst", [ v ] -> Some (value_lines n (w ^ " " ^ name) v) + | "defconst", [ t; v ] -> Some (value_lines n (w ^ " " ^ name ^ ": " ^ ty t) v) + | "defconst", _ -> None + | _, [ t; v ] when is_sym "dyn" t -> Some (value_lines n (w ^ " " ^ name) v) + | _, [ t ] when type_shaped t -> Some [ pre ^ ": " ^ ty t ] + | _, [ t; v ] -> Some (value_lines n (w ^ " " ^ name ^ ": " ^ ty t) v) + | _ -> None) + | Form.List [ { v = Form.Sym (("defstruct" | "defunion") as d); _ }; + { v = Form.Sym name; _ }; { v = Form.Vec fs; _ } ] + when def_name name -> + (match pairs fs with + | Some prs when List.for_all (fun ((f : Form.t), _) -> + match f.v with Form.Sym x -> def_name x | _ -> false) prs -> + Some + ((i ^ (if d = "defstruct" then "struct " else "union ") ^ name) + :: List.map + (fun ((f : Form.t), t) -> + let fname = fst (expr f) in + ind (n + 2) ^ if is_sym "dyn" t then fname else fname ^ ": " ^ ty t) + prs) + | _ -> None) + | Form.List [ { v = Form.Sym "defdata"; _ }; { v = Form.Sym name; _ }; { v = Form.Vec cs; _ } ] + when def_name name -> + let case (c : Form.t) = + match c.v with + | Form.Sym s when def_name s -> Some s + | Form.List [ { v = Form.Sym s; _ }; { v = Form.Vec ps; _ } ] when def_name s -> + Option.map (fun pt -> s ^ "(" ^ pt ^ ")") (params_text ps) + | _ -> None + in + let cs = List.map case cs in + if List.mem None cs then None + else Some ((i ^ "data " ^ name) :: List.map (fun c -> ind (n + 2) ^ Option.get c) cs) + | Form.List [ { v = Form.Sym "defenum"; _ }; { v = Form.Sym name; _ }; { v = Form.Vec ms; _ } ] + when def_name name -> + let rec members = function + | { Form.v = Form.Sym m; _ } :: ({ Form.v = Form.Int _ | Form.UInt _; _ } as v) :: rest + when def_name m -> + Option.map (fun r -> (m ^ " = " ^ fst (expr v)) :: r) (members rest) + | { Form.v = Form.Sym m; _ } :: rest when def_name m -> + Option.map (fun r -> m :: r) (members rest) + | [] -> Some [] + | _ -> None + in + Option.map + (fun ms -> (i ^ "enum " ^ name) :: List.map (fun m -> ind (n + 2) ^ m) ms) + (members ms) + | Form.List [ { v = Form.Sym "import"; _ }; { v = Form.Sym a; _ }; ({ v = Form.Str _; _ } as p) ] + when def_name a -> + Some [ i ^ "import " ^ a ^ " " ^ fst (expr p) ] + | _ -> None + +and is_else (f : Form.t) = match f.v with Form.Kw "else" -> true | _ -> false + +and handler_clauses n cls = + let clause (c : Form.t) = + match c.v with + | Form.List (t :: { v = Form.Vec [ { v = Form.Sym v; _ } ]; _ } :: (_ :: _ as b)) + when def_name v -> + Some ((ind n ^ "on " ^ at 9 t ^ "(" ^ v ^ ")") :: block (n + 2) b) + | _ -> None + in + let cs = List.map clause cls in + if List.mem None cs then None else Some (List.concat_map Option.get cs) + +(* A [let] last in its block reads to the block's end, so it is written flat. + One with siblings after it takes its body as an indented block under the + first binding, and the rest of the bindings go inside that block. *) +and let_lines n ~last prs body = + let target (t : Form.t) = "let " ^ guard (at 8 t) in + if last then + List.concat_map (fun (t, v) -> value_lines n (target t) v) prs @ block n body + else + match prs with + | (t, v) :: rest -> + (ind n ^ target t ^ " = " ^ at 0 v) + :: (List.concat_map (fun (t, v) -> value_lines (n + 2) (target t) v) rest + @ block (n + 2) body) + | [] -> block n body + +(** A whole file: top-level forms with a blank line between them. *) +let program (fs : Form.t list) : string = + let rec go = function + | [] -> [] + | [ x ] -> [ String.concat "\n" (stmt 0 ~last:true x) ] + | x :: rest -> String.concat "\n" (stmt 0 ~last:false x) :: go rest + in + String.concat "\n\n" (go fs) ^ "\n" diff --git a/lib/indent_reader.ml b/lib/indent_reader.ml new file mode 100644 index 00000000..4c8b34da --- /dev/null +++ b/lib/indent_reader.ml @@ -0,0 +1,1310 @@ +(** The indented reader: [.fln] text to exactly the [Form.t] tree the paren + reader ([Reader]) makes. Nothing after the reader knows which syntax a form + came from. spec-syntax.md is the grammar; this comment is only the shape. + + Three passes. [lex] turns text into tokens, reusing [Reader]'s own string, + character, number and quoted-datum readers so the atoms mean exactly what + they mean in a [.flan] file. [layout] adds NEWLINE, INDENT and DEDENT at + bracket depth zero from an indent stack of columns. The parser is a + statement parser (soft keywords at the start of a line) over a precedence + climber for expressions. + + Locations are spans, as [Reader] makes them: a form starts at its first + token and ends where its last one does. A form this reader invents — the + [dyn] of an untyped parameter, the [do] around a block, the [set] of an + assignment — takes the location of the text that asked for it. *) + +type tok = + | NAME of string (* a name run, after field splitting *) + | KW of string + | ATOM of Form.value (* number, string, character *) + | DATUM of Form.t (* 'x and '(a b), read by the paren reader *) + | LP | RP | LB | RB | LC | RC + | COMMA + | COLON (* x: T, and the trailing : of a call's block *) + | UNQ | SPLICE (* ~ and ~@ *) + | NEG (* the - glued to the front of a name *) + | NEWLINE | INDENT | DEDENT | EOF + +type token = { tok : tok; loc : Loc.t; sp : bool (* whitespace before it *) } + +let failk ?notes kind loc fmt = Loc.failk ?notes ("indent/" ^ kind) loc fmt + +let show = function + | NAME s -> s + | KW s -> ":" ^ s + | ATOM v -> Form.to_source (Form.make v Loc.unknown) + | DATUM f -> Form.to_source f + | LP -> "(" | RP -> ")" | LB -> "[" | RB -> "]" | LC -> "{" | RC -> "}" + | COMMA -> "," | COLON -> ":" | UNQ -> "~" | SPLICE -> "~@" | NEG -> "-" + | NEWLINE -> "the end of the line" + | INDENT -> "an indented line" + | DEDENT -> "the end of the block" + | EOF -> "the end of the file" + +(* ── Names ─────────────────────────────────────────────────────────── *) + +(* Binary operators and their levels, low to high (spec §2 "Precedence"). + [not] sits at 3 and unary minus at 8; neither is binary. *) +let binops = + [ ("or", 1); ("and", 2); + ("==", 4); ("!=", 4); ("<", 4); ("<=", 4); (">", 4); (">=", 4); + ("<<", 5); (">>", 5); ("+", 6); ("-", 6); ("*", 7); ("/", 7); ("%", 7) ] + +let binop_level s = List.assoc_opt s binops +let is_binop s = binop_level s <> None + +(* [==] is Flan's [=]; every other operator is its own name. *) +let op_sym = function "==" -> "=" | s -> s + +(* Words that are operators rather than names wherever a value is read. Alone + before a comma or a closer they are the symbol itself, [reduce(+, 0, xs)]; + glued to a parenthesis they are a call, [+(a, b, c)]. *) +let is_op_word s = is_binop s || s = "not" || s = "=" + +let assign_ops = [ ("+=", "+"); ("-=", "-"); ("*=", "*"); ("/=", "/") ] + +(* A [-] glued to one of these starts a negation: [-x] is [(- x)]. Anything + else keeps the Lisp reading, so [--], [->] and [-=] stay names. *) +let is_neg_char c = + (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || c = '$' || c = '_' + || c = '*' + +(* The segment a dot splits after, checked for a capital: [Shape.Rect] and + [tree/Node.Branch] are one qualified name, [camera.target.x] is two field + accesses. The part after a package's [/] is what is checked. *) +let capitalised seg = + let base = + match String.rindex_opt seg '/' with + | Some i -> String.sub seg (i + 1) (String.length seg - i - 1) + | None -> seg + in + base <> "" && base.[0] >= 'A' && base.[0] <= 'Z' + +let split_fields text = + if text = "" || text.[0] = '.' then [ text ] + else + let segs = String.split_on_char '.' text in + if List.length segs < 2 || List.mem "" segs || capitalised (List.hd segs) + then [ text ] + else segs + +(* ── Lexing ────────────────────────────────────────────────────────── *) + +let lex ~file src : token list = + let st = Reader.of_string ~file src in + let out = ref [] in + let sp = ref true in + let line_start = ref true in + let tab = ref None in + let emit tok loc = out := { tok; loc; sp = !sp } :: !out; sp := false in + let piece line col len = + { (Loc.make file line col) with Loc.eline = line; ecol = col + len } + in + let name_run () = + let l0 = Reader.here st in + let text = Reader.take_while st (fun c -> not (Reader.is_delimiter c)) in + let n = String.length text in + let line = l0.Loc.line and col = l0.Loc.col in + if n = 0 then + failk "unexpected-character" l0 "unexpected character %C" (Reader.peek st); + if text = ":" then emit COLON (piece line col 1) + else if text.[0] = ':' then emit (KW (String.sub text 1 (n - 1))) (piece line col n) + else begin + let body, colon = + if text.[n - 1] = ':' then (String.sub text 0 (n - 1), true) + else (text, false) + in + let bn = String.length body in + let bcol, body = + if bn > 1 && body.[0] = '-' && is_neg_char body.[1] then begin + emit NEG (piece line col 1); + (col + 1, String.sub body 1 (bn - 1)) + end + else (col, body) + in + let off = ref 0 in + List.iteri + (fun i seg -> + let s = if i = 0 then seg else "." ^ seg in + emit (NAME s) (piece line (bcol + !off) (String.length s)); + off := !off + String.length s) + (split_fields body); + if colon then emit COLON (piece line (col + n - 1) 1) + end + in + let token c = + let l0 = Reader.here st in + let simple t = Reader.advance st; emit t (Loc.upto l0 (Reader.here st)) in + match c with + | '(' -> simple LP | ')' -> simple RP + | '[' -> simple LB | ']' -> simple RB + | '{' -> simple LC | '}' -> simple RC + | ',' -> simple COMMA + | '"' -> let f = Reader.read_string st in emit (ATOM f.v) f.loc + | '\\' -> let f = Reader.read_byte st in emit (ATOM f.v) f.loc + (* The paren reader reads the quoted datum whole, so ['(a (b c))] is the + Lisp list it always was and nothing here re-invents it. *) + | '\'' -> let f = Reader.read_form st in emit (DATUM f) f.loc + | '`' -> + failk "backquote" l0 + "` is not read in a .fln file. A quasiquote is quote followed by an \ + indented block, or quasiquote(x) on one line" + | '~' -> + Reader.advance st; + if Reader.peek st = '@' then begin + Reader.advance st; + emit SPLICE (Loc.upto l0 (Reader.here st)) + end + else emit UNQ (Loc.upto l0 (Reader.here st)) + | c when Reader.is_digit c + || ((c = '-' || c = '+') && Reader.is_digit (Reader.peek2 st)) -> + let f = Reader.read_number st in + emit (ATOM f.v) f.loc + | _ -> name_run () + in + let rec go () = + if not (Reader.at_end st) then + match Reader.peek st with + | ' ' | '\r' -> Reader.advance st; sp := true; go () + | '\t' -> + if !line_start && !tab = None then tab := Some (Reader.here st); + Reader.advance st; sp := true; go () + | '\n' -> + Reader.advance st; sp := true; line_start := true; tab := None; go () + | ';' -> + while (not (Reader.at_end st)) && Reader.peek st <> '\n' do + Reader.advance st + done; + go () + | c -> + (match !tab with + | Some l when !line_start -> + failk "tab" l + "this line is indented with a tab. Indentation in a .fln file is \ + measured in columns, and a tab has no one width, so only spaces \ + indent. Replace the tab with spaces" + | _ -> ()); + line_start := false; + token c; + go () + in + go (); + List.rev !out + +(* ── Layout ────────────────────────────────────────────────────────── *) + +let point (l : Loc.t) = { l with Loc.line = l.Loc.eline; col = l.Loc.ecol } + +(* NEWLINE, INDENT and DEDENT, at bracket depth zero only: inside ( [ { a + line break is whitespace. A line continues the one before it when either + side of the break is a spaced binary operator (spec §2 "Continuation"). *) +let layout ?(base = 1) (toks : token list) : token array = + let arr = Array.of_list toks in + let n = Array.length arr in + let out = ref [] in + let add tok loc = out := { tok; loc; sp = true } :: !out in + let stack = ref [ base ] in + let depth = ref 0 in + let binop t = match t.tok with NAME s -> is_binop s | _ -> false in + for i = 0 to n - 1 do + let t = arr.(i) in + (if i = 0 then begin + if t.loc.Loc.col <> base then + failk "unexpected-indent" t.loc + "the first line starts at column %d, and a file's top-level lines \ + start at column %d. Remove the indentation" + t.loc.Loc.col base + end + else + let p = arr.(i - 1) in + if !depth = 0 && t.loc.Loc.line > p.loc.Loc.eline then begin + let spaced_after = + i + 1 < n && arr.(i + 1).loc.Loc.line = t.loc.Loc.line + && arr.(i + 1).sp + in + let continues = (binop p && p.sp) || (binop t && spaced_after) in + if not continues then begin + let at = point p.loc in + add NEWLINE at; + let col = t.loc.Loc.col in + let top = List.hd !stack in + if col > top then begin + stack := col :: !stack; + add INDENT at + end + else if col < top then begin + let rec pop () = + match !stack with + | top :: (_ :: _ as rest) when col < top -> + stack := rest; add DEDENT at; pop () + | _ -> () + in + pop (); + if col <> List.hd !stack then + failk "dedent" t.loc + "this line starts at column %d, which is not where any \ + enclosing block starts — those start at column%s %s. Line \ + it up with one of them" + col + (if List.length !stack > 1 then "s" else "") + (String.concat ", " + (List.rev_map string_of_int !stack)) + end + end + end); + out := t :: !out; + (match t.tok with + | LP | LB | LC -> incr depth + | RP | RB | RC -> if !depth > 0 then decr depth + | _ -> ()) + done; + (if n > 0 then + let at = point arr.(n - 1).loc in + add NEWLINE at; + List.iter (fun _ -> add DEDENT at) (List.tl !stack)); + let eof_loc = if n > 0 then point arr.(n - 1).loc else Loc.unknown in + add EOF eof_loc; + Array.of_list (List.rev !out) + +(* ── Parsing ───────────────────────────────────────────────────────── *) + +type p = { toks : token array; mutable i : int } + +let peek p = p.toks.(p.i) +let peek_at p k = p.toks.(min (p.i + k) (Array.length p.toks - 1)) +let advance p = + let t = peek p in + if t.tok <> EOF then p.i <- p.i + 1; + t +let last p = p.toks.(max 0 (p.i - 1)) + +(* From [l] to the end of the last token consumed. *) +let span p (l : Loc.t) = + let e = (last p).loc in + if e.Loc.eline > l.Loc.line + || (e.Loc.eline = l.Loc.line && e.Loc.ecol > l.Loc.col) + then { l with Loc.eline = e.Loc.eline; ecol = e.Loc.ecol } + else l + +let mk p l v = Form.make v (span p l) +let sym l s = Form.make (Form.Sym s) l + +(* Where a stray token is, pointing at the real token after a layout one. *) +let where_ p = + let t = peek p in + match t.tok with + | NEWLINE | INDENT | DEDENT -> (peek_at p 1).loc + | _ -> t.loc + +let starts_value = function + | NAME _ | KW _ | ATOM _ | DATUM _ | LP | LB | LC | UNQ | SPLICE | NEG -> true + | _ -> false + +let ends_value = function + | RP | RB | RC | COMMA | NEWLINE | EOF | INDENT | DEDENT -> true + | _ -> false + +let negative_literal = function + | ATOM (Form.Int i) -> Int64.compare i 0L < 0 + | ATOM (Form.Float f) -> f < 0. + | _ -> false + +(* Something followed a complete value where nothing may. The two shapes that + get their own sentence are the ones a Lisp hand writes: [a -1] and + [f (x)]. *) +let stray p ~after = + let t = peek p in + match t.tok with + | ATOM _ when t.sp && negative_literal t.tok -> + let text = show t.tok in + let digits = String.sub text 1 (String.length text - 1) in + failk "glued-minus" t.loc + "%s is read as the number %s, right after %s with nothing between them. \ + To subtract, space the minus: %s - %s. For two values, separate them \ + with a comma: %s, %s" + text text after after digits after text + | LP when t.sp -> + failk "spaced-call" t.loc + "there is a space before this (, so it does not call %s — a call has \ + none. Write %s(...), or put a comma before the ( if it is a separate \ + value" + after after + | LB when t.sp -> + failk "spaced-index" t.loc + "there is a space before this [, so it does not index %s — indexing has \ + none. Write %s[i]" + after after + | NEWLINE | INDENT | DEDENT | EOF -> + failk "unexpected-end" (where_ p) "the line ends after %s, which is not \ + finished here" after + | _ -> + failk "unexpected-token" t.loc + "%s follows %s, and two values cannot sit side by side here. Separate \ + them with a comma, or join them with an operator" + (show t.tok) after + +let expect p tok ~what = + let t = peek p in + if t.tok = tok then ignore (advance p) + else + failk "expected" (where_ p) "expected %s here, and found %s" what + (show t.tok) + +let expect_name p s ~what = + match (peek p).tok with + | NAME n when n = s -> ignore (advance p) + | t -> failk "expected" (where_ p) "expected %s here, and found %s" what (show t) + +(* The end of a line that is not followed by a block. *) +let expect_eol p ~after = + match (peek p).tok with + | NEWLINE -> + ignore (advance p); + if (peek p).tok = INDENT then + failk "stray-indent" (peek_at p 1).loc + "this line is indented under %s, which takes no block. A call takes \ + an indented block only with a trailing colon, as in \ + rl/with-drawing():" + after + | EOF -> () + | _ -> stray p ~after + +let check_name (t : token) s = + if String.contains s ':' then + failk "colon-in-name" t.loc + "%s has a colon inside it, and a name cannot. A type annotation puts a \ + space after the colon: %s" + s + (match String.index_opt s ':' with + | Some i -> String.sub s 0 (i + 1) ^ " " ^ String.sub s (i + 1) (String.length s - i - 1) + | None -> s) + +(* A form's own text, for the "after" half of a message. *) +let text_of (f : Form.t) = + let s = Form.to_source f in + if String.length s > 40 then String.sub s 0 37 ^ "..." else s + +let unclosed p c l0 = + failk "unclosed" l0 + ~notes:[ Loc.note (where_ p) "the input ends here, still inside it" ] + "unclosed %C" c + +let refuse_ws loc e = + failk "separate-elements" loc + "%s has an operator in it and sits in a list separated by spaces, where \ + only single values are. Separate the elements with commas: [a - 1, b]" + (text_of e) + +(* Expressions come back with their syntactic level: 10 an atom or a bracket, + 9 a postfix chain, 8 a unary minus, 1-7 a binary operator's level, 3 a + [not], 0 a one-line [if] or a lambda. Anything under 8 is "compound": it + has an operator at its top, so it cannot sit in a list separated only by + whitespace. *) +let rec expr p : Form.t * int = binary p 1 + +and binary p lvl : Form.t * int = + if lvl = 3 then not_ p + else if lvl > 7 then unary p + else + let l0 = (peek p).loc in + let ((first, _) as fst_) = binary p (lvl + 1) in + let close op operands = + match List.rev operands with + | [ x ] -> (x, lvl) + | ops -> + if op = "!=" && List.length ops > 2 then + failk "chained-not-equal" l0 + "a != b != c is not read. != with more than two values means all \ + of them are distinct, which is not what the chain says, so it is \ + written as a call: !=(a, b, c)"; + (mk p l0 (Form.List (sym l0 (op_sym op) :: ops)), lvl) + in + (* An operator glued to a parenthesis is a call, [+(a, b)], and never + the operator between two values. *) + let binary_here s = + binop_level s = Some lvl + && not ((peek_at p 1).tok = LP && not (peek_at p 1).sp) + in + let rec run op operands = + match (peek p).tok with + | NAME s when binary_here s -> + let ot = advance p in + if not (ot.sp && (peek p).sp) then + failk "unspaced-operator" ot.loc + "%s is an operator here, and a binary operator has a space on each \ + side: a %s b. Without them a-b is one name" + s s; + let rhs, _ = binary p (lvl + 1) in + if s = op then run op (rhs :: operands) + else begin + if lvl = 4 then + failk "mixed-comparison" ot.loc + "%s follows %s in one chain, and a chain compares with one \ + operator. Join the tests with and, or parenthesise one side" + s op; + let folded, _ = close op operands in + run s [ rhs; folded ] + end + | _ -> close op operands + in + (* [run] folds a different operator at the same level into the left + operand, so the first operator here only starts the first run. *) + match (peek p).tok with + | NAME s when binary_here s -> run s [ first ] + | _ -> fst_ + +and not_ p = + let t = peek p in + match t.tok with + | NAME "not" when (peek_at p 1).sp && starts_value (peek_at p 1).tok -> + ignore (advance p); + let x, _ = not_ p in + (mk p t.loc (Form.List [ sym t.loc "not"; x ]), 3) + | _ -> binary p 4 + +and unary p = + let t = peek p in + match t.tok with + | NEG -> + ignore (advance p); + let x, _ = postfix p in + (mk p t.loc (Form.List [ sym t.loc "-"; x ]), 8) + | _ -> postfix p + +and postfix p = + let l0 = (peek p).loc in + let rec loop ((f, _) as fp) = + let t = peek p in + if t.sp then fp + else + match t.tok with + | LP -> + ignore (advance p); + let args = items p RP t.loc ~what:"arguments" in + loop (mk p l0 (Form.List (f :: args)), 9) + | LB -> + ignore (advance p); + let idx = items p RB t.loc ~what:"indices" in + loop (mk p l0 (Form.List (sym t.loc "at" :: f :: idx)), 9) + | NAME s when String.length s > 1 && s.[0] = '.' -> + ignore (advance p); + loop (mk p l0 (Form.List [ sym t.loc s; f ]), 9) + | LC -> + ignore (advance p); + let m = map_items p t.loc in + loop (mk p l0 (Form.List [ f; Form.make (Form.Map m) (span p t.loc) ]), 9) + | _ -> fp + in + loop (primary p) + +and primary p : Form.t * int = + let t = peek p in + let l0 = t.loc in + match t.tok with + | NAME s -> + let nxt = peek_at p 1 in + let glued_lp = nxt.tok = LP && not nxt.sp in + if s = "if" && nxt.sp && starts_value nxt.tok then if_expr p + else if s = "fn" && glued_lp then fn_expr p + else if is_op_word s then begin + if glued_lp || ends_value nxt.tok then begin + ignore (advance p); + (sym l0 (op_sym s), 10) + end + else + failk "operator-operand" l0 + "%s is an operator, and nothing is on its left. As a value on its \ + own it goes before a comma or a closing bracket, reduce(%s, xs); \ + as a call it is glued to its parenthesis, %s(a, b)" + s s s + end + else begin + ignore (advance p); + check_name t s; + (sym l0 s, 10) + end + | KW k -> ignore (advance p); (Form.make (Form.Kw k) l0, 10) + | ATOM v -> + ignore (advance p); + (Form.make v l0, if negative_literal t.tok then 8 else 10) + | DATUM f -> ignore (advance p); (f, 10) + | LP -> + ignore (advance p); + if (peek p).tok = RP then begin + ignore (advance p); + (mk p l0 (Form.List []), 10) + end + else + let e, _ = expr p in + (match (peek p).tok with + | RP -> ignore (advance p) + | EOF -> unclosed p '(' l0 + | _ -> stray p ~after:(text_of e)); + (e, 10) + | LB -> + ignore (advance p); + let xs = vec_items p l0 in + (mk p l0 (Form.Vec xs), 10) + | LC -> + ignore (advance p); + let xs = map_items p l0 in + (mk p l0 (Form.Map xs), 10) + | UNQ | SPLICE -> + ignore (advance p); + let x, _ = primary p in + let name = if t.tok = UNQ then "unquote" else "unquote-splicing" in + (mk p l0 (Form.List [ sym l0 name; x ]), 10) + | NEG -> unary p + | tk -> + failk "expected-value" (where_ p) "expected a value here, and found %s" + (show tk) + +(* [if c then a else b]: the one-line form, for a value. *) +and if_expr p = + let t = advance p in + let c, _ = binary p 1 in + (match (peek p).tok with + | NAME "then" -> ignore (advance p) + | _ -> + failk "if-then" (where_ p) + "an if inside a line is if c then a else b, and there is no then \ + after %s. Write the then, or start the if on its own line with its \ + branches indented under it" + (text_of c)); + let a, _ = binary p 1 in + match (peek p).tok with + | NAME "else" -> + ignore (advance p); + let b, _ = expr p in + (mk p t.loc (Form.List [ sym t.loc "if"; c; a; b ]), 0) + | _ -> (mk p t.loc (Form.List [ sym t.loc "when"; c; a ]), 0) + +(* [fn(a, b) = body] is a lambda; [fn(...)] followed by anything else is the + fallback call spelling of [(fn ...)]. *) +and fn_expr p = + let t = advance p in + let lp = advance p in + let args = items p RP lp.loc ~what:"parameters" in + match (peek p).tok with + | NAME "=" -> + ignore (advance p); + let ps = lambda_params args in + let body, _ = expr p in + (mk p t.loc + (Form.List + [ sym t.loc "fn"; Form.make (Form.Vec ps) (span_of_list lp.loc args); body ]), + 0) + | _ -> (mk p t.loc (Form.List (sym t.loc "fn" :: args)), 9) + +and span_of_list l args = + match List.rev args with + | [] -> l + | (x : Form.t) :: _ -> { l with Loc.eline = x.loc.Loc.eline; ecol = x.loc.Loc.ecol } + +and lambda_params args = + List.map + (fun (a : Form.t) -> + match a.v with + | Form.Sym _ -> a + | _ -> + failk "lambda-param" a.loc + "a lambda's parameter is a name, and this is %s. Take the value \ + under a name and destructure it in the body" + (text_of a)) + args + +(* Comma-separated values up to [closer]. [const T] is two elements without a + comma, for [Ptr(const u8)]: const is a reserved word in a type and never a + value. *) +and items p closer open_loc ~what = + let opener = if closer = RB then '[' else '(' in + let rec go acc = + let t = peek p in + if t.tok = closer then (ignore (advance p); List.rev acc) + else if t.tok = EOF then unclosed p opener open_loc + else + match t.tok, peek_at p 1 with + | NAME "const", n when n.sp && starts_value n.tok -> + ignore (advance p); + go (sym t.loc "const" :: acc) + | _ -> + let e, _ = expr p in + (match (peek p).tok with + | COMMA -> ignore (advance p); go (e :: acc) + | tk when tk = closer -> ignore (advance p); List.rev (e :: acc) + | EOF -> unclosed p opener open_loc + | _ -> + let n = peek p in + if starts_value n.tok && n.sp && not (negative_literal n.tok) then + failk "missing-comma" n.loc + "%s follows %s with no comma between them. Separate %s with \ + commas: f(a, b)" + (show n.tok) (text_of e) what + else stray p ~after:(text_of e)) + in + go [] + +(* [[a b c]] or [[a, b + 1]]: whitespace separates only single terms. *) +and vec_items p open_loc = + let rec go acc prev_ws = + let t = peek p in + match t.tok with + | RB -> ignore (advance p); List.rev acc + | EOF -> unclosed p '[' open_loc + | _ -> + let e, lvl = expr p in + if lvl < 8 && prev_ws then refuse_ws t.loc e; + (match (peek p).tok with + | COMMA -> ignore (advance p); go (e :: acc) false + | RB -> ignore (advance p); List.rev (e :: acc) + | EOF -> unclosed p '[' open_loc + | tk when starts_value tk && (peek p).sp -> + if lvl < 8 then refuse_ws t.loc e; + go (e :: acc) true + | _ -> stray p ~after:(text_of e)) + in + go [] false + +(* Braces pair a key with a value, so a value may be any expression; after + one that has an operator in it, the next entry needs a comma. *) +and map_items p open_loc = + let rec go acc = + let t = peek p in + match t.tok with + | RC -> ignore (advance p); List.rev acc + | EOF -> unclosed p '{' open_loc + | _ -> + let e, lvl = expr p in + (match (peek p).tok with + | COMMA -> ignore (advance p); go (e :: acc) + | RC -> ignore (advance p); List.rev (e :: acc) + | EOF -> unclosed p '{' open_loc + | tk when starts_value tk && (peek p).sp -> + if lvl < 8 then refuse_ws t.loc e; + go (e :: acc) + | _ -> stray p ~after:(text_of e)) + in + go [] + + +(* A type after [:] or [->]: a postfix term, plus the arrow of a function + type, [Fn(A, B) -> R], which reads as [(Fn [A B] R)]. *) +let rec ty p : Form.t = + let l0 = (peek p).loc in + let f, _ = postfix p in + match f.v, (peek p).tok with + | Form.List (({ v = Form.Sym ("Fn" | "CFn"); _ } as h) :: args), NAME "->" + when (last p).tok = RP -> + ignore (advance p); + let r = ty p in + mk p l0 (Form.List [ h; Form.make (Form.Vec args) h.loc; r ]) + | _ -> f + +(* ── Statements ────────────────────────────────────────────────────── *) + +(* The let-statements this reader built, so that a [let] whose whole body is + another one merges into one binding vector (spec §2), and a [let] written + as a call does not. *) +type st = { p : p; mutable lets : Form.t list } + +let blk (s : st) l (ss : Form.t list) = + match ss with + | [ x ] -> x + | _ -> mk s.p l (Form.List (sym l "do" :: ss)) + +let is_lambda_candidate (e : Form.t) = + match e.v with + | Form.List ({ v = Form.Sym "fn"; _ } :: args) -> + List.for_all (fun (a : Form.t) -> match a.v with Form.Sym _ -> true | _ -> false) args + | _ -> false + +let header_follow p s = + let n = peek_at p 1 in + let plain_name = function + | NAME x -> not (is_op_word x || x = "=" || List.mem_assoc x assign_ops) + | _ -> false + in + match s with + | "fn" | "fn-" | "def" | "once" | "const" | "struct" | "union" | "data" + | "enum" | "import" -> + n.sp && plain_name n.tok + | "if" | "while" | "until" | "match" | "let" | "for" -> + n.sp && starts_value n.tok + && (match n.tok with + | NAME x when x = "=" || List.mem_assoc x assign_ops -> false + | NAME x when is_binop x -> + let a = peek_at p 2 in + a.tok = LP && not a.sp + | _ -> true) + | "return" -> n.tok = NEWLINE || (n.sp && starts_value n.tok) + | "break" | "continue" -> + n.tok = NEWLINE || (n.sp && (match n.tok with KW _ -> true | _ -> false)) + | "defer" -> + (n.tok = NEWLINE && (peek_at p 2).tok = INDENT) || (n.sp && starts_value n.tok) + | "handler-case" | "handler-bind" | "restart-case" -> n.tok = NEWLINE + | "quote" -> n.tok = NEWLINE && (peek_at p 2).tok = INDENT + | _ -> false + +let name_tok p ~what = + let t = peek p in + match t.tok with + | NAME s when not (String.length s > 0 && s.[0] = '.') -> + ignore (advance p); + check_name t s; + sym t.loc s + | tk -> failk "expected-name" (where_ p) "expected %s here, and found %s" what (show tk) + +let glued_lp p ~what = + let t = peek p in + if t.tok = LP && not t.sp then advance p + else failk "expected" (where_ p) "expected %s here, and found %s" what (show t.tok) + +(* [(a: i32, b)] as name/type pairs, [dyn] written out for the untyped: the + reader never leaves a vector for [Check.pair_params] to guess at. *) +let params p (lp : token) = + let rec go acc = + let t = peek p in + match t.tok with + | RP -> ignore (advance p); List.rev acc + | EOF -> unclosed p '(' lp.loc + | _ -> + let n = name_tok p ~what:"a parameter's name" in + let tyf = + match (peek p).tok with + | COLON -> ignore (advance p); ty p + | _ -> sym n.loc "dyn" + in + (match (peek p).tok with + | COMMA -> ignore (advance p) + | RP -> () + | _ -> stray p ~after:(text_of tyf)); + go (tyf :: n :: acc) + in + go [] + +let rec stmts (s : st) : Form.t list = + let p = s.p in + match (peek p).tok with + | DEDENT -> ignore (advance p); [] + | EOF -> [] + | NAME "let" when header_follow p "let" -> let_stmt s + | _ -> + let f = stmt s in + f :: stmts s + +and block (s : st) ~after : Form.t list = + let p = s.p in + match (peek p).tok with + | INDENT -> ignore (advance p); stmts s + | _ -> + failk "expected-block" (where_ p) + "%s takes an indented block on the lines under it, and the next line is \ + not indented" + after + +(* The rest of a line read as a value, through its end: [= v], or [=] and an + indented block that reduces to one form, or a lambda with a block body. *) +and value_line ?(block_ok = false) (s : st) ~after : Form.t = + let p = s.p in + let l0 = where_ p in + if (peek p).tok = NEWLINE && (peek_at p 1).tok = INDENT then begin + ignore (advance p); + blk s l0 (block s ~after) + end + else + let e, _ = expr p in + lambda_block ~block_ok s e ~after:(text_of e) + +and lambda_block ?(block_ok = false) (s : st) (e : Form.t) ~after = + let p = s.p in + if is_lambda_candidate e && (last p).tok = RP && (peek p).tok = NEWLINE + && (peek_at p 1).tok = INDENT + then begin + ignore (advance p); + let body = block s ~after in + match e.v with + | Form.List (h :: args) -> + mk p e.loc + (Form.List (h :: Form.make (Form.Vec args) (span_of_list e.loc args) :: body)) + | _ -> assert false + end + else begin + if block_ok && (peek p).tok = NEWLINE then ignore (advance p) + else expect_eol p ~after; + e + end + +and let_stmt (s : st) : Form.t list = + let p = s.p in + let t = advance p in + let target, _ = unary p in + (match (peek p).tok with + | NAME "=" -> ignore (advance p) + | _ -> + failk "let-equals" (where_ p) + "a let is let name = value, and %s is not followed by =" (text_of target)); + let v = value_line ~block_ok:true s ~after:("let " ^ text_of target) in + let make bindings body = + let f = + mk p t.loc + (Form.List + (sym t.loc "let" :: Form.make (Form.Vec bindings) (span_of_list target.loc bindings) + :: body)) + in + s.lets <- f :: s.lets; + f + in + let merged body = + match body with + | [ ({ Form.v = Form.List (_ :: { v = Form.Vec bs; _ } :: body); _ } as inner) ] + when List.memq inner s.lets -> + make (target :: v :: bs) body + | _ -> make [ target; v ] body + in + if (peek p).tok = INDENT then begin + let f = merged (block s ~after:"let") in + f :: stmts s + end + else [ merged (stmts s) ] + +and stmt (s : st) : Form.t = + let p = s.p in + let t = peek p in + match t.tok with + | NAME w when header_follow p w -> header s w + | NAME (("else" | "elif") as w) -> + failk "orphan-else" t.loc + "%s is not under an if at this column. It goes at the same column as \ + the if it belongs to, right after that if's block" + w + | _ -> expr_stmt s + +and expr_stmt (s : st) : Form.t = + let p = s.p in + let i0 = p.i in + let t0 = peek p in + let e, _ = expr p in + match (peek p).tok with + | NAME "=" -> + let eq = advance p in + let v = value_line s ~after:(text_of e ^ " =") in + mk p t0.loc (Form.List [ sym eq.loc "set"; e; v ]) + | NAME op when List.mem_assoc op assign_ops -> + let eq = advance p in + let v = value_line s ~after:(text_of e ^ " " ^ op) in + let o = List.assoc op assign_ops in + mk p t0.loc + (Form.List + [ sym eq.loc "set"; e; + Form.make (Form.List [ sym eq.loc o; e; v ]) (span p e.loc) ]) + | COLON -> + let before = (last p).tok in + let c = advance p in + (match e.v, before with + | Form.List (_ :: _), RP -> () + | _ -> + failk "colon-block" c.loc + "a trailing colon gives a call an indented block, and %s is not a \ + call. Write it as one, as in %s():" + (text_of e) (text_of e)); + (match (peek p).tok with + | NEWLINE -> ignore (advance p) + | _ -> stray p ~after:":"); + let body = block s ~after:(text_of e ^ ":") in + (match e.v with + | Form.List items -> mk p t0.loc (Form.List (items @ body)) + | _ -> assert false) + | _ -> + (* [()] alone on a line is the empty statement, spec §2 "Unit". *) + let e = + if p.i - i0 = 2 && t0.tok = LP && e.v = Form.List [] then + Form.make (Form.List [ sym t0.loc "do" ]) e.loc + else e + in + lambda_block s e ~after:(text_of e) + +and header (s : st) w : Form.t = + let p = s.p in + let t = advance p in + let l0 = t.loc in + let form items = mk p l0 (Form.List (sym l0 w :: items)) in + let named head items = mk p l0 (Form.List (sym l0 head :: items)) in + match w with + | "fn" | "fn-" -> + let name = name_tok p ~what:"the function's name" in + let lp = glued_lp p ~what:"the parameters, in parentheses glued to the name" in + let ps = params p lp in + let rp = last p in + let ret = + match (peek p).tok with + | NAME "->" -> ignore (advance p); ty p + | _ -> + let n = match name.v with Form.Sym n -> n | _ -> "" in + failk "return-type" rp.loc + "fn %s has no return type after its parameters, and a .fln \ + function states one for now. Write it after an arrow: fn %s(...) \ + -> i32, or -> dyn, or -> () when it returns nothing" + n n + in + let where_clause = + match (peek p).tok with + | NAME "where" -> + let wt = advance p in + let rec preds acc = + let e, _ = expr p in + match (peek p).tok with + | COMMA -> ignore (advance p); preds (e :: acc) + | _ -> List.rev (e :: acc) + in + let es = preds [] in + let v = + match es with + | [ e ] -> e + | _ -> Form.make (Form.Vec es) (span p wt.loc) + in + [ mk p wt.loc (Form.Map [ Form.make (Form.Kw "where") wt.loc; v ]) ] + | _ -> [] + in + let body = + match (peek p).tok with + | NAME "=" -> + ignore (advance p); + if (peek p).tok = NEWLINE && (peek_at p 1).tok = INDENT then begin + ignore (advance p); + block s ~after:"fn" + end + else [ value_line s ~after:"=" ] + | NEWLINE -> + ignore (advance p); + if (peek p).tok = INDENT then block s ~after:"fn" else [] + | _ -> stray p ~after:(text_of ret) + in + named (if w = "fn" then "defn" else "defn-") + (name :: Form.make (Form.Vec ps) lp.loc :: ret :: (where_clause @ body)) + | "def" | "once" | "const" -> + let name = name_tok p ~what:"the name being defined" in + let tyf = + match (peek p).tok with + | COLON -> ignore (advance p); Some (ty p) + | _ -> None + in + let v = + match (peek p).tok with + | NAME "=" -> + ignore (advance p); + Some (value_line s ~after:(w ^ " " ^ text_of name ^ " =")) + | _ -> + expect_eol p ~after:(match tyf with Some f -> text_of f | None -> text_of name); + None + in + let head = + match w with "def" -> "def" | "once" -> "defonce" | _ -> "defconst" + in + let items = + match w, tyf, v with + | "const", None, Some v -> [ name; v ] + | "const", Some t, Some v -> [ name; t; v ] + | "const", _, None -> + failk "const-value" l0 + "a const needs its value: const %s = 3" (text_of name) + | _, None, Some v -> [ name; sym name.loc "dyn"; v ] + | _, Some t, None -> [ name; t ] + | _, Some t, Some v -> [ name; t; v ] + | _, None, None -> + failk "def-empty" l0 + "%s %s names neither a type nor a value. Give it one or both: %s %s: \ + i32 = 0" + w (text_of name) w (text_of name) + in + named head items + | "struct" | "union" -> + let name = name_tok p ~what:"the type's name" in + expect_eol_block p ~after:(w ^ " " ^ text_of name); + let fields = + lines s (fun () -> + let f = name_tok p ~what:"a field's name" in + let tf = + match (peek p).tok with + | COLON -> ignore (advance p); ty p + | _ -> sym f.loc "dyn" + in + expect_eol p ~after:(text_of tf); + [ f; tf ]) + in + named (if w = "struct" then "defstruct" else "defunion") + [ name; Form.make (Form.Vec fields) (span p name.loc) ] + | "data" -> + let name = name_tok p ~what:"the type's name" in + expect_eol_block p ~after:("data " ^ text_of name); + let cases = + lines s (fun () -> + let c = name_tok p ~what:"a case's name" in + let f = + match (peek p).tok with + | LP when not (peek p).sp -> + let lp = advance p in + let ps = params p lp in + mk p c.loc (Form.List [ c; Form.make (Form.Vec ps) lp.loc ]) + | _ -> c + in + expect_eol p ~after:(text_of f); + [ f ]) + in + named "defdata" [ name; Form.make (Form.Vec cases) (span p name.loc) ] + | "enum" -> + let name = name_tok p ~what:"the enum's name" in + expect_eol_block p ~after:("enum " ^ text_of name); + let members = + lines s (fun () -> + let m = name_tok p ~what:"a member's name" in + match (peek p).tok with + | NAME "=" -> + ignore (advance p); + let v, _ = unary p in + expect_eol p ~after:(text_of v); + [ m; v ] + | _ -> expect_eol p ~after:(text_of m); [ m ]) + in + named "defenum" [ name; Form.make (Form.Vec members) (span p name.loc) ] + | "import" -> + let alias = name_tok p ~what:"the package's alias" in + let path = + match (peek p).tok with + | ATOM (Form.Str _ as v) -> let pt = advance p in Form.make v pt.loc + | tk -> + failk "import-path" (where_ p) + "an import is import alias \"collection:path\", and found %s where \ + the path goes" + (show tk) + in + expect_eol p ~after:(text_of path); + form [ alias; path ] + | "if" -> + let c, _ = binary p 1 in + (match (peek p).tok with + | NAME "then" -> + ignore (advance p); + let a, _ = binary p 1 in + let f = + match (peek p).tok with + | NAME "else" -> + ignore (advance p); + let b, _ = expr p in + form [ c; a; b ] + | _ -> named "when" [ c; a ] + in + expect_eol p ~after:(text_of f); + f + | _ -> + expect_line_end p ~after:("if " ^ text_of c); + let body = block s ~after:("if " ^ text_of c) in + let rec elifs acc = + match (peek p).tok with + | NAME "elif" -> + ignore (advance p); + let c, _ = binary p 1 in + expect_line_end p ~after:("elif " ^ text_of c); + let b = block s ~after:"elif" in + elifs ((c, b) :: acc) + | _ -> List.rev acc + in + let els_ = elifs [] in + let else_ = + match (peek p).tok with + | NAME "else" -> + let et = advance p in + (match (peek p).tok with + | NEWLINE -> ignore (advance p) + | NAME "if" -> + failk "else-if" (where_ p) + "else takes its block on the lines under it. For another test \ + at this level, write elif c" + | _ -> stray p ~after:"else"); + Some (et.loc, block s ~after:"else") + | _ -> None + in + (match els_, else_ with + | [], None -> named "when" (c :: body) + | [], Some (el, e) -> form [ c; blk s l0 body; blk s el e ] + | _ -> + let pairs = + List.concat_map (fun (c, b) -> [ c; blk s c.Form.loc b ]) ((c, body) :: els_) + in + let tail = + match else_ with + | Some (el, e) -> [ Form.make (Form.Kw "else") el; blk s el e ] + | None -> [] + in + named "cond" (pairs @ tail))) + | "while" | "until" -> + let label = + match (peek p).tok, (peek_at p 1).tok with + | KW k, n when n <> NEWLINE -> let kt = advance p in [ Form.make (Form.Kw k) kt.loc ] + | _ -> [] + in + let c, _ = expr p in + expect_line_end p ~after:(w ^ " " ^ text_of c); + let body = block s ~after:w in + form (label @ (c :: body)) + | "for" -> + let label = + match (peek p).tok with + | KW k -> let kt = advance p in [ Form.make (Form.Kw k) kt.loc ] + | _ -> [] + in + let v = name_tok p ~what:"the loop variable" in + expect_name p "in" ~what:"in, as in for i in range(n)"; + let rt = peek p in + expect_name p "range" ~what:"range(n), range(a, b) or range(a, b, step)"; + let lp = glued_lp p ~what:"range's bounds in parentheses" in + let bs = items p RP lp.loc ~what:"bounds" in + if bs = [] || List.length bs > 3 then + failk "range-arity" rt.loc + "range takes one, two or three bounds: range(stop), range(start, stop) \ + or range(start, stop, step)"; + expect_line_end p ~after:"range(...)"; + let body = block s ~after:"for" in + named "dotimes" + (label @ (Form.make (Form.Vec (v :: bs)) (span_of_list v.loc bs) :: body)) + | "return" -> + (match (peek p).tok with + | NEWLINE -> expect_eol p ~after:"return"; form [] + | _ -> + let e, _ = expr p in + expect_eol p ~after:(text_of e); + form [ e ]) + | "break" | "continue" -> + (match (peek p).tok with + | KW k -> + let kt = advance p in + expect_eol p ~after:(":" ^ k); + form [ Form.make (Form.Kw k) kt.loc ] + | _ -> expect_eol p ~after:w; form []) + | "defer" -> + (match (peek p).tok with + | NEWLINE -> + ignore (advance p); + form (block s ~after:"defer") + | _ -> + let e, _ = expr p in + expect_eol p ~after:(text_of e); + form [ e ]) + | "match" -> + let scrut, _ = expr p in + expect_eol_block p ~after:("match " ^ text_of scrut); + let arms = + lines s (fun () -> + let pat, _ = unary p in + expect_name p "->" ~what:"-> and the arm's value"; + let body = + if (peek p).tok = NEWLINE && (peek_at p 1).tok = INDENT then begin + let nl = advance p in + blk s nl.loc (block s ~after:"->") + end + else begin + let e, _ = expr p in + expect_eol p ~after:(text_of e); + e + end + in + [ pat; body ]) + in + form (scrut :: arms) + | "handler-case" | "handler-bind" -> + expect_line_end p ~after:w; + let body = block s ~after:w in + let rec clauses acc = + match (peek p).tok, (peek_at p 1) with + | NAME "on", n when n.sp -> + let ot = advance p in + let head, _ = postfix p in + let ty, var = + match head.v with + | Form.List [ ty; ({ v = Form.Sym _; _ } as var) ] -> (ty, var) + | _ -> + failk "on-clause" head.loc + "a handler clause is on Type(name), naming the condition type \ + and the name it is bound to, as in on FileError(c)" + in + expect_line_end p ~after:("on " ^ text_of head); + let b = block s ~after:"on" in + let c = + mk p ot.loc + (Form.List (ty :: Form.make (Form.Vec [ var ]) var.loc :: b)) + in + clauses (c :: acc) + | _ -> List.rev acc + in + let cs = clauses [] in + let vec = Form.make (Form.Vec cs) (span p l0) in + if w = "handler-case" then form [ blk s l0 body; vec ] + else form (vec :: body) + | "restart-case" -> + expect_line_end p ~after:w; + let body = block s ~after:w in + let rec clauses acc = + match (peek p).tok, (peek_at p 1) with + | NAME "restart", n when n.sp -> + ignore (advance p); + let name = name_tok p ~what:"the restart's name" in + let lp = glued_lp p ~what:"the restart's parameters in parentheses" in + let ps = params p lp in + expect_line_end p ~after:("restart " ^ text_of name); + let b = block s ~after:"restart" in + let c = + mk p name.loc (Form.List (name :: Form.make (Form.Vec ps) lp.loc :: b)) + in + clauses (c :: acc) + | _ -> List.rev acc + in + let cs = clauses [] in + form (blk s l0 body :: cs) + | "quote" -> + expect_line_end p ~after:"quote"; + let body = block s ~after:"quote" in + named "quasiquote" [ blk s l0 body ] + | _ -> assert false + +(* The end of a header line whose block must follow. *) +and expect_line_end p ~after = + match (peek p).tok with + | NEWLINE -> ignore (advance p) + | _ -> stray p ~after + +and expect_eol_block p ~after = + expect_line_end p ~after + +(* An indented run of one-line entries — a struct's fields, a match's arms. + None at all is allowed for the declarations and is refused later, by the + form, where it matters. *) +and lines (s : st) (one : unit -> Form.t list) : Form.t list = + let p = s.p in + if (peek p).tok <> INDENT then [] + else begin + ignore (advance p); + let rec go acc = + match (peek p).tok with + | DEDENT -> ignore (advance p); List.rev acc + | EOF -> List.rev acc + | _ -> go (List.rev_append (one ()) acc) + in + go [] + end + +(** All top-level forms in a [.fln] source string. [col] is the column the + text's top level starts at, 1 for a file. *) +let read_all ?(col = 1) ~file src = + let toks = layout ~base:col (lex ~file src) in + let s = { p = { toks; i = 0 }; lets = [] } in + let fs = stmts s in + (match (peek s.p).tok with + | EOF -> () + | tk -> failk "unexpected-token" (where_ s.p) "unexpected %s" (show tk)); + fs + +let read_file path = + let ic = open_in_bin path in + Fun.protect ~finally:(fun () -> close_in ic) (fun () -> + let n = in_channel_length ic in + read_all ~file:path (really_input_string ic n)) diff --git a/lib/load.ml b/lib/load.ml index 040ac95c..55c6b489 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -94,14 +94,14 @@ let rec find_collection dir name = let parent = Filename.dirname dir in if String.equal parent dir then None else find_collection parent name -(* A package is a directory, or a single [.flan] file named outright. The file +(* A package is a directory, or a single source file named outright. The file form is for the program that is also a library: sand.flan sits beside three other loose .flan files, so naming its directory would import all four, and moving it into one of its own would be arranging the tree around a limitation. A file carries no [.c] and no [link] — those belong to a directory, and a package that needs them has one. *) let is_package_file path = - Filename.check_suffix path ".flan" && Sys.file_exists path + Source.is_source path && Sys.file_exists path && not (Sys.is_directory path) (* [Filename.concat] of a directory and "." leaves the dot on the end, and the @@ -117,8 +117,8 @@ let resolve_dir ~file loc path = match split_path path with | None, rel -> let d = Filename.concat here rel in - if ok d then d else fail loc "no package at %s — wanted a directory or a \ - .flan file" d + if ok d then d else fail loc "no package at %s — wanted a directory, a \ + .flan file or a .fln file" d | Some collection, rel -> (match find_collection here collection with | None -> @@ -141,6 +141,14 @@ let entries dir suffix = |> List.sort String.compare |> List.map (Filename.concat dir) +(* A package directory's source files, in either syntax. *) +let source_entries dir = + Sys.readdir dir + |> Array.to_list + |> List.filter Source.is_source + |> List.sort String.compare + |> List.map (Filename.concat dir) + (* ── Qualifying an imported package ────────────────────────────────── *) let qualify alias n = alias ^ "/" ^ n @@ -1203,12 +1211,12 @@ let rec import ~seen ~open_ ~loc alias dir = Hashtbl.replace seen dir' (alias, []); let open_ = open_ @ [ (dir', alias) ] in let one_file = is_package_file dir in - let files = if one_file then [ dir ] else entries dir ".flan" in - if files = [] then fail loc "the package at %s has no .flan file" dir; + let files = if one_file then [ dir ] else source_entries dir in + if files = [] then fail loc "the package at %s has no .flan or .fln file" dir; (* Read once. The forms are wanted twice — for the imports below and for the macros at the end — and reading a file twice is the kind of second opinion this module spends its comments warning about. *) - let sources = List.map (fun f -> (f, Reader.read_file f)) files in + let sources = List.map (fun f -> (f, Source.read_file f)) files in (* What this package imports, resolved first and relative to itself. Its declarations come back already qualified under their own aliases, so the rename below leaves them alone: they are not in [owned]. diff --git a/lib/session.ml b/lib/session.ml index 9a5ea5dd..6cac3334 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -268,7 +268,7 @@ let of_forms ~debug ~x86 ~file forms = built = record_built env p p.Tast.fns SM.empty; live = SM.empty }, l) let create ?(debug = false) ?(x86 = false) ~file () = - of_forms ~debug ~x86 ~file (Reader.read_file file) + of_forms ~debug ~x86 ~file (Source.read_file file) (* ── A file loaded a form at a time, keeping what compiles ─────────── *) @@ -348,7 +348,7 @@ let create_dev ?(debug = false) ?(x86 = false) ~file () = of_forms ~debug ~x86 ~file (if declares_main forms then forms else forms @ stub_main ()) in - let (t, l), _, errs = pruned build (Reader.read_file file) in + let (t, l), _, errs = pruned build (Source.read_file file) in (t, l, errs) (* What a macro may call, for the same reason [macros] is held: an evaluation diff --git a/lib/source.ml b/lib/source.ml new file mode 100644 index 00000000..541f9fc6 --- /dev/null +++ b/lib/source.ml @@ -0,0 +1,20 @@ +(** A program source file, read by the reader its extension names: [.fln] is + the indented syntax ([Indent_reader]), anything else the paren syntax + ([Reader]). Both give the same [Form.t], so nothing past this point knows + which one a file was written in, and a program may mix them freely. + + Only program sources come through here. The prelude, the wire protocol and + the registry's spellings are paren text the compiler writes itself, and + read it with [Reader] directly. *) + +let indented_ext = ".fln" +let paren_ext = ".flan" + +let is_indented path = Filename.check_suffix path indented_ext + +(** A file a package directory contributes, in either syntax. *) +let is_source path = + Filename.check_suffix path paren_ext || is_indented path + +let read_file path = + if is_indented path then Indent_reader.read_file path else Reader.read_file path diff --git a/spec-syntax.md b/spec-syntax.md index 4800e773..e4d50942 100644 --- a/spec-syntax.md +++ b/spec-syntax.md @@ -99,61 +99,75 @@ Each item: the proposal, then the reason in one line. ### Lexical - **Extension `.fln`.** Short; `.flan` keeps meaning parens, so - `generated.flan` and every existing path stay valid. -- **Comments stay `;`.** Nothing else wants the character. + `generated.flan` and every existing path stay valid. **Built.** +- **Comments stay `;`.** Nothing else wants the character. **Built.** - **Spaces only.** A tab in indentation is an error. The corpus has no tabs. + **Built.** - **Indentation is measured in columns, any width.** A dedent must land on a column already on the stack (GDScript `gdscript_tokenizer.cpp:1291-1296`). + **Built.** - **Blank and comment-only lines never open or close a block** (GDScript - 1170-1239). + 1170-1239). **Built.** - **Inside `(` `[` `{`, newlines and indentation are ignored** except where a trailing block is allowed. Make it parser-driven, the way GDScript's `push_multiline` is (`gdscript_parser.cpp` 658-672, 3695-3770), not a paren counter in the lexer, or a block inside a call can't work. + *Built as a depth counter instead: inside brackets a line break is always + whitespace, so no block opens inside a call's parentheses (§3.1's blocks all + open after the `)`; a lambda with a block body is a statement or a value, + `let f = fn(x)` plus a block).* - **Continuation outside brackets:** a line that starts with a spaced infix operator (`+`, `and`, `==`, …) continues the previous line; so does a line after one that ends in a spaced infix operator. (F# `LexFilter.fs` 360-380, - 1850-1870, 2345-2360.) No `\` continuation. + 1850-1870, 2345-2360.) No `\` continuation. **Built** (`=` does not + continue: `let x =` plus a block is a block value). - **Minus.** `-` glued to a digit is a negative literal (`-1`; 269 in the corpus). `-` glued to a name is negation (`-x` becomes `(- x)`; no name starts with `-` except two prelude sentinels, `lib/prelude.ml:2280,2285`, which rename). `a - b` is subtraction. `a -1` is an error: "separate with a comma or - space the minus". -- **`->` needs spaces as the return arrow.** `dyn->f64` stays a name. + space the minus". **Built.** +- **`->` needs spaces as the return arrow.** `dyn->f64` stays a name. **Built.** - **Character literals stay `\c`**, lexed before brackets and operators: `\(`, `\,`, `\space`. 277 uses, many of them delimiters of the new syntax. + **Built.** ### Collections and separators - **Commas separate elements. With no commas, whitespace does, but only between single terms.** `[1 2 3]`, `[i n]`, `{.x 1 .y 2}` and `[4 f32]` read as today. `[a - 1 b]` is refused: "separate elements with commas". This keeps - the Lisp look for data and is refusable by shape. + the Lisp look for data and is refusable by shape. **Built** (in braces a + value may have an operator in it, `{.x a + 1, .y 2}`; the comma after it is + what is required). - **Struct literal:** `Vector2{.x 1, .y 2}` (brace glued to the name) reads `(Vector2 {.x 1 .y 2})`. A bare `{.x 1}` is today's bare literal. `{:a 1}` is a - dyn map. + dyn map. **Built.** - **No set literal.** Flan has none today: `#{1 2}` reads as the symbol `#` and - a map. Adding sets is a language change, not a syntax one. + a map. Adding sets is a language change, not a syntax one. *In a `.fln` file + `#{1 2}` reads `(# {1 2})`, a brace glued to a name.* ### Expressions - **Precedence**, low to high: `or` < `and` < `not` < comparisons (`== != < <= > >=`) < `<< >>` < `+ -` < `* / %` < unary `-` < postfix (call, - index, field). + index, field). **Built.** Mixing comparison operators in one chain, + `a < b <= c`, is refused. An operator glued to `(` is always a call. - **`==` is `=`; `=` is assignment.** `x = v` reads `(set x v)`, `a[i] = v` reads `(set (at a i) v)`, `p.x = v` reads `(set (.x p) v)`. `x += v` reads - `(set x (+ x v))`; like `++` today, the place is evaluated twice. + `(set x (+ x v))`; like `++` today, the place is evaluated twice. **Built** + (also `-=`, `*=`, `/=`). - **A run of the same operator flattens** (variadics, section 3): `a + b + c` reads `(+ a b c)`, `a < b < c` reads `(< a b c)` (Flan's chain semantics, `test/programs/chain.flan`). This keeps the converter round trip - exact (section 4). + exact (section 4). **Built.** - **Field access is postfix:** `camera.target.x` reads `(.x (.target camera))`. A capitalised left side is a qualified case, not a field: `Shape.Rect` stays one symbol. `test/programs/dev-rerun.flan:65` names a global - `.init-once.counter`; rename it. -- **`and`, `or`, `not` are words**, since they are Flan's own names. + `.init-once.counter`; rename it. **Built**, without the rename: it prints and + reads back through the fallback, `defonce(.init-once.counter, i64, 7)`. +- **`and`, `or`, `not` are words**, since they are Flan's own names. **Built.** - **Casts and type-taking builtins are calls:** `i32(x)`, `vec-new(u8)`, - `max-value(u8)`, `the([3 f32], [1 2 3.5])`. + `max-value(u8)`, `the([3 f32], [1 2 3.5])`. **Built.** ### Statements and blocks @@ -163,16 +177,19 @@ Each item: the proposal, then the reason in one line. which is how the printer writes a `let` that has siblings after it. Destructuring: `let {.x .y} = p`, `let [head & tail] = xs`. (`defer` is function-scoped, not let-scoped, `TODO.org` "defer may be written in a let", - so merging never moves a cleanup.) + so merging never moves a cleanup.) **Built**; `let x =` with the value as an + indented block also reads, and so does `def`/`once`/`const`. - **`if`/`elif`/`else`.** `else` and `elif` sit at the `if`'s column. No `elif` reads as `if` (with else) or `when` (without); with `elif` it reads as `cond`. - One-line form: `if c then a else b`, for use in a `let`. -- **`while c`, `until c`**, optional label first: `while :outer c`. + One-line form: `if c then a else b`, for use in a `let`. **Built** (a block + of one line is that line; of more, `(do …)`). +- **`while c`, `until c`**, optional label first: `while :outer c`. **Built.** - **`for i in range(n)`**, `range(a, b)`, `range(a, b, step)` read as `dotimes`. `range` here is syntax, not a function. `..` is avoided because - `a..b` would lex as one name. + `a..b` would lex as one name. **Built** (a label goes first here too: + `for :outer i in range(n)`). - **`return v`, `break`, `break :outer`, `continue`, `defer expr`** (or `defer` - plus a block). + plus a block). **Built**; `defer` plus a block reads `(defer a b …)`. - **`match`:** ``` @@ -182,7 +199,8 @@ Each item: the proposal, then the reason in one line. :north -> 0 _ -> 0 ``` - An arm's body can be an indented block, which reads as `(do …)`. + An arm's body can be an indented block, which reads as `(do …)`. **Built** (a + one-line block reads as that line). - **Conditions**, clauses at the header's column: ``` @@ -199,24 +217,30 @@ Each item: the proposal, then the reason in one line. v * 2 ``` `handler-bind` takes the same `on` clauses; the reader moves them in front of - the body, where the form wants them. -- **Unit:** `()` as a statement reads `(do)`; in a type it is `()`. -- **Lambda:** `fn(i, j) = i * 10 + j`, or `fn(i, j)` plus a block. + the body, where the form wants them. **Built.** +- **Unit:** `()` as a statement reads `(do)`; in a type it is `()`. **Built**; + inside an expression `()` stays `()`, and the printer writes a lone `()` + statement as `(())`. +- **Lambda:** `fn(i, j) = i * 10 + j`, or `fn(i, j)` plus a block. **Built**; + its parameters are bare names, as `(fn [i j] …)` wants, with no `dyn`. + `fn(…)` followed by anything else is the fallback call. ### Definitions - `fn name(a: i32, b) -> R` plus a block; `fn name(a) = expr` for one expression. Reads `(defn name [a i32 b dyn] R …)`. A `{:where …}` constraint - becomes `where ordered?($t)` after the return type. + becomes `where ordered?($t)` after the return type. **Built**, with `-> R` + required until step 6; several predicates are `where p, q`. - `def x = v`, `def x: T = v`, `once x: T`, `once x = v`, `const n = 3`, - `def scratch: [4 u8] = uninit`. + `def scratch: [4 u8] = uninit`. **Built.** `def x = v` and `once x = v` read + with `dyn`; `const n = 3` reads `(defconst n 3)`, its type inferred as today. - `struct Cell` with a `name: Type` line per field. `data Shape` with a line per case: `Circle(r: f32)`, `Empty`. `enum K` with `lo = -1`, `mid`. `union U` like - `struct`. -- `import rl "vendor:raylib"`. + `struct`. **Built** (an untyped field is `dyn`; `Empty()` is `(Empty [])`). +- `import rl "vendor:raylib"`. **Built.** - **Every other form uses the fallback** (next item) until someone asks for sugar: `defclass`, `defgeneric`, `defmulti`, `defmethod`, `declare`, - `declare-c`, `defalias`, `defmacro`, `loop`/`recur`, `array-fill`. + `declare-c`, `defalias`, `defmacro`, `loop`/`recur`, `array-fill`. **Built.** ### The fallback @@ -225,14 +249,16 @@ plus an indented block, reads as `(head arg … block…)`. Commas vanish into t `defmethod(describe, :square, [s]):` plus a block is `(defmethod describe :square [s] …)`. So every form is reachable on day one, the printer has something to fall back on, and the sugar above can land one -piece at a time. +piece at a time. **Built**; a header word glued to `(` is always this call, +`if(c, a)`, `let([x 1], x)`. ### Types After `:` and `->`, a small type grammar that reads to today's type forms: `i32`, `$t`, `()`, `[T]`, `[const T]`, `[n T]`, `Vec(T)`, `Map(K, V)`, `Option(T)`, `Ptr(T)`, `Ptr(const T)`, `Fn(A, B) -> R`, `CFn(A) -> R`, -`rl/Vector2`. +`rl/Vector2`. **Built** (the arrow is read only in a type position; inside a +value, `vec-new(Fn([i32], i32))` is the call spelling). ### Macro templates @@ -246,7 +272,9 @@ defmacro(with-mode-2d, [camera & body]): `quote` plus a block is a quasiquote; `~x` and `~@xs` are unquote and splice, the Clojure spellings the reader already has. (An earlier sketch used `$x`; -that collides with type variables such as `$t`.) +that collides with type variables such as `$t`.) **Built**: one line reads +`(quasiquote line)`, more read `(quasiquote (do …))`; `~` takes the atom right +after it, so `~name(x)` is `((unquote name) x)`, and `~(f(x))` unquotes a call. ## 3. Settled after review (2026-09-25) diff --git a/test/dune b/test/dune index 48c41582..ac95f19b 100644 --- a/test/dune +++ b/test/dune @@ -99,6 +99,27 @@ ; flan run --target=web is refused by the CLI, so the CLI has to be here. (file %{workspace_root}/bin/main.exe))) +; The indented syntax: its two hand-converted programs, the paren -> indented +; -> paren round trip over every .flan the build tree holds, and the import +; programs in test/syntax/mixed. Its own stanza for its deps: the round trip +; walks every directory that has a .flan in it, which is more than the corpus +; alias carries, and the other binaries have no use for the rest. +(test + (name test_syntax) + (modules test_syntax test_support watchdog own_tmp) + (libraries flan unix) + (deps + (alias corpus) + (source_tree syntax) + (file %{workspace_root}/conditions-play.flan) + (glob_files %{workspace_root}/spike/backend/*.flan) + (glob_files %{workspace_root}/spike/generics/*.flan) + (glob_files %{workspace_root}/spike/js/*.flan) + (glob_files %{workspace_root}/spike/x86/*.flan) + (glob_files %{workspace_root}/spike/x86/bench/*.flan) + (glob_files %{workspace_root}/web/examples/*.flan) + (glob_files %{workspace_root}/web/examples/geom/*.flan))) + ; The corpus a second time under ASan and UBSan. Its own alias and not part of ; `dune test`: a sanitized build is a statically linked 1.8MB binary that takes ; tens of seconds to produce, so the sweep is minutes against the existing diff --git a/test/syntax/algorithms.flan b/test/syntax/algorithms.flan new file mode 100644 index 00000000..c99ccb33 --- /dev/null +++ b/test/syntax/algorithms.flan @@ -0,0 +1,51 @@ +(import agent "vendor:agent") + +(defn find-match [str string pattern string] i32 + (dotimes [i (length str)] + (let [matched true] + (dotimes [j (length pattern)] + (when (!= (at str (+ i j)) (at pattern j)) + (set matched false))) + (when matched + (return i)))) + -1) + +(defn selection-sort [coll [$t]] () + {:where (ordered? $t)} + (let [len (length coll)] + (dotimes [i len] + (let [min-val i] + (dotimes [j (+ i 1) len] + (when (< (at coll j) (at coll min-val)) + (set min-val j))) + (let [tmp (at coll min-val)] + (set (at coll min-val) (at coll i)) + (set (at coll i) tmp)))))) + +(defn insertion-sort [coll [$t]] () + {:where (ordered? $t)} + (let [i 1 + length (length coll)] + (while (and (< i length)) + (let [j i] + (while (and (> j 0) + (< (at coll j) (at coll (dec j)))) + (let [temp (at coll j)] + (set (at coll j) (at coll (dec j))) + (set (at coll (dec j)) temp)) + (-- j))) + (++ i)))) + +(defn main [] i32 0) + +(comment + (insertion-sort [\I \N \S \E \R \T \I \O \N \S \O \R \T]) + (insertion-sort (slice [6 2 4 9 1 9 4 5] 0 8)) + (let [str (bytes "INSERTIONSORT")] + (insertion-sort str) + (println str)) + (let [str (bytes "SELECTIONSORT")] + (selection-sort str) + (println str)) + (find-match "aababba" "abba") + :-) diff --git a/test/syntax/algorithms.fln b/test/syntax/algorithms.fln new file mode 100644 index 00000000..eaaa4d7a --- /dev/null +++ b/test/syntax/algorithms.fln @@ -0,0 +1,52 @@ +; algorithms.flan, written by hand in the indented syntax. test_syntax reads +; both and wants the same forms. + +import agent "vendor:agent" + +fn find-match(str: string, pattern: string) -> i32 + for i in range(length(str)) + let matched = true + for j in range(length(pattern)) + if str[i + j] != pattern[j] + matched = false + if matched + return i + -1 + +fn selection-sort(coll: [$t]) -> () where ordered?($t) + let len = length(coll) + for i in range(len) + let min-val = i + for j in range(i + 1, len) + if coll[j] < coll[min-val] + min-val = j + let tmp = coll[min-val] + coll[min-val] = coll[i] + coll[i] = tmp + +fn insertion-sort(coll: [$t]) -> () where ordered?($t) + let i = 1 + let length = length(coll) + while and(i < length) + let j = i + while j > 0 + and coll[j] < coll[dec(j)] + let temp = coll[j] + coll[j] = coll[dec(j)] + coll[dec(j)] = temp + --(j) + ++(i) + +fn main() -> i32 = 0 + +comment(): + insertion-sort([\I \N \S \E \R \T \I \O \N \S \O \R \T]) + insertion-sort(slice([6 2 4 9 1 9 4 5], 0, 8)) + let str = bytes("INSERTIONSORT") + insertion-sort(str) + println(str) + let str = bytes("SELECTIONSORT") + selection-sort(str) + println(str) + find-match("aababba", "abba") + :- diff --git a/test/syntax/mixed/geo/geo.flan b/test/syntax/mixed/geo/geo.flan new file mode 100644 index 00000000..666d3d96 --- /dev/null +++ b/test/syntax/mixed/geo/geo.flan @@ -0,0 +1,10 @@ +;;;; A package written in the paren syntax, imported by ../main.fln. + +(defstruct Pt [x i32 y i32]) + +(defn pt [x i32 y i32] Pt (Pt {.x x .y y})) + +(defn dist2 [a Pt b Pt] i32 + (let [dx (- (.x a) (.x b)) + dy (- (.y a) (.y b))] + (+ (* dx dx) (* dy dy)))) diff --git a/test/syntax/mixed/main.flan b/test/syntax/mixed/main.flan new file mode 100644 index 00000000..d05e9a6d --- /dev/null +++ b/test/syntax/mixed/main.flan @@ -0,0 +1,11 @@ +;;;; A paren-syntax program importing a package written in the indented +;;;; syntax. main.fln is the other direction. + +(import shapes "shapes") + +(defn main [] i32 + (println (shapes/area (shapes/rect (i64 3) (i64 4)))) + (println (shapes/area (shapes/Shape.Circle {.r (i64 2)}))) + (println (shapes/area (shapes/Shape.Empty {}))) + (println (shapes/triangle 10)) + 0) diff --git a/test/syntax/mixed/main.fln b/test/syntax/mixed/main.fln new file mode 100644 index 00000000..d03e1649 --- /dev/null +++ b/test/syntax/mixed/main.fln @@ -0,0 +1,21 @@ +; An indented-syntax program importing a package written in the paren +; syntax. main.flan is the other direction. + +import geo "geo" + +fn far?(a: geo/Pt, b: geo/Pt, limit: i32) -> bool = geo/dist2(a, b) > limit * limit + +fn main() -> i32 + let a = geo/pt(1, 2) + let b = geo/Pt{.x 4, .y 6} + println(geo/dist2(a, b)) + println(a.x + b.y) + if far?(a, b, 4) + println("far") + else + println("near") + let n = 0 + while n < 3 + n += 1 + println(n) + 0 diff --git a/test/syntax/mixed/shapes/shapes.fln b/test/syntax/mixed/shapes/shapes.fln new file mode 100644 index 00000000..5917a8b2 --- /dev/null +++ b/test/syntax/mixed/shapes/shapes.fln @@ -0,0 +1,20 @@ +; A package written in the indented syntax, imported by ../main.flan. + +data Shape + Circle(r: i64) + Rect(w: i64, h: i64) + Empty() + +fn area(s: Shape) -> i64 + match s + Circle(r) -> 3 * r * r + Rect(w, h) -> w * h + Empty -> 0 + +fn rect(w: i64, h: i64) -> Shape = Shape.Rect{.w w, .h h} + +fn triangle(n: i32) -> i64 + let sum = i64(0) + for i in range(n + 1) + sum += i64(i) + sum diff --git a/test/syntax/sand.fln b/test/syntax/sand.fln new file mode 100644 index 00000000..1efab947 --- /dev/null +++ b/test/syntax/sand.fln @@ -0,0 +1,143 @@ +; sand.flan, written by hand in the indented syntax. test_syntax reads both +; and wants the same forms, and checks this one; nothing runs it. + +import rl "vendor:raylib" +import agent "vendor:agent" +import edn "vendor:edn" + +const screen-width = 900 +const screen-height = 600 +const cell-size = 5 +const rows = screen-height / cell-size +const cols = screen-width / cell-size +const brush-size = 10 + +fn dyn->f64(v: f64) -> f64 = v +fn dyn->u32(v: i64) -> u32 = u32(v) + +def gravity = 0.05 +def colors = + let v = vec-new(dyn) + push(v, 0xFFF00FFF) + push(v, 0x3B6E8CFF) + push(v, 0xA83232FF) + push(v, 0xCC6B1FFF) + v + +once grid: [rows [cols u32]] +once velocity: [rows [cols f32]] +once current-color = 0 + +fn clear-grid() -> () + grid = zeroed() + velocity = zeroed() + +fn next-color() -> () + current-color = (current-color + 1) % length(colors) + +fn paint-at(row: i32, col: i32) -> () + let half = brush-size / 2 + for x in range(brush-size) + for y in range(brush-size) + let r = y + (row - half) + let c = x + (col - half) + if r >= 0 and r < rows - 1 + and c >= 0 and c < cols - 1 + and 0 == grid[r, c] + and f32(rand()) < 0.5 + grid[r, c] = dyn->u32(colors[current-color]) + velocity[r, c] = 1.0 + +fn settle(row: i32, col: i32) -> () + let vel = f32(dyn->f64(gravity)) + velocity[row, col] + let y = min(rows - 1, row + i32(vel)) + while y > row + if 0 == grid[y, col] + grid[y, col] = grid[row, col] + grid[row, col] = 0 + velocity[y, col] = vel + velocity[row, col] = 0.0 + return + let left? = col > 0 and 0 == grid[y, col - 1] + let right? = col < cols - 1 and 0 == grid[y, col + 1] + if left? or right? + let side = + if not left? + 1 + elif not right? + -1 + else + if f32(rand()) < 0.5 then 1 else -1 + grid[y, col + side] = grid[row, col] + grid[row, col] = 0 + velocity[y, col + side] = vel + velocity[row, col] = 0.0 + return + y = y - 1 + velocity[row, col] = 0.0 + +fn step() -> () + let row = rows - 2 + while row >= 0 + for col in range(cols) + unless(0 == grid[row, col]): + settle(row, col) + row = row - 1 + +const fnv-offset: u64 = 0xcbf29ce484222325 +const fnv-prime: u64 = 1099511628211 + +fn hash-grid() -> u64 + let h = fnv-offset + for row in range(rows) + for col in range(cols) + let c = grid[row, col] + for b in range(4) + h = bit-xor(h, u64(bit-and(c >> u32(b * 8), 255))) + h = h * fnv-prime + h + +fn game-update() -> () + if rl/key-pressed?(:key-r) + clear-grid() + if rl/mouse-button-down?(:mouse-left) + let m = rl/get-mouse-position() + paint-at(i32(m.y) / cell-size, + i32(m.x) / cell-size) + if rl/mouse-button-released?(:mouse-left) + next-color() + step() + +fn game-draw() -> () + rl/clear-background(rl/black) + for row in range(rows) + for col in range(cols) + let c = grid[row, col] + unless(0 == c): + rl/draw-rectangle(i32(col * cell-size), + i32(row * cell-size), + cell-size, cell-size, + rl/get-color(c)) + rl/draw-fps(20, 20) + +once frame: Allocator = arena-new(262144) +def game-data = + handler-case + edn/read-file("game-data.edn") + on FileError(c) + nil + +fn main() -> () + rl/set-trace-log-level(:log-warning) + rl/init-window(screen-width, screen-height, "SAND") + defer rl/close-window() + rl/set-target-fps(120) + agent/start("/tmp/flan-sand.sock") + until rl/window-should-close?() + restart-case + agent/poll() + game-update() + restart continue() + () + rl/with-drawing(): + game-draw() diff --git a/test/test_syntax.ml b/test/test_syntax.ml new file mode 100644 index 00000000..54fb145a --- /dev/null +++ b/test/test_syntax.ml @@ -0,0 +1,285 @@ +(* The indented syntax (spec-syntax.md): its reader, its printer, and the + switch between the two readers by file extension. + + Four parts. Two programs hand-converted from paren to indented must read to + the same forms. Every corpus file must survive paren -> printed indented -> + read indented unchanged, up to the one merge the spec allows. A table pins + the lexical edge cases and the refusals, with their kinds. And a program in + each syntax importing a package in the other builds and runs the same on + both backends. *) + +open Flan + +let () = Watchdog.arm ~seconds:300 "test_syntax" + +let fail fmt = Test_support.fail fmt +let scratch = Test_support.scratch + +(* ── Forms, compared without locations ─────────────────────────────── *) + +let rec eq (a : Form.t) (b : Form.t) = + match a.v, b.v with + | Form.List x, Form.List y | Form.Vec x, Form.Vec y | Form.Map x, Form.Map y -> + List.length x = List.length y && List.for_all2 eq x y + | Form.Float x, Form.Float y -> + Int64.equal (Int64.bits_of_float x) (Int64.bits_of_float y) + | x, y -> x = y + +(* The innermost pair that differs, for the failure line. *) +let rec first_diff (a : Form.t) (b : Form.t) = + match a.v, b.v with + | (Form.List x, Form.List y | Form.Vec x, Form.Vec y | Form.Map x, Form.Map y) + when List.length x = List.length y -> + (match List.find_opt (fun (p, q) -> not (eq p q)) (List.combine x y) with + | Some (p, q) -> first_diff p q + | None -> (a, b)) + | _ -> (a, b) + +let same_forms a b = + List.length a = List.length b && List.for_all2 eq a b + +let describe_diff a b = + if List.length a <> List.length b then + Printf.sprintf "%d forms against %d" (List.length a) (List.length b) + else + match List.find_opt (fun (x, y) -> not (eq x y)) (List.combine a b) with + | Some (x, y) -> + let u, w = first_diff x y in + Printf.sprintf "wanted %s, read %s (at %d:%d)" (Form.to_string u) + (Form.to_string w) w.loc.Loc.line w.loc.Loc.col + | None -> "equal" + +(* A [let] whose whole body is another [let] is the merged [let]: spec §4 + step 3's one normalisation. Flan's [let] binds in order, so the two mean + the same thing. *) +let rec norm (f : Form.t) : Form.t = + let v = + match f.v with + | Form.List (({ v = Form.Sym "let"; _ } as h) :: { v = Form.Vec bs; loc } :: body) -> + (match List.map norm body with + | [ { v = Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bs2; _ } :: body2); _ } ] -> + Form.List (h :: Form.make (Form.Vec (List.map norm bs @ bs2)) loc :: body2) + | body -> Form.List (h :: Form.make (Form.Vec (List.map norm bs)) loc :: body)) + | Form.List l -> Form.List (List.map norm l) + | Form.Vec l -> Form.Vec (List.map norm l) + | Form.Map l -> Form.Map (List.map norm l) + | v -> v + in + { f with v } + +let diag_text = function + | Loc.Error d -> Printf.sprintf "%s %d:%d %s" d.Loc.kind d.dloc.Loc.line d.dloc.Loc.col d.dmsg + | e -> Printexc.to_string e + +(* ── The hand-converted pairs ──────────────────────────────────────── *) + +let pair flan fln = + match Reader.read_file flan, Source.read_file fln with + | a, b -> + if not (same_forms a b) then + fail "%s and %s read differently: %s" flan fln (describe_diff a b) + | exception e -> fail "%s / %s: %s" flan fln (diag_text e) + +let () = + pair "syntax/algorithms.flan" "syntax/algorithms.fln"; + pair "../sand.flan" "syntax/sand.fln"; + (* Checked, never run: sand opens a window. *) + List.iter + (fun f -> + match Front.checked f with + | _ -> () + | exception e -> fail "%s does not check: %s" f (diag_text e)) + [ "syntax/sand.fln"; "syntax/algorithms.fln" ] + +(* ── The round trip over the corpus ────────────────────────────────── *) + +(* Every .flan the build tree holds. [..] is the workspace root from here; + the deps in test/dune decide what is in it. *) +let corpus () = + let rec walk dir acc = + Array.fold_left + (fun acc name -> + let path = Filename.concat dir name in + if name <> "" && (name.[0] = '.' || name.[0] = '_') then acc + else if Sys.is_directory path then walk path acc + else if Filename.check_suffix name ".flan" then path :: acc + else acc) + acc (Sys.readdir dir) + in + List.sort String.compare (walk ".." []) + +let () = + let ok = ref 0 in + List.iter + (fun path -> + match Reader.read_file path with + | exception Loc.Error _ -> () (* not a program the paren reader takes *) + | forms -> + match Indent_printer.program forms with + | exception Indent_printer.Unprintable (f, why) -> + fail "round trip %s: %s at %d:%d" path why f.loc.Loc.line f.loc.Loc.col + | text -> + match Indent_reader.read_all ~file:(path ^ ".fln") text with + | exception e -> fail "round trip %s: %s" path (diag_text e) + | back -> + let a = List.map norm forms and b = List.map norm back in + if same_forms a b then incr ok + else fail "round trip %s: %s" path (describe_diff a b)) + (corpus ()); + Printf.printf "round trip: %d files\n" !ok; + (* The deps decide what is walked, and a stanza that lost them would pass + over nothing. *) + if !ok < 390 then fail "round trip covered only %d files" !ok + +(* ── Lexical edge cases ────────────────────────────────────────────── *) + +let read src = Indent_reader.read_all ~file:"" src + +let reads name src want = + match read src with + | forms -> + let got = String.concat "\n" (List.map Form.to_string forms) in + if got <> want then fail "%s: read %s, wanted %s" name got want + | exception e -> fail "%s: refused: %s" name (diag_text e) + +let refuses name src kind needle = + match read src with + | forms -> + fail "%s: read %s, wanted the refusal %s" name + (String.concat " " (List.map Form.to_string forms)) kind + | exception Loc.Error d -> + if d.Loc.kind <> kind then fail "%s: refused as %s, wanted %s (%s)" name d.Loc.kind kind d.dmsg + else if not (Test_support.contains d.dmsg needle) then + fail "%s: %s does not say %S: %s" name kind needle d.dmsg + | exception e -> fail "%s: %s" name (Printexc.to_string e) + +let () = + (* Minus. *) + reads "subtraction" "x = a - 1" "(set x (- a 1))"; + reads "negative literal" "x = -1" "(set x -1)"; + reads "negation" "x = -y" "(set x (- y))"; + reads "negation binds after postfix" "x = -p.x" "(set x (- (.x p)))"; + reads "lisp name" "x = a-b" "(set x a-b)"; + reads "decrement is a name" "--(j)" "(-- j)"; + reads "minus as a call" "x = -(a + b)" "(set x (- (+ a b)))"; + refuses "glued minus" "x = a -1" "indent/glued-minus" "a - 1"; + refuses "glued minus in a call" "f(a -1)" "indent/glued-minus" "space the minus"; + (* The arrow. *) + reads "return arrow" "fn f(x: i32) -> i32 = x" "(defn f [x i32] i32 x)"; + reads "arrow inside a name" "fn dyn->f64(v: f64) -> f64 = v" "(defn dyn->f64 [v f64] f64 v)"; + reads "function type" + "fn g(h: Fn(i32, i32) -> bool) -> () = h(1, 2)" + "(defn g [h (Fn [i32 i32] bool)] () (h 1 2))"; + reads "untyped parameter is dyn" "fn id(x) -> dyn = x" "(defn id [x dyn] dyn x)"; + refuses "no return type" "fn f(x)\n x" "indent/return-type" "-> i32"; + (* Characters, lexed before brackets and separators. *) + reads "character literals" "x = [\\( \\, \\space \\)]" "(set x [\\( \\, \\space \\)])"; + reads "character arguments" "f(\\,, \\))" "(f \\, \\))"; + (* Keywords and annotations. *) + reads "keyword" "def k = :else" "(def k dyn :else)"; + reads "annotation" "once grid: [4 [8 u32]]" "(defonce grid [4 [8 u32]])"; + reads "keyword argument" "rl/key-pressed?(:key-r)" "(rl/key-pressed? :key-r)"; + refuses "colon inside a name" "fn f(x:i32) -> () = x" "indent/colon-in-name" "x: i32"; + (* Adjacency. *) + reads "call" "f(a, b)" "(f a b)"; + reads "index" "x[i, j]" "(at x i j)"; + reads "call of a call" "f(a)(b)" "((f a) b)"; + reads "field chain" "camera.target.x" "(.x (.target camera))"; + reads "qualified case" "Shape.Rect" "Shape.Rect"; + reads "field of a call" "f(x).y" "(.y (f x))"; + reads "struct literal" "Vector2{.x 1, .y 2}" "(Vector2 {.x 1 .y 2})"; + reads "operator call" "+(a, b, c)" "(+ a b c)"; + reads "operator value" "reduce(+, 0, xs)" "(reduce + 0 xs)"; + refuses "spaced call" "f (a)" "indent/spaced-call" "f(...)"; + refuses "spaced index" "x [i]" "indent/spaced-index" "x[i]"; + refuses "missing comma" "f(a b)" "indent/missing-comma" "commas"; + refuses "unspaced operator" "x = f(a)+ b" "indent/unspaced-operator" "a + b"; + (* Collections. *) + reads "whitespace vector" "x = [i n]" "(set x [i n])"; + reads "comma vector" "x = [a - 1, b]" "(set x [(- a 1) b])"; + refuses "operator between spaces" "x = [a - 1 b]" "indent/separate-elements" "commas"; + reads "quoted list" "x = '(a b c)" "(set x (quote (a b c)))"; + (* Trailing colon blocks. *) + reads "trailing block" "rl/with-drawing():\n clear()\n draw()" + "(rl/with-drawing (clear) (draw))"; + reads "fallback with a block" "defmethod(describe, :square, [s]):\n s" + "(defmethod describe :square [s] s)"; + refuses "block without the colon" "f(x)\n y" "indent/stray-indent" "trailing colon"; + refuses "colon on a non-call" "x:\n y" "indent/colon-block" "x():"; + (* Indentation. *) + refuses "tab" "fn f() -> ()\n\tg()" "indent/tab" "spaces"; + refuses "dedent to no block" "if a\n b\n c" "indent/dedent" "column 3"; + reads "blank and comment lines" "if a\n\n ; note\n b\n\n; more\nc" + "(when a b)\nc"; + (* Continuation lines. *) + reads "trailing operator" "x = a +\n b" "(set x (+ a b))"; + reads "leading operator" "x = a\n + b" "(set x (+ a b))"; + reads "continued condition" "if a\n and b\n c" "(when (and a b) c)"; + (* Runs of one operator. *) + reads "flattened" "x = a + b + c" "(set x (+ a b c))"; + reads "chain" "x = a < b < c" "(set x (< a b c))"; + reads "left to right" "x = a - b + c" "(set x (+ (- a b) c))"; + reads "precedence" "x = a or b and not c == d" "(set x (or a (and b (not (= c d)))))"; + refuses "not-equal chain" "x = a != b != c" "indent/chained-not-equal" "!=(a, b, c)"; + reads "not-equal call" "x = !=(a, b, c)" "(set x (!= a b c))"; + refuses "mixed comparison" "x = a < b <= c" "indent/mixed-comparison" "and"; + (* Statements. *) + reads "lets merge" "fn f() -> i32\n let a = 1\n let b = 2\n a + b" + "(defn f [] i32 (let [a 1 b 2] (+ a b)))"; + reads "let with a block" "let a = 1\n a\nb" "(let [a 1] a)\nb"; + reads "elif" "if a\n 1\nelif b\n 2\nelse\n 3" "(cond a 1 b 2 :else 3)"; + reads "one-line if" "x = if a then 1 else 2" "(set x (if a 1 2))"; + reads "assignment ops" "a[i] += 1" "(set (at a i) (+ (at a i) 1))"; + reads "for" "for :outer i in range(1, n)\n f(i)" "(dotimes :outer [i 1 n] (f i))"; + reads "unit statement" "restart-case\n f()\nrestart continue()\n ()" + "(restart-case (f) (continue [] (do)))"; + reads "match" "match s\n Circle(r) -> r\n _ ->\n a()\n b()" + "(match s (Circle r) r _ (do (a) (b)))"; + reads "handler-bind moves the clauses" "handler-bind\n f()\non E(c)\n g(c)" + "(handler-bind [(E [c] (g c))] (f))"; + reads "quote block" + "defmacro(m, [x & ys]):\n quote\n f(~x)\n ~@ys" + "(defmacro m [x & ys] (quasiquote (do (f (unquote x)) (unquote-splicing ys))))"; + reads "lambda" "g = fn(i, j) = i * 10 + j" "(set g (fn [i j] (+ (* i 10) j)))"; + reads "lambda with a block" "g = fn(i)\n a(i)\n b(i)" "(set g (fn [i] (a i) (b i)))"; + reads "where" "fn s(xs: [$t]) -> () where ordered?($t) = f(xs)" + "(defn s [xs [$t]] () {:where (ordered? $t)} (f xs))"; + reads "data" "data Shape\n Circle(r: f32)\n Empty" + "(defdata Shape [(Circle [r f32]) Empty])"; + reads "enum" "enum K\n lo = -1\n mid" "(defenum K [lo -1 mid])"; + reads "struct" "struct Cell\n row: i32\n tag" "(defstruct Cell [row i32 tag dyn])"; + reads "read-only pointer" "def p: Ptr(const u8) = uninit" "(def p (Ptr const u8) uninit)" + +(* ── Both directions of an import, on both backends ────────────────── *) + +let run_both path want = + List.iter + (fun x86 -> + let exe = + Filename.concat scratch + (Printf.sprintf "flan-syntax-%s-%d%s" + (Filename.basename path) (Unix.getpid ()) (if x86 then "-x86" else "")) + in + match + let p, csrcs, lflags = Test_support.linked path in + ignore (Build.executable ~opts:{ Build.default with x86 } ~csrcs ~lflags p ~out:exe) + with + | exception e -> fail "%s%s does not build: %s" path (if x86 then " --x86" else "") (diag_text e) + | () -> + let out = exe ^ ".out" in + let code = Sys.command (Filename.quote exe ^ " > " ^ Filename.quote out ^ " 2>&1") in + let text = In_channel.with_open_bin out In_channel.input_all in + (try Sys.remove out; Sys.remove exe with Sys_error _ -> ()); + if code <> 0 || text <> want then + fail "%s%s printed %S and exited %d, wanted %S" path + (if x86 then " --x86" else "") text code want) + [ false; true ] + +let () = + if Test_support.have "clang" then begin + run_both "syntax/mixed/main.flan" "12\n12\n0\n55\n"; + run_both "syntax/mixed/main.fln" "25\n7\nfar\n3\n" + end + else print_endline "syntax: no clang, the import programs are not built" + +let () = Test_support.report ~label:"syntax" () From b0323606fc8376a068354571c912229ba15560e1 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:14:27 +0700 Subject: [PATCH 02/15] spike/ is gone: the x86 and JS surveys and the cells check live in test/, their probes in test/programs as x86-p* and js-p*, and dump.sh in tools/ --- docs/BUGS-2026-09-18.md | 2 +- docs/BUILT.md | 14 +- docs/SPIKE-GENERICS.md | 1 + docs/handoffs/HANDOFF-arith.md | 2 +- docs/handoffs/HANDOFF-cimport-ptr.md | 4 +- docs/handoffs/HANDOFF-devtest-noise.md | 4 +- docs/handoffs/HANDOFF-emacs-flake.md | 4 +- docs/handoffs/HANDOFF-lowering-buffer.md | 2 +- docs/handoffs/HANDOFF-rot.md | 8 +- docs/handoffs/HANDOFF-tidy.md | 2 +- docs/handoffs/HANDOFF-x86-abi-marker.md | 6 +- docs/handoffs/HANDOFF-x86-aggregates.md | 4 +- docs/handoffs/HANDOFF-x86-annotate.md | 8 +- docs/handoffs/HANDOFF-x86-cost.md | 2 +- docs/handoffs/HANDOFF-x86-debug.md | 4 +- docs/handoffs/HANDOFF-x86-devloop.md | 8 +- docs/handoffs/HANDOFF-x86-guards.md | 16 +- docs/handoffs/HANDOFF-x86-macro-visibility.md | 2 +- docs/handoffs/HANDOFF-x86-redef.md | 10 +- docs/handoffs/HANDOFF-x86-rt.md | 22 +- lib/emit.ml | 2 +- lib/js.ml | 2 +- lib/x86.ml | 6 +- plan.org | 2 +- spike/backend/driver.ml | 177 -------- spike/backend/hist.ml | 87 ---- spike/backend/jit_stubs.c | 100 ----- spike/backend/probe.flan | 24 -- spike/backend/run.sh | 48 --- spike/backend/x86.ml | 379 ------------------ spike/embed/.gitignore | 14 - spike/embed/baseline.c | 4 - spike/embed/dynload_stubs.c | 149 ------- spike/embed/gc_ml.ml | 21 - spike/embed/harness1.c | 14 - spike/embed/harness2.c | 54 --- spike/embed/harness3.c | 14 - spike/embed/harness4.c | 106 ----- spike/embed/harness5.c | 91 ----- spike/embed/harness5b.c | 110 ----- spike/embed/harness6.c | 61 --- spike/embed/hello_ml.ml | 5 - spike/embed/merged.sh | 66 --- spike/embed/merged_main.c | 77 ---- spike/embed/run.sh | 76 ---- spike/embed/sig.sh | 23 -- spike/embed/sig_ml.ml | 34 -- spike/embed/stubs_ml.ml | 26 -- spike/embed/symbols.sh | 50 --- spike/embed/thread_ml.ml | 32 -- spike/embed/whole_ml.ml | 40 -- spike/generics/id.flan | 7 - spike/generics/measure.ml | 171 -------- spike/generics/prelude-shapes.flan | 51 --- spike/generics/reject.flan | 4 - spike/generics/run.sh | 28 -- spike/generics/runaway.flan | 3 - spike/generics/sort.flan | 25 -- spike/generics/swap.flan | 19 - spike/generics/two-vars.flan | 5 - spike/x86/COST.md | 210 ---------- spike/x86/annot.sh | 101 ----- spike/x86/bench.sh | 86 ---- spike/x86/bench/b1-calls.flan | 20 - spike/x86/bench/b2-bounds.flan | 20 - spike/x86/bench/b3-spill.flan | 21 - spike/x86/bench/b4-copy.flan | 20 - spike/x86/cost-bench.tsv | 5 - spike/x86/cost-corpus.tsv | 98 ----- spike/x86/cost.sh | 135 ------- {spike/x86 => test}/cell-override.c | 2 +- {spike/x86 => test}/cells.sh | 4 +- test/dune | 36 +- .../programs/js-p1-int-semantics.flan | 0 .../programs/js-p2-value-copies.flan | 0 .../programs/x86-p1-exit.flan | 0 .../programs/x86-p10-defer-transfer.flan | 0 .../programs/x86-p11-reversed-slice.flan | 0 .../programs/x86-p11-shift-edges.flan | 0 .../programs/x86-p12-handler-value.flan | 0 .../programs/x86-p13-dyn-collect.flan | 0 .../programs/x86-p2-loop-print.flan | 0 .../programs/x86-p3-fizz.flan | 0 .../programs/x86-p4-convention.flan | 0 .../programs/x86-p5-core.flan | 0 .../programs/x86-p6-transfer.flan | 0 .../programs/x86-p7-slice-from-ptr.flan | 0 .../programs/x86-p8-cell.flan | 2 +- .../programs/x86-p9-dead-defers.flan | 0 spike/js/survey.sh => test/survey-js.sh | 14 +- spike/x86/survey.sh => test/survey-x86.sh | 23 +- test/test_acceptance.ml | 2 +- test/test_sanitize.ml | 4 +- {spike/x86 => tools}/dump.sh | 4 +- web/index.html | 4 +- 95 files changed, 107 insertions(+), 3036 deletions(-) delete mode 100644 spike/backend/driver.ml delete mode 100644 spike/backend/hist.ml delete mode 100644 spike/backend/jit_stubs.c delete mode 100644 spike/backend/probe.flan delete mode 100644 spike/backend/run.sh delete mode 100644 spike/backend/x86.ml delete mode 100644 spike/embed/.gitignore delete mode 100644 spike/embed/baseline.c delete mode 100644 spike/embed/dynload_stubs.c delete mode 100644 spike/embed/gc_ml.ml delete mode 100644 spike/embed/harness1.c delete mode 100644 spike/embed/harness2.c delete mode 100644 spike/embed/harness3.c delete mode 100644 spike/embed/harness4.c delete mode 100644 spike/embed/harness5.c delete mode 100644 spike/embed/harness5b.c delete mode 100644 spike/embed/harness6.c delete mode 100644 spike/embed/hello_ml.ml delete mode 100644 spike/embed/merged.sh delete mode 100644 spike/embed/merged_main.c delete mode 100644 spike/embed/run.sh delete mode 100644 spike/embed/sig.sh delete mode 100644 spike/embed/sig_ml.ml delete mode 100644 spike/embed/stubs_ml.ml delete mode 100644 spike/embed/symbols.sh delete mode 100644 spike/embed/thread_ml.ml delete mode 100644 spike/embed/whole_ml.ml delete mode 100644 spike/generics/id.flan delete mode 100644 spike/generics/measure.ml delete mode 100644 spike/generics/prelude-shapes.flan delete mode 100644 spike/generics/reject.flan delete mode 100644 spike/generics/run.sh delete mode 100644 spike/generics/runaway.flan delete mode 100644 spike/generics/sort.flan delete mode 100644 spike/generics/swap.flan delete mode 100644 spike/generics/two-vars.flan delete mode 100644 spike/x86/COST.md delete mode 100755 spike/x86/annot.sh delete mode 100755 spike/x86/bench.sh delete mode 100644 spike/x86/bench/b1-calls.flan delete mode 100644 spike/x86/bench/b2-bounds.flan delete mode 100644 spike/x86/bench/b3-spill.flan delete mode 100644 spike/x86/bench/b4-copy.flan delete mode 100644 spike/x86/cost-bench.tsv delete mode 100644 spike/x86/cost-corpus.tsv delete mode 100755 spike/x86/cost.sh rename {spike/x86 => test}/cell-override.c (94%) rename {spike/x86 => test}/cells.sh (97%) rename spike/js/p1-int-semantics.flan => test/programs/js-p1-int-semantics.flan (100%) rename spike/js/p2-value-copies.flan => test/programs/js-p2-value-copies.flan (100%) rename spike/x86/p1-exit.flan => test/programs/x86-p1-exit.flan (100%) rename spike/x86/p10-defer-transfer.flan => test/programs/x86-p10-defer-transfer.flan (100%) rename spike/x86/p11-reversed-slice.flan => test/programs/x86-p11-reversed-slice.flan (100%) rename spike/x86/p11-shift-edges.flan => test/programs/x86-p11-shift-edges.flan (100%) rename spike/x86/p12-handler-value.flan => test/programs/x86-p12-handler-value.flan (100%) rename spike/x86/p13-dyn-collect.flan => test/programs/x86-p13-dyn-collect.flan (100%) rename spike/x86/p2-loop-print.flan => test/programs/x86-p2-loop-print.flan (100%) rename spike/x86/p3-fizz.flan => test/programs/x86-p3-fizz.flan (100%) rename spike/x86/p4-convention.flan => test/programs/x86-p4-convention.flan (100%) rename spike/x86/p5-core.flan => test/programs/x86-p5-core.flan (100%) rename spike/x86/p6-transfer.flan => test/programs/x86-p6-transfer.flan (100%) rename spike/x86/p7-slice-from-ptr.flan => test/programs/x86-p7-slice-from-ptr.flan (100%) rename spike/x86/p8-cell.flan => test/programs/x86-p8-cell.flan (93%) rename spike/x86/p9-dead-defers.flan => test/programs/x86-p9-dead-defers.flan (100%) rename spike/js/survey.sh => test/survey-js.sh (94%) rename spike/x86/survey.sh => test/survey-x86.sh (91%) rename {spike/x86 => tools}/dump.sh (98%) diff --git a/docs/BUGS-2026-09-18.md b/docs/BUGS-2026-09-18.md index 094ec6e4..b7f923e8 100644 --- a/docs/BUGS-2026-09-18.md +++ b/docs/BUGS-2026-09-18.md @@ -64,7 +64,7 @@ claims the hardware masks to operand width; it masks to 63. `emit.ml:2041` masks `bits-1` explicitly (TODO.org, "A shift count is bounded two different ways", records this as the language's rule). Six confirmed divergences, e.g. `(<< x 32)` on i32: LLVM 1, x86 0; `(>> i8min 8)`: LLVM --128, x86 -1. Invisible because `spike/x86/survey.sh:80` never globs `spike/js/*.flan`, +-128, x86 -1. Invisible because `test/survey-x86.sh:80` never globs `spike/js/*.flan`, where `p1-int-semantics.flan` already catches it — widen the glob in the same lane. Same wide-compute root, second divergence: float→int overflow under `--no-bounds-checks` gives 0 on x86 (64-bit `cvttsd2si` then truncate) vs INT_MIN on LLVM. Acknowledged-UB diff --git a/docs/BUILT.md b/docs/BUILT.md index 2fc8b761..17f3f03a 100644 --- a/docs/BUILT.md +++ b/docs/BUILT.md @@ -1265,7 +1265,7 @@ looked wrong. ### Proved by comparing output, never by reading bytes -`spike/x86/survey.sh` builds each program in `test/programs` and each probe in `spike/x86` twice — once default, once +`test/survey-x86.sh` builds each program in `test/programs`, the `x86-p*` probes among them, twice — once default, once `--x86`, **with the same bounds-check setting on both sides** — runs both, and compares stdout, stderr and the exit status. stderr is not a detail: every message the condition machinery produces goes there, each carrying a location this backend emits by hand as a `.rodata` label and a length in a register, and an exit status of 134 with the wrong @@ -1374,7 +1374,7 @@ must not land in the middle of one; and the `flan_dev_reg_enable` constructor, w **The corpus structurally cannot test this.** A dev build starts with every cell pointing at the body this build compiled, so it prints what a release build prints whether or not anything reads the cell — the property that makes -the whole corpus a safe test of the cells is the property that makes it a useless one. `spike/x86/cells.sh` preloads +the whole corpus a safe test of the cells is the property that makes it a useless one. `test/cells.sh` preloads a shared object whose constructor looks up `flan.cell.twice` with `dlsym` and stores a different body there: the one store a redefinition ends in, done from outside with no compiler involved. Four builds, and the two release rows are half the test — they answer `42 42` because there is no cell and `dlsym` finds nothing, which is what says the change @@ -1400,7 +1400,7 @@ refused. What it does not emit is locals and types, and that is deliberate — a temporary whose lifetime this backend does not model, so there is nothing honest for a `DW_TAG_variable` to point at. A backtrace names files, functions and lines; `print x` says the name is not in the current context. A `flan dev --debug` session still takes LLVM's side, because `X86.redefinition` emits no line table. -- **Code size and speed** are measured, in `spike/x86/COST.md`. This backend emits **3.84× the code LLVM does at +- **Code size and speed** were measured in `spike/x86/COST.md`, since deleted with `spike/` and in git history. This backend emits **3.84× the code LLVM does at `-O2` and 1.92× what LLVM emits at `-O0`** — half the factor is the optimiser and not the backend. Of the five suspected costs, the frame-slot round trip on every intermediate is most of everything and is the one worth fixing; `rep movsb` is twenty cycles a copy and worth fixing cheaply; the bounds check's three temporaries cost 241 bytes @@ -1562,7 +1562,7 @@ least two" — and lets the old caller fail at run time with a wrong-number-of-a count at run time to fail on, so the run-time half is a check it has to emit. **A dev cell is three words**: `{ ptr body, i64 word, ptr text }`. The body is first, so a plain load of the cell is -still the body and `spike/x86/cells.sh`'s store through `dlsym` still works. The word is a hash (FNV-1a) of the +still the body and `test/cells.sh`'s store through `dlsym` still works. The word is a hash (FNV-1a) of the signature spelled the way a `defn` writes it — `[i64 i64] i64` — and the text is that spelling as a C string. `Emit.sig_text` and `Emit.sig_word` are the one definition both backends use. A redefinition module's installer stores the word and the text beside the body; a registry cell (`flan_dev_cell`) is three zeroed words until then. @@ -1841,8 +1841,8 @@ the merged entry point uses to flush and park. #### What the embedding spike measured, and the three rules it left behind The merge was taken on a spike run before any of it was built — `spike/embed/`, four shell scripts and sixteen small -sources driving `ocamlfind` and `clang` by hand against the `flan.cmxa` dune already builds. Nothing under `spike/` is -wired into the build. What it answered is why the shape above was safe to commit to. +sources driving `ocamlfind` and `clang` by hand against the `flan.cmxa` dune already builds, deleted since and kept in +git history. What it answered is why the shape above was safe to commit to. **Linking.** `ocamlopt -output-complete-obj`, not `-output-obj`: it bundles the runtime, so there is no hunt for `libasmrun`. The final link needs `-lm -lpthread -ldl` and, on 5.x, **`-lzstd`** — the marshaller is compressed, and @@ -1861,7 +1861,7 @@ specific capability the merged design needs. expected conflict does not exist. The reason is structural: OCaml 5 detects stack overflow with an explicit stack-limit check rather than with a guard page and a SIGSEGV handler. So the break loop can take `SIGSEGV` outright and does not have to install first or last. **This is an `x86_64-pc-linux-gnu` measurement only** — re-run -`spike/embed/sig.sh` on macOS/arm64 before relying on it there. `flan_agent.c` needs nothing from it either way; it +`spike/embed/sig.sh` (git history) on macOS/arm64 before relying on it there. `flan_agent.c` needs nothing from it either way; it sends with `MSG_NOSIGNAL` throughout. **The GC and raw memory.** An 8 MiB arena filled with a checkable pattern, 64 raw interior pointers taken into it, diff --git a/docs/SPIKE-GENERICS.md b/docs/SPIKE-GENERICS.md index 1533da17..d7dfa36e 100644 --- a/docs/SPIKE-GENERICS.md +++ b/docs/SPIKE-GENERICS.md @@ -10,6 +10,7 @@ > and nested inside `[$t]` or `(Option $t)`, and bare `t` only where a type's *name* is an argument in > expression position, as in `(vec-new t)` and the cast `(t x)`. `(Option t)` does not compile. > plan.org's Types section and spec-memory.md's Generics section are the current account. +> `spike/`, which held every file this report names, was deleted on 2026-09-25; the files are in git history. Milestone 5's parametric polymorphism, run early and deliberately out of order, as a spike rather than as a decision. **Feasible, and smaller than expected.** A generic function written in Flan goes through the ordinary diff --git a/docs/handoffs/HANDOFF-arith.md b/docs/handoffs/HANDOFF-arith.md index 0b512cd6..6f673f1b 100644 --- a/docs/handoffs/HANDOFF-arith.md +++ b/docs/handoffs/HANDOFF-arith.md @@ -76,7 +76,7 @@ because `load_loc` has already widened both operands according to their own sign backends used to diverge silently rather than both dying: x86 divided in 64 bits and truncated on the store, producing `-2147483648` for an `i32`, where LLVM emitted poison. `arith.flan` has an `i32` case for exactly that reason. -`spike/x86/survey.sh` is 101 MATCH / 0 DIFFER / 0 REFUSED, with the two programs this change adds among them. +`test/survey-x86.sh` is 101 MATCH / 0 DIFFER / 0 REFUSED, with the two programs this change adds among them. `arith.flan` carries an `i32` overflow case and an `f32` cast case on purpose, and neither is padding. The `i32` overflow is where the two backends disagreed *silently* rather than both dying, and it is the only thing that diff --git a/docs/handoffs/HANDOFF-cimport-ptr.md b/docs/handoffs/HANDOFF-cimport-ptr.md index ac32f351..6349a518 100644 --- a/docs/handoffs/HANDOFF-cimport-ptr.md +++ b/docs/handoffs/HANDOFF-cimport-ptr.md @@ -124,11 +124,11 @@ actually about is a **pointer reinterpretation**, which is not a checker arm. `defstruct`, every hand-written `declare-c` and every mapped constant against `raylib-5.5.h` and refuses to write when they disagree. - `bash web/examples/check.sh` green. -- `spike/x86/survey.sh` on the finished tree: **103 MATCH, 0 DIFFER, 0 REFUSED** (38 skip +- `test/survey-x86.sh` on the finished tree: **103 MATCH, 0 DIFFER, 0 REFUSED** (38 skip — 28 that do not compile on purpose, 8 with no main, 2 that run forever). Expected rather than surprising: nothing here is below the IR, and the one surveyed program that changed is `test/programs/raylib-codepoints.flan`. Run it detached — `setsid timeout - 2400 spike/x86/survey.sh > log 2>&1 log 2>&1 log 2>&1 log 2>&1 log 2>&1 log 2>&1 log 2>&1 log 2>&1 ` beside ``. @@ -112,7 +112,7 @@ fixtures did **not** fail here — `/tmp` had room throughout (6% used at start **Yes, reached and tested.** And the test is the interesting part, because *the corpus cannot do it*: a dev build starts with every cell pointing at the body that build compiled, so it prints exactly what a release build prints -whether or not anything reads the cell. `spike/x86/cells.sh` preloads a `.so` whose constructor `dlsym`s +whether or not anything reads the cell. `test/cells.sh` preloads a `.so` whose constructor `dlsym`s `flan.cell.twice` (the cells are in `.dynsym` — a dev build is `-rdynamic`) and stores a different body there. Four builds; the two release rows are the control that says the effect is the indirection and not symbol interposition: @@ -162,5 +162,5 @@ returned a struct. `cells.sh` does not reach it: the body it installs is `(i64, bounds check, every intermediate in memory, `rep movsb` block copies, and now an extra load per call site in a dev build — which is the one item `emit.ml` pays too. -**Also worth doing and not a backend item: run `spike/x86/survey.sh` in CI.** The 2 refusals this lane found were a +**Also worth doing and not a backend item: run `test/survey-x86.sh` in CI.** The 2 refusals this lane found were a month-old lane's new prim, and nothing noticed. A backend that refuses by name does not rot quietly, but it does rot. diff --git a/lib/emit.ml b/lib/emit.ml index 3572b27b..ae0d1b72 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -81,7 +81,7 @@ let cellname n = "@" ^ quoted (Mangle.cell n) { ptr body, i64 word, ptr text } The body is first, so everything that only ever wanted the body — a load - of the cell, [spike/x86/cells.sh]'s store through [dlsym] — reads the + of the cell, [test/cells.sh]'s store through [dlsym] — reads the same address it always did. The word is what makes a signature change installable. A redefinition that diff --git a/lib/js.ml b/lib/js.ml index 221faf9e..74f86563 100644 --- a/lib/js.ml +++ b/lib/js.ml @@ -135,7 +135,7 @@ {1 Where this stops, and what the next lane picks up} - [spike/js/survey.sh] is the standing measurement: 24 MATCH, 0 DIFFER, 77 + [test/survey-js.sh] is the standing measurement: 24 MATCH, 0 DIFFER, 77 refused by name, 0 that node would not run, over the corpus and this file's own two probes. What the refusals say about the order to work in: diff --git a/lib/x86.ml b/lib/x86.ml index bcf1ae79..e7631275 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -1,6 +1,6 @@ (** Tast -> x86-64, by hand. The dev backend; LLVM stays the release one. - Grown out of [spike/backend/x86.ml], which proved the shape. What is new + Grown out of a spike's [x86.ml], which proved the shape and is in git history. What is new here is everything the spike enumerated and did not do: aggregates, floats, globals, string literals, the transfer channel, and a whole program rather than one function. @@ -4273,7 +4273,7 @@ let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false) transfer exit are dead because no path names that exit. This used to be a refusal, on the theory that a function with a defer and no transfer exit was a sign the reasoning had gone wrong. It is not — it is every leaf - function with a defer, and [spike/x86/p9-dead-defers.flan] is ten lines + function with a defer, and [test/programs/x86-p9-dead-defers.flan] is ten lines of it. [emit.ml]'s [emit_fn] writes the whole exit under the same [if f.unwound], and so drops them too. @@ -5048,7 +5048,7 @@ let program ~checks ?(dev = false) ?(debug = false) ?(annotate = false) # installed while the process runs is reached by the next call.\n\ #\n\ # What is not here are mnemonics. The bytes are a blob so that every\n\ - # offset stays exactly known, and spike/x86/dump.sh puts objdump's\n\ + # offset stays exactly known, and tools/dump.sh puts objdump's\n\ # disassembly of this same object beside this file: that one says what,\n\ # and this one says why.\n"; (* A numbered [.file] is what stops clang's integrated assembler from diff --git a/plan.org b/plan.org index 060ad2dd..cc973a99 100644 --- a/plan.org +++ b/plan.org @@ -525,7 +525,7 @@ on. machine code directly and is selected with ~--x86~; it exists because ~llc~ is most of the 19ms above. It is a different route from the same typed IR to the same observable behaviour, not a different semantics, and what holds it to that -is ~spike/x86/survey.sh~: every program in the corpus is built both ways and +is ~test/survey-x86.sh~: every program in the corpus is built both ways and byte-compared on stdout, stderr and exit status. At the time of writing that is 103 MATCH, 0 DIFFER, 0 refused by name. It handles conditions, bounds checks, indirection cells, redefinition modules and DWARF line tables; what it does not diff --git a/spike/backend/driver.ml b/spike/backend/driver.ml deleted file mode 100644 index fde8ce49..00000000 --- a/spike/backend/driver.ml +++ /dev/null @@ -1,177 +0,0 @@ -(* The spike's harness: run the real frontend, lower the functions it produced - with [X86], put the bytes in executable memory, call them, and compare with - what the language says they should answer. - - The comparison is the whole point. Reading the bytes proves nothing -- a - disassembly that looks right and a program that returns the wrong number is - the normal outcome of hand-encoding, which is why the oracle here is the - arithmetic and not objdump. [oracle.sh] disassembles the same buffer, and - that is a debugging aid, not the evidence. *) - -external jit_alloc : int -> nativeint = "spike_jit_alloc" -external jit_write : nativeint -> string -> unit = "spike_jit_write" -external jit_protect : nativeint -> int -> unit = "spike_jit_protect" -external call1 : nativeint -> int64 -> int64 = "spike_call1" -external call2 : nativeint -> int64 -> int64 -> int64 = "spike_call2" -external sym : string -> nativeint = "spike_sym" - -let failures = ref 0 -let checks = ref 0 - -let check name got want = - incr checks; - if got = want then Printf.printf " ok %-28s = %Ld\n" name got - else begin - incr failures; - Printf.printf " FAIL %-28s = %Ld, want %Ld\n" name got want - end - -(* One page per function, so that a function that runs off its own end lands in - an unmapped page and segfaults at the fault rather than in the middle of the - next function. This is the crudest possible version of the code-object - question the whole exercise is really about. *) -let page = 4096 - -let install (code : string) : nativeint = - if String.length code > page then failwith "function exceeds one page"; - let p = jit_alloc page in - jit_write p code; - jit_protect p page; - p - -let run src = - let decls = - Flan.Load.program ~file:src (Flan.Parse.program_all (Flan.Reader.read_file src)) - in - let prog = Flan.Check.program_all decls.Flan.Load.decls in - Printf.printf "frontend: %d fns, %d globals, %d structs, %d externs\n" - (List.length prog.Flan.Tast.fns) (List.length prog.Flan.Tast.globals) - (List.length prog.Flan.Tast.structs) (List.length prog.Flan.Tast.externs); - - (* Two passes, because [spike-calls] calls functions whose addresses are not - known until they are installed. Pass one installs every function at a - fixed page; pass two emits the real code into it. A real backend does this - with relocations; the spike does it by emitting twice, which is the same - answer with none of the machinery. *) - let addrs : (string, nativeint) Hashtbl.t = Hashtbl.create 16 in - let unsupported = ref [] in - let lowerable = - List.filter - (fun (fd : Flan.Tast.fn) -> - try - ignore (X86.fn ~resolve:(fun _ -> 0L) fd); - true - with X86.Unsupported m -> - unsupported := (fd.Flan.Tast.name, m) :: !unsupported; - false) - prog.Flan.Tast.fns - in - List.iter - (fun (fd : Flan.Tast.fn) -> - Hashtbl.replace addrs fd.Flan.Tast.name (jit_alloc page)) - lowerable; - let resolve name = - match Hashtbl.find_opt addrs name with - | Some p -> Int64.of_nativeint p - | None -> - (* Not a Flan function: a runtime entry point, looked up the way a dev - build already reaches the host's symbols -- through the dynamic symbol - table, which --dev links with -rdynamic. *) - Int64.of_nativeint (sym name) - in - let bytes = Hashtbl.create 16 in - List.iter - (fun (fd : Flan.Tast.fn) -> - let code = X86.fn ~resolve fd in - Hashtbl.replace bytes fd.Flan.Tast.name code; - let p = Hashtbl.find addrs fd.Flan.Tast.name in - jit_write p code; - jit_protect p page) - lowerable; - - Printf.printf "lowered: %d of %d functions\n" - (List.length lowerable) (List.length prog.Flan.Tast.fns); - List.iter (fun (n, m) -> Printf.printf " skipped %-20s %s\n" n m) - (List.rev !unsupported); - Hashtbl.iter (fun n c -> Printf.printf " %-20s %4d bytes at %nx\n" - n (String.length c) (Hashtbl.find addrs n)) bytes; - - (* The bytes that actually ran, dumped where run.sh can objdump them. - A debugging aid and not the evidence: a disassembly that reads correctly - next to a function that answers 656 when it should answer 650 is the - normal outcome of hand-encoding, which is why the checks below compare - numbers. *) - (match Sys.getenv_opt "SPIKE_DUMP" with - | None -> () - | Some dir -> - Hashtbl.iter - (fun n c -> - let oc = open_out_bin (Filename.concat dir (n ^ ".bin")) in - output_string oc c; close_out oc) - bytes); - - (* ── The SysV boundary ────────────────────────────────────────────── - Three synthetic functions, built as Tast by hand rather than written in - Flan, because the surface language has no way to spell a call to an - arbitrary C symbol with eight arguments. [Tast.Rt] is the node a runtime - call already uses and the one a [declare-c] shim lands on, so this is the - real path with a made-up callee. *) - let loc = Flan.Loc.unknown in - let i64 = Flan.Types.Int Flan.Types.I64 in - let ex e = { Flan.Tast.e; ty = i64; loc } in - let lit n = ex (Flan.Tast.Int (Int64.of_int n, Flan.Types.I64)) in - let probe name params body = - { Flan.Tast.name; params; slots = Array.make (List.length params) i64; - snames = Array.make (List.length params) None; ret = i64; - body = [ body ]; fdefers = []; fparent = None; floc = loc } - in - let arg0 = ex (Flan.Tast.Local 0) in - let probes = [ - (* Eight integers: six in registers and two on the stack, which is the case - a register-only convention gets silently wrong. *) - probe "abi-8" [ i64 ] - (ex (Flan.Tast.Prim (Flan.Tast.Rt "spike_probe8", - [ arg0; lit 2; lit 3; lit 4; lit 5; lit 6; lit 7; lit 8 ]))); - (* rsp % 16 == 0 at the call. The callee does an aligned 16-byte spill and - answers -1 if it was entered misaligned. *) - probe "abi-align" [ i64 ] - (ex (Flan.Tast.Prim (Flan.Tast.Rt "spike_probe_align", [ arg0 ]))); - (* The same call, but underneath a binary operator -- so it is evaluated - with the left operand spilled on the stack. This is the one that matters: - alignment at a call site is not a property of the prologue, it is a - property of how much the expression evaluator has pushed. *) - probe "abi-align-nested" [ i64 ] - (ex (Flan.Tast.Prim (Flan.Tast.Add, - [ lit 0; - ex (Flan.Tast.Prim (Flan.Tast.Rt "spike_probe_align", [ arg0 ])) ]))); - ] in - List.iter - (fun (fd : Flan.Tast.fn) -> - let code = X86.fn ~resolve fd in - let p = jit_alloc page in - jit_write p code; jit_protect p page; - Hashtbl.replace addrs fd.Flan.Tast.name p) - probes; - - print_endline "results:"; - let at n = Hashtbl.find addrs n in - check "spike-add 3 4" (call2 (at "spike-add") 3L 4L) 7L; - check "spike-add -5 2" (call2 (at "spike-add") (-5L) 2L) (-3L); - check "spike-arith 10 4" (call2 (at "spike-arith") 10L 4L) 19L; - check "spike-let 6" (call1 (at "spike-let") 6L) 1332L; - check "spike-if 1 2" (call2 (at "spike-if") 1L 2L) 1L; - check "spike-if 9 2" (call2 (at "spike-if") 9L 2L) 7L; - check "spike-calls 5" (call1 (at "spike-calls") 5L) 656L; - check "abi-8 1" (call1 (at "abi-8") 1L) 87654321L; - check "abi-align 10" (call1 (at "abi-align") 10L) 13L; - check "abi-align-nested 10" (call1 (at "abi-align-nested") 10L) 13L; - - Printf.printf "\n%d checks, %d failures\n" !checks !failures; - exit (if !failures = 0 then 0 else 1) - -(* The frontend's diagnostics printed rather than swallowed: a spike that says - [Fatal error: exception Errors(_)] costs an hour. *) -let () = - try run Sys.argv.(1) with - | Flan.Loc.Error d -> prerr_endline (Flan.Loc.report d); exit 2 - | Flan.Loc.Errors ds -> prerr_endline (Flan.Loc.report_all ds); exit 2 diff --git a/spike/backend/hist.ml b/spike/backend/hist.ml deleted file mode 100644 index b8d05ea1..00000000 --- a/spike/backend/hist.ml +++ /dev/null @@ -1,87 +0,0 @@ -(* Histogram of Tast expr_kind constructors over the reachable program. A - measurement, not a backend: it answers "what would a whole-program x86 - build actually have to lower for this input", which is the question that - decides whether whole-program coverage is reachable at all. *) -let tbl : (string, int) Hashtbl.t = Hashtbl.create 64 - -let bump k = - Hashtbl.replace tbl k (1 + (try Hashtbl.find tbl k with Not_found -> 0)) - -let name (k : Flan.Tast.expr_kind) = - match k with - | Int _ -> "Int" | Float _ -> "Float" | Bool _ -> "Bool" | Str _ -> "Str" - | Unit -> "Unit" | Zero _ -> "Zero" | Uninit _ -> "Uninit" - | Local _ -> "Local" | Global _ -> "Global" | Prim _ -> "Prim" - | Call _ -> "Call" | FnAddr _ -> "FnAddr" | CallPtr _ -> "CallPtr" - | Do _ -> "Do" | Let _ -> "Let" | If _ -> "If" | While _ -> "While" - | Return _ -> "Return" | Break _ -> "Break" | Continue _ -> "Continue" - | Set _ -> "Set" | Field _ -> "Field" | Addr _ -> "Addr" | Deref _ -> "Deref" - | Make _ -> "Make" | MakeCase _ -> "MakeCase" | CaseField _ -> "CaseField" - | Arr _ -> "Arr" | Some_ _ -> "Some" | None_ -> "None" | Match _ -> "Match" - | UnwrapSome _ -> "UnwrapSome" | Signal _ -> "Signal" | Handled _ -> "Handled" - | RestartCase _ -> "RestartCase" | WithAlloc _ -> "WithAlloc" - | InvokeRestart _ -> "InvokeRestart" - -let pname (p : Flan.Tast.prim) = - match p with - | Add -> "Add" | Sub -> "Sub" | Mul -> "Mul" | Div -> "Div" | Rem -> "Rem" - | Eq -> "Eq" | Ne -> "Ne" | Lt -> "Lt" | Le -> "Le" | Gt -> "Gt" | Ge -> "Ge" - | Not -> "Not" | BitAnd -> "BitAnd" | BitOr -> "BitOr" | BitXor -> "BitXor" - | Shl -> "Shl" | Shr -> "Shr" | Len -> "Len" | At -> "At" | Slice -> "Slice" - | Bytes -> "Bytes" | BytesToF64 -> "BytesToF64" | BytesToI64 -> "BytesToI64" - | F64ToBytes -> "F64ToBytes" | I64ToBytes -> "I64ToBytes" - | StrOfBytes -> "StrOfBytes" | U64ToBytes -> "U64ToBytes" - | EscapeBytes -> "EscapeBytes" | WriteStdout -> "WriteStdout" | Exit -> "Exit" - | Argv -> "Argv" | Rt s -> "Rt:" ^ s | SizeOf _ -> "SizeOf" - | AlignOf _ -> "AlignOf" | AddrOf -> "AddrOf" | Cast _ -> "Cast" - -let rec ex (e : Flan.Tast.expr) = - bump (name e.e); - match e.e with - | Prim (p, xs) -> bump ("prim/" ^ pname p); List.iter ex xs - | Call (_, xs) | Arr xs -> List.iter ex xs - | Make (_, xs) | MakeCase (_, _, xs) -> List.iter ex xs - | CallPtr (f, xs) -> ex f; List.iter ex xs - | Do xs | Handled (_, xs) -> List.iter ex xs - | Let (bs, body) -> List.iter (fun (_, x) -> ex x) bs; List.iter ex body - | If (a, b, c) -> ex a; ex b; ex c - | While (c, b, l) -> ex c; List.iter ex b; List.iter ex l - | Return (Some x) | Some_ x | Deref x | UnwrapSome x | Field (x, _) - | CaseField (x, _, _) | Signal (_, _, x) -> ex x - | Set (p, x) -> pl p; ex x - | Addr p -> pl p - | Match (x, arms) -> - ex x; - List.iter (fun (a : Flan.Tast.arm) -> List.iter ex a.abody) arms - | RestartCase (cs, x) -> - List.iter (fun (c : Flan.Tast.rclause) -> List.iter ex c.rbody) cs; ex x - | WithAlloc (a, b) -> ex a; List.iter ex b - | InvokeRestart (_, _, xs, _, _, _) -> List.iter ex xs - | _ -> () - -and pl (p : Flan.Tast.place) = - match p with - | Plocal _ -> bump "place/Plocal" - | Pglobal _ -> bump "place/Pglobal" - | Pfield (x, _) -> bump "place/Pfield"; ex x - | Pindex (x, ys) -> bump "place/Pindex"; ex x; List.iter ex ys - | Pderef x -> bump "place/Pderef"; ex x - -let () = - let src = Sys.argv.(1) in - let l = - Flan.Load.program ~file:src - (Flan.Parse.program_all (Flan.Reader.read_file src)) - in - let p = Flan.Check.program_all l.Flan.Load.decls in - let p, _, _ = Flan.Reach.link l p in - List.iter - (fun (f : Flan.Tast.fn) -> List.iter ex f.body; List.iter ex f.fdefers) - p.Flan.Tast.fns; - List.iter (fun (g : Flan.Tast.global) -> ex g.Flan.Tast.ginit) - p.Flan.Tast.globals; - Printf.printf "%s: %d reachable fns\n" (Filename.basename src) - (List.length p.Flan.Tast.fns); - let rows = Hashtbl.fold (fun k v a -> (k, v) :: a) tbl [] in - let rows = List.sort (fun (a, _) (b, _) -> compare a b) rows in - List.iter (fun (k, v) -> Printf.printf " %-24s %d\n" k v) rows diff --git a/spike/backend/jit_stubs.c b/spike/backend/jit_stubs.c deleted file mode 100644 index 04f78441..00000000 --- a/spike/backend/jit_stubs.c +++ /dev/null @@ -1,100 +0,0 @@ -/* The three things OCaml cannot do for itself: get executable memory, put - * bytes in it, and jump to them. Everything interesting is in x86.ml; this - * file is deliberately dumb. - * - * Shaped after lib/dynload_stubs.c's rule, which spike/embed took verbatim for - * the same reason: the boundary passes pointers and scalars, never an OCaml - * [value] into foreign storage. Nothing here keeps anything. - * - * RW then mprotect to R+X, never RWX in one mmap: a hardened kernel may refuse - * a writable-executable anonymous mapping outright, and a policy denial that - * comes back as a null pointer reads exactly like an encoding bug. */ - -#include -#include -#include -#include - -#include -#include -#include -#include -#include - -value spike_jit_alloc(value vlen) { - size_t len = (size_t)Long_val(vlen); - void *p = mmap(NULL, len, PROT_READ | PROT_WRITE, - MAP_PRIVATE | MAP_ANONYMOUS, -1, 0); - if (p == MAP_FAILED) caml_failwith("spike_jit_alloc: mmap failed"); - return caml_copy_nativeint((intnat)p); -} - -value spike_jit_write(value vp, value vbytes) { - char *p = (char *)Nativeint_val(vp); - memcpy(p, String_val(vbytes), caml_string_length(vbytes)); - return Val_unit; -} - -value spike_jit_protect(value vp, value vlen) { - void *p = (void *)Nativeint_val(vp); - if (mprotect(p, (size_t)Long_val(vlen), PROT_READ | PROT_EXEC) != 0) - caml_failwith("spike_jit_protect: mprotect failed"); - return Val_unit; -} - -/* Every Flan function's emitted signature is its parameters followed by the - * transfer channel (emit.ml, [signature]), so the trampolines below all pass a - * trailing pointer. Nothing in the spike transfers, so it is NULL. */ -typedef int64_t (*fn1)(int64_t, void *); -typedef int64_t (*fn2)(int64_t, int64_t, void *); - -value spike_call1(value vp, value a) { - return caml_copy_int64(((fn1)Nativeint_val(vp))(Int64_val(a), NULL)); -} -value spike_call2(value vp, value a, value b) { - return caml_copy_int64(((fn2)Nativeint_val(vp))(Int64_val(a), Int64_val(b), NULL)); -} - -value spike_sym(value vname) { - void *h = dlsym(RTLD_DEFAULT, String_val(vname)); - if (h == NULL) caml_failwith("spike_sym: not found"); - return caml_copy_nativeint((intnat)h); -} - -/* ── The C side of the ABI probes ──────────────────────────────────── */ - -/* Eight integers: six in registers, two on the stack, which is the case a - * register-only convention silently gets wrong. The answer is positional so a - * swapped pair cannot pass. */ -int64_t spike_probe8(int64_t a, int64_t b, int64_t c, int64_t d, - int64_t e, int64_t f, int64_t g, int64_t h) { - return a * 1 + b * 10 + c * 100 + d * 1000 + e * 10000 + f * 100000 - + g * 1000000 + h * 10000000; -} - -/* The alignment check, and it has to be done with an aligned load rather than - * by reading rsp, because that is how raylib finds out: the SysV ABI promises - * rsp % 16 == 0 at the call instruction, so on entry rsp+8 is aligned, and a - * callee that spills an __m128 to its frame faults when it is not. -O2 is what - * turns this into an actual movaps; without it the bug hides. */ -__attribute__((noinline)) -int64_t spike_probe_align(int64_t x) { - volatile double v[2] __attribute__((aligned(16))) = { 1.0, 2.0 }; - /* Reading rsp as well, so a failure says which of the two it was. */ - uintptr_t sp; - __asm__ volatile ("mov %%rsp, %0" : "=r"(sp)); - if ((sp % 16) != 8) return -1; /* entry rsp is call-site rsp minus 8 */ - return x + (int64_t)(v[0] + v[1]); -} - -/* No float probe either, for a plainer reason: this emitter has no SSE, so - * there is nothing here that could call one. Floats are counted as work in - * docs/BUILT.md, "Layout was already owned, and that is why the drift fear - * was misplaced", rather than claimed as done. - * - * And no struct-by-value probe, and that is a finding rather than an - * omission: check.ml rejects an aggregate in a [declare] signature and the - * generated shim flattens every one, so no Flan-emitted call ever passes a - * struct to C. The aggregate problem is real but it is on the Flan-to-Flan - * side, which is measured in docs/BUILT.md, "The obstacle that was named - * first, and dissolved", and not from here. */ diff --git a/spike/backend/probe.flan b/spike/backend/probe.flan deleted file mode 100644 index 0fab0e65..00000000 --- a/spike/backend/probe.flan +++ /dev/null @@ -1,24 +0,0 @@ -;; The spike's input. Ordinary Flan, run through the ordinary frontend -- -;; Reader, Parse, Load, Check -- so that what the emitter below lowers is the -;; same Tast.fn the LLVM backend gets and not a literal someone typed to make -;; the exercise come out. - -(defn spike-add [a i64 b i64] i64 - (+ a b)) - -(defn spike-arith [a i64 b i64] i64 - (- (* a 3) (+ b 7))) - -(defn spike-let [a i64] i64 - (let [x (* a a) - y (+ x 1)] - (* x y))) - -(defn spike-if [a i64 b i64] i64 - (if (< a b) (- b a) (- a b))) - -(defn spike-calls [a i64] i64 - (spike-add (spike-arith a 2) (spike-let a))) - -(defn main [] i32 - 0) diff --git a/spike/backend/run.sh b/spike/backend/run.sh deleted file mode 100644 index bdef39bc..00000000 --- a/spike/backend/run.sh +++ /dev/null @@ -1,48 +0,0 @@ -#!/usr/bin/env bash -# The spike, end to end: the real frontend produces a Tast, x86.ml turns it -# into bytes, the bytes go into an mmap, and the mmap gets called. -# -# Driven by hand with ocamlfind and clang against the flan.cmxa dune already -# builds, exactly as spike/embed does and for the same reason: nothing under -# spike/ is wired into the build, so there is no dune file here and `dune test` -# cannot see any of it. -set -u -here=$(cd "$(dirname "$0")" && pwd) -root=$(cd "$here/../.." && pwd) -cd "$root" || exit 1 - -dune build --root . lib/flan.cmxa 2>&1 | head -20 - -out=$(mktemp -d); trap 'rm -rf "$out"' EXIT - -# The C stubs. -O2 on purpose: spike_probe_align's aligned load only becomes a -# real movaps with optimisation on, and an alignment bug that only shows up in -# a release build is the one this is looking for. -clang -O2 -c -I"$(ocamlopt -where)" "$here/jit_stubs.c" -o "$out/jit_stubs.o" || exit 1 - -ocamlfind ocamlopt -thread -package unix,threads.posix -linkpkg \ - -I "$root/_build/default/lib/.flan.objs/byte" \ - -I "$root/_build/default/lib/.flan.objs/native" \ - -I "$out" -I "$here" \ - -o "$out/spike" \ - "$root/_build/default/lib/flan.cmxa" \ - -cclib -rdynamic -ccopt -L"$root/_build/default/lib" \ - "$out/jit_stubs.o" \ - "$here/x86.ml" "$here/driver.ml" 2>&1 | head -40 - -test -x "$out/spike" || { echo "build failed"; exit 1; } - -SPIKE_DUMP=$out "$out/spike" "$here/probe.flan" -rc=$? - -# Disassembly on request. objdump over the raw buffer, which is what to reach -# for when a function answers the wrong number -- not what proves it answers -# the right one. -if [ "${SPIKE_DISASM:-}" = 1 ]; then - for f in "$out"/*.bin; do - echo; echo "== $(basename "$f" .bin)" - objdump -D -b binary -m i386:x86-64 -M intel "$f" | tail -n +7 - done -fi -echo "exit: $rc" -exit $rc diff --git a/spike/backend/x86.ml b/spike/backend/x86.ml deleted file mode 100644 index 9f486fed..00000000 --- a/spike/backend/x86.ml +++ /dev/null @@ -1,379 +0,0 @@ -(* A spike: Tast -> x86-64 machine code, in memory, called. Not a backend. - The point is to find out what breaks, so the subset is deliberately tiny - and every case it cannot do raises with the node that defeated it -- an - honest [Unsupported] is the measurement, and a silently wrong answer is - the one outcome that would waste the exercise. - - Register allocation is the trivial one the brief allows: every slot is a - stack slot at [rbp - 8*(i+1)], every value is computed into rax, and a - binary operator pushes its left operand. Two registers are enough for - everything below and nothing is kept live across a statement. That is what - makes an instruction selector tractable in an afternoon; it is also why the - code it produces is four times the size of clang -O0's. - - Conventions, all of them SysV's, because raylib is called from this code: - - integer arguments in rdi rsi rdx rcx r8 r9, then right-to-left on the - stack; integer result in rax. - - rsp % 16 == 0 at the [call] instruction. raylib spills xmm registers - with movaps and faults far from the cause when this is wrong. - - rbx rbp r12-r15 are callee-saved. This emitter touches none of them - except rbp, which it saves. - - every Flan function takes the transfer channel as a trailing ptr - (emit.ml, [signature]), so a Flan function of n parameters is an n+1 - argument C function. *) - -exception Unsupported of string - -let unsupported fmt = Printf.ksprintf (fun s -> raise (Unsupported s)) fmt - -(* ── Bytes ───────────────────────────────────────────────────────────── *) - -type buf = { mutable bytes : Buffer.t } - -let create () = { bytes = Buffer.create 256 } -let len b = Buffer.length b.bytes -let contents b = Buffer.contents b.bytes -let u8 b n = Buffer.add_char b.bytes (Char.chr (n land 0xff)) - -let u32 b n = - for i = 0 to 3 do u8 b ((n asr (i * 8)) land 0xff) done - -let i32 b (n : int) = - if n < -0x80000000 || n > 0x7fffffff then unsupported "displacement %d" n; - u32 b n - -let u64 b (n : int64) = - for i = 0 to 7 do - u8 b (Int64.to_int (Int64.logand (Int64.shift_right_logical n (i * 8)) 0xffL)) - done - -(* ── Registers and modrm ─────────────────────────────────────────────── *) - -(* The encoding order, not the ABI order: this numbering *is* the three bits - the modrm byte wants, which is why rsp is 4 and rbp is 5 rather than - anything more memorable. *) -let rax = 0 and rcx = 1 and rdx = 2 and _rbx = 3 -let rsp = 4 and rbp = 5 and rsi = 6 and rdi = 7 -let r8 = 8 and r9 = 9 - -(* REX.W is always set: everything here is 64-bit. R extends the reg field and - B the r/m field, which is the whole of what r8-r15 need. *) -let rex b ~r ~m = u8 b (0x48 lor (if r >= 8 then 4 else 0) lor (if m >= 8 then 1 else 0)) -let modrm b ~md ~r ~m = u8 b ((md lsl 6) lor ((r land 7) lsl 3) lor (m land 7)) - -(* reg, reg *) -let rr b op ~r ~m = rex b ~r ~m; u8 b op; modrm b ~md:3 ~r ~m - -(* reg, [rbp + disp32]. Always disp32 rather than the shorter disp8 form: a - frame can outgrow 128 bytes and a one-byte displacement that silently wraps - is exactly the bug this spike would not find. *) -let rm_rbp b op ~r ~disp = - rex b ~r ~m:rbp; u8 b op; modrm b ~md:2 ~r ~m:rbp; i32 b disp - -let mov_rr b ~dst ~src = rr b 0x89 ~r:src ~m:dst (* mov dst, src *) -let mov_load b ~dst ~disp = rm_rbp b 0x8b ~r:dst ~disp (* mov dst, [rbp+d] *) -let mov_store b ~src ~disp = rm_rbp b 0x89 ~r:src ~disp (* mov [rbp+d], src *) - -let movabs b ~dst (n : int64) = - rex b ~r:0 ~m:dst; u8 b (0xb8 lor (dst land 7)); u64 b n - -let push b r = if r >= 8 then u8 b 0x41; u8 b (0x50 lor (r land 7)) -let pop b r = if r >= 8 then u8 b 0x41; u8 b (0x58 lor (r land 7)) - -let add_rr b ~dst ~src = rr b 0x01 ~r:src ~m:dst -let sub_rr b ~dst ~src = rr b 0x29 ~r:src ~m:dst -let and_rr b ~dst ~src = rr b 0x21 ~r:src ~m:dst -let or_rr b ~dst ~src = rr b 0x09 ~r:src ~m:dst -let xor_rr b ~dst ~src = rr b 0x31 ~r:src ~m:dst -let imul_rr b ~dst ~src = (* 0f af /r *) - rex b ~r:dst ~m:src; u8 b 0x0f; u8 b 0xaf; modrm b ~md:3 ~r:dst ~m:src -let cmp_rr b ~a ~bb = rr b 0x39 ~r:bb ~m:a (* cmp a, b *) - -let add_imm32 b ~dst n = rex b ~r:0 ~m:dst; u8 b 0x81; modrm b ~md:3 ~r:0 ~m:dst; i32 b n -let sub_imm32 b ~dst n = rex b ~r:0 ~m:dst; u8 b 0x81; modrm b ~md:3 ~r:5 ~m:dst; i32 b n - -let call_r b r = if r >= 8 then u8 b 0x41; u8 b 0xff; modrm b ~md:3 ~r:2 ~m:r -let leave b = u8 b 0xc9 -let ret b = u8 b 0xc3 -let ud2 b = u8 b 0x0f; u8 b 0x0b - -(* setcc al, then movzx rax, al -- a compare's result is a bool, which is one - byte in Flan's layout (i1 in LLVM, and the ABI zero-extends it). *) -let setcc b cc = u8 b 0x0f; u8 b (0x90 lor cc); modrm b ~md:3 ~r:0 ~m:rax -let movzx_al b = u8 b 0x48; u8 b 0x0f; u8 b 0xb6; modrm b ~md:3 ~r:rax ~m:rax - -(* jcc rel32 and jmp rel32, patched once the target is known. *) -let jcc b cc = u8 b 0x0f; u8 b (0x80 lor cc); let at = len b in u32 b 0; at -let jmp b = u8 b 0xe9; let at = len b in u32 b 0; at - -let patch b ~at ~target = - let rel = target - (at + 4) in - let s = Buffer.contents b.bytes in - let s = Bytes.of_string s in - for i = 0 to 3 do - Bytes.set s (at + i) (Char.chr ((rel asr (i * 8)) land 0xff)) - done; - let nb = Buffer.create (Bytes.length s) in - Buffer.add_bytes nb s; - b.bytes <- nb - -(* ── Lowering ────────────────────────────────────────────────────────── *) - -type fnctx = { - b : buf; - nslots : int; - (* How many 8-byte words this expression's evaluation has pushed since the - prologue. rsp is 16-aligned at the end of the prologue, so [depth] even - means rsp is aligned and [depth] odd means it is 8 out. - - This counter is the answer to the one bug the ABI probe found. Alignment - is not a property of the prologue: the evaluator spills the left operand - across the right one's evaluation, so a call written in the right operand - runs with one word outstanding. Deriving it from a count kept here is the - only way that stays correct as the evaluator grows cases, and it is what - clang's [sub rsp, 8] before a call is doing. *) - mutable depth : int; - (* A symbol the code calls, resolved to an absolute address by the driver - before emission. movabs + call r is what a JIT does anyway: a rel32 call - cannot reach an arbitrary mmap, and the 2-byte indirect call is cheaper - than the relocation machinery a real backend would grow here. *) - resolve : string -> int64; -} - -let slot_disp i = -8 * (i + 1) - -(* Every stack movement goes through these two, so that nothing can move rsp - without the counter noticing. *) -let pushv f r = push f.b r; f.depth <- f.depth + 1 -let popv f r = pop f.b r; f.depth <- f.depth - 1 - -(* Every type this spike handles is one 8-byte integer register. Everything - else is the real backend's problem and is enumerated in the verdict rather - than guessed at here. *) -let word_ty (t : Flan.Types.t) = - match t with - | Flan.Types.Int _ | Flan.Types.Bool | Flan.Types.Ptr _ -> true - | _ -> false - -let check_word what (t : Flan.Types.t) = - if not (word_ty t) then - unsupported "%s of type %s: not a single integer register" what - (Flan.Types.to_string t) - -let cc_of signed (p : Flan.Tast.prim) = - match p, signed with - | Flan.Tast.Eq, _ -> 0x4 | Flan.Tast.Ne, _ -> 0x5 - | Flan.Tast.Lt, true -> 0xc | Flan.Tast.Lt, false -> 0x2 - | Flan.Tast.Le, true -> 0xe | Flan.Tast.Le, false -> 0x6 - | Flan.Tast.Gt, true -> 0xf | Flan.Tast.Gt, false -> 0x7 - | Flan.Tast.Ge, true -> 0xd | Flan.Tast.Ge, false -> 0x3 - | _ -> assert false - -let arg_regs = [| rdi; rsi; rdx; rcx; r8; r9 |] - -(* Value into rax. Everything is a subexpression of something that will - immediately consume rax, so nothing is kept live and no allocator is - needed. *) -let rec value f (e : Flan.Tast.expr) : unit = - let b = f.b in - match e.Flan.Tast.e with - | Flan.Tast.Int (n, _) -> movabs b ~dst:rax n - | Flan.Tast.Bool v -> movabs b ~dst:rax (if v then 1L else 0L) - | Flan.Tast.Local i -> - check_word "local" e.Flan.Tast.ty; - if i >= f.nslots then unsupported "slot %d out of range" i; - mov_load b ~dst:rax ~disp:(slot_disp i) - | Flan.Tast.Do body -> block f body - | Flan.Tast.Let (binds, body) -> - List.iter - (fun (i, e) -> - value f e; - check_word "binding" e.Flan.Tast.ty; - mov_store b ~src:rax ~disp:(slot_disp i)) - binds; - block f body - | Flan.Tast.Set (Flan.Tast.Plocal i, rhs) -> - value f rhs; - check_word "assignment" rhs.Flan.Tast.ty; - mov_store b ~src:rax ~disp:(slot_disp i) - | Flan.Tast.If (c, t, e') -> emit_if f c t e' - | Flan.Tast.Return (Some x) -> - value f x; - leave b; ret b - | Flan.Tast.Return None -> leave b; ret b - | Flan.Tast.Prim (p, args) -> prim f e p args - | Flan.Tast.Call (name, args) -> call f (f.resolve name) args ~xfer:true - | Flan.Tast.Unit -> () - | k -> unsupported "expression: %s" (node_name k) - -and block f body = - match body with - | [] -> () - | [ last ] -> value f last - | x :: rest -> value f x; block f rest - -and prim f e (p : Flan.Tast.prim) args = - let b = f.b in - match p, args with - | (Flan.Tast.Add | Flan.Tast.Sub | Flan.Tast.Mul - | Flan.Tast.BitAnd | Flan.Tast.BitOr | Flan.Tast.BitXor), [ x; y ] -> - check_word "arithmetic" x.Flan.Tast.ty; - binop f x y; - (* left in rax, right in rcx *) - (match p with - | Flan.Tast.Add -> add_rr b ~dst:rax ~src:rcx - | Flan.Tast.Sub -> sub_rr b ~dst:rax ~src:rcx - | Flan.Tast.Mul -> imul_rr b ~dst:rax ~src:rcx - | Flan.Tast.BitAnd -> and_rr b ~dst:rax ~src:rcx - | Flan.Tast.BitOr -> or_rr b ~dst:rax ~src:rcx - | _ -> xor_rr b ~dst:rax ~src:rcx) - | (Flan.Tast.Eq | Flan.Tast.Ne | Flan.Tast.Lt | Flan.Tast.Le - | Flan.Tast.Gt | Flan.Tast.Ge), [ x; y ] -> - let signed = - match x.Flan.Tast.ty with - | Flan.Types.Int k -> Flan.Types.signed k - | Flan.Types.Bool -> false - | t -> unsupported "comparison on %s" (Flan.Types.to_string t) - in - binop f x y; - cmp_rr b ~a:rax ~bb:rcx; - setcc b (cc_of signed p); - movzx_al b - | Flan.Tast.Rt sym, args -> call f (f.resolve sym) args ~xfer:false - | _ -> unsupported "primitive in %s" (Flan.Types.to_string e.Flan.Tast.ty) - -(* Left into rax, right into rcx, with the left spilled across the right's - evaluation. Left-to-right, which emit.ml's [map_lr] is explicit about being - required rather than a preference -- a call in either operand has effects. - The push/pop pair keeps rsp 16-aligned in pairs, which matters only because - [call] below re-derives alignment from a counter rather than tracking rsp. *) -and binop f x y = - let b = f.b in - value f x; - pushv f rax; - value f y; - mov_rr b ~dst:rcx ~src:rax; - popv f rax - -and emit_if f c t e = - let b = f.b in - value f c; - (* cmp rax, 0: 48 83 f8 00 -- written out because the helper above takes - registers only and a zero-compare is the one immediate form worth having. *) - u8 b 0x48; u8 b 0x83; modrm b ~md:3 ~r:7 ~m:rax; u8 b 0x00; - let to_else = jcc b 0x4 in (* je *) - value f t; - let to_end = jmp b in - patch b ~at:to_else ~target:(len b); - value f e; - patch b ~at:to_end ~target:(len b) - -(* A call, and this is the part that has to be exactly right. - - [xfer] appends the transfer channel, which every Flan function's signature - carries and a C entry point does not. The spike passes NULL: nothing here - signals, and a real backend would pass the caller's own channel pointer. - - Alignment: rsp is 16-aligned at function entry minus the 8 the [call] - pushed, so after [push rbp] it is aligned again, and the frame is rounded to - a multiple of 16. Every push here is paired with a pop before the next call - can happen, so rsp is aligned at every call site by construction. Stack - arguments are pushed in pairs to keep it that way -- an odd count gets a - dummy push, which is what clang's [sub rsp, 8] is doing when you see it. *) -and call f (addr : int64) args ~xfer = - let b = f.b in - let n = List.length args + (if xfer then 1 else 0) in - (* Bring rsp to 16 first, so everything below can count in pairs. *) - let pad = f.depth land 1 = 1 in - if pad then (sub_imm32 b ~dst:rsp 8; f.depth <- f.depth + 1); - let stacked = List.filteri (fun i _ -> i >= 6) args in - let nstack = List.length stacked + (if xfer && n > 6 then 1 else 0) in - (* The stack half, evaluated right to left so that the seventh argument ends - up at [rsp] and the eighth above it. The transfer channel is the last - argument of all, so it is pushed first. *) - if nstack land 1 = 1 then (sub_imm32 b ~dst:rsp 8; f.depth <- f.depth + 1); - if xfer && n > 6 then (movabs b ~dst:rax 0L; pushv f rax); - List.iter (fun a -> value f a; pushv f rax) (List.rev stacked); - (* The register half needs a spill of its own: rdi..r9 are argument registers - and rax is where every value lands, so an earlier argument would be - clobbered by a later one's evaluation. Push each, then pop them into their - registers in reverse. *) - let inreg = List.filteri (fun i _ -> i < 6) args in - List.iter (fun a -> value f a; pushv f rax) inreg; - let nreg = List.length inreg in - List.iteri (fun i _ -> popv f arg_regs.(nreg - 1 - i)) inreg; - if xfer && n <= 6 then movabs b ~dst:arg_regs.(nreg) 0L; - (* al = the number of vector registers used. Required only for a variadic - callee and set unconditionally because it is two bytes: a wrong al on a - printf-shaped entry point -- raylib's TraceLog is one -- is a crash that - looks like anything else. After the argument registers, since al is rax's - low byte. *) - u8 b 0xb0; u8 b 0x00; (* mov al, 0 *) - (* r11 always, never r9: r11 is the scratch register SysV reserves and is the - one register guaranteed not to be carrying an argument. Choosing the - target conditionally is how a six-argument call gets quietly wrong. *) - u8 b 0x49; u8 b 0xbb; u64 b addr; (* movabs r11, addr *) - assert (f.depth land 1 = 0); - call_r b 11; - let back = 8 * (nstack + (nstack land 1)) in - if back > 0 then (add_imm32 b ~dst:rsp back; f.depth <- f.depth - (back / 8)); - if pad then (add_imm32 b ~dst:rsp 8; f.depth <- f.depth - 1) - -and node_name (k : Flan.Tast.expr_kind) = - match k with - | Flan.Tast.Int _ -> "Int" | Flan.Tast.Float _ -> "Float" - | Flan.Tast.Bool _ -> "Bool" | Flan.Tast.Str _ -> "Str" - | Flan.Tast.Unit -> "Unit" | Flan.Tast.Zero _ -> "Zero" - | Flan.Tast.Uninit _ -> "Uninit" | Flan.Tast.Local _ -> "Local" - | Flan.Tast.Global _ -> "Global" | Flan.Tast.Prim _ -> "Prim" - | Flan.Tast.Call _ -> "Call" | Flan.Tast.FnAddr _ -> "FnAddr" - | Flan.Tast.CallPtr _ -> "CallPtr" | Flan.Tast.Do _ -> "Do" - | Flan.Tast.Let _ -> "Let" | Flan.Tast.If _ -> "If" - | Flan.Tast.While _ -> "While" | Flan.Tast.Return _ -> "Return" - | Flan.Tast.Break _ -> "Break" | Flan.Tast.Continue _ -> "Continue" - | Flan.Tast.Set _ -> "Set" | Flan.Tast.Field _ -> "Field" - | Flan.Tast.Addr _ -> "Addr" | Flan.Tast.Deref _ -> "Deref" - | Flan.Tast.Make _ -> "Make" | Flan.Tast.MakeCase _ -> "MakeCase" - | Flan.Tast.CaseField _ -> "CaseField" | Flan.Tast.Arr _ -> "Arr" - | Flan.Tast.Some_ _ -> "Some" | Flan.Tast.None_ -> "None" - | Flan.Tast.Match _ -> "Match" | Flan.Tast.UnwrapSome _ -> "UnwrapSome" - | Flan.Tast.Signal _ -> "Signal" | Flan.Tast.Handled _ -> "Handled" - | Flan.Tast.RestartCase _ -> "RestartCase" - | Flan.Tast.WithAlloc _ -> "WithAlloc" - | Flan.Tast.InvokeRestart _ -> "InvokeRestart" - -(* ── A whole function ────────────────────────────────────────────────── *) - -let fn ~resolve (fd : Flan.Tast.fn) : string = - let b = create () in - let nslots = Array.length fd.Flan.Tast.slots in - let f = { b; nslots; resolve; depth = 0 } in - push b rbp; - mov_rr b ~dst:rbp ~src:rsp; - (* Round the frame to 16 so that rsp is aligned at every call site. One - extra word for the transfer channel's slot, which is not a Flan slot and - has no index -- the spike never reads it, but a real backend must, and - leaving no room for it is the kind of thing that is cheap now and - expensive later. *) - let frame = (nslots + 1) * 8 in - let frame = (frame + 15) land lnot 15 in - if frame > 0 then sub_imm32 b ~dst:rsp frame; - (* Parameters arrive in registers and are stored into their slots at once, - which is also emit.ml's rule: slots 0..n-1 are the parameters, in order. *) - let np = List.length fd.Flan.Tast.params in - if np > 6 then unsupported "more than six parameters"; - List.iteri - (fun i ty -> - check_word "parameter" ty; - mov_store b ~src:arg_regs.(i) ~disp:(slot_disp i)) - fd.Flan.Tast.params; - (* The transfer channel is the last argument and goes just past the slots. *) - if np < 6 then mov_store b ~src:arg_regs.(np) ~disp:(slot_disp nslots); - block f fd.Flan.Tast.body; - leave b; ret b; - (* Anything that falls off the end of a Never-returning body lands here and - traps rather than running into the next function. LLVM's [unreachable] is - undefined behaviour; ud2 is a defined SIGILL, and the difference is one of - the audit's findings. *) - ud2 b; - contents b diff --git a/spike/embed/.gitignore b/spike/embed/.gitignore deleted file mode 100644 index 441349b2..00000000 --- a/spike/embed/.gitignore +++ /dev/null @@ -1,14 +0,0 @@ -# Spike artifacts. run.sh rebuilds all of them from the sources beside it. -*.o -*.cmi -*.cmx -baseline -spike1 -spike2 -spike3 -spike4 -spike5 -spike6 -spike5b -spike5b_std -stubs5b.o diff --git a/spike/embed/baseline.c b/spike/embed/baseline.c deleted file mode 100644 index 4c181ae7..00000000 --- a/spike/embed/baseline.c +++ /dev/null @@ -1,4 +0,0 @@ -/* The floor: what a C binary with no OCaml in it weighs, so the delta the dev - build actually pays can be stated honestly. */ -#include -int main(void) { printf("baseline\n"); return 0; } diff --git a/spike/embed/dynload_stubs.c b/spike/embed/dynload_stubs.c deleted file mode 100644 index e32add72..00000000 --- a/spike/embed/dynload_stubs.c +++ /dev/null @@ -1,149 +0,0 @@ -/* Loading a compiled macro into the compiler's own process. - * - * TODO.org, "The expander design: running a macro means dlopening it": there - * is no interpreter, so running a macro means - * compiling it and dlopening it. The reload primitive does exactly this - * already, but its host is a running Flan program written in C; here the host - * is the OCaml compiler, which has no dlopen of its own -- Dynlink loads - * OCaml, not ELF. So the boundary needs stubs, and this is all of them. - * - * Two rules shape what is here: - * - * - Nothing but pointers and scalars crosses. A Flan `string`/slice is - * {ptr,len} and a `Form` is {i32, [2 x i64]}, and LLVM's calling - * convention for an aggregate passed or returned *by value* in hand-written - * IR is not promised to be clang's C ABI for the equivalent struct. The - * unions lane verified memory layout, so memory is the agreement we have: - * every macro is reached through a thunk taking (ptr,i64,ptr,ptr) and - * writing its result through the out pointer. - * - * - The macro module is self-contained: it links the runtime in and has no - * undefined Flan symbols, so the OCaml executable needs no -rdynamic and - * nothing in it has to be exported. - * - * The peek/poke family is how the marshaller writes a Form image into memory - * the macro can read. OCaml cannot address raw memory, so the bytes are laid - * out from here one field at a time. - */ - -#include -#include -#include -#include - -#include -#include -#include -#include - -CAMLprim value flan_dl_open(value path) { - CAMLparam1(path); - void *h = dlopen(String_val(path), RTLD_NOW | RTLD_LOCAL); - if (!h) caml_failwith(dlerror()); - CAMLreturn(caml_copy_nativeint((intnat)h)); -} - -CAMLprim value flan_dl_sym(value handle, value name) { - CAMLparam2(handle, name); - void *p = dlsym((void *)Nativeint_val(handle), String_val(name)); - if (!p) caml_failwith(dlerror()); - CAMLreturn(caml_copy_nativeint((intnat)p)); -} - -CAMLprim value flan_dl_close(value handle) { - dlclose((void *)Nativeint_val(handle)); - return Val_unit; -} - -/* The one call shape a macro is reached through. See the thunk Emit writes. */ -typedef void (*flan_macro_fn)(void *args, int64_t n, void *out, void *xfer); - -CAMLprim value flan_macro_call(value fn, value args, value n, value out) { - CAMLparam4(fn, args, n, out); - /* The transfer channel every Flan signature carries (spec-conditions.md, - section 6). A macro that signals a condition with nothing above it to - handle it aborts inside the compiler, which is loud rather than silent; - the channel still has to be a real, zeroed slot. */ - int64_t xfer[4] = { 0, 0, 0, 0 }; - ((flan_macro_fn)Nativeint_val(fn))((void *)Nativeint_val(args), - Int64_val(n), - (void *)Nativeint_val(out), xfer); - CAMLreturn(Val_unit); -} - -CAMLprim value flan_mem_alloc(value n) { - CAMLparam1(n); - /* Zeroed, because ZII is the language's rule and an unwritten Form field - must read as the zero of its type rather than as whatever malloc had. */ - void *p = calloc((size_t)Long_val(n), 1); - if (!p) caml_failwith("out of memory laying out a macro's arguments"); - CAMLreturn(caml_copy_nativeint((intnat)p)); -} - -CAMLprim value flan_mem_free(value p) { - free((void *)Nativeint_val(p)); - return Val_unit; -} - -CAMLprim value flan_poke_i32(value p, value off, value x) { - int32_t v = (int32_t)Int32_val(x); - memcpy((char *)Nativeint_val(p) + Long_val(off), &v, 4); - return Val_unit; -} - -CAMLprim value flan_poke_i64(value p, value off, value x) { - int64_t v = Int64_val(x); - memcpy((char *)Nativeint_val(p) + Long_val(off), &v, 8); - return Val_unit; -} - -CAMLprim value flan_poke_f64(value p, value off, value x) { - double v = Double_val(x); - memcpy((char *)Nativeint_val(p) + Long_val(off), &v, 8); - return Val_unit; -} - -CAMLprim value flan_poke_ptr(value p, value off, value q) { - void *v = (void *)Nativeint_val(q); - memcpy((char *)Nativeint_val(p) + Long_val(off), &v, sizeof v); - return Val_unit; -} - -CAMLprim value flan_poke_bytes(value p, value off, value s) { - memcpy((char *)Nativeint_val(p) + Long_val(off), String_val(s), - caml_string_length(s)); - return Val_unit; -} - -CAMLprim value flan_peek_i32(value p, value off) { - int32_t v; - memcpy(&v, (char *)Nativeint_val(p) + Long_val(off), 4); - return caml_copy_int32(v); -} - -CAMLprim value flan_peek_i64(value p, value off) { - int64_t v; - memcpy(&v, (char *)Nativeint_val(p) + Long_val(off), 8); - return caml_copy_int64(v); -} - -CAMLprim value flan_peek_f64(value p, value off) { - double v; - memcpy(&v, (char *)Nativeint_val(p) + Long_val(off), 8); - return caml_copy_double(v); -} - -CAMLprim value flan_peek_ptr(value p, value off) { - void *v; - memcpy(&v, (char *)Nativeint_val(p) + Long_val(off), sizeof v); - return caml_copy_nativeint((intnat)v); -} - -CAMLprim value flan_peek_bytes(value p, value off, value n) { - CAMLparam3(p, off, n); - CAMLlocal1(s); - s = caml_alloc_string((mlsize_t)Long_val(n)); - memcpy((char *)Bytes_val(s), (char *)Nativeint_val(p) + Long_val(off), - (size_t)Long_val(n)); - CAMLreturn(s); -} diff --git a/spike/embed/gc_ml.ml b/spike/embed/gc_ml.ml deleted file mode 100644 index e8b63ebf..00000000 --- a/spike/embed/gc_ml.ml +++ /dev/null @@ -1,21 +0,0 @@ -(* Step 6: the OCaml GC beside Flan's arenas. - Allocate hard, then compact -- the most disruptive thing the collector does, - since compaction is what actually moves blocks. C checks its arena after. *) - -external note : nativeint -> unit = "spike_note_arena" - -let () = - Callback.register "spike_churn" (fun (rounds : int) -> - let keep = ref [] in - for i = 1 to rounds do - (* Garbage, plus a little that survives, so the heap really grows. *) - for _ = 1 to 2000 do ignore (Bytes.create 512) done; - if i mod 10 = 0 then keep := Bytes.create 4096 :: !keep - done; - Gc.full_major (); - Gc.compact (); - let s = Gc.quick_stat () in - Printf.sprintf - "allocated %.0f words, %d major collections, %d compactions, heap %d words" - s.Gc.minor_words s.Gc.major_collections s.Gc.compactions s.Gc.heap_words); - ignore note diff --git a/spike/embed/harness1.c b/spike/embed/harness1.c deleted file mode 100644 index 63d6c29a..00000000 --- a/spike/embed/harness1.c +++ /dev/null @@ -1,14 +0,0 @@ -/* A C main() that owns the process and starts the OCaml runtime underneath it. */ -#include -#include -#include - -int main(int argc, char **argv) { - (void)argc; - caml_startup(argv); - const value *f = caml_named_value("spike_greet"); - if (!f) { fprintf(stderr, "spike: greet not registered\n"); return 1; } - printf("%s\n", String_val(caml_callback(*f, Val_int(42)))); - printf("spike: C main still owns the process\n"); - return 0; -} diff --git a/spike/embed/harness2.c b/spike/embed/harness2.c deleted file mode 100644 index ab960f51..00000000 --- a/spike/embed/harness2.c +++ /dev/null @@ -1,54 +0,0 @@ -/* Step 2: the whole compiler inside a C binary, and what it costs to start. - * - * The startup number is measured around caml_startup itself, not with time(1) - * on the process -- what a merged dev build would pay is the runtime coming up - * and every module initialiser running, not exec and dynamic linking, which it - * pays today anyway. */ -#include -#include -#include -#include -#include - -#ifndef FLANSRC -#define FLANSRC "test/programs/edn.flan" -#endif - -static double ms_since(struct timespec a) { - struct timespec b; - clock_gettime(CLOCK_MONOTONIC, &b); - return (b.tv_sec - a.tv_sec) * 1e3 + (b.tv_nsec - a.tv_nsec) / 1e6; -} - -static const value *need(const char *n) { - const value *f = caml_named_value(n); - if (!f) fprintf(stderr, "spike: %s not registered\n", n); - return f; -} - -int main(int argc, char **argv) { - struct timespec t0; - const char *src = argc > 1 ? argv[1] : FLANSRC; - const value *f; - - clock_gettime(CLOCK_MONOTONIC, &t0); - caml_startup(argv); - printf("caml_startup (runtime + every module initialiser): %.3f ms\n", ms_since(t0)); - - f = need("spike_footprint"); - if (f) printf("linked-module footprint: %s\n", String_val(caml_callback(*f, Val_unit))); - - f = need("spike_compile"); - if (f) { - clock_gettime(CLOCK_MONOTONIC, &t0); - printf("%s\n", String_val(caml_callback(*f, caml_copy_string(src)))); - printf("first in-process compile (read+parse+check+emit): %.3f ms\n", ms_since(t0)); - - clock_gettime(CLOCK_MONOTONIC, &t0); - caml_callback(*f, caml_copy_string(src)); - printf("second, warm: %.3f ms\n", ms_since(t0)); - } - - printf("spike: C main() still owns the process\n"); - return 0; -} diff --git a/spike/embed/harness3.c b/spike/embed/harness3.c deleted file mode 100644 index 09b069f4..00000000 --- a/spike/embed/harness3.c +++ /dev/null @@ -1,14 +0,0 @@ -/* Step 3: does -output-complete-obj carry the project's C stubs through? */ -#include -#include -#include - -int main(int argc, char **argv) { - const value *f; - (void)argc; - caml_startup(argv); - f = caml_named_value("spike_stubs"); - if (!f) { fprintf(stderr, "spike: stubs not registered\n"); return 1; } - printf("stubs reached from embedded runtime: %s\n", String_val(caml_callback(*f, Val_unit))); - return 0; -} diff --git a/spike/embed/harness4.c b/spike/embed/harness4.c deleted file mode 100644 index 49e789d8..00000000 --- a/spike/embed/harness4.c +++ /dev/null @@ -1,106 +0,0 @@ -/* Step 4: the macOS shape, and the discriminating test of the whole spike. - * - * main() is the game: it takes the thread the window needs and runs a loop it - * never leaves until the compiler says stop. The OCaml runtime is started on a - * pthread that C spawned -- exactly where vendor/agent/flan_agent.c already - * puts its listener. - * - * Two separate claims get tested: - * a. caml_startup works on a non-main, C-created thread at all. - * b. a *different* C thread, one the runtime never created, can call into - * OCaml after caml_c_thread_register(). - * (b) is the one that matters for the agent: its listener thread is spawned by - * flan_agent_start and would have to be able to reach the compiler. - */ -#include -#include -#include -#include -#include -#include -#include -#include -#include - -static char **g_argv; -static const char *g_src = "test/programs/edn.flan"; -static atomic_int compiler_up = 0; -static atomic_int quit = 0; -static pthread_t main_tid; - -static void nap(long ms) { - struct timespec t = { ms / 1000, (ms % 1000) * 1000000L }; - nanosleep(&t, NULL); -} - -static const value *need(const char *n) { - const value *f = caml_named_value(n); - if (!f) fprintf(stderr, "spike: %s not registered\n", n); - return f; -} - -/* The compiler thread: starts the OCaml runtime off the main thread. */ -static void *compiler_thread(void *unused) { - const value *f; - (void)unused; - printf(" [compiler thread] is main thread? %s\n", - pthread_equal(pthread_self(), main_tid) ? "YES (wrong)" : "no (correct)"); - caml_startup(g_argv); - printf(" [compiler thread] caml_startup returned off the main thread\n"); - - f = need("spike_domains"); - if (f) printf(" [compiler thread] %s\n", String_val(caml_callback(*f, Val_unit))); - - f = need("spike_thread_compile"); - if (f) printf(" [compiler thread] %s\n", - String_val(caml_callback(*f, caml_copy_string(g_src)))); - - /* Hand the runtime over so another C thread can borrow it, and prove the - main loop kept running throughout. */ - atomic_store(&compiler_up, 1); - caml_release_runtime_system(); - nap(300); - caml_acquire_runtime_system(); - atomic_store(&quit, 1); - return NULL; -} - -/* A second C thread, like the agent's listener: never created by OCaml. */ -static void *listener_thread(void *unused) { - const value *f; - (void)unused; - while (!atomic_load(&compiler_up)) nap(5); - if (caml_c_thread_register() == 0) { - printf(" [listener thread] caml_c_thread_register FAILED\n"); - return NULL; - } - caml_acquire_runtime_system(); - f = need("spike_thread_compile"); - if (f) printf(" [listener thread] %s\n", - String_val(caml_callback(*f, caml_copy_string(g_src)))); - caml_release_runtime_system(); - caml_c_thread_unregister(); - printf(" [listener thread] registered, called OCaml, unregistered\n"); - return NULL; -} - -int main(int argc, char **argv) { - pthread_t comp, lst; - long frames = 0; - g_argv = argv; - if (argc > 1) g_src = argv[1]; - main_tid = pthread_self(); - - if (pthread_create(&comp, NULL, compiler_thread, NULL) != 0) return 1; - if (pthread_create(&lst, NULL, listener_thread, NULL) != 0) return 1; - - /* The game loop. This thread never calls into OCaml and never blocks on it -- - it is the window's thread, and on macOS it has to be this one. */ - while (!atomic_load(&quit)) { frames++; nap(1); } - - pthread_join(comp, NULL); - pthread_join(lst, NULL); - printf(" [main thread] ran %ld frames without ever entering OCaml\n", frames); - printf("spike: the game kept the main thread\n"); - return 0; -} diff --git a/spike/embed/harness5.c b/spike/embed/harness5.c deleted file mode 100644 index 0e9f2143..00000000 --- a/spike/embed/harness5.c +++ /dev/null @@ -1,91 +0,0 @@ -/* Step 5: who owns SIGSEGV. - * - * The OCaml runtime installs a SIGSEGV handler to turn a stack-guard-page hit - * into the Stack_overflow exception. The break loop wants SIGSEGV for the - * crash case. This is the one real collision, so it is measured in both - * directions: - * - * a. what the disposition is before caml_startup, and after it; - * b. whether a handler installed AFTER caml_startup actually receives a - * genuine fault in program memory -- i.e. whether the break loop can have - * what it wants by installing last. - * - * SIGPIPE is not probed: flan_agent.c sends with MSG_NOSIGNAL throughout and - * does not rely on a disposition. - */ -#include -#include -#include -#include -#include -#include - -static void describe(const char *when, int sig) { - struct sigaction old; - memset(&old, 0, sizeof old); - sigaction(sig, NULL, &old); - printf(" %-22s %-8s handler=%p flags=%#x %s%s\n", when, - sig == SIGSEGV ? "SIGSEGV" : sig == SIGINT ? "SIGINT" : "SIGFPE", - (old.sa_flags & SA_SIGINFO) ? (void *)old.sa_sigaction : (void *)old.sa_handler, - (unsigned)old.sa_flags, - (old.sa_flags & SA_ONSTACK) ? "ONSTACK " : "", - old.sa_handler == SIG_DFL ? "(SIG_DFL)" - : old.sa_handler == SIG_IGN ? "(SIG_IGN)" : "(custom)"); -} - -static sigjmp_buf escape; -static volatile sig_atomic_t ours_ran = 0; - -static void our_segv(int sig, siginfo_t *info, void *ctx) { - (void)sig; (void)ctx; - ours_ran = 1; - /* What a break loop would do here is stop and serve; the spike just proves - the handler was reached, with the faulting address in hand. */ - printf(" our SIGSEGV handler ran, fault address = %p\n", info->si_addr); - siglongjmp(escape, 1); -} - -int main(int argc, char **argv) { - struct sigaction sa, ocaml_segv; - volatile int *bad = (int *)0x10; - (void)argc; - - printf("before caml_startup:\n"); - describe("before startup", SIGSEGV); - describe("before startup", SIGINT); - describe("before startup", SIGFPE); - - caml_startup(argv); - - printf("after caml_startup:\n"); - describe("after startup", SIGSEGV); - describe("after startup", SIGINT); - describe("after startup", SIGFPE); - memset(&ocaml_segv, 0, sizeof ocaml_segv); - sigaction(SIGSEGV, NULL, &ocaml_segv); - - /* Now install ours last, the way the break loop would. */ - memset(&sa, 0, sizeof sa); - sa.sa_sigaction = our_segv; - sa.sa_flags = SA_SIGINFO | SA_ONSTACK; - sigemptyset(&sa.sa_mask); - sigaction(SIGSEGV, &sa, NULL); - printf("break loop installs last:\n"); - describe("after break loop", SIGSEGV); - - if (sigsetjmp(escape, 1) == 0) { - printf(" dereferencing %p ...\n", (void *)bad); - *bad = 1; - printf(" no fault -- UNEXPECTED\n"); - } else { - printf(" recovered; a handler installed after caml_startup does receive " - "a real fault: %s\n", ours_ran ? "yes" : "no"); - } - - /* And the cost of taking it: OCaml's own handler is now displaced, so its - stack-overflow detection is gone unless ours chains to the saved one. */ - printf(" OCaml's displaced SIGSEGV handler was %p -- chaining to it is what " - "keeps Stack_overflow working\n", - (void *)ocaml_segv.sa_sigaction); - return 0; -} diff --git a/spike/embed/harness5b.c b/spike/embed/harness5b.c deleted file mode 100644 index 1b164121..00000000 --- a/spike/embed/harness5b.c +++ /dev/null @@ -1,110 +0,0 @@ -/* Step 5b: the SIGSEGV question, asked properly. - * - * 5a read the disposition either side of caml_startup and found SIG_DFL both - * times, which would mean no collision at all. That is too good, and it is - * because OCaml 5 installs the handler per *domain*, on the domain's own - * thread, not once during startup. So this asks at four moments, and then asks - * the only question that decides anything: with the break loop holding SIGSEGV, - * does an OCaml stack overflow still raise Stack_overflow, or does it become a - * hard crash? - * - * Two ways of taking it are compared: - * take_segv -- install ours and discard OCaml's, the naive thing; - * chain_segv -- install ours, keep OCaml's, and forward to it. - */ -#include -#include -#include -#include -#include -#include -#include - -static struct sigaction ocaml_segv; -static int have_ocaml_segv = 0; - -CAMLprim value spike_show_segv(value when) { - struct sigaction cur; - memset(&cur, 0, sizeof cur); - sigaction(SIGSEGV, NULL, &cur); - printf(" SIGSEGV %-46s handler=%p flags=%#x%s\n", String_val(when), - (cur.sa_flags & SA_SIGINFO) ? (void *)cur.sa_sigaction - : (void *)cur.sa_handler, - (unsigned)cur.sa_flags, - cur.sa_handler == SIG_DFL ? " (SIG_DFL)" : ""); - fflush(stdout); - return Val_unit; -} - -/* The break loop's handler. It does not long-jump here -- the point is only to - * see whether it is reached and whether OCaml still works around it. */ -static void break_segv(int sig, siginfo_t *info, void *ctx) { - (void)sig; - if (have_ocaml_segv && ocaml_segv.sa_sigaction && - ocaml_segv.sa_handler != SIG_DFL && ocaml_segv.sa_handler != SIG_IGN) { - /* Chained: hand the fault to OCaml, which turns a guard-page hit into - * Stack_overflow and re-raises anything else. */ - ocaml_segv.sa_sigaction(sig, info, ctx); - return; - } - /* Taken outright: nothing below us. A real break loop would stop and serve; - * here we can only abort, which is the honest cost of discarding OCaml's. */ - printf(" break loop caught SIGSEGV at %p with nothing to chain to\n", - info->si_addr); - fflush(stdout); - _exit(9); -} - -static void install(int keep_old) { - struct sigaction sa; - memset(&sa, 0, sizeof sa); - memset(&ocaml_segv, 0, sizeof ocaml_segv); - sigaction(SIGSEGV, NULL, &ocaml_segv); - have_ocaml_segv = keep_old; - sa.sa_sigaction = break_segv; - sa.sa_flags = SA_SIGINFO | SA_ONSTACK | SA_NODEFER; - sigemptyset(&sa.sa_mask); - sigaction(SIGSEGV, &sa, NULL); -} - -/* A sweep, so "the OCaml runtime installs handlers" can be stated as a list - * rather than a worry. Called from OCaml with the runtime and a domain up. */ -CAMLprim value spike_sweep(value u) { - static const int sigs[] = { SIGSEGV, SIGBUS, SIGFPE, SIGILL, SIGINT, SIGTERM, - SIGPIPE, SIGCHLD, SIGUSR1, SIGUSR2, SIGABRT, - SIGALRM, SIGPROF, SIGVTALRM, SIGWINCH }; - static const char *names[] = { "SEGV", "BUS", "FPE", "ILL", "INT", "TERM", - "PIPE", "CHLD", "USR1", "USR2", "ABRT", - "ALRM", "PROF", "VTALRM", "WINCH" }; - struct sigaction c; - unsigned i; - (void)u; - for (i = 0; i < sizeof sigs / sizeof *sigs; i++) { - memset(&c, 0, sizeof c); - sigaction(sigs[i], NULL, &c); - if (c.sa_handler != SIG_DFL) - printf(" SIG%-8s %s\n", names[i], - c.sa_handler == SIG_IGN ? "SIG_IGN" : "custom handler"); - } - printf(" (every signal not named above is SIG_DFL)\n"); - fflush(stdout); - return Val_unit; -} - -CAMLprim value spike_take_segv(value u) { (void)u; install(0); return Val_unit; } -CAMLprim value spike_chain_segv(value u) { (void)u; install(1); return Val_unit; } - -#ifndef SPIKE_NO_MAIN -int main(int argc, char **argv) { - struct sigaction cur; - (void)argc; - memset(&cur, 0, sizeof cur); - sigaction(SIGSEGV, NULL, &cur); - printf(" SIGSEGV %-46s handler=%p%s\n", "before caml_startup", - (void *)cur.sa_handler, cur.sa_handler == SIG_DFL ? " (SIG_DFL)" : ""); - /* Everything else runs from sig_ml.ml's module initialiser, so the readings - * happen on the runtime's own thread at the moments that matter. */ - caml_startup(argv); - return 0; -} -#endif diff --git a/spike/embed/harness6.c b/spike/embed/harness6.c deleted file mode 100644 index 670e854e..00000000 --- a/spike/embed/harness6.c +++ /dev/null @@ -1,61 +0,0 @@ -/* Step 6: does OCaml's collector touch memory it does not own? - * - * Flan's arenas, Vecs and Maps are plain malloc'd memory. The claim is that - * OCaml never sees them, so a compaction cannot move or scribble on them. The - * probe: fill an arena with a checkable pattern, hold raw interior pointers - * into it across a full major collection AND a compaction, then verify every - * byte and every pointer. - * - * What this proves is narrow and worth stating narrowly: OCaml traces its own - * roots only. It does NOT license storing an OCaml `value` in this arena -- - * that would need caml_register_global_root, and is the way the assumption - * actually breaks. - */ -#include -#include -#include -#include -#include -#include - -#define ARENA (8u << 20) /* 8 MiB, the shape of a Flan arena */ - -static uint8_t *arena; -static uint64_t *interior[64]; - -CAMLprim value spike_note_arena(value p) { (void)p; return Val_unit; } - -static uint8_t pattern(size_t i) { return (uint8_t)(i * 31u + 7u); } - -int main(int argc, char **argv) { - const value *f; - size_t i, bad = 0; - uint8_t *before; - (void)argc; - - arena = malloc(ARENA); - if (!arena) return 1; - for (i = 0; i < ARENA; i++) arena[i] = pattern(i); - for (i = 0; i < 64; i++) interior[i] = (uint64_t *)(arena + i * 4096); - before = arena; - - caml_startup(argv); - - f = caml_named_value("spike_churn"); - if (!f) { fprintf(stderr, "spike: churn not registered\n"); return 1; } - printf("%s\n", String_val(caml_callback(*f, Val_int(200)))); - - for (i = 0; i < ARENA; i++) if (arena[i] != pattern(i)) bad++; - printf("arena base %s (%p -> %p)\n", before == arena ? "unmoved" : "MOVED", - (void *)before, (void *)arena); - printf("arena bytes altered by the GC: %zu of %u\n", bad, ARENA); - - bad = 0; - for (i = 0; i < 64; i++) - if (interior[i] != (uint64_t *)(arena + i * 4096)) bad++; - printf("raw interior pointers invalidated: %zu of 64\n", bad); - printf("spike: %s\n", bad == 0 ? "foreign memory is invisible to the collector" - : "FOREIGN MEMORY WAS DISTURBED"); - free(arena); - return 0; -} diff --git a/spike/embed/hello_ml.ml b/spike/embed/hello_ml.ml deleted file mode 100644 index dbef30c1..00000000 --- a/spike/embed/hello_ml.ml +++ /dev/null @@ -1,5 +0,0 @@ -(* Step 1: the smallest thing that proves OCaml code can be reached from a C - [main]. One function, registered by name, called back from C. *) -let () = - Callback.register "spike_greet" (fun (n : int) -> - Printf.sprintf "ocaml saw %d, unix says pid %d" n (Unix.getpid ())) diff --git a/spike/embed/merged.sh b/spike/embed/merged.sh deleted file mode 100644 index c9639640..00000000 --- a/spike/embed/merged.sh +++ /dev/null @@ -1,66 +0,0 @@ -#!/usr/bin/env bash -# Step 8: the thing the whole spike is really asking about -- ONE binary that -# is both a compiled Flan program and the OCaml compiler, with clang doing the -# final link. -# -# Everything before this proved a piece. This proves the shape: the Flan -# program's own main() is renamed out of the way, a C main() takes the main -# thread and runs the program there, and caml_startup happens on a side thread -# beside it. That is exactly item 11's inversion, built for real. -# -# It is NOT the merged architecture -- nothing is wired up, the compiler and the -# program do not talk. It is a link and a size and a startup number. -set -u -here=$(cd "$(dirname "$0")" && pwd) -root=$(cd "$here/../.." && pwd) -src=${1:-test/programs/edn.flan} -cd "$root" || exit 1 -out=$(mktemp -d); trap 'rm -rf "$out"' EXIT - -FLAN=_build/default/bin/main.exe -OCAMLLIB=$(ocamlopt -where) -SYSLIBS="-lm -lpthread -ldl -lzstd" - -echo "program: $src" - -# 1. The Flan program, as it is built today, for the baseline sizes. -"$FLAN" build "$src" -o "$out/rel" || exit 1 -"$FLAN" build "$src" --dev -o "$out/dev" || exit 1 - -# 2. The same program as an object, with its main renamed so a C main can own -# the process. Emit writes @main literally; sed is enough to move it. -"$FLAN" emit "$src" --dev > "$out/prog.ll" || exit 1 -sed -i 's/define i32 @main(/define i32 @flan_program_main(/' "$out/prog.ll" -grep -q 'define i32 @flan_program_main(' "$out/prog.ll" || { - echo "could not find @main in the emitted IR -- adjust the rename"; exit 1; } -clang -c -x ir "$out/prog.ll" -o "$out/prog.o" || exit 1 - -# 3. The runtime the program needs, and the agent beside it. -clang -c -O2 runtime/flan_rt.c -o "$out/rt.o" || exit 1 -clang -c -O2 runtime/flan_dev.c -o "$out/dev.o" || exit 1 -clang -c -O2 vendor/agent/flan_agent.c -o "$out/ag.o" || exit 1 - -# 4. The whole OCaml compiler as one object. -ocamlfind ocamlopt -thread -package unix,threads.posix -linkpkg \ - -output-complete-obj \ - -I "$root/_build/default/lib/.flan.objs/byte" \ - -I "$root/_build/default/lib/.flan.objs/native" \ - -o "$out/compiler.o" "$root/_build/default/lib/flan.cmxa" \ - "$here/thread_ml.ml" || exit 1 - -# 5. One link. clang, as the project already does it. -clang -I"$OCAMLLIB" "$here/merged_main.c" "$out/prog.o" "$out/rt.o" "$out/dev.o" \ - "$out/ag.o" "$out/compiler.o" -o "$out/merged" $SYSLIBS || exit 1 - -echo -echo "sizes:" -for f in rel dev merged; do - printf ' %-30s %9d bytes\n' "$f" "$(stat -c%s "$out/$f")" -done -printf ' %-30s %9d bytes\n' "what the compiler adds to a dev build" \ - "$(( $(stat -c%s "$out/merged") - $(stat -c%s "$out/dev") ))" - -echo -echo "running the merged binary:" -"$out/merged" "$src" -echo "exit: $?" diff --git a/spike/embed/merged_main.c b/spike/embed/merged_main.c deleted file mode 100644 index 85d0bccf..00000000 --- a/spike/embed/merged_main.c +++ /dev/null @@ -1,77 +0,0 @@ -/* One process: the Flan program on the main thread, the OCaml compiler beside - * it on a domain of its own. - * - * This is the shape item 11 settles on, and the reason it is written this way - * round rather than the other: on macOS the window has to be on the main - * thread, so the game keeps main() and the compiler moves to the side -- - * beside the listener vendor/agent/flan_agent.c already starts there. - * - * The program and the compiler do not talk to each other here. Wiring them up - * is the real work; this only shows they can share an address space, a link, - * and a process, with clang doing the final link. */ -#include -#include -#include -#include -#include -#include -#include -#include - -/* The Flan program's entry point, renamed out of main's way by merged.sh. */ -extern int flan_program_main(int argc, char **argv); - -static char **g_argv; -static const char *g_src; -/* The Flan program's main calls exit(), so the compiler has to be up before it - * starts -- which is the honest ordering anyway: the image comes up and serves, - * then the program runs, the way starting an SBCL image does. */ -static atomic_int compiler_ready = 0; - -static double ms_since(struct timespec a) { - struct timespec b; - clock_gettime(CLOCK_MONOTONIC, &b); - return (b.tv_sec - a.tv_sec) * 1e3 + (b.tv_nsec - a.tv_nsec) / 1e6; -} - -static void *compiler_side(void *unused) { - struct timespec t0; - const value *f; - (void)unused; - clock_gettime(CLOCK_MONOTONIC, &t0); - caml_startup(g_argv); - printf("[compiler] up on a side thread in %.3f ms\n", ms_since(t0)); - f = caml_named_value("spike_thread_compile"); - if (f) { - clock_gettime(CLOCK_MONOTONIC, &t0); - printf("[compiler] %s\n", String_val(caml_callback(*f, caml_copy_string(g_src)))); - printf("[compiler] compiled the running program from inside it, in %.3f ms\n", - ms_since(t0)); - } - caml_release_runtime_system(); - atomic_store(&compiler_ready, 1); - return NULL; -} - -int main(int argc, char **argv) { - pthread_t comp; - int rc; - g_argv = argv; - g_src = argc > 1 ? argv[1] : "test/programs/edn.flan"; - - if (pthread_create(&comp, NULL, compiler_side, NULL) != 0) return 1; - - while (!atomic_load(&compiler_ready)) { - struct timespec t = { 0, 2000000L }; - nanosleep(&t, NULL); - } - - /* The main thread is the program's, and it never enters OCaml. */ - printf("[program] running on the main thread\n"); - rc = flan_program_main(argc, argv); - printf("[program] returned %d\n", rc); - - pthread_join(comp, NULL); - printf("one process: a Flan program and the OCaml compiler, same binary\n"); - return 0; -} diff --git a/spike/embed/run.sh b/spike/embed/run.sh deleted file mode 100644 index 51fdcc10..00000000 --- a/spike/embed/run.sh +++ /dev/null @@ -1,76 +0,0 @@ -#!/usr/bin/env bash -# Spike: what it costs to link the OCaml compiler into a native Flan dev build. -# -# Deliberately NOT a dune target. The root `dune` only excludes old-ocaml/, so a -# dune file here would land in @default and make the spike part of the build. -# Instead this drives ocamlfind and clang by hand, against the flan.cmxa that -# dune already produces. Run it from anywhere: bash spike/embed/run.sh -set -u - -here=$(cd "$(dirname "$0")" && pwd) -root=$(cd "$here/../.." && pwd) -cd "$here" || exit 1 - -OCAMLLIB=$(ocamlopt -where) -CAMLINC="-I$OCAMLLIB" -# OCaml 5.2's marshaller is compressed, so -output-complete-obj pulls in zstd. -SYSLIBS="-lm -lpthread -ldl -lzstd" - -step() { printf '\n=== %s ===\n' "$1"; } - -# ---------------------------------------------------------------- 1. smallest -step "1. smallest link: C main() -> caml_startup -> OCaml callback" -ocamlfind ocamlopt -package unix -linkpkg -output-complete-obj \ - -o embed1.o hello_ml.ml || exit 1 -clang $CAMLINC harness1.c embed1.o -o spike1 $SYSLIBS || exit 1 -./spike1 || echo "spike1 FAILED" -ls -l spike1 | awk '{print "spike1 size: " $5 " bytes"}' - -# ------------------------------------------------------- 2. the real compiler -step "2. link the whole flan compiler (flan.cmxa) into a C binary" -CMXA="$root/_build/default/lib/flan.cmxa" -if [ ! -f "$CMXA" ]; then - echo "no $CMXA -- run 'dune build --root .' first"; exit 1 -fi -ocamlfind ocamlopt -package unix -linkpkg -output-complete-obj \ - -I "$root/_build/default/lib/.flan.objs/byte" \ - -I "$root/_build/default/lib/.flan.objs/native" \ - -o embed2.o "$CMXA" whole_ml.ml || exit 1 -clang $CAMLINC harness2.c embed2.o -o spike2 $SYSLIBS || exit 1 -(cd "$root" && "$here/spike2" test/programs/edn.flan) || echo "spike2 FAILED" -ls -l spike2 | awk '{print "spike2 size: " $5 " bytes"}' -ls -l "$root/_build/default/bin/main.exe" | awk '{print "main.exe size: " $5 " bytes"}' -clang $CAMLINC baseline.c -o baseline -ls -l baseline | awk '{print "bare C baseline: " $5 " bytes"}' - -# ------------------------------------------------------------- 3. with stubs -step "3. the same, with the project's own C stubs compiled in" -ocamlfind ocamlopt -package unix -linkpkg -output-complete-obj \ - -I "$root/_build/default/lib/.flan.objs/byte" \ - -I "$root/_build/default/lib/.flan.objs/native" \ - -o embed3.o "$CMXA" stubs_ml.ml dynload_stubs.c || exit 1 -clang $CAMLINC harness3.c embed3.o -o spike3 $SYSLIBS || exit 1 -./spike3 || echo "spike3 FAILED" - -# ------------------------------------------ 4. threads: game owns main thread -step "4. threads: C main runs the 'game loop', OCaml starts on another thread" -ocamlfind ocamlopt -thread -package unix,threads.posix -linkpkg -output-complete-obj \ - -I "$root/_build/default/lib/.flan.objs/byte" \ - -I "$root/_build/default/lib/.flan.objs/native" \ - -o embed4.o "$CMXA" thread_ml.ml || exit 1 -clang $CAMLINC harness4.c embed4.o -o spike4 $SYSLIBS || exit 1 -(cd "$root" && "$here/spike4" test/programs/edn.flan) || echo "spike4 FAILED" - -# ------------------------------------------------------------ 5. signals -step "5. signals: who owns SIGSEGV across caml_startup" -clang $CAMLINC harness5.c embed2.o -o spike5 $SYSLIBS || exit 1 -./spike5 || echo "spike5 exited nonzero" - -# ------------------------------------------------------- 6. GC vs raw memory -step "6. GC: does a compaction move or touch a C-owned arena" -ocamlfind ocamlopt -package unix -linkpkg -output-complete-obj \ - -o embed6.o gc_ml.ml || exit 1 -clang $CAMLINC harness6.c embed6.o -o spike6 $SYSLIBS || exit 1 -./spike6 || echo "spike6 FAILED" - -printf '\nspike: done\n' diff --git a/spike/embed/sig.sh b/spike/embed/sig.sh deleted file mode 100644 index 6b6a2383..00000000 --- a/spike/embed/sig.sh +++ /dev/null @@ -1,23 +0,0 @@ -#!/usr/bin/env bash -# Step 5b on its own: the SIGSEGV question, embedded and standalone side by -# side. The standalone build is the control -- if OCaml behaves the same in a -# plain ocamlopt executable, then embedding changed nothing about signals. -set -u -here=$(cd "$(dirname "$0")" && pwd) -cd "$here" || exit 1 -OCAMLLIB=$(ocamlopt -where) -SYSLIBS="-lm -lpthread -ldl -lzstd" - -echo "=== 5b-embedded: caml_startup called from a C main() ===" -ocamlfind ocamlopt -package unix -linkpkg -output-complete-obj \ - -o embed5b.o sig_ml.ml || exit 1 -clang -I"$OCAMLLIB" harness5b.c embed5b.o -o spike5b $SYSLIBS || exit 1 -./spike5b; echo "exit: $?" - -echo -echo "=== 5b-standalone: the same OCaml, as a plain ocamlopt executable ===" -# The control. Same stubs, but OCaml owns main(). -clang -c -I"$OCAMLLIB" -DSPIKE_NO_MAIN harness5b.c -o stubs5b.o || exit 1 -ocamlfind ocamlopt -package unix -linkpkg -o spike5b_std sig_ml.ml stubs5b.o \ - -cclib -lzstd || exit 1 -./spike5b_std; echo "exit: $?" diff --git a/spike/embed/sig_ml.ml b/spike/embed/sig_ml.ml deleted file mode 100644 index 5d96ba2b..00000000 --- a/spike/embed/sig_ml.ml +++ /dev/null @@ -1,34 +0,0 @@ -(* Step 5b: OCaml 5.2 installs its SIGSEGV handler per-domain, not once at - startup, so "read the disposition after caml_startup" is not the whole - question. This asks it at four moments, and then asks the thing that - actually matters: does Stack_overflow still get raised once the break loop - has taken SIGSEGV? *) - -external show : string -> unit = "spike_show_segv" -external take_segv : unit -> unit = "spike_take_segv" -external chain_segv : unit -> unit = "spike_chain_segv" -external sweep : unit -> unit = "spike_sweep" - -let rec deep n = if n <= 0 then 0 else 1 + deep (n - 1) + (if n < 0 then deep n else 0) - -let overflow_result () = - try - let n = deep 100_000_000 in - Printf.sprintf "returned %d (no overflow)" n - with Stack_overflow -> "Stack_overflow raised" - -let () = - show "at module init (main domain up)"; - let d = Domain.spawn (fun () -> show "inside a spawned domain") in - Domain.join d; - show "after Domain.join"; - print_endline "every signal the OCaml runtime is holding:"; - sweep (); - Printf.sprintf "before touching SIGSEGV: %s" (overflow_result ()) |> print_endline; - take_segv (); - show "after the break loop takes SIGSEGV outright"; - Printf.sprintf "with SIGSEGV taken outright: %s" (overflow_result ()) - |> print_endline; - chain_segv (); - show "after the break loop chains to OCaml's handler"; - Printf.sprintf "with SIGSEGV chained: %s" (overflow_result ()) |> print_endline diff --git a/spike/embed/stubs_ml.ml b/spike/embed/stubs_ml.ml deleted file mode 100644 index 34a2664a..00000000 --- a/spike/embed/stubs_ml.ml +++ /dev/null @@ -1,26 +0,0 @@ -(* Step 3: the project's own C stubs, in the same link as the compiler. - lib/dynload_stubs.c is taken verbatim from 9e0ae3a (the unmerged dlopen - branch) -- it is the only C the compiler itself is built from, and it is the - case that -output-complete-obj has to carry through. *) - -external dl_open : string -> nativeint = "flan_dl_open" -external dl_sym : nativeint -> string -> nativeint = "flan_dl_sym" -external mem_alloc : int -> nativeint = "flan_mem_alloc" -external mem_free : nativeint -> unit = "flan_mem_free" -external poke_i64 : nativeint -> int -> int64 -> unit = "flan_poke_i64" -external peek_i64 : nativeint -> int -> int64 = "flan_peek_i64" - -let () = - Callback.register "spike_stubs" (fun () -> - (* peek/poke: the raw memory the marshaller lays a Form image out in. *) - let p = mem_alloc 64 in - poke_i64 p 8 0xfeedfacedeadbeefL; - let got = peek_i64 p 8 in - mem_free p; - (* dlopen from inside the embedded runtime, on the process's own image. *) - let h = dl_open "libm.so.6" in - let s = dl_sym h "sqrt" in - Printf.sprintf "peek/poke %s; dlopen+dlsym %s" - (if got = 0xfeedfacedeadbeefL then "ok" else "WRONG") - (if s <> 0n then "ok" else "WRONG")); - ignore dl_open diff --git a/spike/embed/symbols.sh b/spike/embed/symbols.sh deleted file mode 100644 index 34e4bed8..00000000 --- a/spike/embed/symbols.sh +++ /dev/null @@ -1,50 +0,0 @@ -#!/usr/bin/env bash -# Step 7: the integration hazard nobody asks about until the link fails. -# -# Today runtime/flan_rt.c, runtime/flan_dev.c and vendor/agent/flan_agent.c are -# compiled into the *program*, and lib/dynload_stubs.c into the *compiler*. -# Merging the processes puts all four and the OCaml runtime in one link. This -# checks, symbol by symbol, whether anything collides. -set -u -here=$(cd "$(dirname "$0")" && pwd) -root=$(cd "$here/../.." && pwd) -out=$(mktemp -d) -trap 'rm -rf "$out"' EXIT -cd "$root" || exit 1 - -defs() { nm --defined-only "$@" 2>/dev/null | awk 'NF==3 {print $3}' | sort -u; } - -clang -c runtime/flan_rt.c -o "$out/rt.o" || exit 1 -clang -c runtime/flan_dev.c -o "$out/dev.o" || exit 1 -clang -c vendor/agent/flan_agent.c -o "$out/ag.o" || exit 1 -clang -c -I"$(ocamlopt -where)" "$here/dynload_stubs.c" -o "$out/dl.o" || exit 1 - -defs "$out/rt.o" "$out/dev.o" "$out/ag.o" "$out/dl.o" > "$out/flan.syms" -defs /home/joe/.opam/default/lib/ocaml/libasmrun.a > "$out/ml.syms" 2>/dev/null -[ -s "$out/ml.syms" ] || defs "$(ocamlopt -where)/libasmrun.a" > "$out/ml.syms" - -echo "Flan's own C defines $(wc -l < "$out/flan.syms") symbols;" \ - "libasmrun defines $(wc -l < "$out/ml.syms")." -echo "collisions between Flan's C and the OCaml runtime:" -if comm -12 "$out/flan.syms" "$out/ml.syms" | grep . ; then - echo " ^^ those would have to be renamed" -else - echo " none" -fi - -echo "collisions among Flan's own four .c files:" -for a in rt dev ag dl; do defs "$out/$a.o" > "$out/$a.syms"; done -found=0 -for a in rt dev ag dl; do - for b in rt dev ag dl; do - [ "$a" \< "$b" ] || continue - c=$(comm -12 "$out/$a.syms" "$out/$b.syms") - [ -n "$c" ] && { echo " $a vs $b:"; echo "$c" | sed 's/^/ /'; found=1; } - done -done -[ $found -eq 0 ] && echo " none" - -echo "what Flan's C needs that the OCaml runtime also exports (shared libc etc):" -nm --undefined-only "$out/rt.o" "$out/ag.o" 2>/dev/null | awk 'NF==2{print $2}' \ - | sort -u > "$out/need.syms" -comm -12 "$out/need.syms" "$out/ml.syms" | sed 's/^/ /' | head -20 diff --git a/spike/embed/thread_ml.ml b/spike/embed/thread_ml.ml deleted file mode 100644 index 81d0fad2..00000000 --- a/spike/embed/thread_ml.ml +++ /dev/null @@ -1,32 +0,0 @@ -(* Step 4: the macOS shape. The game owns the main thread; the compiler and the - listener run beside it. - - The question is NOT "can OCaml use threads" -- it is whether caml_startup can - be called from a pthread that C spawned, while main() goes on to run a - window loop it never returns from. That is the inversion item 11 settles on, - and it is the one that has to be measured rather than assumed. *) - -let compile file = - let l = Flan.Load.program ~file (Flan.Parse.program (Flan.Reader.read_file file)) in - let p = Flan.Check.program l.Flan.Load.decls in - String.length (Flan.Emit.program ~dev:true p) - -let () = - Callback.register "spike_thread_compile" (fun (file : string) -> - let tid = Thread.id (Thread.self ()) in - match compile file with - | n -> - Printf.sprintf "compiled on OCaml thread %d: %d bytes of LLVM IR" tid n - | exception e -> Printf.sprintf "FAILED: %s" (Printexc.to_string e)); - Callback.register "spike_domains" (fun () -> - (* A second domain doing real work while the main thread is elsewhere -- - 5.2's multicore runtime, which is the objection item 12 says has gone - away. Confirmed rather than assumed. *) - let d = Domain.spawn (fun () -> - let s = ref 0 in - for i = 1 to 5_000_000 do s := !s + i done; - (Domain.self () :> int), !s) - in - let id, s = Domain.join d in - Printf.sprintf "domain %d summed to %d; recommended_domain_count = %d" - id s (Domain.recommended_domain_count ())) diff --git a/spike/embed/whole_ml.ml b/spike/embed/whole_ml.ml deleted file mode 100644 index 38c0197b..00000000 --- a/spike/embed/whole_ml.ml +++ /dev/null @@ -1,40 +0,0 @@ -(* Step 2: reach enough of the compiler that the linker cannot drop it, and do - real compiler work in-process so the measurement is of a working compiler - rather than of dead code that happened to link. - - The work is the driver's own path, the one bin/main.ml takes: - read -> Parse.program -> Load.program -> Check.program -> Emit.program. That - is the whole front end and the whole back end short of [llc]. Check.program - prepends the prelude itself, so the prelude is in the measurement without - being fed in twice. *) - -let compile file = - let l = Flan.Load.program ~file (Flan.Parse.program (Flan.Reader.read_file file)) in - let p = Flan.Check.program l.Flan.Load.decls in - let ir = Flan.Emit.program ~dev:true p in - (List.length l.Flan.Load.decls, String.length ir) - -(* Touched only so the linker keeps the modules a merged dev build would carry. - Nothing here is called for its effect. *) -let footprint () = - String.concat "," - [ Flan.Build.clang; - string_of_int (String.length Flan.Shim.header); - string_of_int (String.length Flan.Runtime_src.source); - string_of_int (String.length Flan.Runtime_src.dev_source); - string_of_int (List.length Flan.Session.externs); - string_of_int (Flan.Render.max_span); - string_of_int (String.length (Flan.Wire.ints [ 1; 2 ])) ] - -let () = - Callback.register "spike_compile" (fun (file : string) -> - match compile file with - | d, n -> Printf.sprintf "%s: %d decls, %d bytes of LLVM IR" file d n - | exception e -> Printf.sprintf "FAILED: %s" (Printexc.to_string e)); - Callback.register "spike_footprint" footprint; - (* Dev.start and Cimport are never run here, but naming them keeps the socket - server and the C importer in the link -- a dev build pays for them. *) - Callback.register "spike_unused" (fun () -> - ignore (Flan.Dev.start : ?debug:bool -> file:string -> sock:string -> unit -> unit); - ignore (Flan.Cimport.decl_source : Flan.Ast.decl -> string); - "ok") diff --git a/spike/generics/id.flan b/spike/generics/id.flan deleted file mode 100644 index 4e029682..00000000 --- a/spike/generics/id.flan +++ /dev/null @@ -1,7 +0,0 @@ -(defn id [x $t] t x) - -(defn main [] () - (println (id 3)) - (println (id 4.5)) - (println (id 7)) - (println (id true))) diff --git a/spike/generics/measure.ml b/spike/generics/measure.ml deleted file mode 100644 index 457795a5..00000000 --- a/spike/generics/measure.ml +++ /dev/null @@ -1,171 +0,0 @@ -(* What redefining a generic function costs the dev loop, measured. - - The question the spike exists to answer: C-c C-c on a concrete function is - about 35 ms today, and a generic function that is redefined has to rebuild - *every* instantiation. So the sweep is one generic called at N concrete - types, N = 1..8, against the handwritten N-copies program it replaces, and - the three things a C-c C-c actually pays for are timed separately: - - check Check.program_with_env over the whole accumulated program — - which is what Session.eval does on every evaluation, so this is - paid whether the redefined function is generic or not. - emit Emit.redefinition for the fns being installed. - build llc + ld -shared, from Build.shared — the dominant term. - - Nothing here modifies the session or the dev loop; it drives the real ones. *) - -let tys = [| "i8"; "i16"; "i32"; "i64"; "u8"; "u16"; "u32"; "f32" |] - -let time f = - let t0 = Unix.gettimeofday () in - let x = f () in - (x, (Unix.gettimeofday () -. t0) *. 1000.) - -(* Best of k, because llc and the linker are processes and the machine is - noisy; a median would hide a systematic cost and a mean would report the - scheduler. *) -let best k f = - let rec go i acc = if i = 0 then acc else - let _, ms = time f in go (i - 1) (min acc ms) in - go k infinity - -let generic_src n = - let b = Buffer.create 1024 in - Buffer.add_string b - "(defn gswap [xs [$t] i i32 j i32] ()\n\ - \ (let [tmp (at xs i)]\n\ - \ (set (at xs i) (at xs j))\n\ - \ (set (at xs j) tmp)))\n\n\ - (defn gsort [s [$t] before? (Fn [$t $t] bool)] ()\n\ - \ (let [i 1]\n\ - \ (while (< i (length s))\n\ - \ (let [j i]\n\ - \ (while (and (> j 0) (before? (at s j) (at s (- j 1))))\n\ - \ (gswap s (- j 1) j)\n\ - \ (set j (- j 1))))\n\ - \ (set i (+ i 1)))))\n\n"; - for i = 0 to n - 1 do - Buffer.add_string b (Printf.sprintf "(defonce xs-%s [8 %s])\n" tys.(i) tys.(i)) - done; - Buffer.add_string b "\n(defn main [] ()\n"; - for i = 0 to n - 1 do - Buffer.add_string b - (Printf.sprintf " (gsort (slice xs-%s 0 8) (fn [a b] (< a b)))\n" tys.(i)) - done; - Buffer.add_string b " )\n"; - Buffer.contents b - -(* The same program as it is written today: one copy of each function per - element type, by hand. This is prelude.ml's shape. *) -let mono_src n = - let b = Buffer.create 1024 in - for i = 0 to n - 1 do - let t = tys.(i) in - Buffer.add_string b - (Printf.sprintf - "(defn mswap-%s [xs [%s] i i32 j i32] ()\n\ - \ (let [tmp (at xs i)]\n\ - \ (set (at xs i) (at xs j))\n\ - \ (set (at xs j) tmp)))\n\n\ - (defn msort-%s [s [%s] before? (Fn [%s %s] bool)] ()\n\ - \ (let [i 1]\n\ - \ (while (< i (length s))\n\ - \ (let [j i]\n\ - \ (while (and (> j 0) (before? (at s j) (at s (- j 1))))\n\ - \ (mswap-%s s (- j 1) j)\n\ - \ (set j (- j 1))))\n\ - \ (set i (+ i 1)))))\n\n" - t t t t t t t); - Buffer.add_string b (Printf.sprintf "(defonce xs-%s [8 %s])\n\n" t t) - done; - Buffer.add_string b "(defn main [] ()\n"; - for i = 0 to n - 1 do - Buffer.add_string b - (Printf.sprintf " (msort-%s (slice xs-%s 0 8) (fn [a b] (< a b)))\n" - tys.(i) tys.(i)) - done; - Buffer.add_string b " )\n"; - Buffer.contents b - -let write path s = - let oc = open_out path in output_string oc s; close_out oc - -let dir = - let d = Filename.concat (Filename.get_temp_dir_name ()) "flan-generics-spike" in - (try Unix.mkdir d 0o700 with Unix.Unix_error (Unix.EEXIST, _, _) -> ()); - d - -let decls_of path = - (Flan.Load.program ~file:path - (Flan.Parse.program (Flan.Reader.read_file path))).Flan.Load.decls - -(* Every function the program ended up with whose name starts with one of the - generic names — the instantiations, which is exactly what a redefinition of - the generic would have to rebuild. *) -let instantiations (p : Flan.Tast.program) = - List.filter_map - (fun (f : Flan.Tast.fn) -> - let n = f.Flan.Tast.name in - if String.length n > 6 && String.sub n 0 6 = "gswap-" then Some n - else if String.length n > 6 && String.sub n 0 6 = "gsort-" then Some n - else None) - p.Flan.Tast.fns - -let build_ms ir = - let out = Filename.concat dir "redef.so" in - best 3 (fun () -> - ignore - (Flan.Build.shared - ~opts:{ Flan.Build.default with dev = true } ~ir ~out ())) - -let () = - Printf.printf - "n check-gen check-mono emit-1 emit-N build-1 build-N fns\n"; - (try - for n = 1 to 8 do - let gpath = Filename.concat dir (Printf.sprintf "gen%d.flan" n) in - let mpath = Filename.concat dir (Printf.sprintf "mono%d.flan" n) in - write gpath (generic_src n); - write mpath (mono_src n); - let gd = decls_of gpath and md = decls_of mpath in - let check_gen = best 3 (fun () -> ignore (Flan.Check.program_with_env gd)) in - let check_mono = best 3 (fun () -> ignore (Flan.Check.program_with_env md)) in - let p, _ = Flan.Check.program_with_env gd in - let insts = instantiations p in - let one = [ List.hd insts ] in - let ir_one = - Flan.Emit.redefinition ~dev:true ~known:(fun _ -> true) p ~fns:one - in - let ir_all = - Flan.Emit.redefinition ~dev:true ~known:(fun _ -> true) p ~fns:insts - in - let emit1 = - best 3 (fun () -> - ignore (Flan.Emit.redefinition ~dev:true ~known:(fun _ -> true) p ~fns:one)) - and emitn = - best 3 (fun () -> - ignore (Flan.Emit.redefinition ~dev:true ~known:(fun _ -> true) p ~fns:insts)) - in - let b1 = build_ms ir_one and bn = build_ms ir_all in - Printf.printf "%d %8.1f %10.1f %7.1f %7.1f %8.1f %8.1f %d\n%!" - n check_gen check_mono emit1 emitn b1 bn (List.length insts) - done - with Flan.Loc.Error d -> prerr_endline (Flan.Loc.report d); exit 1); - (* And what the session actually does when the generic itself is redefined. - This is the real C-c C-c path — Session.eval on the form the editor sent - — and what it reports is the finding, not the timing. *) - let gpath = Filename.concat dir "gen4.flan" in - let t, _ = Flan.Session.create ~file:gpath () in - let form = - "(defn gswap [xs [$t] i i32 j i32] ()\n\ - \ (let [tmp (at xs i)]\n\ - \ (set (at xs i) (at xs j))\n\ - \ (set (at xs j) tmp)))\n" - in - let c, ms = time (fun () -> Flan.Session.eval ~origin:gpath t form) in - Printf.printf - "\nSession.eval on the generic gswap itself: %.1f ms, installs=%b, \ - fns=[%s], names=[%s]\n" - ms c.Flan.Session.installs - (String.concat " " c.Flan.Session.fns) - (String.concat " " c.Flan.Session.names) diff --git a/spike/generics/prelude-shapes.flan b/spike/generics/prelude-shapes.flan deleted file mode 100644 index 519a737a..00000000 --- a/spike/generics/prelude-shapes.flan +++ /dev/null @@ -1,51 +0,0 @@ -;; Which of prelude.ml's per-type families collapse as they are written, and -;; which need their signature changed. Nothing here is installed in the -;; prelude; it is the same bodies, over $t, checked and run. - -(defn keep [s [$t] keep? (Fn [$t] bool)] (Vec $t) - (let [v (vec-new t)] - (dotimes [i (length s)] - (when (keep? (at s i)) - (push v (at s i)))) - v)) - -(defn apply! [s [$t] f (Fn [$t] $t)] () - (dotimes [i (length s)] - (set (at s i) (f (at s i))))) - -(defn fold [s [$t] init $t f (Fn [$t $t] $t)] t - (let [acc init] - (dotimes [i (length s)] - (set acc (f acc (at s i)))) - acc)) - -(defn flip! [s [$t]] () - (let [i 0 - j (- (length s) 1)] - (while (< i j) - (let [tmp (at s i)] - (set (at s i) (at s j)) - (set (at s j) tmp)) - (set i (+ i 1)) - (set j (- j 1))))) - -(defonce ns [5 i32]) -(defonce fs [5 f32]) - -(defn main [] () - (let [xs (slice ns 0 5) - ys (slice fs 0 5)] - (dotimes [i 5] - (set (at xs i) (+ i 1)) - (set (at ys i) (f32 (* 2 (+ i 1))))) - (apply! xs (fn [x] (* x 10))) - (apply! ys (fn [x] (* x (f32 2)))) - (flip! xs) - (flip! ys) - (println (fold xs 0 (fn [a b] (+ a b)))) - (println (fold ys (f32 0) (fn [a b] (+ a b)))) - (let [evens (keep xs (fn [x] (= (% x 20) 0)))] - (println (length evens)) - (free evens)) - (println (at xs 0)) - (println (at ys 0)))) diff --git a/spike/generics/reject.flan b/spike/generics/reject.flan deleted file mode 100644 index 8aeb7f96..00000000 --- a/spike/generics/reject.flan +++ /dev/null @@ -1,4 +0,0 @@ -(defn add2 [a $t b $t] t (+ a b)) - -(defn main [] () - (println (add2 1 2))) diff --git a/spike/generics/run.sh b/spike/generics/run.sh deleted file mode 100644 index 7771e36b..00000000 --- a/spike/generics/run.sh +++ /dev/null @@ -1,28 +0,0 @@ -#!/usr/bin/env bash -# The generics spike's measurement, driven by hand with ocamlfind against the -# flan.cmxa dune already builds — the same arrangement spike/backend uses, and -# for the same reason: nothing under spike/ is wired into the build, there is -# no dune file here, and `dune test --root .` cannot see any of it. -# -# The three .flan programs beside this file are run with the ordinary driver: -# dune exec --root . bin/main.exe -- run spike/generics/sort.flan -set -u -here=$(cd "$(dirname "$0")" && pwd) -root=$(cd "$here/../.." && pwd) -cd "$root" || exit 1 - -dune build --root . lib/flan.cmxa 2>&1 | head -20 - -out=$(mktemp -d); trap 'rm -rf "$out"' EXIT - -ocamlfind ocamlopt -thread -package unix,threads.posix -linkpkg \ - -I "$root/_build/default/lib/.flan.objs/byte" \ - -I "$root/_build/default/lib/.flan.objs/native" \ - -I "$out" -I "$here" \ - -o "$out/measure" \ - "$root/_build/default/lib/flan.cmxa" \ - -cclib -rdynamic -ccopt -L"$root/_build/default/lib" \ - "$here/measure.ml" 2>&1 | head -40 - -test -x "$out/measure" || { echo "build failed"; exit 1; } -"$out/measure" diff --git a/spike/generics/runaway.flan b/spike/generics/runaway.flan deleted file mode 100644 index 9423840a..00000000 --- a/spike/generics/runaway.flan +++ /dev/null @@ -1,3 +0,0 @@ -(defn grow [x $t] () - (grow [x x])) -(defn main [] () (grow 1)) diff --git a/spike/generics/sort.flan b/spike/generics/sort.flan deleted file mode 100644 index 632ed1bb..00000000 --- a/spike/generics/sort.flan +++ /dev/null @@ -1,25 +0,0 @@ -;; The shape prelude.ml's sort-i32-by! / sort-f32-by! pair would collapse into: -;; one generic body, the comparison passed in as a function value because an -;; unconstrained type variable has no < of its own. - -(defn swap! [xs [$t] i i32 j i32] () - (let [tmp (at xs i)] - (set (at xs i) (at xs j)) - (set (at xs j) tmp))) - -(defn sort-by! [s [$t] before? (Fn [$t $t] bool)] () - (let [i 1] - (while (< i (length s)) - (let [j i] - (while (and (> j 0) (before? (at s j) (at s (- j 1)))) - (swap! s (- j 1) j) - (set j (- j 1)))) - (set i (+ i 1))))) - -(defn main [] () - (let [ns [5 3 9 1] - fs [2.5 0.5 1.5]] - (sort-by! (slice ns 0 4) (fn [a b] (< a b))) - (sort-by! (slice fs 0 3) (fn [a b] (> a b))) - (dotimes [i 4] (println (at ns i))) - (dotimes [i 3] (println (at fs i))))) diff --git a/spike/generics/swap.flan b/spike/generics/swap.flan deleted file mode 100644 index 8d69ae4b..00000000 --- a/spike/generics/swap.flan +++ /dev/null @@ -1,19 +0,0 @@ -;; One generic function over one type variable, called at two concrete types -;; in one program. The sigil binds ($t), a bare use reads it (t). - -(defn swap! [xs [$t] i i32 j i32] () - (let [tmp (at xs i)] - (set (at xs i) (at xs j)) - (set (at xs j) tmp))) - -(defn main [] () - (let [ns [10 20 30] - fs [1.5 2.5 3.5]] - (swap! (slice ns 0 3) 0 2) - (swap! (slice fs 0 3) 0 1) - (swap! (slice ns 0 3) 1 2) - (println (at ns 0)) - (println (at ns 1)) - (println (at ns 2)) - (println (at fs 0)) - (println (at fs 1)))) diff --git a/spike/generics/two-vars.flan b/spike/generics/two-vars.flan deleted file mode 100644 index fe3b300a..00000000 --- a/spike/generics/two-vars.flan +++ /dev/null @@ -1,5 +0,0 @@ -(defn fst [a $t b $u] t a) -(defn main [] () - (println (fst 1 2.5)) - (println (fst true (i64 9))) - (println (fst 3 false))) diff --git a/spike/x86/COST.md b/spike/x86/COST.md deleted file mode 100644 index 1500e62e..00000000 --- a/spike/x86/COST.md +++ /dev/null @@ -1,210 +0,0 @@ -# What the hand-written x86-64 backend costs - -`survey.sh` has said for three handoffs that this backend agrees with LLVM on all 97 corpus programs it can build. -Item 7 of `docs/handoffs/HANDOFF-x86-rt.md` is the other half of that sentence — nobody had a number for what the agreement -costs — and it came with a list of suspects: a guard after every call, three frame temporaries per bounds check, -every intermediate in memory, `rep movsb` block copies, and an extra load per call site in a dev build. This is -the measurement. It does not change anything; two of the five suspects turn out not to matter, and the one that -matters most is not on the list. - -Produced by `spike/x86/cost.sh` (the corpus, for size) and `spike/x86/bench.sh` (four purpose-written programs, -for speed). Both are documented in their own headers. Machine: 16-core x86-64, Fedora, clang as the assembler and -linker on both sides, and other work running on it throughout — which is why every time below is the *minimum* of -five or seven runs and why nothing here rests on a difference of a few percent. - -The rows behind the tables are committed beside this file as `cost-corpus.tsv` and `cost-bench.tsv`, so a later -lane can recompute a ratio rather than believe one. - -## What is being compared, and against what - -The interesting column is not the size of the executable. A Flan binary is mostly `flan_rt.o` and libc glue, the -same object on both sides, and it drowns the signal: over the corpus the whole file is only **1.09×** bigger -through this backend and `.text` only **1.18×**, which would be a reassuring number and a meaningless one. - -So the measurement is the sum of the sizes of the defined symbols the compiler *named itself* — everything called -`flan.`. The runtime's C is `flan_` with an underscore, so the two never collide, and a -runtime symbol has the same size on both sides (`flan_map_clone`, `0x4b3` either way), which is the check that -says the difference really is codegen and not a differently-linked runtime. - -There is a third column, and it is what makes the second readable: **LLVM with `--debug`, which forces `-O0`**. -This backend has no optimiser at all, so measuring it against LLVM at `-O2` charges it for the whole of mem2reg, -inlining and constant folding. `-O0` is LLVM's instruction selection with none of that, which is the comparison -that says something about *this* backend rather than about the absence of a middle end. (`--x86 --debug` is -refused — the backend emits no DWARF — so the column exists on one side only. DWARF lands in `.debug_*` sections -and not in `.text`, checked, so it does not contaminate the symbol sums.) - -## The corpus: size - -Ninety-seven programs — the same set `survey.sh` matches on, minus the two that run forever. Summed over all of -them: - -| | LLVM -O2 | LLVM -O0 | x86 | -|---|---|---|---| -| own code, all 97 programs | 221,608 | 444,504 | 851,638 | -| against LLVM -O2 | 1.00× | 2.01× | **3.84×** | -| against LLVM -O0 | | 1.00× | **1.92×** | - -So the headline is two numbers, not one. **This backend emits 3.8× the code LLVM does at `-O2`, and half of that -factor is the optimiser Flan ships with rather than anything about the backend; against LLVM with the optimiser -off it is 1.9×.** Per program the second ratio is tight — median 2.21, quartiles 1.94 and 2.98, the whole range -1.32 to 5.44 — which is itself a finding: the cost is not a few bad nodes, it is a constant tax on everything. - -The ten largest programs, which are where the bytes actually are: - -| program | LLVM -O2 | LLVM -O0 | x86 | x86 / -O2 | x86 / -O0 | -|---|---|---|---|---|---| -| `strings` | 13,395 | 22,681 | 33,265 | 2.48× | 1.47× | -| `maps` | 12,833 | 19,850 | 40,445 | 3.15× | 2.04× | -| `edn` | 12,057 | 34,556 | 48,532 | 4.03× | 1.40× | -| `generics` | 10,137 | 20,427 | 39,241 | 3.87× | 1.92× | -| `slurp` | 9,744 | 14,813 | 24,656 | 2.53× | 1.66× | -| `into` | 8,277 | 12,345 | 21,320 | 2.58× | 1.73× | -| `vec` | 8,039 | 12,089 | 22,770 | 2.83× | 1.88× | -| `map-iter` | 7,211 | 10,374 | 21,715 | 3.01× | 2.09× | -| `algorithms` | 6,776 | 16,616 | 30,875 | 4.56× | 1.86× | -| `slices` | 2,393 | 9,057 | 17,753 | 7.42× | 1.96× | - -And the two ends of the distribution, both of which are more interesting than the middle: - -| program | LLVM -O2 | LLVM -O0 | x86 | x86 / -O2 | x86 / -O0 | why | -|---|---|---|---|---|---|---| -| `bounds` | 363 | 1,951 | 4,039 | **11.13×** | 2.07× | LLVM at `-O2` proves the indices and deletes the checks | -| `array-ctor` | 357 | 1,840 | 3,880 | 10.87× | 2.11× | the same, over a constructor's worth of stores | -| `p2-loop-print` | 283 | 106 | 577 | 2.04× | **5.44×** | a `-O0` build *smaller* than `-O2`: LLVM unrolls the five-iteration loop and `-O0` does not | -| `pkg-return` | 7,024 | 23,635 | 31,716 | 4.52× | 1.34× | mostly prelude, where `-O0` is already fat | - -`bounds` is the clearest case in the table of why the `-O0` column had to exist. Eleven times is a shocking -number and it is not about this backend at all: the program's whole point is indexing, LLVM at `-O2` can see the -indices are in range and removes the check, and neither LLVM at `-O0` nor this backend can. Against the compiler -that also keeps every check, `bounds` is 2.07× — a completely ordinary row. - -## Where the size goes - -Every one of these is from the disassembly of the benchmark programs, which are small enough to read whole. - -**Every intermediate goes through the frame, and so does every constant.** This is the big one and it is not one -feature, it is the shape of the whole backend. `(step acc 1)` in `b1-calls` compiles to: - - movabs $0x1,%rax ; a 10-byte immediate ... - mov %rax,-0x30(%rbp) ; ... stored to a frame slot ... - mov -0x30(%rbp),%rsi ; ... and loaded back into the argument register - -Three instructions and 24 bytes where LLVM writes `mov $1,%esi`, five. The loop bound gets the same treatment -*every iteration* — `movabs $0x1312d00` into a slot, sign-extended out of it, compared — because nothing is -hoisted. So does the loop condition: `cmp`/`setl`/`movzbq`/store a byte to the frame/reload it/`test`/`jne`, -seven instructions for what is `cmp`/`jge` anywhere else. This is most of the 2× against `-O0` and essentially -all of the difference on the programs at the bottom of the table, which have no calls, no bounds checks and no -aggregates in them at all. - -**The guard after every call is four instructions and one dependent load.** - - call 4009f8 - mov -0x18(%rbp),%r11 ; the condition frame, from its own slot - mov 0x0(%r11),%r11 ; ... dereferenced - test %r11,%r11 - jne - -Roughly 25 bytes per call site. Real, cheap, and third in size behind the two above it — on a program that is -nothing *but* calls (`b1`) the whole backend is 2.8× LLVM `-O0`, and the guard is a minority of that. - -**The bounds check is three frame temporaries, as suspected, and it costs code and not time.** The index is -widened, stored, reloaded, stored again, the limit goes to a third slot, and then `cmp`/`jb` — with the failure -path, its `.rodata` location string and its length, inline at the branch target. On `b2-bounds`, `flan.main` is -`0x4b1` with checks and `0x3c0` without: **241 bytes, a quarter of the function.** In time it is 112.6ms against -105.0ms over 20.5 million checked loads — **about 0.4ns, a cycle or two a check** — because the branch predicts -perfectly and the loads were going to memory anyway. That contradicts the way the handoff's list reads. The three -temporaries are a code-size item. They are not a speed item. - -**`rep movsb` is real and it is the most expensive single instruction here.** A 64-byte struct copy lowers to -`lea`/`lea`/`movabs $0x40,%rcx`/`rep movsb`, and `b4-copy` runs 2 million of them in 20.8ms against LLVM `-O0`'s -7.2ms: **about 6.8ns of the difference per copy, some twenty cycles**, which is `rep movsb`'s startup cost and -almost none of it the 64 bytes. It is also the one place where the backend loses to `-O0` by a factor (2.9×) it -does not lose by on straight-line code, and the one item on the suspect list where a targeted fix — inline -16-byte moves under some size threshold — would pay for itself. - -## The corpus: speed, and why there is barely any - -Almost nothing. **Every program in `test/programs` runs in about 2.5 milliseconds, nearly all of it `execve` and -the dynamic loader**, and both backends produce the same 2.5 milliseconds. Best-of-five does not rescue a signal -that is not there. There is exactly one corpus program whose own code is a measurable part of its runtime, and it -is the right one: - -| program | LLVM -O2 | LLVM -O0 | x86 | what it is | -|---|---|---|---|---| -| `recur` | ~1ms | 10ms | 60ms | a ten-million-iteration counting loop, written to prove `recur` is a jump | - -Read that carefully, because the 25× against `-O2` is not a fact about this backend: LLVM folds the loop to its -answer and runs nothing. Against `-O0`, which also runs ten million iterations, it is **6×** — about 6ns an -iteration against 1ns, or roughly eighteen cycles for `i+1` and a compare. That is the frame-slot round trip -above, four or five times over, and it is the honest number. - -## The benchmarks - -Four programs in `spike/x86/bench/`, each written so that one suspected cost is most of what the program does. -They are in a subdirectory on purpose: `survey.sh` globs `spike/x86/*.flan` and a benchmark is not a case. -Times are best-of-seven, in milliseconds. - -| bench | what it is | LLVM -O2 | LLVM -O0 | x86 | x86 / -O0 | own code, -O0 → x86 | -|---|---|---|---|---|---|---| -| `b1-calls` | 20M calls of a one-instruction function | 2.1 | 36.8 | 104.3 | 2.8× | 200 → 807 | -| `b2-bounds` | 20.5M bounds-checked array loads | 4.7 | 27.0 | 112.6 | 4.2× | 407 → 1390 | -| `b3-spill` | 5M iterations of a six-deep arithmetic tree | 22.2 | 29.0 | 137.3 | 4.7× | 248 → 1117 | -| `b4-copy` | 2M copies of a 64-byte struct | 2.0 | 7.2 | 20.8 | 2.9× | 348 → 877 | - -`b2` with `--no-bounds-checks` on both sides: LLVM 4.5ms, x86 105.0ms — the 7.6ms the check costs over 20.5 -million of them, and the 241 bytes it costs in `flan.main`, are the whole of it. - -`b3`'s ratio is the one to distrust slightly: its expression ends in a `%`, which is an `idiv`, and an `idiv` is -twenty-odd cycles on every side. That is most of LLVM's own 22.2ms and a good part of its 29.0ms, so the -denominator is largely a hardware latency this backend cannot do anything about. The absolute gap — 108ms over -5 million iterations, about 21ns of extra work each — is the honest reading of that row. - - - -`b1-calls` and `b3-spill` are the pair to read together, with the `idiv` caveat above in mind. `b1` is 20 million -calls of a one-instruction function and lands at 2.8× `-O0`; `b3` has no calls at all and pays 21ns an iteration -for six dependent arithmetic temporaries. **The backend is worse at arithmetic than it is at calling**, which is -the opposite of what the suspect list implies, and it is because a call already costs enough that four extra -instructions beside it disappear, while an add that should be one instruction costs five. `recur`, which is a -counting loop and nothing else, says the same thing on a corpus program: 6× LLVM `-O0`. - -The `-O2` column in `b1` and `b4` is 2ms — the loop is gone. That is a true fact about the toolchain Flan ships -and a useless one about code generation, which is the whole reason the `-O0` column exists. - -## `--dev`, which is the one axis both backends pay - -`SURVEY_FLAGS=--dev` reported 97 MATCH for the lane before this one, so the comparison is available. The suspected cost was the extra -load per call site — every cross-function call going through its indirection cell. **It is not measurable.** On -`b1-calls`, 20 million calls, x86 release is 104.3ms and x86 `--dev` is 100.9ms: the same number, and the dev -build is nominally the *faster* of the two, which is what a difference below the noise floor looks like. The load -is from a `.data` cell that is in L1 after the first call and the machine was already waiting on the frame. - -What a dev build actually costs is something else entirely, and both backends pay it. `b1-calls` is a program -with two functions in it: - -| build | own code | -|---|---| -| LLVM, release | 82 bytes | -| x86, release | 807 bytes | -| LLVM, `--dev` | 32,714 bytes | -| x86, `--dev` | 83,018 bytes | - -**A dev build emits the entire prelude**, because anything might be redefined and so nothing may be dropped. That -is four hundred times the code for this program, and it dwarfs every item on the suspect list put together. It is -also not a backend cost — LLVM pays a 400× of its own — so it is `Reach`'s business and not `x86.ml`'s. The -backend's share of it is the same ~2.5× it charges everywhere else. - -## What this says to the lane rewriting `lib/x86.ml` - -Ranked by what the numbers actually support, and not by the order of the list in the handoff: - -1. **Keep values in registers across a single expression.** Not a register allocator — just not routing every - constant and every subexpression through a frame slot, and not re-materialising a loop bound every iteration. - This is most of the 2× against `-O0` and most of `recur`'s 6×, and it is what `b3`'s 21ns an iteration buys. -2. **Inline small aggregate copies** instead of `rep movsb`. One instruction, twenty cycles, on a copy that is - four `movdqu` pairs. -3. **`flan_dev_reg_note` in a release build** (item 2 of the old handoff's list) is worth doing and is small. -4. **The call guard is fine.** Four instructions and 25 bytes, invisible in time. Leave it. -5. **The bounds check is fine on time and fat on code.** If it is ever worth touching, it is worth touching for - the 241 bytes — hoisting the failure path out of line would get most of that back without changing a cycle. -6. **The dev call cell is free.** Whatever the redefinition emitter costs, it does not cost this. diff --git a/spike/x86/annot.sh b/spike/x86/annot.sh deleted file mode 100755 index cb5991c6..00000000 --- a/spike/x86/annot.sh +++ /dev/null @@ -1,101 +0,0 @@ -#!/usr/bin/env bash -# Does annotation change a single byte of what the backend emits? -# -# `flan emit --x86` annotates: a comment per Flan form, a frame map per -# function, and a name for each piece of bookkeeping the compiler adds. All of -# that is comments, plus the splitting of one long `.byte` directive into -# several. Both are supposed to be invisible to the assembler -- and "supposed -# to be" is exactly the kind of claim this repo measures rather than asserts, -# because the whole licence for annotating at all is that the bytes are the -# bytes. -# -# So: emit every program in the corpus both ways, assemble both, and compare -# each section of the two objects byte for byte. No linking and no running -- -# survey.sh is what says the programs still behave, and this says nothing they -# are built from moved. -# -# Three settings, because they are three different emitters. The default; --dev, -# which adds the indirection cells and the ABI marker; and --debug, which adds -# the line table, the labels its rows hang off, and the CFI directives. The -# debug case is the sharp one: a `.debug_line` row is an address expressed as a -# label, and annotation emits no labels precisely so that those cannot move. -# -# Usage: spike/x86/annot.sh [name-substring ...] -set -u -orig=$(pwd) -here=$(cd "$(dirname "$0")" && pwd) -root=$(cd "$here/../.." && pwd) -cd "$root" || exit 1 - -if [ -n "${FLAN:-}" ]; then - case $FLAN in /*) flan=$FLAN;; *) flan=$orig/$FLAN;; esac -else - dune build --root . bin/main.exe 2>&1 | head -30 - flan=$root/_build/default/bin/main.exe -fi -test -x "$flan" || { echo "build failed"; exit 1; } - -corpus=${SURVEY_CORPUS:-$root} -tmp=$(mktemp -d "${TMPDIR:-/tmp}/flan-annot.XXXXXX") -trap 'rm -rf "$tmp"' EXIT - -same=0; differ=0; skip=0 - -# Every section either object has, not a fixed list: a section that exists on -# one side and not the other is itself a difference, and comparing a named list -# would miss one that annotation invented. -sections () { - objdump -h "$1" | awk '$1 ~ /^[0-9]+$/ { print $2 }' -} - -check () { - src=$1; shift - name=$(basename "$src" .flan) - tag="$name${*:+ $*}" - a=$tmp/a.s; b=$tmp/b.s - - if ! "$flan" emit --x86 "$@" "$src" > "$a" 2>"$tmp/err"; then - skip=$((skip + 1)); echo "SKIP $tag"; return - fi - if ! "$flan" emit --x86 --no-annotate "$@" "$src" > "$b" 2>/dev/null; then - skip=$((skip + 1)); echo "SKIP $tag"; return - fi - if ! as --64 -o "$tmp/a.o" "$a" 2>"$tmp/err"; then - differ=$((differ + 1)) - echo "BADASM $tag -- the annotated listing does not assemble" - head -3 "$tmp/err"; return - fi - if ! as --64 -o "$tmp/b.o" "$b" 2>/dev/null; then - skip=$((skip + 1)); echo "SKIP $tag"; return - fi - - bad= - for sec in $(sections "$tmp/a.o"; sections "$tmp/b.o"); do - case " $bad " in *" $sec "*) continue;; esac - objcopy -O binary --only-section="$sec" "$tmp/a.o" "$tmp/a.bin" 2>/dev/null - objcopy -O binary --only-section="$sec" "$tmp/b.o" "$tmp/b.bin" 2>/dev/null - cmp -s "$tmp/a.bin" "$tmp/b.bin" || bad="$bad $sec" - done - - if [ -z "$bad" ]; then - same=$((same + 1)); echo "SAME $tag" - else - differ=$((differ + 1)); echo "DIFFER $tag --$bad" - fi -} - -for src in "$corpus"/test/programs/*.flan "$corpus"/spike/x86/*.flan; do - [ -f "$src" ] || continue - if [ $# -gt 0 ]; then - hit= - for pat in "$@"; do case $src in *"$pat"*) hit=1;; esac; done - [ -n "$hit" ] || continue - fi - check "$src" - check "$src" --dev - check "$src" --debug -done - -echo -echo "$same SAME / $differ DIFFER / $skip SKIP" -[ "$differ" -eq 0 ] diff --git a/spike/x86/bench.sh b/spike/x86/bench.sh deleted file mode 100755 index 0899f150..00000000 --- a/spike/x86/bench.sh +++ /dev/null @@ -1,86 +0,0 @@ -#!/usr/bin/env bash -# The speed half of cost.sh, on programs that are long enough to time. -# -# Why this exists beside cost.sh rather than inside it: every program in -# test/programs runs in about two and a half milliseconds, of which nearly -# all is fork, exec and the dynamic loader. Best-of-five does not rescue a -# signal that is not there, and a table of 97 rows that all say "2.5ms vs -# 2.6ms" would be a measurement of execve. So the corpus answers the size -# question and these four answer the speed one, each written so that one -# suspected cost is most of what the program does. -# -# Four builds of each, and the third column is the one to read: -# -# llvm as shipped, -O2. Frequently the loop is simply gone; that is a -# true number about the toolchain and a useless one about codegen. -# llvm -O0 via --debug, which forces it. LLVM's instruction selection with -# its optimiser off -- the fair comparison for a backend that has -# no optimiser. -# x86 this backend. -# x86 nbc --no-bounds-checks, for b2, where the difference is the check. -# -# And --dev on both sides, which is the one suspected cost the two backends -# share: every cross-function call goes through an indirection cell, so it is -# a load and an indirect call where a release build has a direct one. b1 is -# where that has to show. -# -# Usage: spike/x86/bench.sh [name-substring ...] -set -u -orig=$(pwd) -here=$(cd "$(dirname "$0")" && pwd) -root=$(cd "$here/../.." && pwd) -cd "$root" || exit 1 - -if [ -n "${FLAN:-}" ]; then - case $FLAN in /*) flan=$FLAN;; *) flan=$orig/$FLAN;; esac -else - dune build --root . bin/main.exe 2>&1 | head -30 - flan=$root/_build/default/bin/main.exe -fi -test -x "$flan" || { echo "build failed" >&2; exit 1; } - -out=${COST_OUT:-${TMPDIR:-/tmp}/flan-bench.$$} -mkdir -p "$out" || exit 1 -trap 'rm -rf "$out"' EXIT - -REPS=${COST_REPS:-5} - -best () { - min= - for i in $(seq "$REPS"); do - t0=$(date +%s%N) - timeout 120 "$1" >/dev/null 2>&1 /dev/null \ - | awk 'NF==4 && ($3=="T"||$3=="t") && $4 ~ /^flan\./ {n+=strtonum("0x"$2)} END{print n+0}' -} - -printf 'name\tllvm_us\to0_us\tx86_us\tllvm_nbc_us\tx86_nbc_us\tllvm_dev_us\tx86_dev_us\tllvm_own\to0_own\tx86_own\tx86_dev_own\n' - -for src in "$root"/spike/x86/bench/*.flan; do - name=$(basename "$src" .flan) - if [ $# -gt 0 ]; then - want=0 - for pat in "$@"; do case "$name" in *"$pat"*) want=1;; esac; done - [ $want = 1 ] || continue - fi - "$flan" build "$src" -o "$out/l" >/dev/null 2>&1 || { echo "$name: llvm build failed" >&2; continue; } - "$flan" build "$src" --debug -o "$out/d" >/dev/null 2>&1 || { echo "$name: -O0 build failed" >&2; continue; } - "$flan" build "$src" --x86 -o "$out/x" >/dev/null 2>&1 || { echo "$name: x86 build failed" >&2; continue; } - "$flan" build "$src" --no-bounds-checks -o "$out/ln" >/dev/null 2>&1 - "$flan" build "$src" --x86 --no-bounds-checks -o "$out/xn" >/dev/null 2>&1 - "$flan" build "$src" --dev -o "$out/lv" >/dev/null 2>&1 - "$flan" build "$src" --x86 --dev -o "$out/xv" >/dev/null 2>&1 - printf '%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\n' "$name" \ - "$(best "$out/l")" "$(best "$out/d")" "$(best "$out/x")" \ - "$(best "$out/ln")" "$(best "$out/xn")" \ - "$(best "$out/lv")" "$(best "$out/xv")" \ - "$(own "$out/l")" "$(own "$out/d")" "$(own "$out/x")" "$(own "$out/xv")" -done diff --git a/spike/x86/bench/b1-calls.flan b/spike/x86/bench/b1-calls.flan deleted file mode 100644 index 2cf2f50c..00000000 --- a/spike/x86/bench/b1-calls.flan +++ /dev/null @@ -1,20 +0,0 @@ -;;;; A hot loop that does nothing but call. -;;;; -;;;; The suspected cost is the guard this backend emits after every call -- -;;;; and, in a dev build, the load of the indirection cell before it. Neither -;;;; is visible in the corpus, where a program's whole run is process startup. -;;;; Here the call is the program: the body is one add, so whatever separates -;;;; this from LLVM at -O0 is the call sequence and not the arithmetic. -;;;; -;;;; Not in spike/x86 proper, where survey.sh would pick it up: the survey's -;;;; counts are quoted in three handoffs and a benchmark is not a case. - -(defn step [a i64 b i64] i64 - (+ a b)) - -(defn main [] i32 - (let [acc (i64 0)] - (dotimes [i 20000000] - (set acc (step acc 1))) - (print acc) (println "")) - 0) diff --git a/spike/x86/bench/b2-bounds.flan b/spike/x86/bench/b2-bounds.flan deleted file mode 100644 index 3df3841e..00000000 --- a/spike/x86/bench/b2-bounds.flan +++ /dev/null @@ -1,20 +0,0 @@ -;;;; A hot loop that does nothing but index a bounds-checked array. -;;;; -;;;; The suspected cost is three frame temporaries per check. This one has an -;;;; A/B that the others do not: --no-bounds-checks builds the same program -;;;; with the check gone, on both sides, so the difference between the two -;;;; x86 numbers is the check and nothing else, and the same difference on -;;;; the LLVM side says what the check costs when a compiler is allowed to -;;;; hoist it out of the loop. - -(defonce xs [1024 i32]) - -(defn main [] i32 - (dotimes [i 1024] - (set (at xs i) i)) - (let [acc (i64 0)] - (dotimes [r 20000] - (dotimes [i 1024] - (set acc (+ acc (i64 (at xs i)))))) - (print acc) (println "")) - 0) diff --git a/spike/x86/bench/b3-spill.flan b/spike/x86/bench/b3-spill.flan deleted file mode 100644 index d0bdd9fd..00000000 --- a/spike/x86/bench/b3-spill.flan +++ /dev/null @@ -1,21 +0,0 @@ -;;;; A hot loop of arithmetic and nothing else: no calls, no arrays, no -;;;; copies. -;;;; -;;;; The suspected cost is that every intermediate lives in a frame slot -- -;;;; this backend allocates no registers, so an expression tree becomes a -;;;; chain of stores and reloads. The tree here is deliberately deep and -;;;; entirely dependent, so a register allocator would keep all of it in -;;;; registers and this backend cannot keep any of it. - -(defn main [] i32 - (let [acc (i64 1)] - (dotimes [i 5000000] - (let [a (+ acc 3) - b (* a 2) - c (- b 1) - d (bit-xor c 7) - e (+ d (* a 5)) - f (- e (bit-and d 15))] - (set acc (+ (% f 1000003) 1)))) - (print acc) (println "")) - 0) diff --git a/spike/x86/bench/b4-copy.flan b/spike/x86/bench/b4-copy.flan deleted file mode 100644 index 200c2452..00000000 --- a/spike/x86/bench/b4-copy.flan +++ /dev/null @@ -1,20 +0,0 @@ -;;;; A hot loop of struct copies. -;;;; -;;;; The suspected cost is `rep movsb`: this backend copies an aggregate by -;;;; block-moving bytes, where LLVM either keeps the thing in registers or -;;;; emits a handful of wide moves. Eight i64 fields is 64 bytes -- big -;;;; enough that a copy is a real copy, small enough that `rep movsb` is -;;;; paying its setup cost on every one of them, which is the shape the -;;;; instruction is worst at. - -(defstruct Big [a i64 b i64 c i64 d i64 e i64 f i64 g i64 h i64]) - -(defn main [] i32 - (let [acc (i64 0) - v (Big {.a 1 .b 2 .c 3 .d 4 .e 5 .f 6 .g 7 .h 8})] - (dotimes [i 2000000] - (let [w v] - (set (.a v) (+ (.h w) 1)) - (set acc (+ acc (.a w))))) - (print acc) (println "")) - 0) diff --git a/spike/x86/cost-bench.tsv b/spike/x86/cost-bench.tsv deleted file mode 100644 index a231e38d..00000000 --- a/spike/x86/cost-bench.tsv +++ /dev/null @@ -1,5 +0,0 @@ -name llvm_us o0_us x86_us llvm_nbc_us x86_nbc_us llvm_dev_us x86_dev_us llvm_own o0_own x86_own x86_dev_own -b1-calls 2108 36764 104266 1959 103336 26827 100874 82 200 807 83018 -b2-bounds 4711 27047 112567 4548 104951 4663 111295 355 407 1390 83596 -b3-spill 22184 28982 137347 22772 132053 22659 132913 168 248 1117 83323 -b4-copy 2043 7170 20792 1980 19559 2058 18497 140 348 877 83083 diff --git a/spike/x86/cost-corpus.tsv b/spike/x86/cost-corpus.tsv deleted file mode 100644 index d8b36d4c..00000000 --- a/spike/x86/cost-corpus.tsv +++ /dev/null @@ -1,98 +0,0 @@ -name llvm_file llvm_text llvm_own o0_own x86_file x86_text x86_own llvm_us x86_us -agent-longname 82224 42002 79 134 82264 42450 519 -1 -1 -agent-queue 82352 42306 340 567 86488 43698 1747 2491 2546 -agent 82336 42434 454 798 86472 44162 2218 2609 2496 -algorithms 76680 39282 6776 16616 101296 63234 30875 2499 2605 -allocators 67760 33650 1297 1719 71896 37490 5130 3170 3034 -array-ctor 67784 32722 357 1840 71920 36242 3880 2442 2664 -bounds-condition 76416 37074 4641 6963 84648 45858 13493 2673 2469 -bounds 67720 32738 363 1951 71856 36418 4039 3194 2654 -break 82296 42754 819 1182 86432 44482 2549 -1 -1 -bytes2 72120 37010 4576 10893 88544 52018 19654 2573 2510 -cleanup 68176 33986 1583 2077 72312 36946 4583 2351 2402 -conditions 68064 33586 1212 1209 68104 35346 2984 2436 2513 -debug-permuted 67720 32610 261 410 67760 33794 1433 2479 2442 -debug 67720 32610 261 429 67760 33794 1433 2494 2494 -defer-let 67928 34018 1625 1784 72064 36754 4396 2548 2543 -destructure 67792 33650 1290 4577 80120 40946 8583 2534 2523 -dev-break-bounds 82440 42546 588 648 86576 43762 1830 -1 -1 -dev-break 82368 42418 459 715 86504 43682 1755 -1 -1 -dev-globals 82456 42162 206 534 86584 43538 1614 -1 -1 -dev-inspect 82408 42610 652 704 86544 43698 1765 -1 -1 -dev-locals 82336 42418 465 623 86472 43650 1721 -1 -1 -dev-noagent 67720 32434 83 109 67760 32866 507 3116 2939 -dev-pause 82336 42066 112 244 82376 42802 877 -1 -1 -dev-ptr 86632 43954 1970 2859 90768 47490 5543 -1 -1 -dev-repl 82336 42066 112 244 82376 42802 877 -1 -1 -dev-robust 82336 42066 112 244 82376 42802 877 -1 -1 -edn 91208 44706 12057 34556 124016 80898 48532 3218 3165 -embed 67800 33330 977 2461 71936 37906 5550 2440 2650 -enum-compare 67752 32562 201 581 67792 33970 1611 2607 2805 -enum-convert 67752 33202 830 1522 71888 37042 4675 2737 2512 -error 67744 32498 131 163 67784 32946 591 2614 2587 -exhausted-unhandled 67688 33090 749 1156 67728 34850 2491 2442 2591 -exhausted 76192 35778 3415 5139 80336 42674 10321 2409 2469 -fn-values 68296 34226 1745 5124 80632 43026 10672 2405 2406 -format 76032 36802 4413 7076 84264 45394 13038 2449 2388 -frame-rollback 68440 34466 2020 3424 80768 39762 7402 2383 2394 -free-all-refused 67688 32370 28 28 67728 32658 299 2418 2497 -generics 81368 42786 10137 20427 114184 71602 39241 2474 2516 -handles 75880 35826 3482 6289 84112 46338 13981 2520 2470 -higher-order 76648 37154 4652 10329 88976 51314 18948 2413 2439 -into 80256 40658 8277 12345 92584 53682 21320 2428 2412 -loops 67736 33378 1016 1720 71872 37634 5269 2370 2315 -machine 67960 33186 821 1925 72096 37394 5042 2515 2456 -macro-unless 67720 32642 288 615 67760 34610 2243 2466 2457 -macros 67688 32802 461 793 67728 35250 2896 2532 2409 -map-exhausted 76152 36162 3805 5994 84392 44530 12171 2393 2506 -map-iter 76096 39586 7211 10374 92520 54082 21715 2541 2531 -map-stale-region 67688 33650 1307 2106 71824 36898 4537 2354 2407 -maps 88504 45266 12833 19850 117216 72802 40445 3162 3082 -math 67832 33986 1611 3288 72024 39362 7000 2384 2405 -math2 67784 33506 1148 2862 72024 39010 6644 2300 2482 -pkg-diamond 67880 32626 252 616 67928 34162 1801 2353 2227 -pkg-macro-idle 67688 32338 3 3 67728 32562 210 2440 2410 -pkg-macro 67800 32722 354 450 67840 33986 1626 2455 2429 -pkg-return 78416 39570 7024 23635 103032 64082 31716 2432 2375 -pkg-shadow 67848 32642 277 371 67888 33618 1258 2408 2236 -pkg-shared 74560 34066 1676 5593 86888 45650 13283 2422 2648 -pkg-unused 69704 32386 35 35 69744 34658 2298 2351 2271 -pool-stale-region 67688 33282 932 1675 71824 35746 3379 2389 2466 -printers 82464 42098 168 452 82504 43282 1348 -1 -1 -println 76256 36098 3737 7587 88584 50114 17753 2312 2460 -raylib-audio 79536 35522 2478 5610 87768 44178 11225 2574 2769 -raylib-ffi 85848 39538 6245 11506 102272 55650 22537 2607 2852 -raylib-font 79088 35538 2622 6260 83232 43186 10350 2661 2658 -raylib-image 80152 37698 4504 8285 88384 47058 13966 2684 2946 -raylib-imported 70344 33202 612 1003 74480 36658 4066 2688 2602 -reach-walk 67992 33170 774 1082 68032 34802 2443 2552 2308 -recur 67792 34594 2233 4070 76024 40674 8314 2468 62674 -registry 72008 35330 2940 4604 80240 41010 8608 2515 2329 -reload-generic 67944 32930 520 1390 67992 35442 3076 2341 2241 -restarts 77200 39010 6430 9268 89528 49442 17065 2356 2304 -rl-with 69704 32386 35 35 69744 34658 2298 2550 2461 -sand-headless 74728 34546 2139 6326 87056 47634 15269 2783 9172 -signedness 67688 32594 246 386 67728 33938 1576 2418 2411 -slice-from-ptr 67752 33106 755 2549 75984 37458 5101 2421 2367 -slices 68128 34802 2393 9057 88648 50114 17753 2504 2271 -slurp-unhandled 67688 33522 1173 1601 67728 35298 2945 2340 2354 -slurp 80288 42114 9744 14813 100808 57010 24656 2358 2408 -stale-region 67688 33490 1148 1681 71824 35842 3483 2332 2286 -string-of-bytes 67856 33490 981 1925 71992 36338 3817 2319 2353 -strings 88912 45890 13395 22681 109432 65618 33265 2455 2391 -text 72296 37122 4666 8007 84624 49378 17018 2310 2397 -unions 76016 36498 4131 17714 92440 55810 23456 2323 2413 -unit-main 67688 32386 33 33 67728 32674 307 2459 2377 -utf8 81216 39714 7170 21515 114024 73106 40745 2563 2380 -values 67720 32530 180 667 67760 34082 1719 2531 2378 -vec 80080 40402 8039 12089 92408 55122 22770 2370 2389 -virtual-controls-headless 70896 33666 1271 1295 75032 38962 6601 2319 3201 -web-files 67736 33058 706 1000 67776 34610 2246 2321 2382 -p1-exit 67688 32338 3 3 67728 32562 210 2436 2377 -p2-loop-print 67688 32626 283 106 67728 32930 577 2269 2364 -p3-fizz 67720 32530 169 225 67760 33282 928 2512 2359 -p4-convention 67824 32786 405 1005 67864 35138 2778 2436 2332 -p5-core 67792 33346 993 1507 71928 37218 4865 2346 2444 -p6-transfer 68096 34354 1944 2801 72232 37618 5252 2386 2310 -p7-slice-from-ptr 67840 33698 1336 1498 71984 35682 3318 2493 2392 -p8-cell 67752 32514 146 270 67800 33202 847 2402 2381 diff --git a/spike/x86/cost.sh b/spike/x86/cost.sh deleted file mode 100755 index 59fba226..00000000 --- a/spike/x86/cost.sh +++ /dev/null @@ -1,135 +0,0 @@ -#!/usr/bin/env bash -# What does the hand-written backend cost, against LLVM, on the same programs? -# -# survey.sh answers "does it agree". This answers "what does agreeing cost", -# which is item 7 of docs/handoffs/HANDOFF-x86-rt.md and the one thing about this backend -# nobody had a number for. It builds each program the same two ways the -# survey does, and for each records three sizes and a time: -# -# file the whole executable on disk. Mostly runtime and libc glue, and -# the least interesting of the three -- it is here because it is -# the number anybody looks at first, and it should be visible how -# much of it is noise. -# text the .text section, from `size -A`. Still contains flan_rt.o, -# which is the same object on both sides. -# own the sum of the sizes of the defined symbols named `flan.` -# -- the program's *own* code and nothing else. The runtime's C is -# `flan_` with an underscore, so the two do not collide, and -# spot-checking a runtime symbol on both sides (flan_map_clone, -# 0x4b3 either way) says the runtime really is byte-identical and -# the difference in `own` is all codegen. -# -# The `own` column is the measurement; the other two are context. -# -# A fourth build, LLVM with --debug, is the reference that makes the number -# readable. --debug forces -O0, so it is LLVM's codegen with its optimiser -# switched off -- the closest thing available to what this backend is doing, -# which has no optimiser at all. Without it every ratio silently blames the -# backend for the whole of mem2reg and inlining. (--x86 --debug is refused, -# so the column exists on one side only, and that is the point of it.) -# -# Time is best-of-N, not a mean: a mean measures the other tenants of the -# machine. Even so, a corpus program is mostly process startup -- these are -# milliseconds -- so read the time column only where it is tens of -# milliseconds or more, and read the rest as size. -# -# Usage: spike/x86/cost.sh [name-substring ...] -> a TSV on stdout -# COST_FLAGS=--dev extra flags, given to both sides, as SURVEY_FLAGS is -# COST_REPS=5 timing repetitions -# COST_O0=0 skip the LLVM -O0 reference column -set -u -orig=$(pwd) -here=$(cd "$(dirname "$0")" && pwd) -root=$(cd "$here/../.." && pwd) -cd "$root" || exit 1 - -if [ -n "${FLAN:-}" ]; then - case $FLAN in /*) flan=$FLAN;; *) flan=$orig/$FLAN;; esac -else - dune build --root . bin/main.exe 2>&1 | head -30 - flan=$root/_build/default/bin/main.exe -fi -test -x "$flan" || { echo "build failed" >&2; exit 1; } - -# Not mktemp under /tmp by default: this writes a few hundred executables of -# a megabyte or two, and a full /tmp on this machine has already frozen one -# session. The guard is cheap and a wedged run is not. -# A directory of this run's own, made with a plain mkdir so that a second -# copy of this script cannot land in the first one's: two runs sharing a -# scratch directory overwrite each other's `l` and `x` between the build and -# the timing, and the result is a row of numbers that belong to two different -# programs. That happened once here and the numbers looked entirely ordinary. -work=${COST_OUT:-${TMPDIR:-/tmp}/flan-cost} -mkdir -p "$work" || exit 1 -out=$work/run.$$ -mkdir "$out" || exit 1 -trap 'rm -rf "$out"' EXIT -free=$(df -Pk "$out" | awk 'NR==2 {print $4}') -[ "$free" -gt 2000000 ] || { echo "less than 2GB free at $out" >&2; exit 1; } - -forever="dev-loop dev-watch" -REPS=${COST_REPS:-5} -read -r -a extra <<<"${COST_FLAGS:-}" -o0=${COST_O0:-1} -[ -z "${COST_FLAGS:-}" ] || o0=0 - -# The sum of the defined text symbols the compiler itself named. `nm -S` -# prints value, size, type, name; a symbol with no size is not printed with -# four fields at all, which is why the guard is on NF. -own () { - nm --defined-only -S "$1" 2>/dev/null \ - | awk 'NF==4 && ($3=="T"||$3=="t") && $4 ~ /^flan\./ {n+=strtonum("0x"$2)} END{print n+0}' -} -text () { size -A "$1" 2>/dev/null | awk '$1==".text" {print $2}'; } - -# Best of REPS, in whole microseconds. A program that fails on one run and -# not another would make this meaningless, so the exit status of the first -# run is remembered and a run that disagrees with it poisons the row as -1. -# A program that hits the timeout is not timed at all: several of the corpus -# programs are agents or daemons that sit waiting for something that is not -# there, and five repetitions of a twenty-second wait, twice, is most of an -# afternoon spent measuring `timeout`. -best () { - exe=$1; min=; rc0= - for i in $(seq "$REPS"); do - t0=$(date +%s%N) - ( cd "$out" && timeout 20 "$exe" >/dev/null 2>&1 /dev/null 2>&1 || continue - # No main is a link failure, and it leaves nothing behind to measure. - test -x "$out/l" || continue - "$flan" build "$src" --x86 "${extra[@]}" -o "$out/x" >/dev/null 2>&1 || continue - test -x "$out/x" || continue - - d0=0 - if [ "$o0" = 1 ] && "$flan" build "$src" --debug -o "$out/d" >/dev/null 2>&1; then - d0=$(own "$out/d") - fi - - printf '%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\n' "$name" \ - "$(stat -c %s "$out/l")" "$(text "$out/l")" "$(own "$out/l")" "$d0" \ - "$(stat -c %s "$out/x")" "$(text "$out/x")" "$(own "$out/x")" \ - "$(best "$out/l")" "$(best "$out/x")" -done diff --git a/spike/x86/cell-override.c b/test/cell-override.c similarity index 94% rename from spike/x86/cell-override.c rename to test/cell-override.c index 98be2686..d9c8a3d4 100644 --- a/spike/x86/cell-override.c +++ b/test/cell-override.c @@ -13,7 +13,7 @@ * * A release build has no cells, dlsym answers NULL, and this does nothing -- * which is the control: it shows the change below comes from the indirection - * and not from ordinary symbol interposition. See spike/x86/cells.sh. + * and not from ordinary symbol interposition. See test/cells.sh. */ #define _GNU_SOURCE #include diff --git a/spike/x86/cells.sh b/test/cells.sh similarity index 97% rename from spike/x86/cells.sh rename to test/cells.sh index 81c1d4f2..3935df90 100755 --- a/spike/x86/cells.sh +++ b/test/cells.sh @@ -23,7 +23,7 @@ # from ordinary symbol interposition. set -u here=$(cd "$(dirname "$0")" && pwd) -root=$(cd "$here/../.." && pwd) +root=$(cd "$here/.." && pwd) # FLAN overrides the compiler, and when it is set nothing is built here. The # @cells alias sets it, because a dune action that shells out to dune waits on a # lock it cannot get; main.exe is in that rule's deps instead. Resolved to an @@ -47,7 +47,7 @@ test -x "$flan" || { echo "no compiler at $flan"; exit 1; } out=$(mktemp -d); trap 'rm -rf "$out"' EXIT cc -shared -fPIC -o "$out/override.so" "$here/cell-override.c" || exit 1 -src=$here/p8-cell.flan +src=$here/programs/x86-p8-cell.flan fail=0 run() { # run