diff options
| -rw-r--r-- | compiler.sml | 37 | ||||
| -rw-r--r-- | linker.sml | 38 | ||||
| -rw-r--r-- | main.sml | 23 | ||||
| -rw-r--r-- | opts.sml | 81 | ||||
| -rw-r--r-- | parser.sml | 74 | ||||
| -rw-r--r-- | program.cm | 6 | ||||
| -rw-r--r-- | result.sml (renamed from either.sml) | 2 | ||||
| -rw-r--r-- | syntax.sml | 10 |
8 files changed, 209 insertions, 62 deletions
diff --git a/compiler.sml b/compiler.sml new file mode 100644 index 0000000..599d85a --- /dev/null +++ b/compiler.sml @@ -0,0 +1,37 @@ +structure Compiler = +struct + fun compile (prog : Syntax.expr) : Word8Vector.vector = + let + val elab = Elab.elaborate prog + 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 + val _ = print ("bytecode:\n" ^ String.concatWith "\n" (map Syntax.opcodeToString asm) ^ "\n") + in + Linker.link asm + end + + fun main () = + let + val opts = { o = ref "a.out" } + val flags = + [ ("o", Opts.StringOpt (fn arg => #o opts := arg)) ] + val filename = + case Opts.getOpt flags of + [arg] => arg + | _ => raise Fail "usage: sml [-o <outfile>] <filename>" + val ast = + case Parser.parse filename of + Result.Left e => + (print e ; + OS.Process.exit OS.Process.failure) + | Result.Right x => x + val bytecode = compile ast + val outFile = BinIO.openOut (!(#o opts)) + in + BinIO.output (outFile, bytecode) + end +end @@ -18,23 +18,33 @@ struct BinIO.output1 (w, Word8.fromInt (Word.toInt (Word.andb (n, Word.fromInt 0xff)))) fun writeInt w i = - let - val n = Word.fromInt i - fun go b = - if b < 8 - then - (lowByte w (Word.>> (n, Word.fromInt (8 * b))) ; - go (b + 1)) - else () + let val n = Word.fromInt i in - go 0 + (lowByte w (Word.orb (Word.<< (n, Word.fromInt 1), Word.fromInt 0x1)) ; + lowByte w (Word.>> (n, Word.fromInt 7)) ; + lowByte w (Word.>> (n, Word.fromInt 15)) ; + lowByte w (Word.>> (n, Word.fromInt 23)) ; + lowByte w (Word.>> (n, Word.fromInt 31)) ; + lowByte w (Word.>> (n, Word.fromInt 39)) ; + lowByte w (Word.>> (n, Word.fromInt 47)) ; + lowByte w (Word.>> (n, Word.fromInt 55))) end + fun writeVar w v = + if v > 7 + 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 + then raise Fail ("offset out of range: " ^ Int.toString i) + else lowByte w + structure IntMap = Map(type k = int val cmp = Int.compare); fun encode (m : int IntMap.map) (w : BinIO.outstream) (oper : Syntax.opcode) : unit = let - fun writeValue w (Syntax.VVar v) = writeInt w v + fun writeValue w (Syntax.VVar v) = writeVar w v | writeValue w (Syntax.VLabel l) = writeInt w (getOpt (IntMap.lookup l m, 0)) | writeValue w (Syntax.VInt i) = writeInt w i | writeValue w (Syntax.VString _) = raise Fail "I don't support strings yet" @@ -42,23 +52,23 @@ struct case oper of Syntax.OAlloc (r, v) => (makeOpcode w 1 (isConst v) false ; - writeInt w r ; + writeVar w r ; writeValue w v) | Syntax.OCall => makeOpcode w 2 false false | Syntax.OPoke (off, p, v) => (makeOpcode w 3 (isConst v) false ; writeInt w off ; - writeInt w p ; + writeVar w p ; writeValue w v) | Syntax.OPeek (r, off, v) => (makeOpcode w 4 (isConst v) false ; - writeInt w r ; + writeVar w r ; writeInt w off ; writeValue w v) | Syntax.OShuf (r, v) => (makeOpcode w 5 (isConst v) false ; - writeInt w r ; + writeVar w r ; writeValue w v) | Syntax.OExit v => (makeOpcode w 6 (isConst v) false ; @@ -1,9 +1,16 @@ -fun parseFiles (filenames : string list) : (string, Syntax.dec list) Either.either = - let fun go [] acc = Either.Right (concat (rev acc)) - | go (f :: fs) acc = - case Parser.parse f - Either.Right prog => go fs (prog :: acc) - err => err - in go [] filenames +use "result.sml"; +use "buffer.sml"; +use "gensym.sml"; +use "map.sml"; +use "syntax.sml"; +use "codegen.sml"; +use "cps.sml"; +use "elab.sml"; +use "gensym.sml"; +use "linker.sml"; +use "opts.sml"; +use "parser.sml"; +use "compiler.sml"; -val _ = parseFiles (CommandLine.arguments ()) +val _ = Compiler.main () +val _ = OS.Process.exit OS.Process.success diff --git a/opts.sml b/opts.sml new file mode 100644 index 0000000..ea5b935 --- /dev/null +++ b/opts.sml @@ -0,0 +1,81 @@ +structure Opts = +struct + datatype 'a optDesc = BoolOpt of bool -> unit + | StringOpt of string -> unit + + structure StringMap = Map(type k = string val cmp = String.compare) + + fun error (msg : string) : 'a = + (print msg ; + OS.Process.exit (OS.Process.failure)) + + fun boolFromString s = + case s of + "1" => true + | "t" => true + | "T" => true + | "true" => true + | "TRUE" => true + | "True" => true + | "0" => false + | "f" => false + | "F" => false + | "false" => false + | "FALSE" => false + | "False" => false + | _ => error "invalid boolean value" + + fun getOpt (desc : (string * 'a optDesc) list) : string list = + let + val parsers = StringMap.fromList desc + fun go [] = [] + | go (arg :: args) = + if arg = "-" orelse not (String.isPrefix "-" arg) + then arg :: args + else if arg = "--" + then args + else + let + val name = + if String.isPrefix "--" arg + then String.extract (arg, 2, NONE) + else String.extract (arg, 1, NONE) + val _ = + if String.isPrefix "-" name orelse String.isPrefix "=" name + then error "bad flag syntax" + else () + (* It's a flag. Does it have an argument? *) + val (name', value) = + case CharVector.findi (fn (_, x) => x = #"=") name of + SOME (i, _) => (substring (name, 0, i), String.extract (name, i + 1, NONE)) + | NONE => (name, "") + val parser = + case StringMap.lookup name' parsers of + SOME x => x + | NONE => error ("flag provided but not defined: " ^ String.toString name') + in + case parser of + BoolOpt func => + if value = "" + then + (func true ; + go args) + else + (func (boolFromString value) ; + go args) + | StringOpt func => + (* It must have a value, which might be the next argument. *) + if value = "" andalso not (null args) + then + (func (hd args) ; + go (tl args)) + else if value = "" + then error ("flag needs an argument: " ^ String.toString name') + else + (func value ; + go args) + end + in + go (CommandLine.arguments ()) + end +end @@ -14,7 +14,7 @@ struct datatype message = Unexpected of string | Expected of string datatype parseError = ParseError of sourceLoc * message list datatype hints = Hints of string list - type 'a parser = state -> response * (parseError, 'a * state * hints) Either.either + type 'a parser = state -> response * (parseError, 'a * state * hints) Result.either val reservedWords = [ "abstype", "and", "andalso", "as", "case", "datatype", "do", "else" @@ -60,12 +60,12 @@ struct fun stateLoc (State (_, loc, _)) : sourceLoc = loc - fun unpackParserResponse (_ : response, Either.Left err : (parseError, 'a * state * hints) Either.either) : (string, 'a) Either.either = - Either.Left (printError err) - | unpackParserResponse (_, Either.Right (a, st, _)) = + fun unpackParserResponse (_ : response, Result.Left err : (parseError, 'a * state * hints) Result.either) : (string, 'a) Result.either = + Result.Left (printError err) + | unpackParserResponse (_, Result.Right (a, st, _)) = if TextIO.StreamIO.endOfStream (stateStream st) - then Either.Right a - else Either.Left (printSourceLoc (stateLoc st) ^ " Syntax error: trailing characters") + then Result.Right a + else Result.Left (printSourceLoc (stateLoc st) ^ " Syntax error: trailing characters") fun newLoc (fileName : string) : sourceLoc = SourceLoc (fileName, 1, 1) @@ -81,18 +81,18 @@ struct fun updateUserState (f : userState -> userState) : userState parser = fn State (stream, loc, us) => let val st' = f us - in (Empty, Either.Right (st', State (stream, loc, st'), Hints [])) + in (Empty, Result.Right (st', State (stream, loc, st'), Hints [])) end val getUserState : userState parser = updateUserState (fn x => x) - fun runParser (p : 'a parser) (fileName : string) : (string, 'a) Either.either = + fun runParser (p : 'a parser) (fileName : string) : (string, 'a) Result.either = unpackParserResponse (p (newState fileName (TextIO.openIn fileName))) fun testParser (p : 'a parser) (s : string) : 'a = case unpackParserResponse (p (newState "STRING" (TextIO.openString s))) of - Either.Right x => x - | Either.Left e => raise Fail ("Parse failed: " ^ e) + Result.Right x => x + | Result.Left e => raise Fail ("Parse failed: " ^ e) fun mergeHints (Hints a) (Hints b) : hints = Hints (a @ b) @@ -115,33 +115,33 @@ struct fun bind (p : 'a parser) (f : 'a -> 'b parser) : 'b parser = fn st => case p st of - (consumed1, Either.Right (a, st', hints)) => + (consumed1, Result.Right (a, st', hints)) => (case (f a) st' of - (Consumed, Either.Right success) => (Consumed, Either.Right success) - | (Empty, Either.Right (b, st'', hints')) => (consumed1, Either.Right (b, st'', mergeHints hints hints')) - | (Consumed, Either.Left err) => (Consumed, Either.Left (withHints hints err)) - | (Empty, Either.Left err) => (consumed1, Either.Left (withHints hints err))) - | (consumed, Either.Left err) => (consumed, Either.Left err) + (Consumed, Result.Right success) => (Consumed, Result.Right success) + | (Empty, Result.Right (b, st'', hints')) => (consumed1, Result.Right (b, st'', mergeHints hints hints')) + | (Consumed, Result.Left err) => (Consumed, Result.Left (withHints hints err)) + | (Empty, Result.Left err) => (consumed1, Result.Left (withHints hints err))) + | (consumed, Result.Left err) => (consumed, Result.Left err) fun (p1 : 'a parser) >> (p2 : 'b parser) : 'b parser = bind p1 (fn _ => p2) fun (p : 'a parser) <?> (msg : string) : 'a parser = fn st => case p st of - (consumed, Either.Right (a, st', _)) => (consumed, Either.Right (a, st', Hints [msg])) - | (consumed, Either.Left (ParseError (loc, _))) => (consumed, Either.Left (ParseError (loc, [Expected msg]))) + (consumed, Result.Right (a, st', _)) => (consumed, Result.Right (a, st', Hints [msg])) + | (consumed, Result.Left (ParseError (loc, _))) => (consumed, Result.Left (ParseError (loc, [Expected msg]))) fun (p1 : 'a parser) <|> (p2 : 'a parser) : 'a parser = fn st => case p1 st of - (Empty, Either.Left err) => + (Empty, Result.Left err) => (case p2 st of - (Empty, Either.Right (a, st', hints)) => (Empty, Either.Right (a, st', mergeHints (errToHints err) hints)) - | (Empty, Either.Left err') => (Empty, Either.Left (mergeError err err')) + (Empty, Result.Right (a, st', hints)) => (Empty, Result.Right (a, st', mergeHints (errToHints err) hints)) + | (Empty, Result.Left err') => (Empty, Result.Left (mergeError err err')) | res => res) | res => res - fun const (x : 'a) (st : state) = (Empty, Either.Right (x, st, Hints [])) + fun const (x : 'a) (st : state) = (Empty, Result.Right (x, st, Hints [])) fun (f : 'a -> 'b) <$> (p : 'a parser) : 'b parser = bind p (const o f) @@ -150,7 +150,7 @@ struct fun try (p : 'a parser) : 'a parser = fn st => case p st of - (Consumed, Either.Left err) => (Empty, Either.Left err) + (Consumed, Result.Left err) => (Empty, Result.Left err) | res => res fun updatePosChar (SourceLoc (file, row, column)) (c : char) : sourceLoc = @@ -162,11 +162,11 @@ struct fun satisfy (pred : char -> bool) : char parser = fn State (stream, loc, us) => case TextIO.StreamIO.input1 stream of - NONE => (Empty, Either.Left (ParseError (loc, [Expected "UNKNOWN"]))) + NONE => (Empty, Result.Left (ParseError (loc, [Expected "UNKNOWN"]))) | SOME (c, stream') => if pred c - then (Consumed, Either.Right (c, State (stream', updatePosChar loc c, us), Hints [])) - else (Empty, Either.Left (ParseError (loc, [Expected "UNKNOWN"]))) + then (Consumed, Result.Right (c, State (stream', updatePosChar loc c, us), Hints [])) + else (Empty, Result.Left (ParseError (loc, [Expected "UNKNOWN"]))) fun parseChar (c : char) : char parser = satisfy (fn c' => c = c') <?> str c @@ -182,16 +182,16 @@ struct fn st => let fun walk xs s' = case p s' of - (Consumed, Either.Right (x, s'', _)) => walk (x :: xs) s'' - | (Consumed, Either.Left err) => (Consumed, Either.Left err) - | (Empty, Either.Right _) => manyErr () - | (Empty, Either.Left err) => (Consumed, Either.Right (rev xs, s', errToHints err)) + (Consumed, Result.Right (x, s'', _)) => walk (x :: xs) s'' + | (Consumed, Result.Left err) => (Consumed, Result.Left err) + | (Empty, Result.Right _) => manyErr () + | (Empty, Result.Left err) => (Consumed, Result.Right (rev xs, s', errToHints err)) in case p st of - (Consumed, Either.Right (x, s', _)) => walk [x] s' - | (Consumed, Either.Left err) => (Consumed, Either.Left err) - | (Empty, Either.Right _) => manyErr () - | (Empty, Either.Left err) => (Empty, Either.Right ([], st, errToHints err)) + (Consumed, Result.Right (x, s', _)) => walk [x] s' + | (Consumed, Result.Left err) => (Consumed, Result.Left err) + | (Empty, Result.Right _) => manyErr () + | (Empty, Result.Left err) => (Empty, Result.Right ([], st, errToHints err)) end fun many1 (p : 'a parser) : 'a list parser = @@ -204,7 +204,7 @@ struct val spaces : unit parser = many space <$ () <?> "white space" fun unexpected (s : string) : 'a parser = - fn st => (Empty, Either.Left (ParseError (stateLoc st, [Unexpected s]))) + fn st => (Empty, Result.Left (ParseError (stateLoc st, [Unexpected s]))) val letter : char parser = satisfy Char.isAlpha <?> "letter" @@ -431,6 +431,6 @@ struct and expr : Syntax.expr parser = fn st => typedExp 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.ETuple [])) <$> many dec - fun parse (f : string) : (string, Syntax.expr) Either.either = runParser program f + val program : Syntax.expr parser = (fn decs => Syntax.ELet (decs, Syntax.EInt 0)) <$> many dec + fun parse (f : string) : (string, Syntax.expr) Result.either = runParser program f end @@ -1,14 +1,16 @@ Group is +buffer.sml codegen.sml +compiler.sml cps.sml -either.sml elab.sml gensym.sml linker.sml map.sml +opts.sml parser.sml +result.sml syntax.sml -buffer.sml $/basis.cm @@ -1,4 +1,4 @@ -structure Either = +structure Result = struct datatype ('a, 'b) either = Left of 'a | Right of 'b end @@ -125,4 +125,14 @@ struct end val cexpToString : cexp -> string = cexpToStringI "" + + fun opcodeToString (oper : opcode) : string = + case oper of + OAlloc (r, s) => "OAlloc (" ^ Int.toString r ^ ", " ^ valueToString s ^ ")" + | OCall => "OCall" + | OPoke (i, p, v) => "OPoke (" ^ Int.toString i ^ ", " ^ Int.toString p ^ ", " ^ valueToString v ^ ")" + | OPeek (r, i, p) => "OPeek (" ^ Int.toString r ^ ", " ^ Int.toString i ^ ", " ^ valueToString p ^ ")" + | OShuf (d, s) => "OShuf (" ^ Int.toString d ^ ", " ^ valueToString s ^ ")" + | OExit v => "OExit " ^ valueToString v + | OLabel l => "OLabel " ^ Int.toString l end |