diff --git a/emacs/flan-mode.el b/emacs/flan-mode.el index f494606..27424a6 100644 --- a/emacs/flan-mode.el +++ b/emacs/flan-mode.el @@ -47,7 +47,7 @@ (defconst flan--special '("let" "if" "do" "while" "until" "dotimes" "loop" "match" "set" "return" "defer" "some" "none" "try" "zeroed" "uninit" "slice" "at" "len" "addr" - "bytes" "cast" "true" "false" "nil") + "bytes" "cast" "true" "false" "nil" "print" "println") "Forms with meaning to the checker.") (defvar flan-font-lock-keywords diff --git a/lib/check.ml b/lib/check.ml index 508c7e7..b4e2cbf 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -1214,6 +1214,59 @@ and named_call ctx ~want loc name args = | "write-stdout" -> arity loc name 1 args; prim Tast.WriteStdout Types.Unit [ byte_slice ctx (List.hd args) ] + + (* (println x) and (print x): the structural printer, selected on the type + the argument checked to. plan.org, Milestone 5 — "compiler-provided, + per concrete type". That is not overloading and needs no type variables: + there is no dispatch at run time and no user-supplied printer to pick + between. The walk itself is render.ml, shared with the REPL, which is what + stops the two from drifting apart. + + [min]/[max]/[zeroed] above dispatch on the resolved argument type the same + way. The slots the slice arm needs come out of the frame of whatever + function this call is written in, via [fresh_slot] — allocated once per + call site, at check time, not once per iteration of a loop around it. + + A string prints raw here and quoted inside a structure. Those are not in + conflict: (println "hello") has to print hello or it is useless, and + (println b) where b has a string field has to quote it or the field + cannot be told from the punctuation. The split is exactly top level vs + nested, which is why it lives here and not in the walk. *) + | "print" | "println" -> + arity loc name 1 args; + let a = check ctx (List.hd args) in + let bslice = Types.Slice (Types.Int Types.U8) in + let write x = mk loc Types.Unit (Tast.Prim (Tast.WriteStdout, [ x ])) in + let conv pr x = mk loc bslice (Tast.Prim (pr, [ x ])) in + let emitter : Render.emitter = + { Render.ebytes = write; + estr = (fun x -> write (conv Tast.EscapeBytes x)); + ei64 = (fun x -> write (conv Tast.I64ToBytes x)); + eu64 = (fun x -> write (conv Tast.U64ToBytes x)); + ef64 = (fun x -> write (conv Tast.F64ToBytes x)) } + in + let rc = + { Render.structs = + Hashtbl.fold (fun _ v acc -> v :: acc) ctx.env.structs []; + enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) ctx.env.enums []; + emit = emitter; + alloc = (fun ty -> fresh_slot ctx ty) } + in + let parts = + match a.Tast.ty with + | Types.String | Types.Slice (Types.Int Types.U8) -> + [ write (mk loc bslice (Tast.Prim (Tast.Bytes, [ a ]))) ] + | _ -> Render.render rc 0 a + in + let nl = + if String.equal name "println" then + [ write + (mk loc bslice + (Tast.Prim (Tast.Bytes, [ mk loc Types.String (Tast.Str "\n") ]))) + ] + else [] + in + expect loc ~want (mk loc Types.Unit (Tast.Do (parts @ nl))) | "exit" -> arity loc name 1 args; prim Tast.Exit Types.Never [ check ctx ~want:index_ty (List.hd args) ] diff --git a/lib/emit.ml b/lib/emit.ml index 3a85c50..372a445 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -668,12 +668,17 @@ and addr f (e : Tast.expr) : string = and field_addr f (target : Tast.expr) i = let base = addr f target in - let sn = match target.Tast.ty with - | Types.Named n -> n + (* An Option is { i8, T } and has no declared name to gep through, so its + layout is spelled out instead. Nothing in the surface language reaches a + field of one -- [match] and [some] are how an Option is opened -- but the + structural printer does, to read the tag without unwrapping a None. *) + let sty = match target.Tast.ty with + | Types.Named n -> sname n + | Types.Option _ as t -> ll t | t -> failwith ("field of " ^ Types.to_string t) in let p = fresh f in - ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 %d" p (sname sn) base i; + ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 %d" p sty base i; p (* One index per dimension, so [(at grid row col)] is two geps. Indices are @@ -1207,6 +1212,8 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) = | Tast.BytesToI64, [ x ] -> shim_in f "@flan_bytes_to_i64" "i64" x | Tast.F64ToBytes, [ x ] -> shim_out f "@flan_f64_to_bytes" x | Tast.I64ToBytes, [ x ] -> shim_out f "@flan_i64_to_bytes" x + | Tast.U64ToBytes, [ x ] -> shim_out f "@flan_u64_to_bytes" x + | Tast.EscapeBytes, [ x ] -> shim_in_out f "@flan_escape_bytes" x | Tast.WriteStdout, [ x ] -> let p, n = explode f x in ins f "call void @flan_write_stdout(ptr %s, i64 %s)" p n; @@ -1244,6 +1251,14 @@ and shim_out f name (x : Tast.expr) = ins f "call void %s(%s %s, ptr %s)" name (ll x.Tast.ty) v tmp; load f tmp (Types.Slice (Types.Int Types.U8)) +(* Slice in, slice out: [shim_in] returns a scalar and [shim_out] takes one, so + a shim that transforms bytes into bytes is neither. *) +and shim_in_out f name (x : Tast.expr) = + let p, n = explode f x in + let tmp = alloca f (Types.Slice (Types.Int Types.U8)) in + ins f "call void %s(ptr %s, i64 %s, ptr %s)" name p n tmp; + load f tmp (Types.Slice (Types.Int Types.U8)) + and cast f (x : Tast.expr) target = let v = value f x in (* An enum is an i32 at run time and its own type only in the checker, so a @@ -1509,6 +1524,8 @@ declare double @flan_bytes_to_f64(ptr, i64) declare i64 @flan_bytes_to_i64(ptr, i64) declare void @flan_f64_to_bytes(double, ptr) declare void @flan_i64_to_bytes(i64, ptr) +declare void @flan_u64_to_bytes(i64, ptr) +declare void @flan_escape_bytes(ptr, i64, ptr) declare void @flan_handler_push(ptr) declare void @flan_handler_pop(ptr) declare void @flan_signal(i32, ptr, ptr) diff --git a/lib/prelude.ml b/lib/prelude.ml index 988914f..c93e0ad 100644 --- a/lib/prelude.ml +++ b/lib/prelude.ml @@ -9,9 +9,20 @@ loader yet; at milestone 3 it becomes an ordinary [core:] package and this module goes away. The acceptance programs may call anything defined here. - No overloading: [print-f64] and [print-str] name the type, because - compile-time overloading before the checker is stable is how a small - language stops being one. A single [println] is milestone 5. *) + [println] is not here and is not a function: it is compiler-provided and + structural, a walk over the concrete type at the call site (check.ml, and + the walk itself in render.ml). That is plan.org's Milestone 5 item, and it + needed none of the rest of milestone 5 -- there is nothing to dispatch on + at run time and no user-supplied printer to choose between, so no type + variables are involved. The earlier note here said a single [println] had + to wait for generics; it did not. + + The [print-*] functions stay, and not as compatibility. They print without + a newline and name their type at the call site, which is what a loop that + prints elements separated by spaces wants -- see [show] in + test/programs/slices.flan. [println] cannot express that, and [print] is + structural where these are not: [(print-str s)] is the raw bytes, whereas + [(print s)] is the same walk [println] uses. *) let source = {flan| (defn print-bytes [b [u8]] diff --git a/lib/render.ml b/lib/render.ml new file mode 100644 index 0000000..28ceb37 --- /dev/null +++ b/lib/render.ml @@ -0,0 +1,201 @@ +(** The structural printer: a compile-time walk over a [Tast] type that emits + the calls which print a value of it. + + It lives apart from its two callers because there are two, and they differ + in exactly one thing: where the pieces go. The REPL sends them to + [flan_dev_emit] ([session.ml]); [println] sends them to stdout + ([check.ml]). Everything else — which arm a type takes, how an enum + recovers its member names, the depth and span caps — has to be the same in + both, and the way to make it the same is to have one copy. + + Why the walk is at compile time at all: a Flan value carries no header, so + nothing at run time could say what it is. The compiler knows the type and + renders it there. And why it emits piecewise rather than building a string: + a struct is its fields with punctuation between them, and concatenating + that would need an allocator the language does not have. + + The emitter is five functions rather than five names because the two sides + are not both extern calls. The REPL's are ([flan_dev_emit_i64] takes an + i64); stdout's compose a conversion with a write — [(write-stdout + (i64->bytes x))] — and a name alone cannot say that. *) + +(* Each takes a value of the type its field is named for and returns a Unit + expression that prints it. [estr] is handed a [u8] slice and is expected to + quote and escape it: it is the *nested* string case, the one inside a struct + or an array, where an unquoted run of bytes could not be told from the + punctuation around it. A caller that wants a string printed raw does not go + through the walk at all. *) +type emitter = { + ebytes : Tast.expr -> Tast.expr; (* [u8], verbatim: punctuation and literals *) + estr : Tast.expr -> Tast.expr; (* [u8], quoted and escaped *) + ei64 : Tast.expr -> Tast.expr; + eu64 : Tast.expr -> Tast.expr; + ef64 : Tast.expr -> Tast.expr; +} + +type ctx = { + structs : Tast.structure list; + enums : (string * (string * int64) list) list; + emit : emitter; + (* A slot in the *caller's* frame. Only the slice arm needs one, and it needs + two: the slice itself, so the expression it came from is evaluated once + rather than once per element, and the loop counter. Who owns the frame + differs — the REPL's is a thunk it is building, [println]'s is the user + function being checked — so allocating one is the caller's to do. *) + alloc : Types.t -> int; +} + +(* Two separate limits, easily conflated. [depth] and [span] bound the *walk*, + so a big fixed array or a self-containing struct cannot turn one expression + into a module with ten thousand render sites in it. How much text actually + comes out is bounded in the runtime instead, once, for every renderer. *) +let max_depth = 4 +let max_span = 8 + +let fail = Loc.fail + +let rec render c depth (e : Tast.expr) : Tast.expr list = + let loc = e.Tast.loc in + let unit_ e = { Tast.e; ty = Types.Unit; loc } in + let cast t x = { Tast.e = Tast.Prim (Tast.Cast t, [ x ]); ty = t; loc } in + let bytes_of s = + { Tast.e = Tast.Prim (Tast.Bytes, [ { Tast.e = Tast.Str s; ty = Types.String; loc } ]); + ty = Types.Slice (Types.Int Types.U8); loc } + in + let lit s = c.emit.ebytes (bytes_of s) in + let int64 n = { Tast.e = Tast.Int (n, Types.I64); ty = Types.Int Types.I64; loc } in + let i32 n = + { Tast.e = Tast.Int (Int64.of_int n, Types.I32); ty = Types.Int Types.I32; loc } + in + let do_ xs = unit_ (Tast.Do xs) in + if depth > max_depth then [ lit "..." ] + else + match e.Tast.ty with + | Types.Int Types.U64 -> [ c.emit.eu64 e ] + | Types.Int _ -> [ c.emit.ei64 (cast (Types.Int Types.I64) e) ] + | Types.Float _ -> [ c.emit.ef64 (cast (Types.Float Types.F64) e) ] + | Types.Bool -> + [ unit_ (Tast.If (e, lit "true", lit "false")) ] + (* Evaluated *and then* reported. A Unit expression is almost always a call + made for its effect — (print-line "x") is the REPL's most ordinary + input — so emitting the literal without running it would make the prompt + answer () while nothing happened. *) + | Types.Unit -> [ e; lit "()" ] + | Types.String -> + [ c.emit.estr + { Tast.e = Tast.Prim (Tast.Bytes, [ e ]); + ty = Types.Slice (Types.Int Types.U8); loc } ] + (* Bytes are almost always text, and escaping makes the case where they are + not readable rather than a mess. *) + | Types.Slice (Types.Int Types.U8) -> [ c.emit.estr e ] + (* An enum's members are erased to i32 before the backend sees them, so the + name has to be recovered here, from the checker's table, as a chain of + comparisons. Falling through to the number is not a failure: a value + outside the declared members is exactly what you would want to see. *) + | Types.Enum n -> + let members = try List.assoc n c.enums with Not_found -> [] in + let number = c.emit.ei64 (cast (Types.Int Types.I64) e) in + List.fold_left + (fun otherwise (name, v) -> + let is = + { Tast.e = + Tast.Prim (Tast.Eq, + [ cast (Types.Int Types.I64) e; int64 v ]); + ty = Types.Bool; loc } + in + unit_ (Tast.If (is, lit (":" ^ name), otherwise))) + number members + |> fun x -> [ x ] + (* A pointer is rendered as its shape and never followed: it is the only + thing that could make this walk cycle, and dereferencing one a REPL was + handed is not a safe thing to do on someone's behalf. *) + | Types.Ptr _ -> [ lit "" ] + | Types.Option t -> + let tag = { Tast.e = Tast.Field (e, 0); ty = Types.Int Types.I8; loc } in + let some = { Tast.e = Tast.Field (e, 1); ty = t; loc } in + let is_some = + { Tast.e = + Tast.Prim (Tast.Ne, + [ tag; { Tast.e = Tast.Int (0L, Types.I8); + ty = Types.Int Types.I8; loc } ]); + ty = Types.Bool; loc } + in + [ unit_ + (Tast.If (is_some, + do_ ((lit "(some " :: render c (depth + 1) some) @ [ lit ")" ]), + lit "none")) ] + | Types.Named n -> + (match + List.find_opt (fun (s : Tast.structure) -> String.equal s.Tast.sname n) + c.structs + with + | None -> [ lit ("<" ^ n ^ ">") ] + | Some st -> + let fields = st.Tast.fields in + let shown = List.filteri (fun i _ -> i < max_span) fields in + let parts = + List.concat + (List.mapi + (fun i (f : Tast.field) -> + let v = { Tast.e = Tast.Field (e, i); ty = f.Tast.fty; loc } in + (if i = 0 then [] else [ lit " " ]) + @ [ lit (":" ^ f.Tast.fname ^ " ") ] + @ render c (depth + 1) v) + shown) + in + [ do_ ((lit ("(" ^ n ^ " {") :: parts) + @ (if List.length fields > max_span then [ lit " ..." ] else []) + @ [ lit "})" ]) ]) + (* A fixed array's length is in its type, so it unrolls — capped, because + sand's grid is [100 [100 u32]] and unrolling that is ten thousand render + sites in one module. *) + | Types.Array (n, t) -> + let shown = min (Int64.to_int n) max_span in + let parts = + List.concat + (List.init shown (fun i -> + let v = + { Tast.e = Tast.Prim (Tast.At, [ e; i32 i ]); ty = t; loc } + in + lit " " :: render c (depth + 1) v)) + in + [ do_ ((lit "[" :: parts) + @ (if Int64.to_int n > shown then [ lit " ..." ] else []) + @ [ lit "]" ]) ] + (* A slice's length is not known until it runs, so this is the one case + that needs a loop. The slice goes into a slot first: the expression it + came from must not be evaluated once per element. *) + | Types.Slice t -> + let sv = c.alloc e.Tast.ty and iv = c.alloc (Types.Int Types.I32) in + let local i ty = { Tast.e = Tast.Local i; ty; loc } in + let len = + { Tast.e = Tast.Prim (Tast.Len, [ local sv e.Tast.ty ]); + ty = Types.Int Types.I32; loc } + in + let cond = + { Tast.e = Tast.Prim (Tast.Lt, [ local iv (Types.Int Types.I32); len ]); + ty = Types.Bool; loc } + in + let elem = + { Tast.e = + Tast.Prim (Tast.At, [ local sv e.Tast.ty; local iv (Types.Int Types.I32) ]); + ty = t; loc } + in + let step = + unit_ + (Tast.Set + (Tast.Plocal iv, + { Tast.e = + Tast.Prim (Tast.Add, [ local iv (Types.Int Types.I32); i32 1 ]); + ty = Types.Int Types.I32; loc })) + in + [ unit_ + (Tast.Let + ([ (sv, e); (iv, i32 0) ], + [ lit "["; + unit_ + (Tast.While + (cond, (lit " " :: render c (depth + 1) elem) @ [ step ])); + lit "]" ])) ] + | t -> + fail loc "no printer for %s" (Types.to_string t) diff --git a/lib/session.ml b/lib/session.ml index 540bd39..a10d3bb 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -398,174 +398,18 @@ let externs : Tast.extern list = { Tast.ename = "flan/dev-end"; esym = "flan_dev_result_end"; eparams = []; eret = Types.Unit } ] -(* Two separate limits, easily conflated. [depth] and [span] bound the *walk*, - so a big fixed array or a self-containing struct cannot turn one expression - into a module with ten thousand render sites in it. How much text actually - comes out is bounded in the runtime instead, once, for every renderer. *) -let max_depth = 4 -let max_span = 8 - -type ctx = { - structs : Tast.structure list; - enums : (string * (string * int64) list) list; - (* Slots a rendered loop needs. The thunk's frame grows as the walk finds - slices in it. *) - mutable slots : Types.t list; (* reversed *) - mutable nslots : int; -} - -let slot c ty = - let i = c.nslots in - c.nslots <- i + 1; - c.slots <- ty :: c.slots; - i - -let rec render c depth (e : Tast.expr) : Tast.expr list = - let loc = e.Tast.loc in - let unit_ e = { Tast.e; ty = Types.Unit; loc } in - let call em x = unit_ (Tast.Call (em.ename, [ x ])) in - let cast t x = { Tast.e = Tast.Prim (Tast.Cast t, [ x ]); ty = t; loc } in - let bytes_of s = - { Tast.e = Tast.Prim (Tast.Bytes, [ { Tast.e = Tast.Str s; ty = Types.String; loc } ]); - ty = Types.Slice (Types.Int Types.U8); loc } +(* The REPL's emitter. Each piece is one extern call: the dev runtime already + has a renderer per scalar, and [flan_dev_emit_str] already quotes and + escapes. See render.ml for what the five are and why they are functions. *) +let dev_emitter : Render.emitter = + let call em (x : Tast.expr) : Tast.expr = + { Tast.e = Tast.Call (em.ename, [ x ]); ty = Types.Unit; loc = x.Tast.loc } in - let lit s = call emit_bytes (bytes_of s) in - let int64 n = { Tast.e = Tast.Int (n, Types.I64); ty = Types.Int Types.I64; loc } in - let i32 n = - { Tast.e = Tast.Int (Int64.of_int n, Types.I32); ty = Types.Int Types.I32; loc } - in - let do_ xs = unit_ (Tast.Do xs) in - if depth > max_depth then [ lit "..." ] - else - match e.Tast.ty with - | Types.Int Types.U64 -> [ call emit_u64 e ] - | Types.Int _ -> [ call emit_i64 (cast (Types.Int Types.I64) e) ] - | Types.Float _ -> [ call emit_f64 (cast (Types.Float Types.F64) e) ] - | Types.Bool -> - [ unit_ (Tast.If (e, lit "true", lit "false")) ] - (* Evaluated *and then* reported. A Unit expression is almost always a call - made for its effect — (print-line "x") is the REPL's most ordinary - input — so emitting the literal without running it would make the prompt - answer () while nothing happened. *) - | Types.Unit -> [ e; lit "()" ] - | Types.String -> - [ call emit_str - { Tast.e = Tast.Prim (Tast.Bytes, [ e ]); - ty = Types.Slice (Types.Int Types.U8); loc } ] - (* Bytes are almost always text, and escaping makes the case where they are - not readable rather than a mess. *) - | Types.Slice (Types.Int Types.U8) -> [ call emit_str e ] - (* An enum's members are erased to i32 before the backend sees them, so the - name has to be recovered here, from the checker's table, as a chain of - comparisons. Falling through to the number is not a failure: a value - outside the declared members is exactly what you would want to see. *) - | Types.Enum n -> - let members = try List.assoc n c.enums with Not_found -> [] in - let number = call emit_i64 (cast (Types.Int Types.I64) e) in - List.fold_left - (fun otherwise (name, v) -> - let is = - { Tast.e = - Tast.Prim (Tast.Eq, - [ cast (Types.Int Types.I64) e; int64 v ]); - ty = Types.Bool; loc } - in - unit_ (Tast.If (is, lit (":" ^ name), otherwise))) - number members - |> fun x -> [ x ] - (* A pointer is rendered as its shape and never followed: it is the only - thing that could make this walk cycle, and dereferencing one a REPL was - handed is not a safe thing to do on someone's behalf. *) - | Types.Ptr _ -> [ lit "" ] - | Types.Option t -> - let tag = { Tast.e = Tast.Field (e, 0); ty = Types.Int Types.I8; loc } in - let some = { Tast.e = Tast.Field (e, 1); ty = t; loc } in - let is_some = - { Tast.e = - Tast.Prim (Tast.Ne, - [ tag; { Tast.e = Tast.Int (0L, Types.I8); - ty = Types.Int Types.I8; loc } ]); - ty = Types.Bool; loc } - in - [ unit_ - (Tast.If (is_some, - do_ ((lit "(some " :: render c (depth + 1) some) @ [ lit ")" ]), - lit "none")) ] - | Types.Named n -> - (match - List.find_opt (fun (s : Tast.structure) -> String.equal s.Tast.sname n) - c.structs - with - | None -> [ lit ("<" ^ n ^ ">") ] - | Some st -> - let fields = st.Tast.fields in - let shown = List.filteri (fun i _ -> i < max_span) fields in - let parts = - List.concat - (List.mapi - (fun i (f : Tast.field) -> - let v = { Tast.e = Tast.Field (e, i); ty = f.Tast.fty; loc } in - (if i = 0 then [] else [ lit " " ]) - @ [ lit (":" ^ f.Tast.fname ^ " ") ] - @ render c (depth + 1) v) - shown) - in - [ do_ ((lit ("(" ^ n ^ " {") :: parts) - @ (if List.length fields > max_span then [ lit " ..." ] else []) - @ [ lit "})" ]) ]) - (* A fixed array's length is in its type, so it unrolls — capped, because - sand's grid is [100 [100 u32]] and unrolling that is ten thousand render - sites in one module. *) - | Types.Array (n, t) -> - let shown = min (Int64.to_int n) max_span in - let parts = - List.concat - (List.init shown (fun i -> - let v = - { Tast.e = Tast.Prim (Tast.At, [ e; i32 i ]); ty = t; loc } - in - lit " " :: render c (depth + 1) v)) - in - [ do_ ((lit "[" :: parts) - @ (if Int64.to_int n > shown then [ lit " ..." ] else []) - @ [ lit "]" ]) ] - (* A slice's length is not known until it runs, so this is the one case - that needs a loop. The slice goes into a slot first: the expression it - came from must not be evaluated once per element. *) - | Types.Slice t -> - let sv = slot c e.Tast.ty and iv = slot c (Types.Int Types.I32) in - let local i ty = { Tast.e = Tast.Local i; ty; loc } in - let len = - { Tast.e = Tast.Prim (Tast.Len, [ local sv e.Tast.ty ]); - ty = Types.Int Types.I32; loc } - in - let cond = - { Tast.e = Tast.Prim (Tast.Lt, [ local iv (Types.Int Types.I32); len ]); - ty = Types.Bool; loc } - in - let elem = - { Tast.e = - Tast.Prim (Tast.At, [ local sv e.Tast.ty; local iv (Types.Int Types.I32) ]); - ty = t; loc } - in - let step = - unit_ - (Tast.Set - (Tast.Plocal iv, - { Tast.e = - Tast.Prim (Tast.Add, [ local iv (Types.Int Types.I32); i32 1 ]); - ty = Types.Int Types.I32; loc })) - in - [ unit_ - (Tast.Let - ([ (sv, e); (iv, i32 0) ], - [ lit "["; - unit_ - (Tast.While - (cond, (lit " " :: render c (depth + 1) elem) @ [ step ])); - lit "]" ])) ] - | t -> - fail loc "no printer for %s" (Types.to_string t) + { Render.ebytes = call emit_bytes; + estr = call emit_str; + ei64 = call emit_i64; + eu64 = call emit_u64; + ef64 = call emit_f64 } let eval_expr ?(origin = "") t src : change = let form = @@ -575,21 +419,31 @@ let eval_expr ?(origin = "") t src : change = | _ :: f :: _ -> fail f.Form.loc "one expression at a time" in let checked, base = Check.expression t.env (Parse.expr form) in + (* The thunk's frame starts at whatever [Check.expression] needed and grows + as the walk finds slices in it, so the slots the renderer asks for are + appended past [base] and collected here to size the frame below. *) + let extra = ref [] and nslots = ref (Array.length base) in let c = - { structs = t.program.Tast.structs; + { Render.structs = t.program.Tast.structs; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; - slots = []; nslots = Array.length base } + emit = dev_emitter; + alloc = (fun ty -> + let i = !nslots in + incr nslots; + extra := ty :: !extra; + i) } in let loc = checked.Tast.loc in let nullary n = { Tast.e = Tast.Call (n, []); ty = Types.Unit; loc } in let body = - (nullary "flan/dev-begin" :: render c 0 checked) @ [ nullary "flan/dev-end" ] + (nullary "flan/dev-begin" :: Render.render c 0 checked) + @ [ nullary "flan/dev-end" ] in t.thunks <- t.thunks + 1; let name = Printf.sprintf "eval/%d" t.thunks in let thunk : Tast.fn = { Tast.name; params = []; ret = Types.Unit; body; fdefers = []; fparent = None; floc = loc; - slots = Array.append base (Array.of_list (List.rev c.slots)) } + slots = Array.append base (Array.of_list (List.rev !extra)) } in (* Built against the program but never spliced into it: an evaluation is not a declaration, and adding one would leave the session carrying an eval/N diff --git a/lib/tast.ml b/lib/tast.ml index 2f686dd..0ae656a 100644 --- a/lib/tast.ml +++ b/lib/tast.ml @@ -28,6 +28,10 @@ type prim = *text*: bytes->f64 parses "12.5", f64->bytes renders it — that is what calc-me's tokenizer and the prelude's printers each need. *) | Bytes | BytesToF64 | BytesToI64 | F64ToBytes | I64ToBytes + (* No surface name: the structural printer is the only thing that builds + these. U64ToBytes because u64 is not i64 with a flag, EscapeBytes for a + string nested inside a printed structure. *) + | U64ToBytes | EscapeBytes | WriteStdout | Exit | Argv | Cast of Types.t diff --git a/plan.org b/plan.org index 0011baf..390a663 100644 --- a/plan.org +++ b/plan.org @@ -381,10 +381,14 @@ wasm32 target cheap, because a primitive is the only thing implemented twice. | arithmetic, comparison, casts | per machine type | Printing is *not* a primitive. ~print-str~, ~print-f64~ and friends are Flan -functions over ~write-stdout~. At milestone 5, compiler-provided ~println~ emits -or selects a structural printer for every concrete type, including generic -instantiations. This is intentionally not user-defined overload resolution: -ordinary values remain untagged, while ~any~ and ~Error~ carry the metadata their +functions over ~write-stdout~. ~println~ and ~print~ are compiler-provided: the +checker walks the concrete type at the call site and emits the printer for it +(lib/render.ml, shared with the REPL's ~C-x C-e~). This is intentionally not +user-defined overload resolution — ordinary values remain untagged, and there +is nothing to dispatch on at run time — which is why it did not have to wait +for generics as this line once said it would. Generic instantiations are +concrete types by the time the checker sees them, so they need nothing further; +~any~ and ~Error~ are the remaining case, and they carry the metadata their dynamic printers need. *Entry point.* ~(defn main [args [string]] i32)~. Both the parameter and the diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index cf932af..ada55fa 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -191,6 +191,63 @@ void flan_i64_to_bytes(int64_t x, flan_slice *out) { out->len = n < 0 ? 0 : (int64_t)n; } +/* u64 is not i64 with a flag: 0xFFFFFFFFFFFFFFFF is 18446744073709551615 and + * not -1, and routing it through the signed printer is the only way println + * could disagree with the REPL about a value both can hold. Hence a second + * shim rather than a cast at the call site. */ +void flan_u64_to_bytes(uint64_t x, flan_slice *out) { + int n = snprintf(scratch, SCRATCH, "%llu", (unsigned long long)x); + out->ptr = (const uint8_t *)scratch; + out->len = n < 0 ? 0 : (int64_t)n; +} + +/* A string *inside* a printed structure, quoted and escaped, so that the run + * of bytes can be told from the punctuation around it — (S {:name "a b"}) has + * two fields if the quotes are missing and one if they are there. + * + * This is the same escape table as flan_dev_emit_str in flan_dev.c, and + * deliberately so: the REPL and println must not disagree about what a struct + * looks like. It cannot be the *same function* because the dev one streams + * into the result buffer and this one has to hand back a slice; if either + * table changes, change both. + * + * Its own buffer, not `scratch`: escaping is the one conversion whose output + * is not a bounded handful of characters. Over-long input is truncated with an + * ellipsis rather than silently cut, because a value that prints as a shorter + * value is the failure nobody notices. */ +#define ESCAPE_MAX 1024 +static char escaped[ESCAPE_MAX]; + +void flan_escape_bytes(const uint8_t *p, int64_t n, flan_slice *out) { + size_t len = n < 0 ? 0 : (size_t)n; + size_t w = 0; + int cut = 0; + /* 5 is the longest single escape (\xNN is 4, plus room for the close + * quote); leaving it spare means the loop never writes a partial escape. */ + escaped[w++] = '"'; + for (size_t i = 0; i < len; i++) { + if (w + 5 + 4 >= ESCAPE_MAX) { cut = 1; break; } + unsigned char c = p[i]; + switch (c) { + case '"': escaped[w++] = '\\'; escaped[w++] = '"'; break; + case '\\': escaped[w++] = '\\'; escaped[w++] = '\\'; break; + case '\n': escaped[w++] = '\\'; escaped[w++] = 'n'; break; + case '\t': escaped[w++] = '\\'; escaped[w++] = 't'; break; + case '\r': escaped[w++] = '\\'; escaped[w++] = 'r'; break; + default: + if (c < 0x20) { + w += (size_t)snprintf(escaped + w, 5, "\\x%02x", c); + } else { + escaped[w++] = (char)c; + } + } + } + if (cut) { escaped[w++] = '.'; escaped[w++] = '.'; escaped[w++] = '.'; } + escaped[w++] = '"'; + out->ptr = (const uint8_t *)escaped; + out->len = (int64_t)w; +} + /* Bounds failures. The emitted code branches here and then falls off the end * with `unreachable`, so these must not return — the same explicit shape as * every other non-local exit, which is what keeps wasm32 free of unwinding. diff --git a/test/programs/println.flan b/test/programs/println.flan new file mode 100644 index 0000000..394c074 --- /dev/null +++ b/test/programs/println.flan @@ -0,0 +1,115 @@ +;;;; println, one row per arm of the structural printer. +;;;; +;;;; The walk in render.ml is shared with the REPL, but until now its only +;;;; coverage was the REPL tests -- and those run a dev build, where the pieces +;;;; go to flan_dev_emit. println is the same walk with the other emitter, in +;;;; an ordinary build, so every arm needs saying again here: the two emitters +;;;; are the one thing the shared module does *not* make identical. +;;;; +;;;; Run at -O0 as well as -O2. The slice arm emits a loop over slots taken +;;;; from the enclosing function's frame, and mem2reg is exactly the pass that +;;;; would launder a slot mistake into working code. + +(defstruct V [x f32 y f32]) +(defstruct Blob [id i32 name string pos V tags [3 i32]]) +(defenum Colour [red 0 green 1 blue 2]) + +;; Five deep, so the walk hits max_depth (4) and prints "..." rather than +;; descending forever. A self-containing struct is the case this cap exists +;; for; five nested ones are the same shape without needing a pointer. +(defstruct D5 [n i32]) +(defstruct D4 [d D5]) +(defstruct D3 [d D4]) +(defstruct D2 [d D3]) +(defstruct D1 [d D2]) + +(defvar b Blob) +(defvar col Colour) +(defvar big u64) +(defvar small u64) +(defvar arr [4 i32]) +(defvar wide [10 i32]) +(defvar deep D1) +(defvar n i32) + +(defn nothing [] ) + +(defn find-it [s [i32] k i32] (Option i32) + (dotimes [i (len s)] + (when (= (at s i) k) (return (Some i)))) + None) + +(defn main [] i32 + ;; A string at top level prints raw. Anywhere else it is quoted, which the + ;; Blob row below shows -- the two are the same value printed two ways on + ;; purpose, and that difference is the thing most likely to be "fixed". + (println "plain string") + (println (bytes "plain bytes")) + + (println 42) + (println -7) + (set small 5) + (println small) + ;; The u64 row. Through the signed printer this reads -1, which is the one + ;; way println could disagree with the REPL about a value both can hold. + (set big 0xFFFFFFFFFFFFFFFF) + (println big) + + (println 3.5) + (println -0.25) + + (println true) + (println false) + + ;; Unit is evaluated and *then* reported: a Unit expression is a call made + ;; for its effect, so emitting () without running it would be a lie. + (println (nothing)) + + (set col :green) + (println col) + ;; red is 0, which is also the zero value, so this row says the chain of + ;; comparisons reaches the *first* member and does not fall through to the + ;; number it is erased to. + (set col :red) + (println col) + + ;; A pointer is its shape and is never followed -- the only thing that could + ;; make this walk cycle. + (set n 3) + (println (addr n)) + + (println (find-it (slice wide 0 10) 0)) + (println (find-it (slice wide 0 10) 99)) + + (set (.id b) 7) + (set (.name b) "sandy \"quoted\"") + (set (.x (.pos b)) 1.5) + (set (.y (.pos b)) -2.0) + (set (at (.tags b) 1) 42) + (println b) + + (set (at arr 2) 9) + (println arr) + + ;; Ten elements against a span cap of eight: eight, then "...". + (set (at wide 9) 1) + (println wide) + + ;; A slice's length is not known until it runs, so this is the arm that + ;; emits a loop rather than unrolling. + (println (slice arr 1 4)) + + (set (.n (.d (.d (.d (.d deep))))) 5) + (println deep) + + ;; Two slice printlns in one function, and one inside a loop: the slots the + ;; loop needs are allocated per *call site* at check time, not per iteration. + (dotimes [i 2] + (println (slice arr 0 2))) + (println (slice arr 2 4)) + + ;; print is println without the newline. + (print "a") + (print "b") + (println "c") + 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 398a605..e5fb534 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -127,6 +127,33 @@ let () = in outputs "slice algorithms" "programs/slices.flan" slices_out; outputs ~opt:"-O0" "slice algorithms, -O0" "programs/slices.flan" slices_out; + (* println, one row per arm of render.ml's walk. The walk is shared with + the REPL, but its only coverage was the REPL tests -- a dev build, + emitting to flan_dev_emit. This is the same walk with the other emitter + in an ordinary build, which is a path nothing else takes. + + Three of these rows are load-bearing beyond "it prints something". The + u64 reads 18446744073709551615 and not -1, which is what a second shim + exists for. The Blob's name is quoted and escaped while the two strings + at the top are raw, which is the top-level/nested split and the thing + most likely to be "tidied up" into being wrong. And the Option rows are + an arm that never ran until now: a field of an Option had no gep in + emit.ml, so the REPL would have failed on one too. + + At -O0 as well -- the slice arm allocates slots in the enclosing + function's frame and emits a loop, and mem2reg is the pass that would + hide a mistake in either. *) + let println_out = + "plain string\nplain bytes\n42\n-7\n5\n18446744073709551615\n3.5\n\ + -0.25\ntrue\nfalse\n()\n:green\n:red\n\n(some 0)\nnone\n\ + (Blob {:id 7 :name \"sandy \\\"quoted\\\"\" :pos (V {:x 1.5 :y -2}) :tags [ 0 42 0]})\n\ + [ 0 0 9 0]\n[ 0 0 0 0 0 0 0 0 ...]\n[ 0 9 0]\n\ + (D1 {:d (D2 {:d (D3 {:d (D4 {:d (D5 {:n ...})})})})})\n[ 0 0]\n\ + [ 0 0]\n[ 9 0]\nabc\n" + in + outputs "println, every arm" "programs/println.flan" println_out; + outputs ~opt:"-O0" "println, every arm, -O0" "programs/println.flan" + println_out; (* The byte predicates, parse-i64, and the two number helpers. The refused parse-i64 cases are every shape strtoll answers 0 for — "", "abc", "12x", "-", " 1" — so a None there is the whole reason the function is