Finish the compiler.

Just joking. But we did manage to compile a program from SML
to bytecode.

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
diff --git a/linker.sml b/linker.sml
index b52e84b..874e145 100644
--- a/linker.sml
+++ b/linker.sml
@@ -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 ;
diff --git a/main.sml b/main.sml
index c020691..10e6937 100644
--- a/main.sml
+++ b/main.sml
@@ -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
diff --git a/parser.sml b/parser.sml
index 1860344..cfc6563 100644
--- a/parser.sml
+++ b/parser.sml
@@ -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
diff --git a/program.cm b/program.cm
index b957215..4724772 100644
--- a/program.cm
+++ b/program.cm
@@ -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
diff --git a/either.sml b/result.sml
index 6a63fe5..ff1a9a3 100644
--- a/either.sml
+++ b/result.sml
@@ -1,4 +1,4 @@
-structure Either =
+structure Result =
 struct
   datatype ('a, 'b) either = Left of 'a | Right of 'b
 end
diff --git a/syntax.sml b/syntax.sml
index 2e2cc11..5ed5954 100644
--- a/syntax.sml
+++ b/syntax.sml
@@ -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