Type checking and stuff
This commit is contained in:
parent
5a8c2327c6
commit
6d86d09a84
9
.gitignore
vendored
9
.gitignore
vendored
@ -29,4 +29,11 @@ setup.log
|
||||
_opam/
|
||||
|
||||
# VSCode settings folder
|
||||
.vscode
|
||||
.vscode
|
||||
|
||||
# Emitted LLVM IR, from `flan emit` or a kept build
|
||||
*.ll
|
||||
|
||||
# The pre-rewrite menhir/ocamllex frontend: reference only, excluded from the
|
||||
# build by the root dune file. Its contents are in git history at 2c232dd.
|
||||
old-ocaml/
|
||||
|
||||
128
NEXT.md
128
NEXT.md
@ -1,10 +1,11 @@
|
||||
# Where this is
|
||||
|
||||
Milestone 2 of the build sequence in `plan.org`: *run `calc-me.flan` on the
|
||||
interpreter*. Two of four stages exist.
|
||||
Milestones 2 and 3 of `plan.org` were merged: the interpreter was dropped
|
||||
(open decision #7, settled — see below) and the compiled path is the only
|
||||
backend. **calc-me.flan compiles and runs.**
|
||||
|
||||
```
|
||||
reader ✅ → parse ✅ → check ⬜ → interpret ⬜
|
||||
reader ✅ → parse ✅ → check ✅ → emit ✅ → clang ✅
|
||||
```
|
||||
|
||||
| File | What it does |
|
||||
@ -14,48 +15,97 @@ reader ✅ → parse ✅ → check ⬜ → interpret ⬜
|
||||
| `lib/reader.ml` | hand-written S-expression reader, no menhir/ocamllex |
|
||||
| `lib/ast.ml` | AST: `texpr`, `expr`, `place`, `pattern`, `decl` |
|
||||
| `lib/parse.ml` | forms → AST; special forms, desugaring, declarations |
|
||||
| `bin/main.ml` | `flan read <file>` and `flan parse <file>` |
|
||||
| `test/test_flan.ml` | 110+ assertions; `calc-me.flan` and `sand.flan` are deps |
|
||||
| `lib/types.ml` | resolved types; structural equality, `Never` fits anywhere |
|
||||
| `lib/tast.ml` | the typed IR the backend consumes |
|
||||
| `lib/check.ml` | AST → typed IR; two passes, bidirectional |
|
||||
| `lib/prelude.ml` | `print-str`/`print-f64`/`print-line`, written in Flan |
|
||||
| `lib/emit.ml` | typed IR → LLVM IR text |
|
||||
| `lib/build.ml` | `.ll` + the shim → clang → executable |
|
||||
| `runtime/flan_rt.c` | the whole host ABI: argv, stdout, exit, 4 conversions |
|
||||
| `bin/main.ml` | `flan read \| parse \| check \| emit \| build \| run` |
|
||||
| `test/test_flan.ml` | reader, parser and checker |
|
||||
| `test/test_acceptance.ml` | 20 expression/result pairs + 3 whole programs |
|
||||
| `test/programs/*.flan` | the milestone-2 surface calc-me does not reach |
|
||||
|
||||
`dune build && dune test` is green. `flan parse calc-me.flan` and
|
||||
`flan parse sand.flan` both succeed.
|
||||
```
|
||||
$ flan run calc-me.flan "1 + 2 * (3 - 0.5) / 2"
|
||||
3.5
|
||||
```
|
||||
|
||||
## Next: `lib/types.ml` and the checker
|
||||
`dune build && dune test` is green, and the whole-program cases run at `-O2`
|
||||
*and* `-O0` — `mem2reg` launders a sloppy alloca, so -O0 is what tests the IR
|
||||
actually emitted. `flan emit` is byte-reproducible. `flan check sand.flan` fails on
|
||||
`(import rl ...)`, which is milestone 4 — as it should.
|
||||
|
||||
1. **Type representation.** Resolve `Ast.texpr` into a real type. Needs the
|
||||
declared-type environment `Parse.declared_types` already computes — that
|
||||
pre-pass exists and should be reused rather than rebuilt.
|
||||
2. **Top-level environment.** Two passes, because top-level names are
|
||||
order-independent (`plan.org`, Modules): collect all signatures, then check
|
||||
bodies.
|
||||
3. **Check `calc-me.flan`.** It needs: `i32`/`u8`/`f64`/`bool`, structs, `[u8]`
|
||||
slices, `(Ptr T)` with one level of auto-deref on `.field`, `(Option T)` with
|
||||
`Some`/`None`, `Unwrap (Usome, _)` as early-return-None, `while`, `return`,
|
||||
`set` on the five places, `match` on `Option`, and the milestone-2 primitive
|
||||
list in `plan.org`.
|
||||
4. **Then the interpreter** over the typed IR.
|
||||
## Why there is no interpreter
|
||||
|
||||
Open decision #7 is settled: **the compiled path is the only backend.** The two
|
||||
arguments for a permanent interpreter had both already expired in `plan.org` —
|
||||
the instrumentation step debugger that wanted it is cut, and compiled
|
||||
redefinition measured at ~16ms, which is perceptually instant for expression
|
||||
eval too. CCL and SBCL both do full interactive development without leaning on
|
||||
an interpreter; what makes a live image work is a fast compiler callable at
|
||||
runtime.
|
||||
|
||||
The remaining argument was that milestone 3 needs an oracle to check the
|
||||
compiler against. It does not: the acceptance test is a hand-written table of
|
||||
expression/result pairs, so the table *is* the oracle.
|
||||
|
||||
Consequences, both already applied: milestone 2's "measured interpreted calls
|
||||
per second" exit criterion is dropped — milestone 4 runs on the compiled build
|
||||
and nothing depended on that number — and the host ABI moved onto the critical
|
||||
path, which is why `runtime/flan_rt.c` exists now rather than at milestone 3.
|
||||
|
||||
## The layout, which is the whole backend design
|
||||
|
||||
```
|
||||
i8..i64 / u8..u64 i8..i64 signedness lives in the ops
|
||||
f32 f64 float double
|
||||
bool i1
|
||||
[T] and string { ptr, i64 } ptr+len, non-owning
|
||||
[n T] [n x T] inline, a value
|
||||
(Ptr T) ptr opaque pointers
|
||||
(Option T) { i8, T } tag 0 None, 1 Some
|
||||
a struct a literal struct, declaration order
|
||||
Unit and Never {}
|
||||
```
|
||||
|
||||
No object headers anywhere, so a Flan struct is exactly its C struct and
|
||||
nothing marshals. Two consequences carry the semantics:
|
||||
|
||||
- **Every slot is an `alloca`.** Reading a local is a `load`, assigning is a
|
||||
`store`, and a `store` of an aggregate *is* the copy `spec-memory.md`
|
||||
requires — value structs and fixed arrays copy, a slice copies only its view.
|
||||
`addr` of a local is then just the alloca, and `mem2reg` removes the ones
|
||||
nobody addressed. `test/programs/values.flan` pins this down: mutate the
|
||||
original, the copy is unchanged.
|
||||
- **A place is a pointer, a value is a load from it.** `(set (.pos c) …)`
|
||||
through a `(Ptr Cursor)` becomes a `getelementptr` on the pointer, not on a
|
||||
copy. This is the split that would have made a tree-walker silently wrong.
|
||||
|
||||
Non-local exit is lowered explicitly: `return` and `some` are branches to a
|
||||
`ret`, never platform unwinding, so wasm32 needs no exception proposal.
|
||||
|
||||
## Next
|
||||
|
||||
1. **wasm32.** The backend is there (`llc` lists `wasm32`) and
|
||||
`Build.opts.target` already plumbs `--target`, but there is **no wasi
|
||||
sysroot on this machine** — `clang --target=wasm32-wasi` cannot find
|
||||
`stdio.h`. Install `wasi-sdk`/`wasi-libc`, then run the same acceptance
|
||||
table on both targets in CI. That is milestone 3's real remaining work.
|
||||
2. **Bounds checks.** `at` and `slice` emit a bare `getelementptr`. Dev builds
|
||||
should trap; release should not.
|
||||
3. **Then milestone 4** — sand.flan: fixed 2-D arrays (done), `dotimes`,
|
||||
`defer`, and typed raylib FFI with keyword→enum coercion.
|
||||
|
||||
## Watch for
|
||||
|
||||
The two bugs found so far were both *silent misparses* — code that read fine and
|
||||
meant something else:
|
||||
|
||||
- `'skip-form` became a symbol named `'skip-form`
|
||||
- `dotimes`/`defer`/`some` fell through to `Call`, discarding their binding and
|
||||
control-flow meaning
|
||||
- `(Some 1)` in first body position was eaten as a return type
|
||||
|
||||
The rule that catches this class: **anything that binds a name, alters control
|
||||
flow, or is not yet implemented must be recognised explicitly and rejected if
|
||||
unsupported — never allowed to fall through to a generic case.** `parse.ml`
|
||||
rejects `handler-bind`, `restart-case`, `loop`/`recur`, `defmacro`, `signal`,
|
||||
`with-allocator`, `errdefer` and `await` for exactly this reason. Keep doing that
|
||||
in the checker.
|
||||
|
||||
## Open decisions that touch the checker
|
||||
|
||||
None block milestone 2. `plan.org` tags each open decision with the milestone it
|
||||
is due by; #1 (host language) is now settled as OCaml.
|
||||
The rule that caught the two misparse bugs applies unchanged: **anything that
|
||||
binds a name, alters control flow, or is not yet implemented must be recognised
|
||||
explicitly and rejected if unsupported.** `check.ml` rejects `Vec`, `Map`,
|
||||
`Result`/`try`, union values, closures, `dotimes`, `defer`, keywords at call
|
||||
sites, imports, generics and function values *by name*, each with the milestone
|
||||
it belongs to. The tests assert on the reason, not just on the failure.
|
||||
|
||||
## Untracked on purpose
|
||||
|
||||
|
||||
2
bin/dune
2
bin/dune
@ -1,3 +1,3 @@
|
||||
(executable
|
||||
(name main)
|
||||
(libraries flan))
|
||||
(libraries flan unix))
|
||||
|
||||
66
bin/main.ml
66
bin/main.ml
@ -40,6 +40,70 @@ let () =
|
||||
|> Flan.Parse.program
|
||||
|> List.iter (fun d -> print_endline (summarise d))))
|
||||
files
|
||||
| _ :: "check" :: files when files <> [] ->
|
||||
List.iter
|
||||
(fun path ->
|
||||
with_errors path (fun () ->
|
||||
let p =
|
||||
Flan.Reader.read_file path
|
||||
|> Flan.Parse.program
|
||||
|> Flan.Check.program
|
||||
in
|
||||
List.iter
|
||||
(fun (g : Flan.Tast.global) ->
|
||||
Printf.printf "%s %s %s\n"
|
||||
(if g.gconst then "defconst" else "defvar")
|
||||
g.gname (Flan.Types.to_string g.gty))
|
||||
p.globals;
|
||||
List.iter
|
||||
(fun (f : Flan.Tast.fn) ->
|
||||
Printf.printf "defn %s : (Fn [%s] %s) %d slots\n" f.name
|
||||
(String.concat " "
|
||||
(List.map Flan.Types.to_string f.params))
|
||||
(Flan.Types.to_string f.ret) (Array.length f.slots))
|
||||
p.fns))
|
||||
files
|
||||
| _ :: "emit" :: files when files <> [] ->
|
||||
List.iter
|
||||
(fun path ->
|
||||
with_errors path (fun () ->
|
||||
Flan.Reader.read_file path
|
||||
|> Flan.Parse.program
|
||||
|> Flan.Check.program
|
||||
|> Flan.Emit.program
|
||||
|> print_string))
|
||||
files
|
||||
| _ :: "build" :: path :: rest ->
|
||||
let out =
|
||||
match rest with
|
||||
| [ "-o"; o ] -> o
|
||||
| [] -> Filename.remove_extension (Filename.basename path)
|
||||
| _ -> prerr_endline "usage: flan build <file.flan> [-o out]"; exit 2
|
||||
in
|
||||
with_errors path (fun () ->
|
||||
Flan.Reader.read_file path
|
||||
|> Flan.Parse.program
|
||||
|> Flan.Check.program
|
||||
|> fun p -> ignore (Flan.Build.executable p ~out))
|
||||
| _ :: "run" :: path :: args ->
|
||||
with_errors path (fun () ->
|
||||
let exe =
|
||||
Filename.concat (Filename.get_temp_dir_name ())
|
||||
(Printf.sprintf "flan-run-%d" (Unix.getpid ()))
|
||||
in
|
||||
Flan.Reader.read_file path
|
||||
|> Flan.Parse.program
|
||||
|> Flan.Check.program
|
||||
|> fun p ->
|
||||
ignore (Flan.Build.executable p ~out:exe);
|
||||
let code =
|
||||
Sys.command (String.concat " " (List.map Filename.quote (exe :: args)))
|
||||
in
|
||||
(try Sys.remove exe with Sys_error _ -> ());
|
||||
exit code)
|
||||
| _ ->
|
||||
prerr_endline "usage: flan (read|parse) <file.flan>...";
|
||||
prerr_endline
|
||||
"usage: flan (read|parse|check|emit) <file.flan>...\n\
|
||||
\ flan build <file.flan> [-o out]\n\
|
||||
\ flan run <file.flan> [args...]";
|
||||
exit 2
|
||||
|
||||
52
lib/build.ml
Normal file
52
lib/build.ml
Normal file
@ -0,0 +1,52 @@
|
||||
(** Driver: typed IR → an executable, via LLVM IR text and clang.
|
||||
|
||||
The release path from plan.org, Compilation:
|
||||
|
||||
{v flan → typed IR → .ll → clang --target={native,wasm32} v}
|
||||
|
||||
Not the dev path — that one never invokes the clang driver, because the
|
||||
driver *is* the cost (52ms of the measured 68), and goes llc + ld -shared +
|
||||
dlopen instead for ~16ms. Nothing at milestone 2 needs it yet. *)
|
||||
|
||||
let clang = try Sys.getenv "FLAN_CLANG" with Not_found -> "clang"
|
||||
|
||||
let write path contents =
|
||||
let ch = open_out path in
|
||||
output_string ch contents;
|
||||
close_out ch
|
||||
|
||||
(* One temporary directory per build, so the .ll is findable by name when
|
||||
something is wrong with it. *)
|
||||
let workdir () =
|
||||
let d =
|
||||
Filename.concat (Filename.get_temp_dir_name ())
|
||||
(Printf.sprintf "flan-%d" (Unix.getpid ()))
|
||||
in
|
||||
(try Unix.mkdir d 0o700 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
|
||||
d
|
||||
|
||||
type opts = {
|
||||
target : string option; (* None is the host; "wasm32-wasi" is the other *)
|
||||
opt : string;
|
||||
keep : bool; (* leave the .ll behind *)
|
||||
}
|
||||
|
||||
let default = { target = None; opt = "-O2"; keep = false }
|
||||
|
||||
let executable ?(opts = default) (p : Tast.program) ~out =
|
||||
let dir = workdir () in
|
||||
let ll = Filename.concat dir (Filename.basename out ^ ".ll") in
|
||||
let rt = Filename.concat dir "flan_rt.c" in
|
||||
write ll (Emit.program p);
|
||||
write rt Runtime_src.source;
|
||||
let cmd =
|
||||
String.concat " "
|
||||
([ Filename.quote clang; opts.opt; "-Wno-override-module" ]
|
||||
@ (match opts.target with None -> [] | Some t -> [ "--target=" ^ t ])
|
||||
@ [ Filename.quote ll; Filename.quote rt; "-o"; Filename.quote out ])
|
||||
in
|
||||
let code = Sys.command cmd in
|
||||
if code <> 0 then
|
||||
failwith (Printf.sprintf "%s failed (exit %d); the IR is at %s" clang code ll);
|
||||
if not opts.keep then (try Sys.remove ll; Sys.remove rt with Sys_error _ -> ());
|
||||
out
|
||||
991
lib/check.ml
Normal file
991
lib/check.ml
Normal file
@ -0,0 +1,991 @@
|
||||
(** The checker: AST → typed IR.
|
||||
|
||||
Two passes, because top-level names in a package are order-independent
|
||||
(plan.org, Modules): the first collects every type, signature and global,
|
||||
the second checks bodies against them. Mutually recursive functions need no
|
||||
forward declaration, and a struct may be used above where it is declared.
|
||||
|
||||
Checking is *bidirectional*. An expression is checked against an expected
|
||||
type when there is one and inferred when there is not, which is what makes
|
||||
[None], a bare [0] and a struct literal work without any inference engine:
|
||||
the expected type flows in from the function's return type, the parameter
|
||||
it is being passed to, or the field it is being stored in.
|
||||
|
||||
The rule from the two misparse bugs applies here too: *anything not yet
|
||||
implemented is rejected by name*, never approximated. Milestone 2 is
|
||||
calc-me.flan and nothing more (plan.org, Build sequence), so [Vec], [Map],
|
||||
[Result]/[try], user unions, closures, [dotimes], [defer], generics and
|
||||
cross-package imports are all errors with a message that says which
|
||||
milestone they belong to. *)
|
||||
|
||||
let fail = Loc.fail
|
||||
|
||||
(* [List.map]'s evaluation order is unspecified, and checking allocates frame
|
||||
slots as a side effect. Left-to-right is required, not a preference: a later
|
||||
let binding sees an earlier one, and slot numbering must be reproducible. *)
|
||||
let rec map_lr f = function
|
||||
| [] -> []
|
||||
| x :: rest -> let y = f x in y :: map_lr f rest
|
||||
|
||||
let rec map2_lr f xs ys =
|
||||
match xs, ys with
|
||||
| [], [] -> []
|
||||
| x :: xs, y :: ys -> let z = f x y in z :: map2_lr f xs ys
|
||||
| _ -> invalid_arg "map2_lr"
|
||||
|
||||
(* ── Environments ──────────────────────────────────────────────────── *)
|
||||
|
||||
type binding = {
|
||||
slot : int;
|
||||
bty : Types.t;
|
||||
assignable : bool; (* locals are places; parameters are not — spec-memory *)
|
||||
}
|
||||
|
||||
type env = {
|
||||
structs : (string, Tast.structure) Hashtbl.t;
|
||||
unions : (string, Tast.union) Hashtbl.t;
|
||||
aliases : (string, Ast.texpr) Hashtbl.t;
|
||||
consts : (string, int64) Hashtbl.t; (* compile-time array lengths *)
|
||||
locs : (string, Loc.t) Hashtbl.t; (* where each type was declared *)
|
||||
fns : (string, Types.t list * Types.t) Hashtbl.t;
|
||||
globals : (string, Types.t * bool) Hashtbl.t; (* type, is a constant *)
|
||||
}
|
||||
|
||||
let new_env () = {
|
||||
structs = Hashtbl.create 16;
|
||||
unions = Hashtbl.create 16;
|
||||
aliases = Hashtbl.create 16;
|
||||
consts = Hashtbl.create 16;
|
||||
locs = Hashtbl.create 16;
|
||||
fns = Hashtbl.create 32;
|
||||
globals = Hashtbl.create 16;
|
||||
}
|
||||
|
||||
(* Per-function state. Slots are never reused, so [slots] is also the frame
|
||||
size — the interpreter allocates one array of this length per call. *)
|
||||
type ctx = {
|
||||
env : env;
|
||||
ret : Types.t;
|
||||
mutable slots : int;
|
||||
(* The type of each slot, newest first. A backend needs it to size the
|
||||
frame — nothing else records it, since the IR refers to slots by index. *)
|
||||
mutable slot_tys : Types.t list;
|
||||
mutable scope : (string * binding) list; (* innermost first *)
|
||||
}
|
||||
|
||||
let fresh_slot ctx ty =
|
||||
let s = ctx.slots in
|
||||
ctx.slots <- s + 1;
|
||||
ctx.slot_tys <- ty :: ctx.slot_tys;
|
||||
s
|
||||
|
||||
let bind ctx name bty ~assignable =
|
||||
let slot = fresh_slot ctx bty in
|
||||
ctx.scope <- (name, { slot; bty; assignable }) :: ctx.scope;
|
||||
slot
|
||||
|
||||
let lookup ctx name = List.assoc_opt name ctx.scope
|
||||
|
||||
let scoped ctx f =
|
||||
let saved = ctx.scope in
|
||||
let r = f () in
|
||||
ctx.scope <- saved;
|
||||
r
|
||||
|
||||
(* ── Type resolution ───────────────────────────────────────────────── *)
|
||||
|
||||
let unimplemented loc what milestone =
|
||||
fail loc "%s is not implemented yet — milestone %d (see plan.org)"
|
||||
what milestone
|
||||
|
||||
let rec resolve env ?(seen = []) (t : Ast.texpr) : Types.t =
|
||||
let loc = t.Ast.tloc in
|
||||
match t.Ast.t with
|
||||
| Ast.Tname n -> resolve_name env ~seen loc n
|
||||
| Ast.Tslice e -> Types.Slice (resolve env ~seen e)
|
||||
| Ast.Tarray (l, e) -> Types.Array (array_len env loc l, resolve env ~seen e)
|
||||
| Ast.Tmap _ -> unimplemented loc "the Map type" 6
|
||||
| Ast.Tfn (ps, r) ->
|
||||
Types.Fn (List.map (resolve env ~seen) ps, resolve env ~seen r)
|
||||
| Ast.Tapp (name, args) ->
|
||||
(match name, args with
|
||||
| "Ptr", [ a ] -> Types.Ptr (resolve env ~seen a)
|
||||
| "Option", [ a ] -> Types.Option (resolve env ~seen a)
|
||||
| ("Ptr" | "Option"), _ -> fail loc "(%s T) takes exactly one type" name
|
||||
| "Vec", _ -> unimplemented loc "(Vec T)" 6
|
||||
| "Map", _ -> unimplemented loc "(Map K V)" 6
|
||||
| "Result", _ -> unimplemented loc "(Result T E)" 6
|
||||
| "Handle", _ -> unimplemented loc "(Handle T)" 6
|
||||
| _ ->
|
||||
fail loc
|
||||
"%s takes no type arguments — generics are milestone 5" name)
|
||||
|
||||
and resolve_name env ~seen loc n =
|
||||
match Types.ikind_of_name n with
|
||||
| Some k -> Types.Int k
|
||||
| None ->
|
||||
match Types.fkind_of_name n with
|
||||
| Some k -> Types.Float k
|
||||
| None ->
|
||||
match n with
|
||||
| "bool" -> Types.Bool
|
||||
| "string" -> Types.String
|
||||
| "Unit" -> Types.Unit
|
||||
| "Never" -> Types.Never
|
||||
| _ when Hashtbl.mem env.aliases n ->
|
||||
if List.mem n seen then
|
||||
fail loc "the type alias %s is defined in terms of itself" n
|
||||
else resolve env ~seen:(n :: seen) (Hashtbl.find env.aliases n)
|
||||
| _ when Hashtbl.mem env.structs n || Hashtbl.mem env.unions n ->
|
||||
Types.Named n
|
||||
(* Lowercase is a type variable, Capitalized is concrete — no sigil
|
||||
(plan.org, Types). A variable parses, but nothing at milestone 2 can
|
||||
give a value one, so it is rejected here rather than later. *)
|
||||
| _ when n <> "" && n.[0] = Char.lowercase_ascii n.[0] ->
|
||||
unimplemented loc
|
||||
(Printf.sprintf "generic code over the type variable %s" n) 5
|
||||
| _ -> fail loc "unknown type %s" n
|
||||
|
||||
and array_len env loc = function
|
||||
| Ast.Lint n -> n
|
||||
| Ast.Lname n ->
|
||||
(match Hashtbl.find_opt env.consts n with
|
||||
| Some v -> v
|
||||
| None ->
|
||||
fail loc "%s is not a compile-time integer constant, so it cannot be \
|
||||
an array length" n)
|
||||
|
||||
(* ── Small helpers over the AST ────────────────────────────────────── *)
|
||||
|
||||
(* Untyped literals: their machine type comes from context, so when one is an
|
||||
operand of a binary operator we look at the *other* operand first. *)
|
||||
let is_literal (e : Ast.expr) =
|
||||
match e.Ast.e with Ast.Int _ | Ast.Float _ | Ast.Byte _ -> true | _ -> false
|
||||
|
||||
(* [addr] takes the address of a place, but the parser only builds places for
|
||||
[set]. Recover one from the expression it parsed instead. *)
|
||||
let place_of_expr (e : Ast.expr) : Ast.place option =
|
||||
match e.Ast.e with
|
||||
| Ast.Var s -> Some (Ast.Pvar s)
|
||||
| Ast.Field (t, f) -> Some (Ast.Pfield (t, f))
|
||||
| Ast.Call ({ Ast.e = Ast.Var "at"; _ }, t :: idx) when idx <> [] ->
|
||||
Some (Ast.Pindex (t, idx))
|
||||
| Ast.Call ({ Ast.e = Ast.Var "get"; _ }, [ m; k ]) -> Some (Ast.Pkey (m, k))
|
||||
| Ast.Call ({ Ast.e = Ast.Var "deref"; _ }, [ p ]) -> Some (Ast.Pderef p)
|
||||
| _ -> None
|
||||
|
||||
let mk loc ty e : Tast.expr = { Tast.e; ty; loc }
|
||||
|
||||
let unit_at loc = mk loc Types.Unit Tast.Unit
|
||||
|
||||
(* Every integer index into an array or slice is i32 at milestone 2. *)
|
||||
let index_ty = Types.Int Types.I32
|
||||
|
||||
let expect loc ~want (got : Tast.expr) =
|
||||
match want with
|
||||
| None -> got
|
||||
| Some w ->
|
||||
if Types.fits ~expected:w ~actual:got.Tast.ty then got
|
||||
else
|
||||
fail loc "expected %s, found %s" (Types.to_string w)
|
||||
(Types.to_string got.Tast.ty)
|
||||
|
||||
(* ── Expressions ───────────────────────────────────────────────────── *)
|
||||
|
||||
let rec check ctx ?want (e : Ast.expr) : Tast.expr =
|
||||
let loc = e.Ast.loc in
|
||||
match e.Ast.e with
|
||||
| Ast.Int n -> int_literal loc ~want n
|
||||
| Ast.Byte b -> int_literal loc ~want ~default:Types.U8 (Int64.of_int b)
|
||||
| Ast.Float x ->
|
||||
let k =
|
||||
match want with
|
||||
| Some (Types.Float k) -> k
|
||||
| Some other when other <> Types.Never ->
|
||||
fail loc "expected %s, found the float literal %g"
|
||||
(Types.to_string other) x
|
||||
| _ -> Types.F64
|
||||
in
|
||||
mk loc (Types.Float k) (Tast.Float (x, k))
|
||||
| Ast.Str s -> expect loc ~want (mk loc Types.String (Tast.Str s))
|
||||
| Ast.Kw _ ->
|
||||
unimplemented loc "a keyword at a call site (keyword->enum coercion)" 4
|
||||
| Ast.Quote _ ->
|
||||
unimplemented loc "a quoted symbol (restart names)" 6
|
||||
| Ast.Var name -> var ctx loc ~want name
|
||||
| Ast.Do body -> block ctx ?want loc body
|
||||
| Ast.Let (bs, body) -> check_let ctx ?want loc bs body
|
||||
| Ast.If (c, t, e') -> check_if ctx ?want loc c t e'
|
||||
| Ast.While (c, body) ->
|
||||
let c = check ctx ~want:Types.Bool c in
|
||||
let body = scoped ctx (fun () -> map_lr (fun b -> check ctx b) body) in
|
||||
expect loc ~want (mk loc Types.Unit (Tast.While (c, body)))
|
||||
| Ast.Return v ->
|
||||
let v =
|
||||
match v with
|
||||
| None ->
|
||||
if not (Types.equal ctx.ret Types.Unit) then
|
||||
fail loc "this function returns %s, so return needs a value"
|
||||
(Types.to_string ctx.ret);
|
||||
None
|
||||
| Some v -> Some (check ctx ~want:ctx.ret v)
|
||||
in
|
||||
mk loc Types.Never (Tast.Return v)
|
||||
| Ast.Set (p, v) ->
|
||||
let p, pty = check_place ctx loc p in
|
||||
let v = check ctx ~want:pty v in
|
||||
expect loc ~want (mk loc Types.Unit (Tast.Set (p, v)))
|
||||
| Ast.Field (target, name) ->
|
||||
let target, sname = struct_target ctx target in
|
||||
let s = Hashtbl.find ctx.env.structs sname in
|
||||
(match Tast.field_index s name with
|
||||
| None -> fail loc "%s has no field %s" sname name
|
||||
| Some i ->
|
||||
let fty = (List.nth s.Tast.fields i).Tast.fty in
|
||||
expect loc ~want (mk loc fty (Tast.Field (target, i))))
|
||||
| Ast.Struct (name, kvs) -> check_struct ctx ~want loc name kvs
|
||||
| Ast.Arr items -> check_arr ctx ~want loc items
|
||||
| Ast.Match (scrutinee, arms) -> check_match ctx ?want loc scrutinee arms
|
||||
| Ast.Call (head, args) -> check_call ctx ~want loc head args
|
||||
| Ast.Unwrap (Ast.Usome, v) ->
|
||||
(* Unwrap Some, else early-return None from the enclosing function, so the
|
||||
enclosing function must itself return an Option (plan.org). *)
|
||||
(match ctx.ret with
|
||||
| Types.Option _ ->
|
||||
let v = check ctx v in
|
||||
(match v.Tast.ty with
|
||||
| Types.Option t ->
|
||||
expect loc ~want (mk loc t (Tast.UnwrapSome v))
|
||||
| other ->
|
||||
fail loc "some takes an (Option T), found %s" (Types.to_string other))
|
||||
| other ->
|
||||
fail loc
|
||||
"some early-returns None, so the enclosing function must return an \
|
||||
Option; this one returns %s" (Types.to_string other))
|
||||
| Ast.Unwrap (Ast.Utry, _) -> unimplemented loc "try (Result)" 6
|
||||
| Ast.Fn _ -> unimplemented loc "fn values" 5
|
||||
| Ast.Dotimes _ -> unimplemented loc "dotimes" 4
|
||||
| Ast.Defer _ -> unimplemented loc "defer" 4
|
||||
|
||||
and int_literal loc ~want ?(default = Types.I32) n =
|
||||
match want with
|
||||
| Some (Types.Int k) -> mk loc (Types.Int k) (Tast.Int (in_range loc k n, k))
|
||||
(* An untyped integer constant is usable where a float is wanted, as in
|
||||
Odin. A float literal is never usable where an integer is wanted. *)
|
||||
| Some (Types.Float k) ->
|
||||
mk loc (Types.Float k) (Tast.Float (Int64.to_float n, k))
|
||||
| Some other when other <> Types.Never ->
|
||||
fail loc "expected %s, found the integer literal %Ld"
|
||||
(Types.to_string other) n
|
||||
| _ -> mk loc (Types.Int default) (Tast.Int (in_range loc default n, default))
|
||||
|
||||
(* Arithmetic wraps, but a literal that does not fit its type is a typo, not a
|
||||
wrap — 300 is never what someone meant by a u8. *)
|
||||
and in_range loc k n =
|
||||
let bits = Types.bits k in
|
||||
let ok =
|
||||
if Types.signed k then
|
||||
bits = 64
|
||||
|| (Int64.compare n (Int64.neg (Int64.shift_left 1L (bits - 1))) >= 0
|
||||
&& Int64.compare n (Int64.shift_left 1L (bits - 1)) < 0)
|
||||
else
|
||||
Int64.compare n 0L >= 0
|
||||
&& (bits = 64 || Int64.compare n (Int64.shift_left 1L bits) < 0)
|
||||
in
|
||||
if ok then n
|
||||
else fail loc "%Ld does not fit in %s" n (Types.ikind_name k)
|
||||
|
||||
and var ctx loc ~want name =
|
||||
match name with
|
||||
| "true" | "false" ->
|
||||
expect loc ~want (mk loc Types.Bool (Tast.Bool (name = "true")))
|
||||
| "None" ->
|
||||
(match want with
|
||||
| Some (Types.Option t) -> mk loc (Types.Option t) Tast.None_
|
||||
| Some other when other <> Types.Never ->
|
||||
fail loc "expected %s, found None" (Types.to_string other)
|
||||
| _ ->
|
||||
fail loc
|
||||
"nothing here says what None is an Option of — annotate the \
|
||||
function's return type or the binding")
|
||||
| _ ->
|
||||
match lookup ctx name with
|
||||
| Some b -> expect loc ~want (mk loc b.bty (Tast.Local b.slot))
|
||||
| None ->
|
||||
match Hashtbl.find_opt ctx.env.globals name with
|
||||
| Some (ty, _) -> expect loc ~want (mk loc ty (Tast.Global name))
|
||||
| None ->
|
||||
if Hashtbl.mem ctx.env.fns name then
|
||||
unimplemented loc
|
||||
(Printf.sprintf "the function value %s (a name used as a value)" name) 5
|
||||
else fail loc "unknown name %s" name
|
||||
|
||||
and block ctx ?want loc body =
|
||||
match body with
|
||||
| [] -> expect loc ~want (unit_at loc)
|
||||
| _ ->
|
||||
let rec go = function
|
||||
| [ last ] -> let l = check ctx ?want last in [ l ], l.Tast.ty
|
||||
| x :: rest -> let x = check ctx x in
|
||||
let rest, ty = go rest in x :: rest, ty
|
||||
| [] -> assert false
|
||||
in
|
||||
let body, ty = go body in
|
||||
mk loc ty (Tast.Do body)
|
||||
|
||||
and check_let ctx ?want loc bs body =
|
||||
scoped ctx (fun () ->
|
||||
let bs =
|
||||
map_lr
|
||||
(fun (b : Ast.binding) ->
|
||||
let want = Option.map (resolve ctx.env) b.Ast.bty in
|
||||
let v = check ctx ?want b.Ast.bval in
|
||||
(match v.Tast.ty with
|
||||
| Types.Unit | Types.Never ->
|
||||
fail b.Ast.bloc "%s would be bound to %s, which is not a value"
|
||||
b.Ast.bname (Types.to_string v.Tast.ty)
|
||||
| _ -> ());
|
||||
(* Locals are assignable places; parameters are not. *)
|
||||
let slot = bind ctx b.Ast.bname v.Tast.ty ~assignable:true in
|
||||
(slot, v))
|
||||
bs
|
||||
in
|
||||
let body = block ctx ?want loc body in
|
||||
mk loc body.Tast.ty (Tast.Let (bs, [ body ])))
|
||||
|
||||
and check_if ctx ?want loc c t e =
|
||||
let c = check ctx ~want:Types.Bool c in
|
||||
match e with
|
||||
| None ->
|
||||
(* A one-armed if produces Unit whatever the branch evaluates to: there is
|
||||
no value on the missing side. `when` desugars to this. *)
|
||||
let t = scoped ctx (fun () -> check ctx t) in
|
||||
expect loc ~want (mk loc Types.Unit (Tast.If (c, t, unit_at loc)))
|
||||
| Some e ->
|
||||
let t = scoped ctx (fun () -> check ctx ?want t) in
|
||||
(* With no expectation the then-branch supplies one for the else-branch,
|
||||
unless it diverges, in which case the else-branch decides. *)
|
||||
let ewant =
|
||||
match want with
|
||||
| Some _ -> want
|
||||
| None -> if t.Tast.ty = Types.Never then None else Some t.Tast.ty
|
||||
in
|
||||
let e = scoped ctx (fun () -> check ctx ?want:ewant e) in
|
||||
let ty =
|
||||
if t.Tast.ty = Types.Never then e.Tast.ty
|
||||
else if e.Tast.ty = Types.Never then t.Tast.ty
|
||||
else if Types.equal t.Tast.ty e.Tast.ty then t.Tast.ty
|
||||
else
|
||||
fail loc "the branches of this if have different types: %s and %s"
|
||||
(Types.to_string t.Tast.ty) (Types.to_string e.Tast.ty)
|
||||
in
|
||||
mk loc ty (Tast.If (c, t, e))
|
||||
|
||||
and check_struct ctx ~want loc name kvs =
|
||||
match Hashtbl.find_opt ctx.env.structs name with
|
||||
| None ->
|
||||
if Hashtbl.mem ctx.env.unions name then
|
||||
unimplemented loc "constructing a union value" 6
|
||||
else fail loc "unknown struct %s" name
|
||||
| Some s ->
|
||||
let seen = Hashtbl.create 8 in
|
||||
List.iter
|
||||
(fun (k, (v : Ast.expr)) ->
|
||||
if Hashtbl.mem seen k then
|
||||
fail v.Ast.loc "field %s is given twice" k;
|
||||
if Tast.field_index s k = None then
|
||||
fail v.Ast.loc "%s has no field %s" name k;
|
||||
Hashtbl.add seen k v)
|
||||
kvs;
|
||||
(* Omitted fields are zeroed — ZII, the same rule as a declaration with no
|
||||
initialiser (plan.org, Data model). Every field is present from here on,
|
||||
in declaration order, so no backend has to know about omission. *)
|
||||
let fields =
|
||||
map_lr
|
||||
(fun (f : Tast.field) ->
|
||||
match Hashtbl.find_opt seen f.Tast.fname with
|
||||
| Some v -> check ctx ~want:f.Tast.fty v
|
||||
| None -> mk loc f.Tast.fty (Tast.Zero f.Tast.fty))
|
||||
s.Tast.fields
|
||||
in
|
||||
expect loc ~want (mk loc (Types.Named name) (Tast.Make (name, fields)))
|
||||
|
||||
and check_arr ctx ~want loc items =
|
||||
let elem_want =
|
||||
match want with
|
||||
| Some (Types.Array (_, t)) -> Some t
|
||||
| Some (Types.Slice t) -> Some t
|
||||
| _ -> None
|
||||
in
|
||||
let items = map_lr (fun i -> check ctx ?want:elem_want i) items in
|
||||
let n = Int64.of_int (List.length items) in
|
||||
let elem =
|
||||
match elem_want, items with
|
||||
| Some t, _ -> t
|
||||
| None, first :: _ -> first.Tast.ty
|
||||
| None, [] ->
|
||||
fail loc "an empty array literal needs a type — annotate the binding"
|
||||
in
|
||||
List.iter
|
||||
(fun (i : Tast.expr) ->
|
||||
if not (Types.fits ~expected:elem ~actual:i.Tast.ty) then
|
||||
fail i.Tast.loc "this array's elements are %s, but this one is %s"
|
||||
(Types.to_string elem) (Types.to_string i.Tast.ty))
|
||||
items;
|
||||
(match want with
|
||||
| Some (Types.Array (m, _)) when not (Int64.equal m n) ->
|
||||
fail loc "expected %Ld elements, found %Ld" m n
|
||||
| _ -> ());
|
||||
(* [n T] and [T] are distinct in type and in ownership (spec-memory.md), so
|
||||
an array literal does not satisfy a slice expectation. *)
|
||||
expect loc ~want (mk loc (Types.Array (n, elem)) (Tast.Arr items))
|
||||
|
||||
and check_match ctx ?want loc scrutinee arms =
|
||||
let s = check ctx scrutinee in
|
||||
let elem =
|
||||
match s.Tast.ty with
|
||||
| Types.Option t -> t
|
||||
| other ->
|
||||
(* Union matching arrives with unions themselves, at milestone 6. *)
|
||||
fail loc "match works on an Option at milestone 2, not on %s"
|
||||
(Types.to_string other)
|
||||
in
|
||||
let want = ref want in
|
||||
let saw_some = ref false and saw_none = ref false and saw_wild = ref false in
|
||||
let arms =
|
||||
map_lr
|
||||
(fun (a : Ast.arm) ->
|
||||
let ctor, binds =
|
||||
match a.Ast.pat with
|
||||
| Ast.Pwild -> saw_wild := true; None, []
|
||||
| Ast.Pctor ("Some", [ x ]) -> saw_some := true; Some "Some", [ x ]
|
||||
| Ast.Pctor ("Some", _) ->
|
||||
fail a.Ast.aloc "the Some pattern binds exactly one name"
|
||||
| Ast.Pctor ("None", []) -> saw_none := true; Some "None", []
|
||||
| Ast.Pctor ("None", _) -> fail a.Ast.aloc "None binds no names"
|
||||
| Ast.Pctor (c, _) ->
|
||||
fail a.Ast.aloc
|
||||
"%s is not a case of Option — the cases are Some and None" c
|
||||
in
|
||||
scoped ctx (fun () ->
|
||||
let binds = List.map (fun n -> bind ctx n elem ~assignable:false) binds in
|
||||
let body = block ctx ?want:!want a.Ast.aloc a.Ast.body in
|
||||
if !want = None && body.Tast.ty <> Types.Never then
|
||||
want := Some body.Tast.ty;
|
||||
{ Tast.acase = ctor; binds; abody = [ body ] }))
|
||||
arms
|
||||
in
|
||||
if not (!saw_wild || (!saw_some && !saw_none)) then
|
||||
fail loc
|
||||
"this match is not exhaustive — Option needs both Some and None, or a \
|
||||
_ arm";
|
||||
let ty = match !want with Some t -> t | None -> Types.Never in
|
||||
mk loc ty (Tast.Match (s, arms))
|
||||
|
||||
(* ── Places ────────────────────────────────────────────────────────── *)
|
||||
|
||||
(* The target of [.field] is a struct, or one level of pointer to one. The
|
||||
auto-deref is inserted here as a real node, so no backend re-derives it. *)
|
||||
and struct_target ctx (target : Ast.expr) : Tast.expr * string =
|
||||
let t = check ctx target in
|
||||
match t.Tast.ty with
|
||||
| Types.Named n when Hashtbl.mem ctx.env.structs n -> t, n
|
||||
| Types.Ptr (Types.Named n) when Hashtbl.mem ctx.env.structs n ->
|
||||
mk t.Tast.loc (Types.Named n) (Tast.Deref t), n
|
||||
| other ->
|
||||
fail target.Ast.loc "%s is not a struct, so it has no fields"
|
||||
(Types.to_string other)
|
||||
|
||||
and check_place ctx loc (p : Ast.place) : Tast.place * Types.t =
|
||||
match p with
|
||||
| Ast.Pvar name ->
|
||||
(match lookup ctx name with
|
||||
| Some b ->
|
||||
if not b.assignable then
|
||||
fail loc
|
||||
"%s is a parameter, and parameters are not assignable places \
|
||||
(spec-memory.md) — bind a local with let" name;
|
||||
Tast.Plocal b.slot, b.bty
|
||||
| None ->
|
||||
match Hashtbl.find_opt ctx.env.globals name with
|
||||
| Some (_, true) -> fail loc "%s is a constant" name
|
||||
| Some (ty, false) -> Tast.Pglobal name, ty
|
||||
| None -> fail loc "unknown name %s" name)
|
||||
| Ast.Pfield (target, name) ->
|
||||
let target, sname = struct_target ctx target in
|
||||
let s = Hashtbl.find ctx.env.structs sname in
|
||||
(match Tast.field_index s name with
|
||||
| None -> fail loc "%s has no field %s" sname name
|
||||
| Some i -> Tast.Pfield (target, i), (List.nth s.Tast.fields i).Tast.fty)
|
||||
| Ast.Pindex (target, idx) ->
|
||||
let target = check ctx target in
|
||||
let idx, ty = indexed ctx target idx in
|
||||
Tast.Pindex (target, idx), ty
|
||||
| Ast.Pkey _ -> unimplemented loc "(get m k) as a place — Map" 6
|
||||
| Ast.Pderef target ->
|
||||
let target = check ctx target in
|
||||
(match target.Tast.ty with
|
||||
| Types.Ptr t -> Tast.Pderef target, t
|
||||
| other ->
|
||||
fail loc "deref takes a (Ptr T), found %s" (Types.to_string other))
|
||||
|
||||
(* [(at a i)] and [(at grid row col)]: one index per dimension. *)
|
||||
and indexed ctx (target : Tast.expr) (idx : Ast.expr list) =
|
||||
let rec go ty = function
|
||||
| [] -> [], ty
|
||||
| i :: rest ->
|
||||
let elem =
|
||||
match ty with
|
||||
| Types.Array (_, t) | Types.Slice t -> t
|
||||
| other ->
|
||||
fail i.Ast.loc "%s cannot be indexed" (Types.to_string other)
|
||||
in
|
||||
let i = check ctx ~want:index_ty i in
|
||||
let rest, ty = go elem rest in
|
||||
i :: rest, ty
|
||||
in
|
||||
go target.Tast.ty idx
|
||||
|
||||
(* ── Calls ─────────────────────────────────────────────────────────── *)
|
||||
|
||||
and check_call ctx ~want loc (head : Ast.expr) (args : Ast.expr list) =
|
||||
match head.Ast.e with
|
||||
| Ast.Var name -> named_call ctx ~want loc name args
|
||||
| _ ->
|
||||
unimplemented loc "calling something other than a named function" 5
|
||||
|
||||
and arity loc name n args =
|
||||
if List.length args <> n then
|
||||
fail loc "%s takes %d argument%s, given %d" name n
|
||||
(if n = 1 then "" else "s") (List.length args)
|
||||
|
||||
and named_call ctx ~want loc name args =
|
||||
let prim p ty args = expect loc ~want (mk loc ty (Tast.Prim (p, args))) in
|
||||
match name with
|
||||
(* ── arithmetic and comparison ─────────────────────────────────── *)
|
||||
| "+" | "-" | "*" | "/" | "%" ->
|
||||
let p = match name with
|
||||
| "+" -> Tast.Add | "-" -> Tast.Sub | "*" -> Tast.Mul
|
||||
| "/" -> Tast.Div | _ -> Tast.Rem
|
||||
in
|
||||
arity loc name 2 args;
|
||||
let a, b = binary ctx name loc ~want:(numeric_want want) args in
|
||||
if not (Types.is_numeric a.Tast.ty) then
|
||||
fail loc "%s takes numbers, found %s" name (Types.to_string a.Tast.ty);
|
||||
prim p a.Tast.ty [ a; b ]
|
||||
| "=" | "!=" | "<" | "<=" | ">" | ">=" ->
|
||||
let p = match name with
|
||||
| "=" -> Tast.Eq | "!=" -> Tast.Ne | "<" -> Tast.Lt
|
||||
| "<=" -> Tast.Le | ">" -> Tast.Gt | _ -> Tast.Ge
|
||||
in
|
||||
arity loc name 2 args;
|
||||
let a, b = binary ctx name loc ~want:None args in
|
||||
if not (Types.is_comparable a.Tast.ty) then
|
||||
fail loc
|
||||
"%s compares machine numbers; %s has no built-in comparison \
|
||||
(plan.org, Types)" name (Types.to_string a.Tast.ty);
|
||||
prim p Types.Bool [ a; b ]
|
||||
| "not" ->
|
||||
arity loc name 1 args;
|
||||
prim Tast.Not Types.Bool [ check ctx ~want:Types.Bool (List.hd args) ]
|
||||
|
||||
(* ── containers ────────────────────────────────────────────────── *)
|
||||
| "len" ->
|
||||
arity loc name 1 args;
|
||||
let a = check ctx (List.hd args) in
|
||||
(match a.Tast.ty with
|
||||
| Types.Array _ | Types.Slice _ | Types.String -> ()
|
||||
| other -> fail loc "len takes an array, a slice or a string, found %s"
|
||||
(Types.to_string other));
|
||||
prim Tast.Len index_ty [ a ]
|
||||
| "at" | "nth" ->
|
||||
(match args with
|
||||
| target :: idx when idx <> [] ->
|
||||
let target = check ctx target in
|
||||
let idx, ty = indexed ctx target idx in
|
||||
prim Tast.At ty (target :: idx)
|
||||
| _ -> fail loc "%s is (%s collection index ...)" name name)
|
||||
| "slice" ->
|
||||
arity loc name 3 args;
|
||||
(match args with
|
||||
| [ target; lo; hi ] ->
|
||||
let target = check ctx target in
|
||||
let elem = match target.Tast.ty with
|
||||
| Types.Array (_, t) | Types.Slice t -> t
|
||||
| other -> fail loc "slice takes an array or a slice, found %s"
|
||||
(Types.to_string other)
|
||||
in
|
||||
prim Tast.Slice (Types.Slice elem)
|
||||
(let lo = check ctx ~want:index_ty lo in
|
||||
[ target; lo; check ctx ~want:index_ty hi ])
|
||||
| _ -> assert false)
|
||||
|
||||
(* ── pointers ──────────────────────────────────────────────────── *)
|
||||
| "addr" ->
|
||||
arity loc name 1 args;
|
||||
let a = List.hd args in
|
||||
(match place_of_expr a with
|
||||
| None ->
|
||||
fail a.Ast.loc
|
||||
"addr takes the address of a place — a name, (.field x), (at a i) \
|
||||
or (deref p)"
|
||||
| Some p ->
|
||||
let p, ty = check_place ctx a.Ast.loc p in
|
||||
expect loc ~want (mk loc (Types.Ptr ty) (Tast.Addr p)))
|
||||
| "deref" ->
|
||||
arity loc name 1 args;
|
||||
let a = check ctx (List.hd args) in
|
||||
(match a.Tast.ty with
|
||||
| Types.Ptr t -> expect loc ~want (mk loc t (Tast.Deref a))
|
||||
| other -> fail loc "deref takes a (Ptr T), found %s"
|
||||
(Types.to_string other))
|
||||
|
||||
(* ── Option ────────────────────────────────────────────────────── *)
|
||||
| "Some" ->
|
||||
arity loc name 1 args;
|
||||
let inner = match want with Some (Types.Option t) -> Some t | _ -> None in
|
||||
let a = check ctx ?want:inner (List.hd args) in
|
||||
expect loc ~want (mk loc (Types.Option a.Tast.ty) (Tast.Some_ a))
|
||||
|
||||
(* ── the milestone-2 host primitives (plan.org) ────────────────── *)
|
||||
| "bytes" ->
|
||||
arity loc name 1 args;
|
||||
prim Tast.Bytes (Types.Slice (Types.Int Types.U8))
|
||||
[ check ctx ~want:Types.String (List.hd args) ]
|
||||
| "bytes->f64" ->
|
||||
arity loc name 1 args;
|
||||
prim Tast.BytesToF64 (Types.Float Types.F64) [ byte_slice ctx (List.hd args) ]
|
||||
| "bytes->i64" ->
|
||||
arity loc name 1 args;
|
||||
prim Tast.BytesToI64 (Types.Int Types.I64) [ byte_slice ctx (List.hd args) ]
|
||||
| "f64->bytes" ->
|
||||
arity loc name 1 args;
|
||||
prim Tast.F64ToBytes (Types.Slice (Types.Int Types.U8))
|
||||
[ check ctx ~want:(Types.Float Types.F64) (List.hd args) ]
|
||||
| "i64->bytes" ->
|
||||
arity loc name 1 args;
|
||||
prim Tast.I64ToBytes (Types.Slice (Types.Int Types.U8))
|
||||
[ check ctx ~want:(Types.Int Types.I64) (List.hd args) ]
|
||||
| "write-stdout" ->
|
||||
arity loc name 1 args;
|
||||
prim Tast.WriteStdout Types.Unit [ byte_slice ctx (List.hd args) ]
|
||||
| "exit" ->
|
||||
arity loc name 1 args;
|
||||
prim Tast.Exit Types.Never [ check ctx ~want:index_ty (List.hd args) ]
|
||||
| "argv" ->
|
||||
arity loc name 0 args;
|
||||
prim Tast.Argv (Types.Slice Types.String) []
|
||||
|
||||
(* ── casts: (i32 x), (f64 x) ───────────────────────────────────── *)
|
||||
| _ when is_cast name && List.length args = 1 ->
|
||||
let target = resolve_name ctx.env ~seen:[] loc name in
|
||||
let a = check ctx (List.hd args) in
|
||||
if not (Types.is_numeric a.Tast.ty) then
|
||||
fail loc "%s converts a number, found %s" name
|
||||
(Types.to_string a.Tast.ty);
|
||||
prim (Tast.Cast target) target [ a ]
|
||||
|
||||
(* ── ordinary calls ────────────────────────────────────────────── *)
|
||||
| _ ->
|
||||
match Hashtbl.find_opt ctx.env.fns name with
|
||||
| Some (params, ret) ->
|
||||
if List.length args <> List.length params then
|
||||
fail loc "%s takes %d argument%s, given %d" name
|
||||
(List.length params)
|
||||
(if List.length params = 1 then "" else "s")
|
||||
(List.length args);
|
||||
let args = map2_lr (fun p a -> check ctx ~want:p a) params args in
|
||||
expect loc ~want (mk loc ret (Tast.Call (name, args)))
|
||||
| None ->
|
||||
if Hashtbl.mem ctx.env.structs name || Hashtbl.mem ctx.env.unions name
|
||||
then
|
||||
fail loc
|
||||
"%s is a type — a struct value is written (%s {:field value ...})"
|
||||
name name
|
||||
else if String.contains name '/' then
|
||||
unimplemented loc
|
||||
(Printf.sprintf "the call %s into an imported package" name) 4
|
||||
else fail loc "unknown function %s" name
|
||||
|
||||
and is_cast name =
|
||||
Types.ikind_of_name name <> None || Types.fkind_of_name name <> None
|
||||
|
||||
and byte_slice ctx (a : Ast.expr) =
|
||||
check ctx ~want:(Types.Slice (Types.Int Types.U8)) a
|
||||
|
||||
and numeric_want want =
|
||||
match want with Some (Types.Int _ | Types.Float _) -> want | _ -> None
|
||||
|
||||
(* Both operands of a binary operator have one type, and there is no implicit
|
||||
widening, so one side has to decide it. Check the side that carries the most
|
||||
information first: a non-literal over a literal, and a float literal over an
|
||||
integer one, since an integer constant converts to a float and not back. *)
|
||||
and binary ctx name loc ~want args =
|
||||
match args with
|
||||
| [ x; y ] ->
|
||||
let y_decides =
|
||||
(is_literal x && not (is_literal y))
|
||||
|| (match x.Ast.e, y.Ast.e with
|
||||
| (Ast.Int _ | Ast.Byte _), Ast.Float _ -> true
|
||||
| _ -> false)
|
||||
in
|
||||
if y_decides then begin
|
||||
let b = check ctx ?want y in
|
||||
let a = check ctx ~want:b.Tast.ty x in
|
||||
a, b
|
||||
end else begin
|
||||
let a = check ctx ?want x in
|
||||
let b = check ctx ~want:a.Tast.ty y in
|
||||
a, b
|
||||
end
|
||||
| _ -> fail loc "%s takes two arguments" name
|
||||
|
||||
(* ── Declarations: pass 1, collect ─────────────────────────────────── *)
|
||||
|
||||
(* Constant folding, only over integers and only for defconst — enough for an
|
||||
array length like (/ screen-height cell-size). *)
|
||||
let rec const_int env (e : Ast.expr) : int64 option =
|
||||
match e.Ast.e with
|
||||
| Ast.Int n -> Some n
|
||||
| Ast.Byte b -> Some (Int64.of_int b)
|
||||
| Ast.Var n -> Hashtbl.find_opt env.consts n
|
||||
| Ast.Call ({ Ast.e = Ast.Var op; _ }, [ x; y ]) ->
|
||||
(match const_int env x, const_int env y with
|
||||
| Some a, Some b ->
|
||||
(match op with
|
||||
| "+" -> Some (Int64.add a b)
|
||||
| "-" -> Some (Int64.sub a b)
|
||||
| "*" -> Some (Int64.mul a b)
|
||||
| "/" when b <> 0L -> Some (Int64.div a b)
|
||||
| "%" when b <> 0L -> Some (Int64.rem a b)
|
||||
| _ -> None)
|
||||
| _ -> None)
|
||||
| _ -> None
|
||||
|
||||
let collect env (decls : Ast.decl list) =
|
||||
(* Names first, so a struct may mention one declared below it. *)
|
||||
List.iter
|
||||
(fun (d : Ast.decl) ->
|
||||
match d.Ast.d with
|
||||
| Ast.Defstruct (n, _) ->
|
||||
Hashtbl.replace env.locs n d.Ast.dloc;
|
||||
Hashtbl.replace env.structs n { Tast.sname = n; fields = [] }
|
||||
| Ast.Defunion (n, _) ->
|
||||
Hashtbl.replace env.locs n d.Ast.dloc;
|
||||
Hashtbl.replace env.unions n { Tast.uname = n; cases = [] }
|
||||
| Ast.Defalias (n, t) -> Hashtbl.replace env.aliases n t
|
||||
| _ -> ())
|
||||
decls;
|
||||
(* Compile-time integer constants next, to a fixpoint, because an array
|
||||
length may name a constant declared below it — top-level names in a
|
||||
package are order-independent (plan.org, Modules). *)
|
||||
let fold_consts () =
|
||||
let progress = ref false in
|
||||
List.iter
|
||||
(fun (d : Ast.decl) ->
|
||||
match d.Ast.d with
|
||||
| Ast.Defconst (n, _, v) when not (Hashtbl.mem env.consts n) ->
|
||||
(match const_int env v with
|
||||
| Some i -> Hashtbl.replace env.consts n i; progress := true
|
||||
| None -> ())
|
||||
| _ -> ())
|
||||
decls;
|
||||
!progress
|
||||
in
|
||||
while fold_consts () do () done;
|
||||
let field (f : Ast.field) : Tast.field =
|
||||
{ Tast.fname = f.Ast.fname; fty = resolve env f.Ast.fty }
|
||||
in
|
||||
(* Constants with no declared type are inferred from their value, which needs
|
||||
every other signature in hand — so they are deferred to a pass of their
|
||||
own below. *)
|
||||
let untyped = ref [] in
|
||||
List.iter
|
||||
(fun (d : Ast.decl) ->
|
||||
let loc = d.Ast.dloc in
|
||||
match d.Ast.d with
|
||||
| Ast.Package _ -> ()
|
||||
| Ast.Import (alias, _) ->
|
||||
unimplemented loc
|
||||
(Printf.sprintf "the cross-package import (import %s ...)" alias) 4
|
||||
| Ast.Defalias _ -> ()
|
||||
| Ast.Defstruct (n, fs) ->
|
||||
let names = List.map (fun (f : Ast.field) -> f.Ast.fname) fs in
|
||||
if List.length (List.sort_uniq compare names) <> List.length names then
|
||||
fail loc "%s declares the same field twice" n;
|
||||
Hashtbl.replace env.structs n
|
||||
{ Tast.sname = n; fields = List.map field fs }
|
||||
| Ast.Defunion (n, vs) ->
|
||||
Hashtbl.replace env.unions n
|
||||
{ Tast.uname = n;
|
||||
cases = List.map (fun (v : Ast.variant) ->
|
||||
{ Tast.vname = v.Ast.vname;
|
||||
vfields = List.map field v.Ast.vfields }) vs }
|
||||
| Ast.Defn fn ->
|
||||
if Hashtbl.mem env.fns fn.Ast.name then
|
||||
fail loc "%s is defined twice" fn.Ast.name;
|
||||
let params =
|
||||
List.map (fun (p : Ast.field) -> resolve env p.Ast.fty) fn.Ast.params
|
||||
in
|
||||
let ret =
|
||||
match fn.Ast.ret with None -> Types.Unit | Some t -> resolve env t
|
||||
in
|
||||
Hashtbl.replace env.fns fn.Ast.name (params, ret)
|
||||
| Ast.Defvar (n, t, _) ->
|
||||
let ty = match t with
|
||||
| Some t -> resolve env t
|
||||
| None -> fail loc "defvar %s needs a type" n
|
||||
in
|
||||
Hashtbl.replace env.globals n (ty, false)
|
||||
| Ast.Defconst (n, Some t, _) ->
|
||||
Hashtbl.replace env.globals n (resolve env t, true)
|
||||
| Ast.Defconst (n, None, v) -> untyped := (n, v) :: !untyped)
|
||||
decls;
|
||||
(* Also to a fixpoint, and for the same reason: one untyped constant may be
|
||||
defined in terms of another declared after it. A constant that still does
|
||||
not check once no progress is left has a real error, so the last round is
|
||||
run without swallowing it. *)
|
||||
let infer (_, v) =
|
||||
(check { env; ret = Types.Unit; slots = 0; slot_tys = []; scope = [] } v).Tast.ty
|
||||
in
|
||||
let pending = ref (List.rev !untyped) in
|
||||
let rec settle () =
|
||||
let left =
|
||||
List.filter
|
||||
(fun ((n, _) as c) ->
|
||||
match infer c with
|
||||
| ty -> Hashtbl.replace env.globals n (ty, true); false
|
||||
| exception Loc.Error _ -> true)
|
||||
!pending
|
||||
in
|
||||
let progressed = List.length left < List.length !pending in
|
||||
pending := left;
|
||||
if progressed && left <> [] then settle ()
|
||||
in
|
||||
settle ();
|
||||
List.iter (fun c -> ignore (infer c)) !pending
|
||||
|
||||
(* A type that contains itself by value has no finite size. [(Ptr T)] and a
|
||||
slice are indirections and break the cycle; a fixed array does not, because
|
||||
it is inline. Caught here rather than when a backend tries to lay the type
|
||||
out or a zero value is built for it — which would not fail, it would hang. *)
|
||||
let check_finite env =
|
||||
let rec walk seen name =
|
||||
if List.mem name seen then
|
||||
fail (Option.value (Hashtbl.find_opt env.locs name) ~default:Loc.unknown)
|
||||
"%s contains itself by value, so it has no size — go through (Ptr %s)"
|
||||
name name;
|
||||
let seen = name :: seen in
|
||||
match Hashtbl.find_opt env.structs name with
|
||||
| Some s -> List.iter (fun (f : Tast.field) -> ty seen f.Tast.fty) s.Tast.fields
|
||||
| None ->
|
||||
match Hashtbl.find_opt env.unions name with
|
||||
| None -> ()
|
||||
| Some u ->
|
||||
List.iter
|
||||
(fun (c : Tast.variant) ->
|
||||
List.iter (fun (f : Tast.field) -> ty seen f.Tast.fty) c.Tast.vfields)
|
||||
u.Tast.cases
|
||||
and ty seen = function
|
||||
| Types.Named n -> walk seen n
|
||||
| Types.Array (_, e) | Types.Option e -> ty seen e
|
||||
| _ -> ()
|
||||
in
|
||||
Hashtbl.iter (fun n _ -> walk [] n) env.structs;
|
||||
Hashtbl.iter (fun n _ -> walk [] n) env.unions
|
||||
|
||||
(* ── Declarations: pass 2, check bodies ────────────────────────────── *)
|
||||
|
||||
let check_fn env (fn : Ast.fn) : Tast.fn =
|
||||
let params, ret = Hashtbl.find env.fns fn.Ast.name in
|
||||
let ctx = { env; ret; slots = 0; slot_tys = []; scope = [] } in
|
||||
List.iter2
|
||||
(fun (p : Ast.field) ty ->
|
||||
if List.mem_assoc p.Ast.fname ctx.scope then
|
||||
fail p.Ast.floc "%s has two parameters named %s" fn.Ast.name p.Ast.fname;
|
||||
ignore (bind ctx p.Ast.fname ty ~assignable:false))
|
||||
fn.Ast.params params;
|
||||
let body =
|
||||
match fn.Ast.fbody with
|
||||
| [] ->
|
||||
if Types.equal ret Types.Unit then []
|
||||
else fail fn.Ast.nloc "%s returns %s but has no body" fn.Ast.name
|
||||
(Types.to_string ret)
|
||||
| body ->
|
||||
(* The last form is the return value, unless the function returns Unit,
|
||||
in which case whatever it evaluates to is discarded. *)
|
||||
let want = if Types.equal ret Types.Unit then None else Some ret in
|
||||
let rec go = function
|
||||
| [ last ] -> [ check ctx ?want last ]
|
||||
| x :: rest -> check ctx x :: go rest
|
||||
| [] -> assert false
|
||||
in
|
||||
go body
|
||||
in
|
||||
{ Tast.name = fn.Ast.name; params;
|
||||
slots = Array.of_list (List.rev ctx.slot_tys);
|
||||
ret; body; floc = fn.Ast.nloc }
|
||||
|
||||
let check_global env (d : Ast.decl) : Tast.global option =
|
||||
let ctx () = { env; ret = Types.Unit; slots = 0; slot_tys = []; scope = [] } in
|
||||
match d.Ast.d with
|
||||
| Ast.Defvar (n, _, init) ->
|
||||
let ty, _ = Hashtbl.find env.globals n in
|
||||
let ginit =
|
||||
match init with
|
||||
| Ast.Zeroed -> { Tast.e = Tast.Zero ty; ty; loc = d.Ast.dloc }
|
||||
| Ast.Uninit -> { Tast.e = Tast.Uninit ty; ty; loc = d.Ast.dloc }
|
||||
| Ast.Init v -> check (ctx ()) ~want:ty v
|
||||
in
|
||||
Some { Tast.gname = n; gty = ty; ginit; gconst = false }
|
||||
| Ast.Defconst (n, _, v) ->
|
||||
let ty, _ = Hashtbl.find env.globals n in
|
||||
Some { Tast.gname = n; gty = ty; ginit = check (ctx ()) ~want:ty v;
|
||||
gconst = true }
|
||||
| _ -> None
|
||||
|
||||
(* The entry point, plan.org: (defn main [args [string]] i32), with both the
|
||||
parameter and the return type optional. *)
|
||||
let check_main env =
|
||||
match Hashtbl.find_opt env.fns "main" with
|
||||
| None -> () (* a library, or a file being checked on its own *)
|
||||
| Some (params, ret) ->
|
||||
let ok_params =
|
||||
match params with
|
||||
| [] -> true
|
||||
| [ Types.Slice Types.String ] -> true
|
||||
| _ -> false
|
||||
in
|
||||
if not ok_params then
|
||||
fail Loc.unknown
|
||||
"main takes no parameters or one [string], not (%s)"
|
||||
(String.concat " " (List.map Types.to_string params));
|
||||
if not (Types.equal ret Types.Unit || Types.equal ret (Types.Int Types.I32))
|
||||
then
|
||||
fail Loc.unknown "main returns i32 or nothing, not %s"
|
||||
(Types.to_string ret)
|
||||
|
||||
let program (decls : Ast.decl list) : Tast.program =
|
||||
let env = new_env () in
|
||||
let decls = Parse.program (Prelude.forms ()) @ decls in
|
||||
collect env decls;
|
||||
check_finite env;
|
||||
check_main env;
|
||||
let globals = List.filter_map (check_global env) decls in
|
||||
let fns =
|
||||
List.filter_map
|
||||
(fun (d : Ast.decl) ->
|
||||
match d.Ast.d with
|
||||
| Ast.Defn fn -> Some (check_fn env fn)
|
||||
| _ -> None)
|
||||
decls
|
||||
in
|
||||
(* Sorted, so the emitted IR is reproducible build to build: a Hashtbl's
|
||||
fold order is not. *)
|
||||
let values name tbl =
|
||||
Hashtbl.fold (fun _ v acc -> v :: acc) tbl []
|
||||
|> List.sort (fun a b -> String.compare (name a) (name b))
|
||||
in
|
||||
{ Tast.structs = values (fun (s : Tast.structure) -> s.Tast.sname) env.structs;
|
||||
unions = values (fun (u : Tast.union) -> u.Tast.uname) env.unions;
|
||||
globals; fns }
|
||||
17
lib/dune
17
lib/dune
@ -1,2 +1,17 @@
|
||||
(library
|
||||
(name flan))
|
||||
(name flan)
|
||||
(libraries unix))
|
||||
|
||||
; The host shim is Flan's, not the user's, so the compiler carries it rather
|
||||
; than looking for it in an install directory. Generated from the real .c file
|
||||
; so there is only ever one copy to edit.
|
||||
(rule
|
||||
(target runtime_src.ml)
|
||||
(deps %{workspace_root}/runtime/flan_rt.c)
|
||||
(action
|
||||
(with-stdout-to
|
||||
runtime_src.ml
|
||||
(progn
|
||||
(echo "let source = {c|\n")
|
||||
(cat %{workspace_root}/runtime/flan_rt.c)
|
||||
(echo "|c}\n")))))
|
||||
|
||||
720
lib/emit.ml
Normal file
720
lib/emit.ml
Normal file
@ -0,0 +1,720 @@
|
||||
(** Typed IR → LLVM IR, as text.
|
||||
|
||||
Text rather than libLLVM bindings, for the reasons in plan.org: the build
|
||||
dependency is a clang on PATH instead of a version-pinned libLLVM with C++
|
||||
linkage, the output is readable when something is wrong, and an LLVM
|
||||
upgrade does not break the compiler. The only thing text loses is the
|
||||
in-process JIT, and that was measured at ~13ms — below perception.
|
||||
|
||||
Layout — this is the whole of it, and it is deliberately C's:
|
||||
|
||||
{v
|
||||
i8..i64 / u8..u64 i8..i64 signedness lives in the ops
|
||||
f32 f64 float double
|
||||
bool i1
|
||||
[T] and string { ptr, i64 } ptr+len, non-owning
|
||||
[n T] [n x T] inline, a value
|
||||
(Ptr T) ptr opaque pointers
|
||||
(Option T) { i8, T } tag 0 None, 1 Some
|
||||
a struct a literal struct in declaration order
|
||||
Unit and Never {} zero-sized, one value
|
||||
v}
|
||||
|
||||
No object headers anywhere, which is the consequence that drives everything
|
||||
(plan.org, Memory) — a Flan struct is exactly its C struct.
|
||||
|
||||
Two things fall out of the layout and are load-bearing:
|
||||
|
||||
- Every slot is an [alloca], so reading a local is a [load] and assigning is
|
||||
a [store]. Aggregates are SSA values in LLVM, so a [store] of a struct or
|
||||
a fixed array *is* the copy that spec-memory.md requires on assignment,
|
||||
and a slice copies its view for the same reason. [addr] of a local is then
|
||||
just the alloca. [mem2reg] removes the ones nobody took the address of.
|
||||
- A place lowers to a pointer and a value to a load from it, which is the
|
||||
split the interpreter would have had to make by hand: [(set (.pos c) ...)]
|
||||
through a [(Ptr Cursor)] becomes a [getelementptr] on the pointer, not on
|
||||
a copy of the struct. *)
|
||||
|
||||
let fail = Loc.fail
|
||||
|
||||
(* [List.map]'s evaluation order is unspecified, and so is [let ... and ...].
|
||||
Emission is all side effect — instructions, calls, branches to a [ret] — so
|
||||
left-to-right is required, not a preference. Same rule as in Check. *)
|
||||
let rec map_lr f = function
|
||||
| [] -> []
|
||||
| x :: rest -> let y = f x in y :: map_lr f rest
|
||||
|
||||
(* ── Names ─────────────────────────────────────────────────────────── *)
|
||||
|
||||
(* Flan names contain -, ?, > and /, so every emitted name is quoted. The
|
||||
[flan.] prefix keeps the Flan [main] from colliding with C's. *)
|
||||
let quoted s = "\"" ^ s ^ "\""
|
||||
let fname n = "@" ^ quoted ("flan." ^ n)
|
||||
let gname n = "@" ^ quoted ("flan." ^ n)
|
||||
let sname n = "%" ^ quoted n
|
||||
|
||||
(* ── Types ─────────────────────────────────────────────────────────── *)
|
||||
|
||||
let rec ll (t : Types.t) =
|
||||
match t with
|
||||
| Types.Int k -> "i" ^ string_of_int (Types.bits k)
|
||||
| Types.Float Types.F32 -> "float"
|
||||
| Types.Float Types.F64 -> "double"
|
||||
| Types.Bool -> "i1"
|
||||
| Types.String | Types.Slice _ -> "%slice"
|
||||
| Types.Unit | Types.Never -> "{}"
|
||||
| Types.Named n -> sname n
|
||||
| Types.Array (n, e) -> Printf.sprintf "[%Ld x %s]" n (ll e)
|
||||
| Types.Ptr _ -> "ptr"
|
||||
| Types.Option e -> Printf.sprintf "{ i8, %s }" (ll e)
|
||||
| Types.Map _ | Types.Fn _ | Types.Var _ ->
|
||||
(* The checker rejects each of these by name — nothing reaches here. *)
|
||||
failwith ("no layout for " ^ Types.to_string t)
|
||||
|
||||
let is_void (t : Types.t) = match t with Types.Unit | Types.Never -> true | _ -> false
|
||||
|
||||
(* ── Module-level state ────────────────────────────────────────────── *)
|
||||
|
||||
type m = {
|
||||
out : Buffer.t;
|
||||
strs : Buffer.t; (* string literal constants *)
|
||||
structs : (string, Tast.structure) Hashtbl.t;
|
||||
globals : (string, Types.t) Hashtbl.t;
|
||||
mutable nstr : int;
|
||||
}
|
||||
|
||||
let field_ty m sn i =
|
||||
let s = Hashtbl.find m.structs sn in
|
||||
(List.nth s.Tast.fields i).Tast.fty
|
||||
|
||||
(* ── Per-function state ────────────────────────────────────────────── *)
|
||||
|
||||
type f = {
|
||||
md : m;
|
||||
allocas : Buffer.t; (* the entry block: mem2reg only promotes these *)
|
||||
b : Buffer.t;
|
||||
mutable n : int;
|
||||
mutable live : bool; (* is the current block still open? *)
|
||||
ret : Types.t;
|
||||
slots : string array;
|
||||
slot_tys : Types.t array;
|
||||
}
|
||||
|
||||
let fresh f = f.n <- f.n + 1; Printf.sprintf "%%t%d" f.n
|
||||
let fresh_label f name = f.n <- f.n + 1; Printf.sprintf "%s%d" name f.n
|
||||
|
||||
(* Nothing may follow a terminator, so emission after one is dropped: the code
|
||||
is unreachable and LLVM would reject it. *)
|
||||
let ins f fmt =
|
||||
Printf.ksprintf (fun s -> if f.live then Buffer.add_string f.b (" " ^ s ^ "\n")) fmt
|
||||
|
||||
let term f fmt =
|
||||
Printf.ksprintf
|
||||
(fun s -> if f.live then Buffer.add_string f.b (" " ^ s ^ "\n"); f.live <- false)
|
||||
fmt
|
||||
|
||||
let label f name =
|
||||
Buffer.add_string f.b (Printf.sprintf "\n%s:\n" name);
|
||||
f.live <- true
|
||||
|
||||
let alloca f ty =
|
||||
let name = fresh f in
|
||||
Buffer.add_string f.allocas (Printf.sprintf " %s = alloca %s\n" name (ll ty));
|
||||
name
|
||||
|
||||
(* ── Constants ─────────────────────────────────────────────────────── *)
|
||||
|
||||
(* LLVM's hex form is exact, which decimal is not: a literal must mean the same
|
||||
thing after a round trip through the .ll file. *)
|
||||
let float_const (k : Types.fkind) x =
|
||||
let x = match k with Types.F32 -> Int32.float_of_bits (Int32.bits_of_float x)
|
||||
| Types.F64 -> x in
|
||||
Printf.sprintf "0x%Lx" (Int64.bits_of_float x)
|
||||
|
||||
let escape s =
|
||||
let b = Buffer.create (String.length s + 8) in
|
||||
String.iter
|
||||
(fun c ->
|
||||
if c = '"' || c = '\\' || Char.code c < 0x20 || Char.code c > 0x7e then
|
||||
Buffer.add_string b (Printf.sprintf "\\%02X" (Char.code c))
|
||||
else Buffer.add_char b c)
|
||||
s;
|
||||
Buffer.contents b
|
||||
|
||||
let string_const m s =
|
||||
let id = Printf.sprintf "@\".str.%d\"" m.nstr in
|
||||
m.nstr <- m.nstr + 1;
|
||||
Buffer.add_string m.strs
|
||||
(Printf.sprintf "%s = private unnamed_addr constant [%d x i8] c\"%s\"\n"
|
||||
id (String.length s) (escape s));
|
||||
(* The value alone: LLVM takes the type from the operand's context. *)
|
||||
Printf.sprintf "{ ptr %s, i64 %d }" id (String.length s)
|
||||
|
||||
(* ── Expressions ───────────────────────────────────────────────────── *)
|
||||
|
||||
let icmp_op signed = function
|
||||
| Tast.Eq -> "eq" | Tast.Ne -> "ne"
|
||||
| Tast.Lt -> if signed then "slt" else "ult"
|
||||
| Tast.Le -> if signed then "sle" else "ule"
|
||||
| Tast.Gt -> if signed then "sgt" else "ugt"
|
||||
| Tast.Ge -> if signed then "sge" else "uge"
|
||||
| _ -> assert false
|
||||
|
||||
let fcmp_op = function
|
||||
| Tast.Eq -> "oeq" | Tast.Ne -> "one" | Tast.Lt -> "olt"
|
||||
| Tast.Le -> "ole" | Tast.Gt -> "ogt" | Tast.Ge -> "oge"
|
||||
| _ -> assert false
|
||||
|
||||
let rec value f (e : Tast.expr) : string =
|
||||
match e.Tast.e with
|
||||
| Tast.Int (n, _) -> Int64.to_string n
|
||||
| Tast.Float (x, k) -> float_const k x
|
||||
| Tast.Bool b -> if b then "true" else "false"
|
||||
| Tast.Str s -> string_const f.md s
|
||||
| Tast.Unit | Tast.Zero _ | Tast.None_ -> "zeroinitializer"
|
||||
| Tast.Uninit _ -> "poison"
|
||||
| Tast.Local _ | Tast.Global _ | Tast.Field _ | Tast.Deref _ ->
|
||||
(* Everything that denotes a location is a load from its address. *)
|
||||
load f (addr f e) e.Tast.ty
|
||||
| Tast.Addr p -> fst (place f p)
|
||||
| Tast.Prim (p, args) -> prim f e p args
|
||||
| Tast.Call (name, args) -> call f e.Tast.ty (fname name) args
|
||||
| Tast.Do body -> block f body
|
||||
| Tast.Let (bs, body) ->
|
||||
List.iter
|
||||
(fun (slot, v) ->
|
||||
let v' = value f v in
|
||||
ins f "store %s %s, ptr %s" (ll v.Tast.ty) v' f.slots.(slot))
|
||||
bs;
|
||||
block f body
|
||||
| Tast.If (c, t, e') -> emit_if f e.Tast.ty c t e'
|
||||
| Tast.While (c, body) -> emit_while f c body; "zeroinitializer"
|
||||
| Tast.Return v ->
|
||||
(match v with
|
||||
| None -> term f "ret %s zeroinitializer" (ll f.ret)
|
||||
| Some v ->
|
||||
let v' = value f v in
|
||||
term f "ret %s %s" (ll f.ret) v');
|
||||
"zeroinitializer"
|
||||
| Tast.Set (p, v) ->
|
||||
let ptr, ty = place f p in
|
||||
let v' = value f v in
|
||||
ins f "store %s %s, ptr %s" (ll ty) v' ptr;
|
||||
"zeroinitializer"
|
||||
| Tast.Make (_, fields) -> aggregate f e.Tast.ty fields
|
||||
| Tast.Arr items -> aggregate f e.Tast.ty items
|
||||
| Tast.Some_ v ->
|
||||
let v' = value f v in
|
||||
let t = ll e.Tast.ty in
|
||||
let a = fresh f in
|
||||
ins f "%s = insertvalue %s zeroinitializer, i8 1, 0" a t;
|
||||
let b = fresh f in
|
||||
ins f "%s = insertvalue %s %s, %s %s, 1" b t a (ll v.Tast.ty) v';
|
||||
b
|
||||
| Tast.Match (s, arms) -> emit_match f e.Tast.ty s arms
|
||||
| Tast.UnwrapSome v -> emit_unwrap f e.Tast.ty v
|
||||
|
||||
and load f ptr ty =
|
||||
let t = fresh f in
|
||||
ins f "%s = load %s, ptr %s" t (ll ty) ptr;
|
||||
t
|
||||
|
||||
(* The address of an expression that denotes a location. Anything else is
|
||||
spilled to a temporary first, so [(at (f) 0)] on a returned array works. *)
|
||||
and addr f (e : Tast.expr) : string =
|
||||
match e.Tast.e with
|
||||
| Tast.Local i -> f.slots.(i)
|
||||
| Tast.Global n -> gname n
|
||||
| Tast.Deref p -> value f p
|
||||
| Tast.Field (target, i) -> field_addr f target i
|
||||
| Tast.Prim (Tast.At, target :: idx) -> fst (element_addr f target idx)
|
||||
| _ ->
|
||||
let tmp = alloca f e.Tast.ty in
|
||||
let v = value f e in
|
||||
ins f "store %s %s, ptr %s" (ll e.Tast.ty) v tmp;
|
||||
tmp
|
||||
|
||||
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
|
||||
| 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;
|
||||
p
|
||||
|
||||
(* One index per dimension, so [(at grid row col)] is two geps. Indices are
|
||||
i32 in Flan and i64 in a gep. *)
|
||||
and element_addr f (target : Tast.expr) idx =
|
||||
let rec go ptr ty = function
|
||||
| [] -> ptr, ty
|
||||
| (i : Tast.expr) :: rest ->
|
||||
let iv = value f i in
|
||||
let i64 = fresh f in
|
||||
ins f "%s = sext %s %s to i64" i64 (ll i.Tast.ty) iv;
|
||||
(match ty with
|
||||
| Types.Array (_, elem) ->
|
||||
let p = fresh f in
|
||||
ins f "%s = getelementptr inbounds %s, ptr %s, i64 0, i64 %s"
|
||||
p (ll ty) ptr i64;
|
||||
go p elem rest
|
||||
| Types.Slice elem ->
|
||||
(* A slice is ptr+len, so step through the pointer it holds. *)
|
||||
let s = load f ptr ty in
|
||||
let base = fresh f in
|
||||
ins f "%s = extractvalue %%slice %s, 0" base s;
|
||||
let p = fresh f in
|
||||
ins f "%s = getelementptr inbounds %s, ptr %s, i64 %s" p (ll elem) base i64;
|
||||
go p elem rest
|
||||
| t -> failwith ("index into " ^ Types.to_string t))
|
||||
in
|
||||
go (addr f target) target.Tast.ty idx
|
||||
|
||||
and place f (p : Tast.place) : string * Types.t =
|
||||
match p with
|
||||
| Tast.Plocal i -> f.slots.(i), f.slot_tys.(i)
|
||||
| Tast.Pglobal n -> gname n, Hashtbl.find f.md.globals n
|
||||
| Tast.Pfield (target, i) ->
|
||||
let sn = match target.Tast.ty with
|
||||
| Types.Named n -> n | t -> failwith ("field of " ^ Types.to_string t)
|
||||
in
|
||||
field_addr f target i, field_ty f.md sn i
|
||||
| Tast.Pindex (target, idx) -> element_addr f target idx
|
||||
| Tast.Pderef target ->
|
||||
let t = match target.Tast.ty with
|
||||
| Types.Ptr t -> t | t -> failwith ("deref of " ^ Types.to_string t)
|
||||
in
|
||||
value f target, t
|
||||
| Tast.Pkey _ -> failwith "Map places are milestone 6"
|
||||
|
||||
(* A struct or fixed-array value, built field by field from zeroinitializer.
|
||||
The checker already filled the omitted fields in with Zero, so this is
|
||||
simply every field in declaration order. *)
|
||||
and aggregate f ty parts =
|
||||
let t = ll ty in
|
||||
let acc = ref "zeroinitializer" in
|
||||
List.iteri
|
||||
(fun i (p : Tast.expr) ->
|
||||
let v = value f p in
|
||||
let next = fresh f in
|
||||
ins f "%s = insertvalue %s %s, %s %s, %d" next t !acc (ll p.Tast.ty) v i;
|
||||
acc := next)
|
||||
parts;
|
||||
!acc
|
||||
|
||||
and block f body =
|
||||
match body with
|
||||
| [] -> "zeroinitializer"
|
||||
| _ ->
|
||||
let last = ref "zeroinitializer" in
|
||||
List.iter (fun e -> last := value f e) body;
|
||||
!last
|
||||
|
||||
and call f ret name args =
|
||||
let vs = map_lr (fun (a : Tast.expr) ->
|
||||
let v = value f a in Printf.sprintf "%s %s" (ll a.Tast.ty) v) args in
|
||||
let t = fresh f in
|
||||
ins f "%s = call %s %s(%s)" t (ll ret) name (String.concat ", " vs);
|
||||
t
|
||||
|
||||
and emit_if f ty c t e =
|
||||
let cv = value f c in
|
||||
let lt = fresh_label f "then" and le = fresh_label f "else"
|
||||
and ld = fresh_label f "endif" in
|
||||
let result = if is_void ty then None else Some (alloca f ty) in
|
||||
term f "br i1 %s, label %%%s, label %%%s" cv lt le;
|
||||
let arm lbl (branch : Tast.expr) =
|
||||
label f lbl;
|
||||
let v = value f branch in
|
||||
(match result with
|
||||
| Some r when f.live -> ins f "store %s %s, ptr %s" (ll ty) v r
|
||||
| _ -> ());
|
||||
let reached = f.live in
|
||||
term f "br label %%%s" ld;
|
||||
reached
|
||||
in
|
||||
let a = arm lt t in
|
||||
let b = arm le e in
|
||||
if not (a || b) then begin
|
||||
(* Both branches diverge, so there is no join: nothing follows. *)
|
||||
f.live <- false;
|
||||
"zeroinitializer"
|
||||
end else begin
|
||||
label f ld;
|
||||
match result with Some r -> load f r ty | None -> "zeroinitializer"
|
||||
end
|
||||
|
||||
and emit_while f c body =
|
||||
let lc = fresh_label f "loop" and lb = fresh_label f "body"
|
||||
and le = fresh_label f "endloop" in
|
||||
term f "br label %%%s" lc;
|
||||
label f lc;
|
||||
let cv = value f c in
|
||||
term f "br i1 %s, label %%%s, label %%%s" cv lb le;
|
||||
label f lb;
|
||||
List.iter (fun e -> ignore (value f e)) body;
|
||||
term f "br label %%%s" lc;
|
||||
label f le
|
||||
|
||||
and emit_match f ty scrut arms =
|
||||
let sv = value f scrut in
|
||||
let sty = ll scrut.Tast.ty in
|
||||
let tag = fresh f in
|
||||
ins f "%s = extractvalue %s %s, 0" tag sty sv;
|
||||
let payload_ty = match scrut.Tast.ty with
|
||||
| Types.Option t -> t | t -> failwith ("match on " ^ Types.to_string t)
|
||||
in
|
||||
let ld = fresh_label f "endmatch" in
|
||||
let result = if is_void ty then None else Some (alloca f ty) in
|
||||
let reached = ref false in
|
||||
let rec go = function
|
||||
| [] -> term f "unreachable" (* the checker proved exhaustiveness *)
|
||||
| (a : Tast.arm) :: rest ->
|
||||
let lb = fresh_label f "arm" and ln = fresh_label f "next" in
|
||||
(match a.Tast.acase with
|
||||
| None -> term f "br label %%%s" lb
|
||||
| Some c ->
|
||||
let want = if c = "Some" then 1 else 0 in
|
||||
let t = fresh f in
|
||||
ins f "%s = icmp eq i8 %s, %d" t tag want;
|
||||
term f "br i1 %s, label %%%s, label %%%s" t lb ln);
|
||||
label f lb;
|
||||
List.iter
|
||||
(fun slot ->
|
||||
let v = fresh f in
|
||||
ins f "%s = extractvalue %s %s, 1" v sty sv;
|
||||
ins f "store %s %s, ptr %s" (ll payload_ty) v f.slots.(slot))
|
||||
a.Tast.binds;
|
||||
let v = block f a.Tast.abody in
|
||||
(match result with
|
||||
| Some r when f.live -> ins f "store %s %s, ptr %s" (ll ty) v r
|
||||
| _ -> ());
|
||||
if f.live then reached := true;
|
||||
term f "br label %%%s" ld;
|
||||
if a.Tast.acase <> None then begin label f ln; go rest end
|
||||
in
|
||||
go arms;
|
||||
if not !reached then begin f.live <- false; "zeroinitializer" end
|
||||
else begin
|
||||
label f ld;
|
||||
match result with Some r -> load f r ty | None -> "zeroinitializer"
|
||||
end
|
||||
|
||||
(* (some x): unwrap Some, else return None from the enclosing function. The
|
||||
early return is explicit — a branch to a ret, not platform unwinding, so
|
||||
native and wasm32 do the same thing (plan.org, Compilation). *)
|
||||
and emit_unwrap f ty v =
|
||||
let ov = value f v in
|
||||
let oty = ll v.Tast.ty in
|
||||
let tag = fresh f in
|
||||
ins f "%s = extractvalue %s %s, 0" tag oty ov;
|
||||
let isnone = fresh f in
|
||||
ins f "%s = icmp eq i8 %s, 0" isnone tag;
|
||||
let ln = fresh_label f "none" and lc = fresh_label f "some" in
|
||||
term f "br i1 %s, label %%%s, label %%%s" isnone ln lc;
|
||||
label f ln;
|
||||
term f "ret %s zeroinitializer" (ll f.ret);
|
||||
label f lc;
|
||||
let out = fresh f in
|
||||
ins f "%s = extractvalue %s %s, 1" out oty ov;
|
||||
ignore ty;
|
||||
out
|
||||
|
||||
(* ── Primitives ────────────────────────────────────────────────────── *)
|
||||
|
||||
and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) =
|
||||
ignore e;
|
||||
match p, args with
|
||||
| (Tast.Add | Tast.Sub | Tast.Mul | Tast.Div | Tast.Rem), [ x; y ] ->
|
||||
let a = value f x in
|
||||
let b = value f y in
|
||||
let op = match x.Tast.ty, p with
|
||||
| Types.Float _, Tast.Add -> "fadd" | Types.Float _, Tast.Sub -> "fsub"
|
||||
| Types.Float _, Tast.Mul -> "fmul" | Types.Float _, Tast.Div -> "fdiv"
|
||||
| Types.Float _, _ -> "frem"
|
||||
| Types.Int _, Tast.Add -> "add" | Types.Int _, Tast.Sub -> "sub"
|
||||
| Types.Int _, Tast.Mul -> "mul"
|
||||
| Types.Int k, Tast.Div -> if Types.signed k then "sdiv" else "udiv"
|
||||
| Types.Int k, _ -> if Types.signed k then "srem" else "urem"
|
||||
| t, _ -> failwith ("arithmetic on " ^ Types.to_string t)
|
||||
in
|
||||
let t = fresh f in
|
||||
(* No nsw/nuw: arithmetic wraps (plan.org, Types). *)
|
||||
ins f "%s = %s %s %s, %s" t op (ll x.Tast.ty) a b;
|
||||
t
|
||||
| (Tast.Eq | Tast.Ne | Tast.Lt | Tast.Le | Tast.Gt | Tast.Ge), [ x; y ] ->
|
||||
let a = value f x in
|
||||
let b = value f y in
|
||||
let t = fresh f in
|
||||
(match x.Tast.ty with
|
||||
| Types.Float _ ->
|
||||
ins f "%s = fcmp %s %s %s, %s" t (fcmp_op p) (ll x.Tast.ty) a b
|
||||
| Types.Int k ->
|
||||
ins f "%s = icmp %s %s %s, %s" t (icmp_op (Types.signed k) p)
|
||||
(ll x.Tast.ty) a b
|
||||
| t' -> failwith ("comparison on " ^ Types.to_string t'));
|
||||
t
|
||||
| Tast.Not, [ x ] ->
|
||||
let a = value f x in
|
||||
let t = fresh f in
|
||||
ins f "%s = xor i1 %s, true" t a;
|
||||
t
|
||||
| Tast.Len, [ x ] ->
|
||||
(match x.Tast.ty with
|
||||
| Types.Array (n, _) -> Int64.to_string n
|
||||
| _ ->
|
||||
let v = value f x in
|
||||
let n = fresh f in
|
||||
ins f "%s = extractvalue %%slice %s, 1" n v;
|
||||
let t = fresh f in
|
||||
ins f "%s = trunc i64 %s to i32" t n;
|
||||
t)
|
||||
| Tast.At, target :: idx ->
|
||||
let p, elem = element_addr f target idx in
|
||||
load f p elem
|
||||
| Tast.Slice, [ target; lo; hi ] ->
|
||||
(* lo is evaluated once and used twice — as the offset and as part of the
|
||||
length — so it must not be emitted twice. *)
|
||||
let lov = value f lo in
|
||||
let hiv = value f hi in
|
||||
let lo64 = fresh f in
|
||||
ins f "%s = sext i32 %s to i64" lo64 lov;
|
||||
let base =
|
||||
match target.Tast.ty with
|
||||
| Types.Array (_, _) ->
|
||||
let a = addr f target in
|
||||
let p = fresh f in
|
||||
ins f "%s = getelementptr inbounds %s, ptr %s, i64 0, i64 %s"
|
||||
p (ll target.Tast.ty) a lo64;
|
||||
p
|
||||
| Types.Slice elem ->
|
||||
let v = value f target in
|
||||
let q = fresh f in
|
||||
ins f "%s = extractvalue %%slice %s, 0" q v;
|
||||
let p = fresh f in
|
||||
ins f "%s = getelementptr inbounds %s, ptr %s, i64 %s" p (ll elem) q lo64;
|
||||
p
|
||||
| Types.String ->
|
||||
let v = value f target in
|
||||
let q = fresh f in
|
||||
ins f "%s = extractvalue %%slice %s, 0" q v;
|
||||
let p = fresh f in
|
||||
ins f "%s = getelementptr inbounds i8, ptr %s, i64 %s" p q lo64;
|
||||
p
|
||||
| t -> failwith ("slice of " ^ Types.to_string t)
|
||||
in
|
||||
let d = fresh f in
|
||||
ins f "%s = sub i32 %s, %s" d hiv lov;
|
||||
let n = fresh f in
|
||||
ins f "%s = sext i32 %s to i64" n d;
|
||||
let a = fresh f in
|
||||
ins f "%s = insertvalue %%slice zeroinitializer, ptr %s, 0" a base;
|
||||
let b = fresh f in
|
||||
ins f "%s = insertvalue %%slice %s, i64 %s, 1" b a n;
|
||||
b
|
||||
(* string and [u8] have the same layout, so bytes is the identity — a view,
|
||||
no copy (plan.org, Milestone-2 primitives). *)
|
||||
| Tast.Bytes, [ x ] -> value f x
|
||||
| Tast.BytesToF64, [ x ] -> shim_in f "@flan_bytes_to_f64" "double" x
|
||||
| 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.WriteStdout, [ x ] ->
|
||||
let p, n = explode f x in
|
||||
ins f "call void @flan_write_stdout(ptr %s, i64 %s)" p n;
|
||||
"zeroinitializer"
|
||||
| Tast.Exit, [ x ] ->
|
||||
let v = value f x in
|
||||
ins f "call void @flan_exit(i32 %s)" v;
|
||||
term f "unreachable";
|
||||
"zeroinitializer"
|
||||
| Tast.Argv, [] ->
|
||||
let tmp = alloca f (Types.Slice Types.String) in
|
||||
ins f "call void @flan_argv(ptr %s)" tmp;
|
||||
load f tmp (Types.Slice Types.String)
|
||||
| Tast.Cast target, [ x ] -> cast f x target
|
||||
| _ -> failwith "malformed primitive"
|
||||
|
||||
(* A slice argument crosses to C as ptr+len, never as a struct by value. *)
|
||||
and explode f (x : Tast.expr) =
|
||||
let v = value f x in
|
||||
let p = fresh f in
|
||||
ins f "%s = extractvalue %%slice %s, 0" p v;
|
||||
let n = fresh f in
|
||||
ins f "%s = extractvalue %%slice %s, 1" n v;
|
||||
p, n
|
||||
|
||||
and shim_in f name ret x =
|
||||
let p, n = explode f x in
|
||||
let t = fresh f in
|
||||
ins f "%s = call %s %s(ptr %s, i64 %s)" t ret name p n;
|
||||
t
|
||||
|
||||
and shim_out f name (x : Tast.expr) =
|
||||
let v = value f x in
|
||||
let tmp = alloca f (Types.Slice (Types.Int Types.U8)) in
|
||||
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))
|
||||
|
||||
and cast f (x : Tast.expr) target =
|
||||
let v = value f x in
|
||||
let src = x.Tast.ty in
|
||||
if Types.equal src target then v
|
||||
else
|
||||
let op =
|
||||
match src, target with
|
||||
| Types.Int a, Types.Int b ->
|
||||
if Types.bits b < Types.bits a then "trunc"
|
||||
else if Types.bits b = Types.bits a then "bitcast"
|
||||
else if Types.signed a then "sext" else "zext"
|
||||
| Types.Int a, Types.Float _ -> if Types.signed a then "sitofp" else "uitofp"
|
||||
| Types.Float _, Types.Int b -> if Types.signed b then "fptosi" else "fptoui"
|
||||
| Types.Float a, Types.Float b ->
|
||||
if Types.bits_f b > Types.bits_f a then "fpext" else "fptrunc"
|
||||
| _ -> failwith "unsupported cast"
|
||||
in
|
||||
if op = "bitcast" then v
|
||||
else begin
|
||||
let t = fresh f in
|
||||
ins f "%s = %s %s %s to %s" t op (ll src) v (ll target);
|
||||
t
|
||||
end
|
||||
|
||||
(* ── Functions ─────────────────────────────────────────────────────── *)
|
||||
|
||||
let emit_fn m (fn : Tast.fn) =
|
||||
let n = Array.length fn.Tast.slots in
|
||||
let f = {
|
||||
md = m;
|
||||
allocas = Buffer.create 256;
|
||||
b = Buffer.create 1024;
|
||||
n = 0;
|
||||
live = true;
|
||||
ret = fn.Tast.ret;
|
||||
slots = Array.init n (fun i -> Printf.sprintf "%%s%d" i);
|
||||
slot_tys = fn.Tast.slots;
|
||||
} in
|
||||
(* Every slot is an alloca in the entry block, because [addr] may take the
|
||||
address of any of them and mem2reg only promotes entry-block allocas. *)
|
||||
Array.iteri
|
||||
(fun i ty ->
|
||||
Buffer.add_string f.allocas
|
||||
(Printf.sprintf " %s = alloca %s\n" f.slots.(i) (ll ty)))
|
||||
fn.Tast.slots;
|
||||
(* Parameters arrive as SSA values and are stored into their slots at once,
|
||||
which is also the copy a value struct gets on assignment. *)
|
||||
List.iteri
|
||||
(fun i ty ->
|
||||
Buffer.add_string f.allocas
|
||||
(Printf.sprintf " store %s %%p%d, ptr %s\n" (ll ty) i f.slots.(i)))
|
||||
fn.Tast.params;
|
||||
let last = ref "zeroinitializer" in
|
||||
List.iter (fun e -> last := value f e) fn.Tast.body;
|
||||
term f "ret %s %s" (ll fn.Tast.ret) !last;
|
||||
let params =
|
||||
List.mapi (fun i ty -> Printf.sprintf "%s %%p%d" (ll ty) i) fn.Tast.params
|
||||
in
|
||||
Buffer.add_string m.out
|
||||
(Printf.sprintf "\ndefine %s %s(%s) {\nentry:\n%s%s}\n"
|
||||
(ll fn.Tast.ret) (fname fn.Tast.name) (String.concat ", " params)
|
||||
(Buffer.contents f.allocas) (Buffer.contents f.b))
|
||||
|
||||
(* ── Globals ───────────────────────────────────────────────────────── *)
|
||||
|
||||
(* A global's initialiser is a compile-time constant: literals live in
|
||||
read-only memory and zeroed globals live in BSS and cost nothing to start
|
||||
(plan.org, Data model). There is no init-at-startup path, by design. *)
|
||||
let rec const m (e : Tast.expr) =
|
||||
match e.Tast.e with
|
||||
| Tast.Int (n, _) -> Int64.to_string n
|
||||
| Tast.Float (x, k) -> float_const k x
|
||||
| Tast.Bool b -> if b then "true" else "false"
|
||||
| Tast.Str s -> string_const m s
|
||||
| Tast.Unit | Tast.Zero _ | Tast.None_ -> "zeroinitializer"
|
||||
| Tast.Uninit _ -> "poison"
|
||||
| Tast.Make (_, parts) | Tast.Arr parts ->
|
||||
let inner =
|
||||
map_lr (fun (p : Tast.expr) ->
|
||||
Printf.sprintf "%s %s" (ll p.Tast.ty) (const m p)) parts
|
||||
in
|
||||
(match e.Tast.ty with
|
||||
| Types.Array _ -> "[" ^ String.concat ", " inner ^ "]"
|
||||
| _ -> "{ " ^ String.concat ", " inner ^ " }")
|
||||
| Tast.Some_ v ->
|
||||
Printf.sprintf "{ i8 1, %s %s }" (ll v.Tast.ty) (const m v)
|
||||
| _ ->
|
||||
fail e.Tast.loc
|
||||
"a global's value must be a compile-time constant — this one is computed"
|
||||
|
||||
let emit_global m (g : Tast.global) =
|
||||
Buffer.add_string m.out
|
||||
(Printf.sprintf "%s = %s %s %s\n" (gname g.Tast.gname)
|
||||
(if g.Tast.gconst then "constant" else "global")
|
||||
(ll g.Tast.gty) (const m g.Tast.ginit))
|
||||
|
||||
(* ── Program ───────────────────────────────────────────────────────── *)
|
||||
|
||||
let header = {|; Generated by flan. The layout is C's: no object headers anywhere,
|
||||
; so a Flan struct is exactly its C struct and nothing marshals.
|
||||
|
||||
%slice = type { ptr, i64 }
|
||||
|
||||
declare void @flan_rt_init(i32, ptr)
|
||||
declare void @flan_argv(ptr)
|
||||
declare void @flan_write_stdout(ptr, i64)
|
||||
declare void @flan_exit(i32)
|
||||
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)
|
||||
|}
|
||||
|
||||
(* C's main, adapting to whichever of the four shapes Flan's main has: argv and
|
||||
the i32 status are each optional (plan.org, Milestone-2 primitives). *)
|
||||
let emit_main m (fn : Tast.fn) =
|
||||
let b = Buffer.create 256 in
|
||||
Buffer.add_string b "\ndefine i32 @main(i32 %argc, ptr %argv) {\nentry:\n";
|
||||
Buffer.add_string b " call void @flan_rt_init(i32 %argc, ptr %argv)\n";
|
||||
let args =
|
||||
if fn.Tast.params = [] then ""
|
||||
else begin
|
||||
Buffer.add_string b " %a = alloca %slice\n";
|
||||
Buffer.add_string b " call void @flan_argv(ptr %a)\n";
|
||||
Buffer.add_string b " %args = load %slice, ptr %a\n";
|
||||
"%slice %args"
|
||||
end
|
||||
in
|
||||
Buffer.add_string b
|
||||
(Printf.sprintf " %%r = call %s %s(%s)\n" (ll fn.Tast.ret)
|
||||
(fname "main") args);
|
||||
(* Flushing matters: stdout is a FILE* and the acceptance test reads it. *)
|
||||
Buffer.add_string b " call void @flan_exit(i32 ";
|
||||
Buffer.add_string b
|
||||
(if Types.equal fn.Tast.ret (Types.Int Types.I32) then "%r" else "0");
|
||||
Buffer.add_string b ")\n unreachable\n}\n";
|
||||
Buffer.add_string m.out (Buffer.contents b)
|
||||
|
||||
let program (p : Tast.program) : string =
|
||||
let m = {
|
||||
out = Buffer.create 8192; strs = Buffer.create 512;
|
||||
structs = Hashtbl.create 16; globals = Hashtbl.create 16; nstr = 0;
|
||||
} in
|
||||
List.iter (fun (s : Tast.structure) -> Hashtbl.replace m.structs s.Tast.sname s)
|
||||
p.Tast.structs;
|
||||
List.iter (fun (g : Tast.global) -> Hashtbl.replace m.globals g.Tast.gname g.Tast.gty)
|
||||
p.Tast.globals;
|
||||
List.iter
|
||||
(fun (s : Tast.structure) ->
|
||||
Buffer.add_string m.out
|
||||
(Printf.sprintf "%s = type { %s }\n" (sname s.Tast.sname)
|
||||
(String.concat ", "
|
||||
(List.map (fun (f : Tast.field) -> ll f.Tast.fty) s.Tast.fields))))
|
||||
p.Tast.structs;
|
||||
Buffer.add_char m.out '\n';
|
||||
List.iter (emit_global m) p.Tast.globals;
|
||||
List.iter (emit_fn m) p.Tast.fns;
|
||||
(match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = "main") p.Tast.fns with
|
||||
| Some fn -> emit_main m fn
|
||||
| None -> ());
|
||||
header ^ Buffer.contents m.strs ^ "\n" ^ Buffer.contents m.out
|
||||
41
lib/prelude.ml
Normal file
41
lib/prelude.ml
Normal file
@ -0,0 +1,41 @@
|
||||
(** The milestone-2 prelude, written in Flan.
|
||||
|
||||
Printing is deliberately *not* a primitive (plan.org, Milestone-2
|
||||
primitives): [write-stdout] is the one output primitive and everything
|
||||
above it is Flan. That is what keeps a second backend cheap — a primitive
|
||||
is the only thing implemented twice.
|
||||
|
||||
It lives here as a string rather than as a file because there is no package
|
||||
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. *)
|
||||
|
||||
let source = {flan|
|
||||
(defn print-bytes [b [u8]]
|
||||
(write-stdout b))
|
||||
|
||||
(defn print-str [s string]
|
||||
(write-stdout (bytes s)))
|
||||
|
||||
(defn print-f64 [x f64]
|
||||
(write-stdout (f64->bytes x)))
|
||||
|
||||
(defn print-i64 [x i64]
|
||||
(write-stdout (i64->bytes x)))
|
||||
|
||||
(defn newline []
|
||||
(write-stdout (bytes "\n")))
|
||||
|
||||
;; Prints s and then a newline. Takes a string, not an Option or an any —
|
||||
;; there is nothing to dispatch on yet.
|
||||
(defn print-line [s string]
|
||||
(print-str s)
|
||||
(newline))
|
||||
|flan}
|
||||
|
||||
let file = "<prelude>"
|
||||
|
||||
let forms () = Reader.read_all ~file source
|
||||
105
lib/tast.ml
Normal file
105
lib/tast.ml
Normal file
@ -0,0 +1,105 @@
|
||||
(** The typed IR: what the checker produces and what every backend consumes.
|
||||
|
||||
Three backends share this — the tree-walking interpreter, dev redefinition
|
||||
and the release AOT build (plan.org, Compilation) — so everything a backend
|
||||
would otherwise have to re-derive is resolved here and nowhere else:
|
||||
|
||||
- names are gone. A local is a slot index into the frame, a global is a
|
||||
name, and a call names its callee directly. No environment lookup.
|
||||
- field access is an index, not a string, and any auto-deref the source
|
||||
relied on is an explicit [Deref] node.
|
||||
- literals have a machine type. There is no untyped 1 past this point.
|
||||
- a struct literal lists every field in declaration order, with the omitted
|
||||
ones filled in as [Zero] — ZII is settled here rather than at runtime.
|
||||
- sugar is already gone from the AST; what is left is the small set below. *)
|
||||
|
||||
type prim =
|
||||
(* arithmetic and comparison, per machine type — the operands carry their own
|
||||
kind at runtime, so one constructor covers every width *)
|
||||
| Add | Sub | Mul | Div | Rem
|
||||
| Eq | Ne | Lt | Le | Gt | Ge
|
||||
| Not
|
||||
(* containers: fixed arrays and slices only at milestone 2 *)
|
||||
| Len | At | Slice
|
||||
(* the milestone-2 host primitives, plan.org. The four conversions are
|
||||
*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
|
||||
| WriteStdout | Exit | Argv
|
||||
| Cast of Types.t
|
||||
|
||||
type expr = { e : expr_kind; ty : Types.t; loc : Loc.t }
|
||||
|
||||
and expr_kind =
|
||||
| Int of int64 * Types.ikind
|
||||
| Float of float * Types.fkind
|
||||
| Bool of bool
|
||||
| Str of string
|
||||
| Unit
|
||||
| Zero of Types.t (* ZII: all-bytes-zero of this type *)
|
||||
| Uninit of Types.t (* the explicit opt-out *)
|
||||
| Local of int (* slot index into the frame *)
|
||||
| Global of string
|
||||
| Prim of prim * expr list
|
||||
| Call of string * expr list (* direct call; no first-class fns yet *)
|
||||
| Do of expr list
|
||||
| Let of (int * expr) list * expr list
|
||||
| If of expr * expr * expr
|
||||
| While of expr * expr list
|
||||
| Return of expr option
|
||||
| Set of place * expr
|
||||
| Field of expr * int (* target is already a struct value *)
|
||||
| Addr of place
|
||||
| Deref of expr
|
||||
| Make of string * expr list (* struct literal, every field, in order *)
|
||||
| Arr of expr list (* fixed-array literal *)
|
||||
| Some_ of expr
|
||||
| None_
|
||||
| Match of expr * arm list
|
||||
(* (some x): unwrap Some, else early-return None from the enclosing function.
|
||||
An early return, not an expression that can fail — hence its own node. *)
|
||||
| UnwrapSome of expr
|
||||
|
||||
and place =
|
||||
| Plocal of int
|
||||
| Pglobal of string
|
||||
| Pfield of expr * int
|
||||
| Pindex of expr * expr list
|
||||
| Pkey of expr * expr
|
||||
| Pderef of expr
|
||||
|
||||
(* [binds] are the slots the pattern's fields are bound to, in field order. *)
|
||||
and arm = { acase : string option; binds : int list; abody : expr list }
|
||||
|
||||
type field = { fname : string; fty : Types.t }
|
||||
|
||||
type structure = { sname : string; fields : field list }
|
||||
|
||||
type variant = { vname : string; vfields : field list }
|
||||
|
||||
type union = { uname : string; cases : variant list }
|
||||
|
||||
type fn = {
|
||||
name : string;
|
||||
params : Types.t list; (* bound to slots 0 .. n-1, in order *)
|
||||
slots : Types.t array; (* the frame: one entry per slot *)
|
||||
ret : Types.t;
|
||||
body : expr list;
|
||||
floc : Loc.t;
|
||||
}
|
||||
|
||||
type global = { gname : string; gty : Types.t; ginit : expr; gconst : bool }
|
||||
|
||||
type program = {
|
||||
structs : structure list;
|
||||
unions : union list;
|
||||
globals : global list; (* in declaration order *)
|
||||
fns : fn list;
|
||||
}
|
||||
|
||||
let field_index (s : structure) name =
|
||||
let rec go i = function
|
||||
| [] -> None
|
||||
| f :: rest -> if String.equal f.fname name then Some i else go (i + 1) rest
|
||||
in
|
||||
go 0 s.fields
|
||||
106
lib/types.ml
Normal file
106
lib/types.ml
Normal file
@ -0,0 +1,106 @@
|
||||
(** Resolved types: what [Ast.texpr] means once names are looked up.
|
||||
|
||||
The AST's type expressions are surface syntax — [Tname "Ptr"] and
|
||||
[Tapp ("Option", ...)] are just names there. Here they are the real thing,
|
||||
and two types are the same type exactly when they are structurally equal.
|
||||
|
||||
Milestone 2 has no generics, so there is no unification and no substitution:
|
||||
a type variable is parsed, carried, and rejected the moment a value would
|
||||
have to have it. That rejection lives in [Check]; this module only names
|
||||
the shape. *)
|
||||
|
||||
(* Machine integer types. Signedness and width are both part of the type —
|
||||
there is no implicit widening anywhere, per plan.org. *)
|
||||
type ikind = I8 | I16 | I32 | I64 | U8 | U16 | U32 | U64
|
||||
|
||||
type fkind = F32 | F64
|
||||
|
||||
type t =
|
||||
| Int of ikind
|
||||
| Float of fkind
|
||||
| Bool
|
||||
| String
|
||||
| Unit (* the zero-sized type, not C's void *)
|
||||
| Never (* return, exit, error: no value at all *)
|
||||
| Named of string (* a struct or union declared in the file *)
|
||||
| Slice of t (* [T] ptr+len, non-owning *)
|
||||
| Array of int64 * t (* [n T] inline, a value, copies *)
|
||||
| Map of t * t (* {K V} *)
|
||||
| Ptr of t (* (Ptr T) *)
|
||||
| Option of t (* (Option T) *)
|
||||
| Fn of t list * t (* (Fn [T ...] R) *)
|
||||
| Var of string (* a type variable — milestone 5 *)
|
||||
|
||||
let signed = function
|
||||
| I8 | I16 | I32 | I64 -> true
|
||||
| U8 | U16 | U32 | U64 -> false
|
||||
|
||||
let bits = function
|
||||
| I8 | U8 -> 8 | I16 | U16 -> 16 | I32 | U32 -> 32 | I64 | U64 -> 64
|
||||
|
||||
let bits_f = function F32 -> 32 | F64 -> 64
|
||||
|
||||
let ikind_of_name = function
|
||||
| "i8" -> Some I8 | "i16" -> Some I16 | "i32" -> Some I32 | "i64" -> Some I64
|
||||
| "u8" -> Some U8 | "u16" -> Some U16 | "u32" -> Some U32 | "u64" -> Some U64
|
||||
| _ -> None
|
||||
|
||||
let fkind_of_name = function
|
||||
| "f32" -> Some F32 | "f64" -> Some F64 | _ -> None
|
||||
|
||||
let ikind_name k =
|
||||
(if signed k then "i" else "u") ^ string_of_int (bits k)
|
||||
|
||||
let fkind_name = function F32 -> "f32" | F64 -> "f64"
|
||||
|
||||
(* Structural equality is the whole story: no subtyping, no coercion between
|
||||
machine types, no variance. Written out rather than using [=] so that adding
|
||||
a case with a function or a mutable field cannot silently break it. *)
|
||||
let rec equal a b =
|
||||
match a, b with
|
||||
| Int x, Int y -> x = y
|
||||
| Float x, Float y -> x = y
|
||||
| Bool, Bool | String, String | Unit, Unit | Never, Never -> true
|
||||
| Named x, Named y -> String.equal x y
|
||||
| Slice x, Slice y -> equal x y
|
||||
| Array (n, x), Array (m, y) -> Int64.equal n m && equal x y
|
||||
| Map (k, v), Map (k', v') -> equal k k' && equal v v'
|
||||
| Ptr x, Ptr y -> equal x y
|
||||
| Option x, Option y -> equal x y
|
||||
| Fn (ps, r), Fn (ps', r') ->
|
||||
List.length ps = List.length ps'
|
||||
&& List.for_all2 equal ps ps'
|
||||
&& equal r r'
|
||||
| Var x, Var y -> String.equal x y
|
||||
| _ -> false
|
||||
|
||||
let rec to_string = function
|
||||
| Int k -> ikind_name k
|
||||
| Float k -> fkind_name k
|
||||
| Bool -> "bool"
|
||||
| String -> "string"
|
||||
| Unit -> "Unit"
|
||||
| Never -> "Never"
|
||||
| Named n -> n
|
||||
| Slice t -> "[" ^ to_string t ^ "]"
|
||||
| Array (n, t) -> Printf.sprintf "[%Ld %s]" n (to_string t)
|
||||
| Map (k, v) -> Printf.sprintf "{%s %s}" (to_string k) (to_string v)
|
||||
| Ptr t -> "(Ptr " ^ to_string t ^ ")"
|
||||
| Option t -> "(Option " ^ to_string t ^ ")"
|
||||
| Fn (ps, r) ->
|
||||
Printf.sprintf "(Fn [%s] %s)"
|
||||
(String.concat " " (List.map to_string ps)) (to_string r)
|
||||
| Var n -> n
|
||||
|
||||
let is_numeric = function Int _ | Float _ -> true | _ -> false
|
||||
|
||||
(* Ordering and equality are defined on machine types and on nothing else at
|
||||
milestone 2 — strings, structs and slices have no built-in [=], because an
|
||||
unconstrained type supports only what every type supports (plan.org, Types). *)
|
||||
let is_comparable = is_numeric
|
||||
|
||||
(* [Never] is the type of an expression that does not produce a value: return,
|
||||
an early-returning `some`, exit. It fits anywhere, and that is the only
|
||||
place anything resembling subtyping exists. *)
|
||||
let fits ~expected ~actual =
|
||||
match actual with Never -> true | _ -> equal expected actual
|
||||
86
runtime/flan_rt.c
Normal file
86
runtime/flan_rt.c
Normal file
@ -0,0 +1,86 @@
|
||||
/* flan_rt — the milestone-2 host ABI.
|
||||
*
|
||||
* This is the whole of it: argv, stdout, exit, and four text conversions
|
||||
* (plan.org, Milestone-2 primitives). Keeping the list this short is what
|
||||
* makes the wasm32 target cheap, because a primitive is the only thing
|
||||
* implemented twice.
|
||||
*
|
||||
* Every function here takes and returns scalars or an out-pointer. Nothing
|
||||
* returns a struct by value: the emitted .ll would then have to agree with the
|
||||
* platform's struct-return ABI, which is exactly the kind of thing that works
|
||||
* on x86-64 and silently does not on wasm32.
|
||||
*/
|
||||
|
||||
#include <stdint.h>
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
|
||||
/* [T] and string are both ptr+len — see Emit.ll. */
|
||||
typedef struct { const uint8_t *ptr; int64_t len; } flan_slice;
|
||||
|
||||
static int rt_argc;
|
||||
static char **rt_argv;
|
||||
static flan_slice *rt_args; /* argv as [string], built once, never freed */
|
||||
|
||||
void flan_rt_init(int32_t argc, char **argv) {
|
||||
rt_argc = (int)argc;
|
||||
rt_argv = argv;
|
||||
}
|
||||
|
||||
void flan_argv(flan_slice *out) {
|
||||
if (rt_args == NULL && rt_argc > 0) {
|
||||
rt_args = (flan_slice *)malloc(sizeof(flan_slice) * (size_t)rt_argc);
|
||||
for (int i = 0; i < rt_argc; i++) {
|
||||
rt_args[i].ptr = (const uint8_t *)rt_argv[i];
|
||||
rt_args[i].len = (int64_t)strlen(rt_argv[i]);
|
||||
}
|
||||
}
|
||||
out->ptr = (const uint8_t *)rt_args;
|
||||
out->len = (int64_t)rt_argc;
|
||||
}
|
||||
|
||||
void flan_write_stdout(const uint8_t *p, int64_t n) {
|
||||
if (n > 0) fwrite(p, 1, (size_t)n, stdout);
|
||||
}
|
||||
|
||||
void flan_exit(int32_t status) {
|
||||
fflush(stdout);
|
||||
exit((int)status);
|
||||
}
|
||||
|
||||
/* The conversions are *text*: bytes->f64 parses "12.5", f64->bytes renders it.
|
||||
* calc-me's tokenizer needs the first, the prelude's printers the second. */
|
||||
|
||||
#define SCRATCH 64
|
||||
static char scratch[SCRATCH]; /* rendered text lives here until the next call */
|
||||
|
||||
double flan_bytes_to_f64(const uint8_t *p, int64_t n) {
|
||||
char buf[512];
|
||||
size_t k = (size_t)n < sizeof buf - 1 ? (size_t)n : sizeof buf - 1;
|
||||
memcpy(buf, p, k);
|
||||
buf[k] = '\0';
|
||||
return strtod(buf, NULL);
|
||||
}
|
||||
|
||||
int64_t flan_bytes_to_i64(const uint8_t *p, int64_t n) {
|
||||
char buf[64];
|
||||
size_t k = (size_t)n < sizeof buf - 1 ? (size_t)n : sizeof buf - 1;
|
||||
memcpy(buf, p, k);
|
||||
buf[k] = '\0';
|
||||
return (int64_t)strtoll(buf, NULL, 10);
|
||||
}
|
||||
|
||||
/* %g so that 3.5 prints as "3.5" and not "3.500000" — calc-me's expected
|
||||
* output is a table of exact strings. */
|
||||
void flan_f64_to_bytes(double x, flan_slice *out) {
|
||||
int n = snprintf(scratch, SCRATCH, "%g", x);
|
||||
out->ptr = (const uint8_t *)scratch;
|
||||
out->len = n < 0 ? 0 : (int64_t)n;
|
||||
}
|
||||
|
||||
void flan_i64_to_bytes(int64_t x, flan_slice *out) {
|
||||
int n = snprintf(scratch, SCRATCH, "%lld", (long long)x);
|
||||
out->ptr = (const uint8_t *)scratch;
|
||||
out->len = n < 0 ? 0 : (int64_t)n;
|
||||
}
|
||||
11
test/dune
11
test/dune
@ -1,8 +1,9 @@
|
||||
(test
|
||||
(name test_flan)
|
||||
(tests
|
||||
(names test_flan test_acceptance)
|
||||
(libraries flan)
|
||||
; The acceptance programs are part of the test corpus: if the reader or the
|
||||
; parser regresses on them we want to know here, not at the CLI.
|
||||
; The acceptance programs are part of the test corpus: if the reader, the
|
||||
; parser or the checker regresses on them we want to know here, not at the CLI.
|
||||
(deps
|
||||
(file %{workspace_root}/calc-me.flan)
|
||||
(file %{workspace_root}/sand.flan)))
|
||||
(file %{workspace_root}/sand.flan)
|
||||
(glob_files programs/*.flan)))
|
||||
|
||||
47
test/programs/machine.flan
Normal file
47
test/programs/machine.flan
Normal file
@ -0,0 +1,47 @@
|
||||
;;;; Globals, 2-D fixed arrays, places, pointers, casts and match — the
|
||||
;;;; milestone-2 surface calc-me does not reach.
|
||||
(defconst rows 3)
|
||||
(defconst cols 4)
|
||||
(defvar grid [rows [cols i32]])
|
||||
(defvar total i32)
|
||||
(defconst pal [4 u32] [10 20 30 40])
|
||||
|
||||
(defstruct P [x i32 y i32])
|
||||
(defstruct Line [a P b P])
|
||||
|
||||
(defn bump [p (Ptr P)]
|
||||
(set (.x p) (+ (.x p) 1)))
|
||||
|
||||
(defn sum-grid [] i32
|
||||
(let [t 0 r 0]
|
||||
(while (< r rows)
|
||||
(let [c 0]
|
||||
(while (< c cols)
|
||||
(set t (+ t (at grid r c)))
|
||||
(set c (+ c 1))))
|
||||
(set r (+ r 1)))
|
||||
t))
|
||||
|
||||
(defn find [n i32] (Option i32)
|
||||
(if (> n 0) (Some (* n 2)) None))
|
||||
|
||||
(defn main [] i32
|
||||
(set (at grid 1 2) 7)
|
||||
(set (at grid 0 0) 5)
|
||||
(set total (sum-grid))
|
||||
(print-i64 (i64 total)) (newline) ; 12
|
||||
(print-i64 (i64 (at pal 2))) (newline) ; 30
|
||||
(let [p (P {:x 1 :y 2})] ; :y omitted is zeroed
|
||||
(bump (addr p))
|
||||
(print-i64 (i64 (.x p))) (newline) ; 2
|
||||
(let [l (Line {:a p})]
|
||||
(print-i64 (i64 (.y (.a l)))) (newline))) ; 2
|
||||
(print-f64 (f64 (/ 7 2))) (newline) ; 3 integer divide
|
||||
(print-f64 (/ (f64 7) 2.0)) (newline) ; 3.5 float divide
|
||||
(print-i64 (i64 (match (find 21) (Some v) v None 0))) (newline) ; 42
|
||||
(print-i64 (i64 (match (find -1) (Some v) v None 99))) (newline) ; 99
|
||||
(let [q (addr total)]
|
||||
(print-i64 (i64 (deref q))) (newline) ; 12
|
||||
(set (deref q) 123)
|
||||
(print-i64 (i64 total)) (newline)) ; 123
|
||||
0)
|
||||
4
test/programs/unit-main.flan
Normal file
4
test/programs/unit-main.flan
Normal file
@ -0,0 +1,4 @@
|
||||
;;;; The short entry point: both the parameter and the i32 status are optional,
|
||||
;;;; and an omitted return type means Unit, so the process exits 0.
|
||||
(defn main []
|
||||
(print-line "ok"))
|
||||
21
test/programs/values.flan
Normal file
21
test/programs/values.flan
Normal file
@ -0,0 +1,21 @@
|
||||
;;;; Value semantics, spec-memory.md. Not covered by calc-me, and the property
|
||||
;;;; most likely to be silently wrong in a backend: a struct or a fixed array
|
||||
;;;; copies on assignment, a slice copies only its view.
|
||||
(defstruct P [x i32])
|
||||
(defvar arr [3 i32])
|
||||
|
||||
(defn main [] i32
|
||||
(let [a (P {:x 1})]
|
||||
(let [b a] ; a copy, not an alias
|
||||
(set (.x a) 99)
|
||||
(print-i64 (i64 (.x b))) (newline))) ; 1
|
||||
|
||||
(set (at arr 0) 5)
|
||||
(let [c arr] ; fixed arrays are values too
|
||||
(set (at arr 0) 77)
|
||||
(print-i64 (i64 (at c 0))) (newline)) ; 5
|
||||
|
||||
(let [s (bytes "hello")]
|
||||
(let [v (slice s 1 3)] ; a view into the same bytes
|
||||
(print-bytes v) (newline))) ; el
|
||||
0)
|
||||
114
test/test_acceptance.ml
Normal file
114
test/test_acceptance.ml
Normal file
@ -0,0 +1,114 @@
|
||||
(* The milestone-2 acceptance test: a table of expression/result pairs run
|
||||
through a compiled calc-me (plan.org, Build sequence).
|
||||
|
||||
It is a table rather than a golden file because milestone 3 runs the *same*
|
||||
table on wasm32 — headless is what makes one test cover both targets. *)
|
||||
|
||||
open Flan
|
||||
|
||||
let failures = ref 0
|
||||
|
||||
let scratch = Filename.get_temp_dir_name ()
|
||||
|
||||
let run exe arg =
|
||||
let out = Filename.concat scratch "flan-acceptance.out" in
|
||||
let cmd =
|
||||
Printf.sprintf "%s %s > %s 2>&1"
|
||||
(Filename.quote exe)
|
||||
(match arg with None -> "" | Some a -> Filename.quote a)
|
||||
(Filename.quote out)
|
||||
in
|
||||
let code = Sys.command cmd in
|
||||
let text = In_channel.with_open_bin out In_channel.input_all in
|
||||
Sys.remove out;
|
||||
(code, text)
|
||||
|
||||
let compile ?(opt = "-O2") path =
|
||||
let exe =
|
||||
Filename.concat scratch
|
||||
("flan-t-" ^ Filename.remove_extension (Filename.basename path))
|
||||
in
|
||||
let p = Reader.read_file path |> Parse.program |> Check.program in
|
||||
ignore (Build.executable ~opts:{ Build.default with opt } p ~out:exe);
|
||||
exe
|
||||
|
||||
let () =
|
||||
match Sys.command "command -v clang > /dev/null 2>&1" with
|
||||
| 0 ->
|
||||
let exe = compile "../calc-me.flan" in
|
||||
|
||||
let case name arg expected_out expected_code =
|
||||
let code, text = run exe arg in
|
||||
if text <> expected_out || code <> expected_code then begin
|
||||
incr failures;
|
||||
Printf.printf
|
||||
"FAIL %s\n got: %S (exit %d)\n wanted: %S (exit %d)\n"
|
||||
name text code expected_out expected_code
|
||||
end
|
||||
in
|
||||
let evaluates src expected = case src (Some src) (expected ^ "\n") 0 in
|
||||
let rejects src = case src (Some src) "calc-me: cannot parse\n" 1 in
|
||||
|
||||
(* Arithmetic and precedence *)
|
||||
evaluates "1 + 2 * (3 - 0.5) / 2" "3.5";
|
||||
evaluates "1+2*3" "7";
|
||||
evaluates "2*3+4" "10";
|
||||
evaluates "(1+2)*3" "9";
|
||||
evaluates "10/4" "2.5";
|
||||
evaluates "7" "7";
|
||||
evaluates " 7 " "7";
|
||||
evaluates "1.5+2.25" "3.75";
|
||||
|
||||
(* Left-associative: 1-2-3 is (1-2)-3, not 1-(2-3) *)
|
||||
evaluates "1-2-3" "-4";
|
||||
evaluates "8/4/2" "1";
|
||||
|
||||
(* Unary minus, including nested *)
|
||||
evaluates "-5" "-5";
|
||||
evaluates "-(1+2)" "-3";
|
||||
evaluates "3 * -2" "-6";
|
||||
|
||||
(* Whole input or nothing: trailing junk is an error, not ignored *)
|
||||
rejects "1 +";
|
||||
rejects "(1+2";
|
||||
rejects "1 2";
|
||||
rejects "";
|
||||
rejects "+";
|
||||
rejects "1+2)";
|
||||
|
||||
case "no argument" None "usage: calc-me \"1 + 2 * 3\"\n" 1;
|
||||
(try Sys.remove exe with Sys_error _ -> ());
|
||||
|
||||
(* Programs whose whole output is fixed. These cover the milestone-2
|
||||
surface calc-me does not reach — globals, 2-D arrays, places through a
|
||||
pointer, casts, match with either arm taken, and the value semantics of
|
||||
spec-memory.md. *)
|
||||
let outputs ?opt name path expected =
|
||||
let exe = compile ?opt path in
|
||||
let code, text = run exe None in
|
||||
if text <> expected || code <> 0 then begin
|
||||
incr failures;
|
||||
Printf.printf
|
||||
"FAIL %s\n got: %S (exit %d)\n wanted: %S (exit 0)\n"
|
||||
name text code expected
|
||||
end;
|
||||
(try Sys.remove exe with Sys_error _ -> ())
|
||||
in
|
||||
let values_out = "1\n5\nel\n" in
|
||||
let machine_out = "12\n30\n2\n2\n3\n3.5\n42\n99\n12\n123\n" in
|
||||
outputs "value semantics" "programs/values.flan" values_out;
|
||||
outputs "machine surface" "programs/machine.flan" machine_out;
|
||||
outputs "unit main exits 0" "programs/unit-main.flan" "ok\n";
|
||||
|
||||
(* Again at -O0. Everything above runs through mem2reg, which launders a
|
||||
sloppy alloca; -O0 tests the IR actually emitted, so a disagreement
|
||||
between the two points at undefined behaviour rather than a typo. *)
|
||||
outputs ~opt:"-O0" "value semantics, -O0" "programs/values.flan" values_out;
|
||||
outputs ~opt:"-O0" "machine surface, -O0" "programs/machine.flan" machine_out;
|
||||
|
||||
if !failures = 0 then print_endline "acceptance: all tests passed"
|
||||
else begin
|
||||
Printf.printf "\n%d failure(s)\n" !failures;
|
||||
exit 1
|
||||
end
|
||||
| _ -> print_endline "acceptance: skipped (no clang on PATH)"
|
||||
@ -311,7 +311,225 @@ let () =
|
||||
check "unknown capitalised head is a body form"
|
||||
(ret_and_body "unknown" "(defn f [] (Nope 1) (bar))" = (false, 2));
|
||||
|
||||
if !failures = 0 then print_endline "ambiguity: all tests passed"
|
||||
()
|
||||
|
||||
(* ── Checker: AST → typed IR ───────────────────────────────────────── *)
|
||||
|
||||
let checked src = program src |> Check.program
|
||||
|
||||
(* The type a defconst's value infers to, as the checker prints it. Enough to
|
||||
pin down literal defaulting and every primitive's result. *)
|
||||
let infers name src expected =
|
||||
match checked (Printf.sprintf "(defconst probe %s)" src) with
|
||||
| p ->
|
||||
(match List.find_opt (fun (g : Tast.global) -> g.gname = "probe") p.globals with
|
||||
| Some g ->
|
||||
let got = Types.to_string g.gty in
|
||||
if got <> expected then begin
|
||||
incr failures;
|
||||
Printf.printf "FAIL %s\n src: %s\n got: %s\n wanted: %s\n"
|
||||
name src got expected
|
||||
end
|
||||
| None -> incr failures; Printf.printf "FAIL %s: no probe\n" name)
|
||||
| exception Loc.Error (loc, msg) ->
|
||||
incr failures;
|
||||
Printf.printf "FAIL %s\n src: %s\n error: %s: %s\n"
|
||||
name src (Loc.to_string loc) msg
|
||||
|
||||
let accepts name src =
|
||||
match checked src with
|
||||
| _ -> ()
|
||||
| exception Loc.Error (loc, msg) ->
|
||||
incr failures;
|
||||
Printf.printf "FAIL %s\n src: %s\n error: %s: %s\n"
|
||||
name src (Loc.to_string loc) msg
|
||||
|
||||
(* [needle] pins the *reason* down: a rejection for the wrong reason is not a
|
||||
passing test, and the unimplemented-feature errors are the whole point. *)
|
||||
let rejects_check name ?needle src =
|
||||
match checked src with
|
||||
| _ ->
|
||||
incr failures;
|
||||
Printf.printf "FAIL %s: expected a type error\n src: %s\n" name src
|
||||
| exception Loc.Error (_, msg) ->
|
||||
(match needle with
|
||||
| Some n
|
||||
when not
|
||||
(List.exists
|
||||
(fun i -> String.length msg - i >= String.length n
|
||||
&& String.sub msg i (String.length n) = n)
|
||||
(List.init (max 1 (String.length msg)) Fun.id)) ->
|
||||
incr failures;
|
||||
Printf.printf "FAIL %s: wrong reason\n wanted: %s\n got: %s\n"
|
||||
name n msg
|
||||
| _ -> ())
|
||||
|
||||
let () =
|
||||
(* ── Literal defaulting and inference ──────────────────────────── *)
|
||||
infers "int defaults to i32" "42" "i32";
|
||||
infers "float defaults to f64" "0.5" "f64";
|
||||
infers "byte is u8" "\\space" "u8";
|
||||
infers "string" "\"hi\"" "string";
|
||||
infers "bool" "true" "bool";
|
||||
infers "arithmetic keeps kind" "(+ 1 2)" "i32";
|
||||
infers "comparison is bool" "(< 1 2)" "bool";
|
||||
infers "cast" "(f64 3)" "f64";
|
||||
infers "array literal" "[1 2 3]" "[3 i32]";
|
||||
infers "nested array" "[[1 2] [3 4]]" "[2 [2 i32]]";
|
||||
infers "bytes of a string" "(bytes \"hi\")" "[u8]";
|
||||
infers "len is i32" "(len (bytes \"hi\"))" "i32";
|
||||
infers "slice of a slice" "(slice (bytes \"hi\") 0 1)" "[u8]";
|
||||
infers "parse text to f64" "(bytes->f64 (bytes \"1.5\"))" "f64";
|
||||
|
||||
(* An untyped integer constant is usable where a float is wanted, as in
|
||||
Odin; the reverse is not. *)
|
||||
infers "int literal into a float" "(+ 1 0.5)" "f64";
|
||||
rejects_check "float literal into an int"
|
||||
"(defn f [] i32 (+ 1 0.5))" ~needle:"expected i32";
|
||||
|
||||
(* ── Bidirectional flow ────────────────────────────────────────── *)
|
||||
accepts "return type types the literal" "(defn f [] u8 0)";
|
||||
accepts "return type types None" "(defn f [] (Option f64) None)";
|
||||
rejects_check "bare None has no type" "(defconst x None)"
|
||||
~needle:"what None is an Option of";
|
||||
accepts "param types the literal"
|
||||
"(defn g [x u8]) (defn f [] (g 3))";
|
||||
rejects_check "wrong argument type"
|
||||
"(defn g [x u8]) (defn f [] (g 0.5))" ~needle:"expected u8";
|
||||
rejects_check "wrong arity"
|
||||
"(defn g [x u8]) (defn f [] (g 1 2))" ~needle:"takes 1 argument";
|
||||
rejects_check "wrong return type"
|
||||
"(defn f [] bool 1)" ~needle:"expected bool";
|
||||
rejects_check "if branches disagree"
|
||||
"(defn f [] i32 (if true 1 true))" ~needle:"expected i32";
|
||||
|
||||
(* ── Structs, fields and auto-deref ────────────────────────────── *)
|
||||
let cursor = "(defstruct Cursor [src [u8] pos i32]) " in
|
||||
accepts "struct literal, omitted field zeroed"
|
||||
(cursor ^ "(defn f [s [u8]] Cursor (Cursor {:src s}))");
|
||||
rejects_check "unknown field"
|
||||
(cursor ^ "(defn f [s [u8]] Cursor (Cursor {:nope s}))")
|
||||
~needle:"has no field nope";
|
||||
rejects_check "field given twice"
|
||||
(cursor ^ "(defn f [s [u8]] Cursor (Cursor {:pos 0 :pos 1}))")
|
||||
~needle:"given twice";
|
||||
accepts "field through a pointer auto-derefs"
|
||||
(cursor ^ "(defn f [c (Ptr Cursor)] i32 (.pos c))");
|
||||
accepts "set through a pointer"
|
||||
(cursor ^ "(defn f [c (Ptr Cursor)] (set (.pos c) 1))");
|
||||
rejects_check "field of a non-struct"
|
||||
"(defn f [x i32] i32 (.pos x))" ~needle:"is not a struct";
|
||||
|
||||
(* ── Places ────────────────────────────────────────────────────── *)
|
||||
accepts "a local is assignable"
|
||||
"(defn f [] i32 (let [x 1] (set x 2) x))";
|
||||
rejects_check "a parameter is not assignable"
|
||||
"(defn f [x i32] (set x 2))" ~needle:"parameters are not assignable";
|
||||
rejects_check "a constant is not assignable"
|
||||
"(defconst k 1) (defn f [] (set k 2))" ~needle:"is a constant";
|
||||
accepts "addr of a local gives a pointer"
|
||||
(cursor ^ "(defn g [c (Ptr Cursor)] i32 (.pos c)) \
|
||||
(defn f [s [u8]] i32 (let [c (Cursor {:src s})] (g (addr c))))");
|
||||
rejects_check "addr of a non-place"
|
||||
"(defn f [] (addr (+ 1 2)))" ~needle:"addr takes the address of a place";
|
||||
|
||||
(* ── Option, some, match ───────────────────────────────────────── *)
|
||||
accepts "some unwraps in an Option-returning function"
|
||||
"(defn g [] (Option i32) None) (defn f [] (Option i32) (Some (some (g))))";
|
||||
rejects_check "some outside an Option-returning function"
|
||||
"(defn g [] (Option i32) None) (defn f [] i32 (some (g)))"
|
||||
~needle:"must return an Option";
|
||||
accepts "match on Option"
|
||||
"(defn g [] (Option i32) None) \
|
||||
(defn f [] i32 (match (g) (Some v) v None 0))";
|
||||
rejects_check "match must be exhaustive"
|
||||
"(defn g [] (Option i32) None) (defn f [] i32 (match (g) (Some v) v))"
|
||||
~needle:"not exhaustive";
|
||||
accepts "a wildcard arm is exhaustive"
|
||||
"(defn g [] (Option i32) None) (defn f [] i32 (match (g) (Some v) v _ 0))";
|
||||
rejects_check "match on a non-Option"
|
||||
"(defn f [x i32] i32 (match x _ 0))" ~needle:"match works on an Option";
|
||||
|
||||
(* ── Names, order-independence, entry point ────────────────────── *)
|
||||
accepts "mutually recursive, no forward declaration"
|
||||
"(defn even? [n i32] bool (if (= n 0) true (odd? (- n 1)))) \
|
||||
(defn odd? [n i32] bool (if (= n 0) false (even? (- n 1))))";
|
||||
rejects_check "unknown name" "(defn f [] i32 nope)" ~needle:"unknown name";
|
||||
rejects_check "unknown function" "(defn f [] i32 (nope 1))"
|
||||
~needle:"unknown function";
|
||||
rejects_check "defined twice" "(defn f []) (defn f [])"
|
||||
~needle:"defined twice";
|
||||
accepts "main with no parameters and no return" "(defn main [])";
|
||||
accepts "main with argv and a status" "(defn main [args [string]] i32 0)";
|
||||
rejects_check "main with a wrong parameter" "(defn main [n i32])"
|
||||
~needle:"main takes no parameters";
|
||||
rejects_check "main returning the wrong type" "(defn main [] bool true)"
|
||||
~needle:"main returns i32";
|
||||
|
||||
(* ── Unconstrained operators, and everything past milestone 2 ──── *)
|
||||
rejects_check "no built-in = on strings"
|
||||
"(defn f [] bool (= \"a\" \"b\"))" ~needle:"no built-in comparison";
|
||||
rejects_check "Vec is milestone 6" "(defn f [x (Vec i32)])"
|
||||
~needle:"milestone 6";
|
||||
rejects_check "Map is milestone 6" "(defn f [x {string i32}])"
|
||||
~needle:"milestone 6";
|
||||
rejects_check "Result is milestone 6" "(defn f [] (Result i32 i32) None)"
|
||||
~needle:"milestone 6";
|
||||
rejects_check "try is milestone 6" "(defn f [] i32 (try 1))"
|
||||
~needle:"milestone 6";
|
||||
rejects_check "dotimes is milestone 4"
|
||||
"(defn f [] (dotimes [i 3] (g)))" ~needle:"milestone 4";
|
||||
rejects_check "defer is milestone 4" "(defn f [] (defer (g)))"
|
||||
~needle:"milestone 4";
|
||||
rejects_check "imports are milestone 4" "(import rl \"vendor:raylib\")"
|
||||
~needle:"milestone 4";
|
||||
rejects_check "keywords are milestone 4"
|
||||
"(defn g [x i32]) (defn f [] (g :space))"
|
||||
~needle:"milestone 4";
|
||||
rejects_check "fn values are milestone 5" "(defn f [] (fn [x] x))"
|
||||
~needle:"milestone 5";
|
||||
rejects_check "type variables are milestone 5" "(defn f [x a])"
|
||||
~needle:"milestone 5";
|
||||
rejects_check "a function name as a value is milestone 5"
|
||||
"(defn g []) (defn f [] i32 g)" ~needle:"milestone 5";
|
||||
|
||||
rejects_check "a struct cannot contain itself by value"
|
||||
"(defstruct Node [next Node])" ~needle:"contains itself by value";
|
||||
rejects_check "nor through a fixed array"
|
||||
"(defstruct Node [kids [2 Node]])" ~needle:"contains itself by value";
|
||||
accepts "a pointer breaks the cycle"
|
||||
"(defstruct Node [next (Ptr Node)])";
|
||||
rejects_check "an integer literal must fit its type"
|
||||
"(defn f [] u8 300)" ~needle:"does not fit in u8";
|
||||
accepts "sequential let bindings"
|
||||
"(defn f [] i32 (let [a 1 b (+ a 1)] b))";
|
||||
|
||||
(* An array literal is [n T] and does not satisfy a slice expectation:
|
||||
the two are distinct in type and in ownership (spec-memory.md). *)
|
||||
rejects_check "array literal is not a slice"
|
||||
"(defn f [] [u8] [1 2 3])" ~needle:"expected [u8]";
|
||||
rejects_check "array literal is not a struct"
|
||||
"(defstruct C [pos i32]) (defn f [] C [1 2])" ~needle:"expected C";
|
||||
rejects_check "wrong element count"
|
||||
"(defvar xs [2 i32] [1 2 3])" ~needle:"expected 2 elements";
|
||||
|
||||
(* Top-level names are order-independent (plan.org, Modules) — including
|
||||
constants used as array lengths and constants defined in terms of each
|
||||
other. *)
|
||||
accepts "a constant declared after its use as a length"
|
||||
"(defvar grid [rows i32]) (defconst rows 8)";
|
||||
accepts "constants defined out of order"
|
||||
"(defconst a (+ b 1)) (defconst b 1)";
|
||||
accepts "an untyped constant from a later function"
|
||||
"(defconst k (g)) (defn g [] u8 1)";
|
||||
rejects_check "a genuinely unknown constant still reports itself"
|
||||
"(defconst a (+ nope 1))" ~needle:"unknown name nope";
|
||||
|
||||
(* ── The acceptance program checks end to end ──────────────────── *)
|
||||
accepts "calc-me.flan type checks"
|
||||
(In_channel.with_open_bin "../calc-me.flan" In_channel.input_all);
|
||||
|
||||
if !failures = 0 then print_endline "all tests passed"
|
||||
else begin
|
||||
Printf.printf "\n%d failure(s)\n" !failures;
|
||||
exit 1
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user