diff options
| -rw-r--r-- | cps.sml | 22 | ||||
| -rw-r--r-- | elab.sml | 36 | ||||
| -rw-r--r-- | linker.sml | 6 | ||||
| -rw-r--r-- | parser.sml | 55 | ||||
| -rw-r--r-- | syntax.sml | 100 |
5 files changed, 143 insertions, 76 deletions
@@ -12,6 +12,20 @@ struct ([(fnName, [v, k], toCPS expr (fn ret => Syntax.CApp (Syntax.VVar k, [ret])))], cont (Syntax.VVar fnName)) end + | Syntax.LFix (decls, body) => + Syntax.CFix + ( map + (fn (name, arg, expr) => + let val w = Gensym.new () + in + ( name + , [arg, w] + , toCPS expr (fn z => Syntax.CApp (Syntax.VVar w, [z])) + ) + end) + decls + , toCPS body cont + ) | Syntax.LApp (Syntax.LPrim primop, Syntax.LRecord args) => let val temp = Gensym.new () @@ -130,9 +144,11 @@ struct | Syntax.CSelect (i, arg, res, k) => Syntax.CSelect (i, translateValue arg, res, convertExpr varMap k) | Syntax.CApp (func, args) => - let val temp = Gensym.new () - in Syntax.CSelect (0, translateValue func, temp, - Syntax.CApp (Syntax.VVar temp, map translateValue args)) + let + val temp = Gensym.new () + val f = translateValue func + in Syntax.CSelect (0, f, temp, + Syntax.CApp (Syntax.VVar temp, f :: map translateValue args)) end | Syntax.CFix (funcs, body) => let @@ -1,31 +1,47 @@ structure Elab = struct + structure StringMap = Map(type k = string val cmp = String.compare); + fun primop (s : string) : Syntax.primop = case s of "exit" => Syntax.PExit | _ => raise Fail ("invalid op: " ^ s) - fun elaborate (p : Syntax.expr) : Syntax.lexp = + fun elab (env : int StringMap.map) (p : Syntax.expr) : Syntax.lexp = case p of - Syntax.EIdent [i] => raise Fail "only primitive operations for now, no variables" + Syntax.EIdent [i] => (case StringMap.lookup i env of + NONE => raise Fail ("unbound identifier " ^ i) + | SOME x => Syntax.LVar x) | 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.ETuple exprs => Syntax.LRecord (map (elab env) exprs) | Syntax.EList exprs => foldr (fn (x, acc) => - Syntax.LRecord [elaborate x, acc]) + Syntax.LRecord [elab env x, acc]) (Syntax.LInt 0) exprs - | Syntax.EApp (f, x) => Syntax.LApp (elaborate f, elaborate x) - | Syntax.ETyped (e, _) => elaborate e + | Syntax.EApp (f, x) => Syntax.LApp (elab env f, elab env x) + | Syntax.ETyped (e, _) => elab env 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])) - | Syntax.ELambda e => Syntax.LFn (Gensym.new (), elaborate e) + foldr + (fn (Syntax.DVal v, acc) => + Syntax.LApp (Syntax.LFn (Gensym.new (), acc), elab env v)) + (elab env body) + decls + | Syntax.ELambda (var, body) => + let + val v = Gensym.new () + val env' = + case var of + Syntax.PWild => env + | Syntax.PVar name => StringMap.insert name v env + in Syntax.LFn (v, elab env' body) + end + + fun elaborate (p : Syntax.expr) : Syntax.lexp = elab StringMap.empty p end @@ -36,9 +36,9 @@ struct else lowByte w (Word.fromInt v) fun writeOffset w i = - if 0 > i orelse i > 127 - then raise Fail ("offset out of range: " ^ Int.toString i) - else lowByte w (Word.fromInt i) + if i < 0 + then raise Fail ("negative offset: " ^ Int.toString i) + else writeInt w i structure IntMap = Map(type k = int val cmp = Int.compare); @@ -145,7 +145,7 @@ struct fun (f : 'a -> 'b) <$> (p : 'a parser) : 'b parser = bind p (const o f) - fun (p : 'a parser) <$ (x : 'b) : 'b parser = (fn _ => x) <$> p + fun (x : 'a) <$ (p : 'b parser) : 'a parser = (fn _ => x) <$> p fun try (p : 'a parser) : 'a parser = fn st => @@ -174,7 +174,7 @@ struct fun parseString (s : string) : string parser = case explode s of [] => const "" - | c1 :: cs => foldl (fn (c, p) => p >> parseChar c) (parseChar c1) cs <$ s <?> "'" ^ String.toString s ^ "'" + | c1 :: cs => s <$ foldl (fn (c, p) => p >> parseChar c) (parseChar c1) cs <?> "'" ^ String.toString s ^ "'" fun manyErr () = raise Fail "many is applied to a parser that accepts an empty string" @@ -201,7 +201,7 @@ struct val space : char parser = satisfy Char.isSpace <?> "space" - val spaces : unit parser = many space <$ () <?> "white space" + val spaces : unit parser = () <$ many space <?> "white space" fun unexpected (s : string) : 'a parser = fn st => (Empty, Result.Left (ParseError (stateLoc st, [Unexpected s]))) @@ -289,13 +289,13 @@ struct const (valOf (Int.fromString (implode digits))))) val stringInternalChar : char parser = - (parseString "\\" >> (parseChar #"a" <$ #"\a" - <|> parseChar #"b" <$ #"\b" - <|> parseChar #"t" <$ #"\t" - <|> parseChar #"n" <$ #"\n" - <|> parseChar #"v" <$ #"\v" - <|> parseChar #"f" <$ #"\f" - <|> parseChar #"r" <$ #"\r" + (parseString "\\" >> (#"\a" <$ parseChar #"a" + <|> #"\b" <$ parseChar #"b" + <|> #"\t" <$ parseChar #"t" + <|> #"\n" <$ parseChar #"n" + <|> #"\v" <$ parseChar #"v" + <|> #"\f" <$ parseChar #"f" + <|> #"\r" <$ parseChar #"r" <|> parseChar #"\"" <|> parseChar #"\\") <?> "string escape") <|> (satisfy (fn c => c <> #"\"" andalso c <> #"\\") <?> "string character") @@ -311,21 +311,24 @@ struct reserved "__builtin" >> Syntax.EBuiltin <$> stringConstant + fun between (left : 'a parser) (right : 'b parser) (p : 'c parser) : 'c parser = + left >> + bind p (fn x => + right >> + const x) + fun parseTycons (ty : Syntax.etype) : Syntax.etype parser = bind identifier (fn longtycon => parseTycons (Syntax.Tycon ([ty], longtycon))) <|> const ty - val rec parseSingleType : Syntax.etype parser = - fn st => + val rec parseSingleType : Syntax.etype parser = fn st => (Syntax.Tyvar <$> identifier - <|> (symbol "(" >> - bind (sepBy1 parseType (symbol ",")) (fn types => - symbol ")" >> - (case types of - [x] => const x - | _ => bind identifier (fn longtycon => - const (Syntax.Tycon (types, longtycon))))))) st + <|> bind (between (symbol "(") (symbol ")") (sepBy1 parseType (symbol ","))) (fn types => + case types of + [x] => const x + | _ => bind identifier (fn longtycon => + const (Syntax.Tycon (types, longtycon))))) st and parseTycon : Syntax.etype parser = fn st => bind parseSingleType parseTycons st @@ -344,6 +347,12 @@ struct const (Syntax.Tyfun (ty, ty')))) <|> const ty) st + val rec atpat : Syntax.pat parser = fn st => + (Syntax.PWild <$ reserved "_" + <|> between (symbol "(") (symbol ")") pat + <|> Syntax.PVar <$> identifier) st + and pat : Syntax.pat parser = fn st => atpat st + fun leftOp (i : int) : Syntax.expr parser = bind getUserState (fn UserState (_, opTable) => let val (leftOps, _) = Vector.sub (opTable, i) @@ -430,7 +439,13 @@ struct <|> const e1) 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 fnExpr : Syntax.expr parser = fn st => + ((reserved "fn" >> + bind pat (fn p => + reserved "=>" >> + bind expr (fn e => + const (Syntax.ELambda (p, e))))) + <|> 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 @@ -1,55 +1,69 @@ structure Syntax = struct (* SML syntax *) - datatype etype = Tyvar of string - | Tycon of etype list * string - | TyTuple of etype list - | Tyfun of etype * etype + datatype etype = + Tyvar of string + | Tycon of etype list * string + | TyTuple of etype list + | Tyfun of etype * etype - datatype expr = EIdent of string list - | EBuiltin of string - | EInt of int - | EStr of string - | ETuple of expr list - | EList of expr list - | EApp of expr * expr - | ETyped of expr * etype - | EAndAlso of expr * expr - | EOrElse of expr * expr - | ELet of dec list * expr - | ELambda of expr + datatype pat = + PWild + | PVar of string + + datatype expr = + EIdent of string list + | EBuiltin of string + | EInt of int + | EStr of string + | ETuple of expr list + | EList of expr list + | EApp of expr * expr + | ETyped of expr * etype + | EAndAlso of expr * expr + | EOrElse of expr * expr + | ELet of dec list * expr + | ELambda of pat * expr and dec = DVal of expr (* Lambda language *) type var = int + datatype primop = PExit - 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 + + datatype lexp = + LVar of var + | LFn of var * lexp + | LFix of (var * var * lexp) list * lexp + | LApp of lexp * lexp + | LInt of int + | LString of string + | LRecord of lexp list + | LPrim of primop (* CPS *) - datatype value = VVar of var - | VLabel of var - | VInt of int - | VString of string - datatype cexp = CRecord of (value * int list) list * var * cexp - | CSelect of int * value * var * cexp - | CApp of value * value list - | CFix of (var * var list * cexp) list * cexp - | CPrimop of primop * value list * var list * cexp list + datatype value = + VVar of var + | VLabel of var + | VInt of int + | VString of string - datatype opcode = OAlloc of var * value - | OCall - | OPoke of int * var * value - | OPeek of var * int * value - | OShuf of var * value - | OExit of value - | OLabel of var + datatype cexp = + CRecord of (value * int list) list * var * cexp + | CSelect of int * value * var * cexp + | CApp of value * value list + | CFix of (var * var list * cexp) list * cexp + | CPrimop of primop * value list * var list * cexp list + + datatype opcode = + OAlloc of var * value + | OCall + | OPoke of int * var * value + | OPeek of var * int * value + | OShuf of var * value + | OExit of value + | OLabel of var fun listToString (show : 'a -> string) (l : 'a list) = "[" ^ String.concatWith ", " (map show l) ^ "]" @@ -72,6 +86,11 @@ struct | TyTuple args => "TyTuple " ^ listToString etypeToString args | Tyfun (a, b) => "Tyfun (" ^ etypeToString a ^ ", " ^ etypeToString b ^ ")" + fun patToString (p : pat) : string = + case p of + PWild => "PWild" + | PVar v => "PVar " ^ quote v + fun exprToStringI (indent : string) (x : expr) : string = let val self = exprToStringI indent in case x of @@ -86,7 +105,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 + | ELambda (pat, e) => "ELambda (" ^ patToString pat ^ ", " ^ exprToStringI indent e ^ ")" end and decToStringI (indent : string) (x : dec) : string = @@ -105,6 +124,7 @@ struct case x of LVar v => "LVar " ^ Int.toString v | LFn (arg, expr) => "LFun (" ^ Int.toString arg ^ ", " ^ lexpToString expr ^ ")" + | LFix (decls, body) => "LFix (" ^ listToString (fn (arg, var, expr) => "(" ^ Int.toString arg ^ ", " ^ Int.toString var ^ ", " ^ lexpToString expr ^ ")") decls ^ ", " ^ lexpToString body ^ ")" | LApp (a, b) => "LApp (" ^ lexpToString a ^ ", " ^ lexpToString b ^ ")" | LInt i => "LInt " ^ Int.toString i | LString s => "LString " ^ quote s |