summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--bytecode/.encoding.c.swpbin0 -> 12288 bytes
-rw-r--r--bytecode/slice.c25
-rw-r--r--bytecode/value.c4
-rw-r--r--codegen.sml13
-rw-r--r--compiler.sml17
-rw-r--r--cps.sml18
-rw-r--r--elab.sml15
-rw-r--r--format.sml7
-rw-r--r--linker.sml10
-rw-r--r--main.sml3
-rw-r--r--opts.sml4
-rw-r--r--parser.sml5
-rw-r--r--syntax.sml12
-rw-r--r--tests/lambda1
-rw-r--r--tests/simple1
15 files changed, 77 insertions, 58 deletions
diff --git a/bytecode/.encoding.c.swp b/bytecode/.encoding.c.swp
new file mode 100644
index 0000000..fc8e88a
--- /dev/null
+++ b/bytecode/.encoding.c.swp
Binary files differ
diff --git a/bytecode/slice.c b/bytecode/slice.c
deleted file mode 100644
index 0739a4a..0000000
--- a/bytecode/slice.c
+++ /dev/null
@@ -1,25 +0,0 @@
-#include <assert.h>
-
-#include "slice.h"
-
-struct slice slice(struct slice a, size_t i, size_t j)
-{
- assert(i <= a.size && j <= a.size && i <= j);
- return (struct slice) { .size = j - i, .buf = a.buf + i };
-}
-
-struct slice slice1(struct slice a, size_t i)
-{
- return slice(a, i, a.size);
-}
-
-struct val_slice val_slice(struct val_slice a, size_t i, size_t j)
-{
- assert(i <= a.size && j <= a.size && i <= j);
- return (struct val_slice) { .size = j - i, .buf = a.buf + i };
-}
-
-struct val_slice val_slice1(struct val_slice a, size_t i)
-{
- return val_slice(a, i, a.size);
-}
diff --git a/bytecode/value.c b/bytecode/value.c
index 2a15b44..1b18a96 100644
--- a/bytecode/value.c
+++ b/bytecode/value.c
@@ -13,7 +13,7 @@ bool is_int(value v)
int64_t to_int(value v)
{
if (!is_int(v)) {
- panicf("value %lx is not an int!\n", v);
+ panicf("value 0x%lx is not an int!\n", v);
}
return (int64_t) v >> 1;
}
@@ -31,7 +31,7 @@ bool is_pointer(value v)
value *to_pointer(value v)
{
if (!is_pointer(v)) {
- panicf("value %lx is not a pointer!\n", v);
+ panicf("value 0x%lx is not a pointer!\n", v);
}
return (value *) v;
}
diff --git a/codegen.sml b/codegen.sml
index 1f6a2a8..84f3ad5 100644
--- a/codegen.sml
+++ b/codegen.sml
@@ -107,7 +107,10 @@ struct
fun toASM (expr : Syntax.cexp) : Syntax.opcode list =
let
val varMap = buildVarMap expr
- fun translate v = valOf (VarMap.lookup v varMap)
+ fun translate v =
+ case VarMap.lookup v varMap of
+ NONE => raise Fail ("unable to translate var " ^ Int.toString v)
+ | SOME x => x
fun translateVal (Syntax.VVar v) = Syntax.VVar (translate v)
| translateVal x = x
fun go expr =
@@ -126,12 +129,12 @@ struct
in rev (Syntax.OPoke (i, translate res, temp) :: ops)
end)
(enumerate args))
- @ toASM k
- | Syntax.CSelect (i, arg, res, k) => Syntax.OPeek (translate res, i, translateVal arg) :: toASM k
- | Syntax.CApp (func, args) => shuffle (func :: args) @ [Syntax.OCall]
+ @ go k
+ | Syntax.CSelect (i, arg, res, k) => Syntax.OPeek (translate res, i, translateVal arg) :: go k
+ | Syntax.CApp (func, args) => shuffle (map translateVal (func :: args)) @ [Syntax.OCall]
| Syntax.CFix (funcs, body) =>
let
- val bodyASM = toASM body
+ val bodyASM = go body
val funcsASM =
foldl
(fn ((name, _, body), acc) =>
diff --git a/compiler.sml b/compiler.sml
index 599d85a..4c5e238 100644
--- a/compiler.sml
+++ b/compiler.sml
@@ -2,25 +2,28 @@ structure Compiler =
struct
fun compile (prog : Syntax.expr) : Word8Vector.vector =
let
+ val _ = print ("ast:\n" ^ Syntax.exprToString prog ^ "\n")
val elab = Elab.elaborate prog
+ val _ = print ("lambda lang:\n" ^ Syntax.lexpToString elab ^ "\n")
val cps =
- CPS.convertClosures
- (CPS.toCPS elab
- (fn _ => Syntax.CPrimop (Syntax.PExit, [Syntax.VInt 0], [], [])))
- val _ = print ("cps:\n" ^ Syntax.cexpToString cps ^ "\n")
- val asm = CodeGen.toASM cps
+ CPS.toCPS elab
+ (fn _ => Syntax.CPrimop (Syntax.PExit, [Syntax.VInt 0], [], []))
+ val _ = print ("cps1:\n" ^ Syntax.cexpToString cps ^ "\n")
+ val cps' = CPS.convertClosures cps
+ val _ = print ("cps:\n" ^ Syntax.cexpToString cps' ^ "\n")
+ val asm = CodeGen.toASM cps'
val _ = print ("bytecode:\n" ^ String.concatWith "\n" (map Syntax.opcodeToString asm) ^ "\n")
in
Linker.link asm
end
- fun main () =
+ fun main (args : string list) : unit =
let
val opts = { o = ref "a.out" }
val flags =
[ ("o", Opts.StringOpt (fn arg => #o opts := arg)) ]
val filename =
- case Opts.getOpt flags of
+ case Opts.getOpt flags args of
[arg] => arg
| _ => raise Fail "usage: sml [-o <outfile>] <filename>"
val ast =
diff --git a/cps.sml b/cps.sml
index 948b8c8..6854545 100644
--- a/cps.sml
+++ b/cps.sml
@@ -2,7 +2,17 @@ structure CPS =
struct
fun toCPS (e : Syntax.lexp) (cont : Syntax.value -> Syntax.cexp) : Syntax.cexp =
case e of
- Syntax.LApp (Syntax.LPrim primop, Syntax.LRecord args) =>
+ Syntax.LVar v => cont (Syntax.VVar v)
+ | Syntax.LFn (v, expr) =>
+ let
+ val fnName = Gensym.new ()
+ val k = Gensym.new ()
+ in
+ Syntax.CFix
+ ([(fnName, [v, k], toCPS expr (fn ret => Syntax.CApp (Syntax.VVar k, [ret])))],
+ cont (Syntax.VVar fnName))
+ end
+ | Syntax.LApp (Syntax.LPrim primop, Syntax.LRecord args) =>
let
val temp = Gensym.new ()
fun go [] acc = Syntax.CPrimop (primop, rev acc, [temp], [cont (Syntax.VVar temp)])
@@ -45,8 +55,8 @@ struct
fun exprs (Syntax.CRecord (args, res, k)) = Syntax.CRecord (args, res, exprs k)
| exprs (Syntax.CSelect (i, arg, res, k)) = Syntax.CSelect (i, arg, res, exprs k)
- | exprs (expr as Syntax.CApp (func, args)) = expr
- | exprs (Syntax.CFix (_, body)) = body
+ | exprs (expr as Syntax.CApp _) = expr
+ | exprs (Syntax.CFix (_, body)) = exprs body
| exprs (Syntax.CPrimop (p, args, res, ks)) = Syntax.CPrimop (p, args, res, (map exprs ks))
val entryPoint = Gensym.new ()
in
@@ -148,7 +158,7 @@ struct
let val funcFreeVars = freeVarsClosure old
in Syntax.CRecord ((Syntax.VLabel newName, []) :: map (fn v => (Syntax.VVar v, [])) funcFreeVars, oldName, acc)
end)
- body
+ (convertExpr varMap body)
(ListPair.zip (funcs, convertedFuncs))
in
Syntax.CFix (convertedFuncs, newBody)
diff --git a/elab.sml b/elab.sml
index 0838f38..6a80715 100644
--- a/elab.sml
+++ b/elab.sml
@@ -7,16 +7,25 @@ struct
fun elaborate (p : Syntax.expr) : Syntax.lexp =
case p of
- Syntax.EBuiltin builtin => Syntax.LPrim (primop builtin)
- | Syntax.EIdent [i] => raise Fail "only primitive operations for now, no variables"
+ Syntax.EIdent [i] => raise Fail "only primitive operations for now, no variables"
+ | Syntax.EIdent _ => raise Fail "long identifiers are not supported"
+ | Syntax.EBuiltin builtin => Syntax.LPrim (primop builtin)
| Syntax.EInt i => Syntax.LInt i
| Syntax.EStr s => Syntax.LString s
| Syntax.ETuple exprs => Syntax.LRecord (map elaborate exprs)
+ | Syntax.EList exprs =>
+ foldr
+ (fn (x, acc) =>
+ Syntax.LRecord [elaborate x, acc])
+ (Syntax.LInt 0)
+ exprs
| Syntax.EApp (f, x) => Syntax.LApp (elaborate f, elaborate x)
| Syntax.ETyped (e, _) => elaborate e
+ | Syntax.EAndAlso (_, _) => raise Fail "unimplemented"
+ | Syntax.EOrElse (_, _) => raise Fail "unimplemented"
| Syntax.ELet (decls, body) =>
Syntax.LRecord
(map elaborate
(map (fn (Syntax.DVal e) => e) decls @ [body]))
- | _ => raise Fail "elaborate: operation not supported"
+ | Syntax.ELambda e => Syntax.LFn (Gensym.new (), elaborate e)
end
diff --git a/format.sml b/format.sml
new file mode 100644
index 0000000..98e8230
--- /dev/null
+++ b/format.sml
@@ -0,0 +1,7 @@
+structure Format =
+struct
+ fun listToString (show : 'a -> string) (l : 'a list) =
+ "[" ^ String.concatWith ", " (map show l) ^ "]"
+
+ fun pairToString showA showB (a, b) = "(" ^ showA a ^ ", " ^ showB b ^ ")"
+end
diff --git a/linker.sml b/linker.sml
index 874e145..6694d89 100644
--- a/linker.sml
+++ b/linker.sml
@@ -31,14 +31,14 @@ struct
end
fun writeVar w v =
- if v > 7
+ if v > CodeGen.tempReg
then raise Fail ("var out of range: " ^ Int.toString v)
else lowByte w (Word.fromInt v)
fun writeOffset w i =
- if ~128 > i orelse i > 127
+ if 0 > i orelse i > 127
then raise Fail ("offset out of range: " ^ Int.toString i)
- else lowByte w
+ else lowByte w (Word.fromInt i)
structure IntMap = Map(type k = int val cmp = Int.compare);
@@ -58,13 +58,13 @@ struct
makeOpcode w 2 false false
| Syntax.OPoke (off, p, v) =>
(makeOpcode w 3 (isConst v) false ;
- writeInt w off ;
+ writeOffset w off ;
writeVar w p ;
writeValue w v)
| Syntax.OPeek (r, off, v) =>
(makeOpcode w 4 (isConst v) false ;
writeVar w r ;
- writeInt w off ;
+ writeOffset w off ;
writeValue w v)
| Syntax.OShuf (r, v) =>
(makeOpcode w 5 (isConst v) false ;
diff --git a/main.sml b/main.sml
index 10e6937..4b22f65 100644
--- a/main.sml
+++ b/main.sml
@@ -1,3 +1,4 @@
+use "format.sml";
use "result.sml";
use "buffer.sml";
use "gensym.sml";
@@ -12,5 +13,5 @@ use "opts.sml";
use "parser.sml";
use "compiler.sml";
-val _ = Compiler.main ()
+val _ = Compiler.main (CommandLine.arguments ())
val _ = OS.Process.exit OS.Process.success
diff --git a/opts.sml b/opts.sml
index ea5b935..f5be8c4 100644
--- a/opts.sml
+++ b/opts.sml
@@ -25,7 +25,7 @@ struct
| "False" => false
| _ => error "invalid boolean value"
- fun getOpt (desc : (string * 'a optDesc) list) : string list =
+ fun getOpt (desc : (string * 'a optDesc) list) (args : string list) : string list =
let
val parsers = StringMap.fromList desc
fun go [] = []
@@ -76,6 +76,6 @@ struct
go args)
end
in
- go (CommandLine.arguments ())
+ go args
end
end
diff --git a/parser.sml b/parser.sml
index cfc6563..7d4d9c2 100644
--- a/parser.sml
+++ b/parser.sml
@@ -428,7 +428,10 @@ struct
bind orelseExpr (fn e2 =>
const (Syntax.EOrElse (e1, e2))))
<|> const e1) st
- and expr : Syntax.expr parser = fn st => typedExp st
+ and handleExpr : Syntax.expr parser = fn st => orelseExpr st
+ and raiseExpr : Syntax.expr parser = fn st => handleExpr st
+ and fnExpr : Syntax.expr parser = fn st => ((reserved "fn" >> reserved "_" >> reserved "=>" >> Syntax.ELambda <$> expr) <|> raiseExpr) st
+ and expr : Syntax.expr parser = fn st => fnExpr st
and dec : Syntax.dec parser = fn st => (reserved "val" >> reserved "_" >> reserved "=" >> Syntax.DVal <$> expr) st
val program : Syntax.expr parser = (fn decs => Syntax.ELet (decs, Syntax.EInt 0)) <$> many dec
diff --git a/syntax.sml b/syntax.sml
index 5ed5954..95487d7 100644
--- a/syntax.sml
+++ b/syntax.sml
@@ -17,19 +17,22 @@ struct
| EAndAlso of expr * expr
| EOrElse of expr * expr
| ELet of dec list * expr
+ | ELambda of expr
and dec = DVal of expr
(* Lambda language *)
+ type var = int
datatype primop = PExit
- datatype lexp = LApp of lexp * lexp
+ datatype lexp = LVar of var
+ | LFn of var * lexp
+ | LApp of lexp * lexp
| LInt of int
| LString of string
| LRecord of lexp list
| LPrim of primop
(* CPS *)
- type var = int
datatype value = VVar of var
| VLabel of var
| VInt of int
@@ -83,6 +86,7 @@ struct
| EAndAlso (a, b) => "EAndAlso (" ^ self a ^ ", " ^ self b ^ ")"
| EOrElse (a, b) => "EOrElse (" ^ self a ^ ", " ^ self b ^ ")"
| ELet (decs, e) => "ELet (" ^ multilineListToString decToStringI indent decs ^ ", " ^ self e ^ ")"
+ | ELambda e => "ELambda " ^ exprToStringI indent e
end
and decToStringI (indent : string) (x : dec) : string =
@@ -99,7 +103,9 @@ struct
fun lexpToString (x : lexp) : string =
case x of
- LApp (a, b) => "LApp (" ^ lexpToString a ^ ", " ^ lexpToString b ^ ")"
+ LVar v => "LVar " ^ Int.toString v
+ | LFn (arg, expr) => "LFun (" ^ Int.toString arg ^ ", " ^ lexpToString expr ^ ")"
+ | LApp (a, b) => "LApp (" ^ lexpToString a ^ ", " ^ lexpToString b ^ ")"
| LInt i => "LInt " ^ Int.toString i
| LString s => "LString " ^ quote s
| LRecord l => "LRecord " ^ listToString lexpToString l
diff --git a/tests/lambda b/tests/lambda
new file mode 100644
index 0000000..45a6137
--- /dev/null
+++ b/tests/lambda
@@ -0,0 +1 @@
+val _ = (fn _ => __builtin "exit" 5) ()
diff --git a/tests/simple b/tests/simple
new file mode 100644
index 0000000..d757a7f
--- /dev/null
+++ b/tests/simple
@@ -0,0 +1 @@
+val _ = __builtin "exit" 5
generated by cgit v1.3.1 (git 2.54.0) at 2026-09-04 05:44:27 +0000