Permalink
Browse files

More towards the new compiler

  • Loading branch information...
1 parent 5c09acd commit 38a93652399be5a6815fcc089ff3ad23bb0216af Edwin Brady committed May 15, 2012
Showing with 178 additions and 25 deletions.
  1. +1 −1 Makefile
  2. +2 −0 idris.cabal
  3. +6 −0 rts/closure.c
  4. +2 −0 rts/closure.h
  5. +1 −0 src/Idris/AbsSyntax.hs
  6. +31 −15 src/Main.hs
  7. +8 −0 src/RTS/Assembler.hs
  8. +56 −0 src/RTS/BCParser.hs
  9. +24 −9 src/RTS/Bytecode.hs
  10. +47 −0 src/RTS/SC.hs
View
@@ -19,7 +19,7 @@ relib: .PHONY
make -C lib IDRIS=../dist/build/idris/idris
linecount : .PHONY
- wc -l src/Idris/*.hs src/Core/*.hs
+ wc -l src/Idris/*.hs src/Core/*.hs src/RTS/*.hs
.PHONY:
View
@@ -68,6 +68,8 @@ Executable idris
Util.Pretty,
+ RTS.BCParser, RTS.Bytecode, RTS.Assembler, RTS.SC,
+
Paths_idris
Build-depends: base>=4 && <5, parsec, mtl, Cabal, haskeline,
View
@@ -86,6 +86,12 @@ VAL mkCon(VM* vm, int tag, int arity) {
VAL* v = POP;
*argptr++ = v;
}
+}
+
+// if 'update' is set, update the value at the top of the stack
+// otherwise, replace it with a new value
+void EVAL(int update) {
+
}
View
@@ -76,4 +76,6 @@ VAL mkStr(VM* vm, char* str);
VAL mkThunk(VM* vm, func fn, int args, int arity);
VAL mkCon(VM* vm, int tag, int arity);
+void EVAL(int update);
+
#endif
View
@@ -418,6 +418,7 @@ data Opt = Filename String
| Verbose
| IBCSubDir String
| ImportDir String
+ | BCAsm String
deriving Eq
View
@@ -24,6 +24,11 @@ import Idris.ElabDecls
import Idris.Primitives
import Idris.Imports
import Idris.Error
+
+import RTS.BCParser
+import RTS.Bytecode
+import RTS.Assembler
+
import Paths_idris
-- Main program reads command line options, parses the main program, and gets
@@ -40,6 +45,8 @@ runIdris opts =
let output = opt getOutput opts
let ibcsubdir = opt getIBCSubDir opts
let importdirs = opt getImportDir opts
+ let bcs = opt getBC opts
+
when (Ver `elem` opts) $ liftIO showver
when (Usage `elem` opts) $ liftIO usage
when (ShowIncs `elem` opts) $ liftIO showIncs
@@ -48,6 +55,10 @@ runIdris opts =
setVerbose runrepl
when (Verbose `elem` opts) $ setVerbose True
mapM_ makeOption opts
+ -- if we have the --bytecode flag, drop into the bytecode assembler
+ case bcs of
+ [] -> return ()
+ xs -> liftIO $ mapM_ bcAsm xs
case ibcsubdir of
[] -> setIBCSubDir ""
(d:_) -> setIBCSubDir d
@@ -77,6 +88,10 @@ getFile :: Opt -> Maybe String
getFile (Filename str) = Just str
getFile _ = Nothing
+getBC :: Opt -> Maybe String
+getBC (BCAsm str) = Just str
+getBC _ = Nothing
+
getOutput :: Opt -> Maybe String
getOutput (Output str) = Just str
getOutput _ = Nothing
@@ -108,22 +123,23 @@ showIncs = do dir <- getDataDir
parseArgs :: [String] -> IO [Opt]
parseArgs [] = return []
-parseArgs ("--log":lvl:ns) = liftM (OLogging (read lvl) : ) (parseArgs ns)
-parseArgs ("--noprelude":ns) = liftM (NoPrelude : ) (parseArgs ns)
-parseArgs ("--check":ns) = liftM (NoREPL : ) (parseArgs ns)
-parseArgs ("-o":n:ns) = liftM (\x -> NoREPL : Output n : x) (parseArgs ns)
-parseArgs ("--typecase":ns) = liftM (TypeCase : ) (parseArgs ns)
-parseArgs ("--typeintype":ns) = liftM (TypeInType : ) (parseArgs ns)
-parseArgs ("--nocoverage":ns) = liftM (NoCoverage : ) (parseArgs ns)
+parseArgs ("--log":lvl:ns) = liftM (OLogging (read lvl) : ) (parseArgs ns)
+parseArgs ("--noprelude":ns) = liftM (NoPrelude : ) (parseArgs ns)
+parseArgs ("--check":ns) = liftM (NoREPL : ) (parseArgs ns)
+parseArgs ("-o":n:ns) = liftM (\x -> NoREPL : Output n : x) (parseArgs ns)
+parseArgs ("--typecase":ns) = liftM (TypeCase : ) (parseArgs ns)
+parseArgs ("--typeintype":ns) = liftM (TypeInType : ) (parseArgs ns)
+parseArgs ("--nocoverage":ns) = liftM (NoCoverage : ) (parseArgs ns)
parseArgs ("--errorcontext":ns) = liftM (ErrContext : ) (parseArgs ns)
-parseArgs ("--help":ns) = liftM (Usage : ) (parseArgs ns)
-parseArgs ("--link":ns) = liftM (ShowLibs : ) (parseArgs ns)
-parseArgs ("--include":ns) = liftM (ShowIncs : ) (parseArgs ns)
-parseArgs ("--version":ns) = liftM (Ver : ) (parseArgs ns)
-parseArgs ("--verbose":ns) = liftM (Verbose : ) (parseArgs ns)
-parseArgs ("--ibcsubdir":n:ns) = liftM (IBCSubDir n : ) (parseArgs ns)
-parseArgs ("-i":n:ns) = liftM (ImportDir n : ) (parseArgs ns)
-parseArgs (n:ns) = liftM (Filename n : ) (parseArgs ns)
+parseArgs ("--help":ns) = liftM (Usage : ) (parseArgs ns)
+parseArgs ("--link":ns) = liftM (ShowLibs : ) (parseArgs ns)
+parseArgs ("--include":ns) = liftM (ShowIncs : ) (parseArgs ns)
+parseArgs ("--version":ns) = liftM (Ver : ) (parseArgs ns)
+parseArgs ("--verbose":ns) = liftM (Verbose : ) (parseArgs ns)
+parseArgs ("--ibcsubdir":n:ns) = liftM (IBCSubDir n : ) (parseArgs ns)
+parseArgs ("-i":n:ns) = liftM (ImportDir n : ) (parseArgs ns)
+parseArgs ("--bytecode":n:ns) = liftM (\x -> NoREPL : BCAsm n : x) (parseArgs ns)
+parseArgs (n:ns) = liftM (Filename n : ) (parseArgs ns)
ver = showVersion version
View
@@ -0,0 +1,8 @@
+module RTS.Assembler where
+
+import RTS.BCParser
+import RTS.Bytecode
+
+bcAsm :: FilePath -> IO ()
+bcAsm f = do bc <- parseFile f
+ print bc
View
@@ -1,6 +1,9 @@
module RTS.BCParser where
import Core.CoreParser
+import Core.TT
+
+import RTS.Bytecode
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Error
@@ -37,3 +40,56 @@ float = PTok.float lexer
strlit = PTok.stringLiteral lexer
chlit = PTok.charLiteral lexer
lchar = lexeme.char
+
+parseFile :: FilePath -> IO BCProg
+parseFile fname = do fp <- readFile fname
+ case runParser pProgram () fname fp of
+ Left err-> fail (show err)
+ Right x -> return x
+
+pProgram :: BParser BCProg
+pProgram = do fs <- many1 pFun
+ return $ BCProg fs
+
+pFun :: BParser (Name, Bytecode)
+pFun = do n <- iName []
+ lchar ':'
+ bc <- many1 pInstruction
+ return (n, bc)
+
+pInstruction :: BParser BCOp
+pInstruction =
+ try (do reserved "PUSH"; v <- pValue; return (PUSH v))
+ <|> try (do reserved "SLIDE"; v <- integer; return (SLIDE (fromInteger v)))
+ <|> try (do reserved "DISCARD"; v <- integer; return (DISCARD (fromInteger v)))
+ <|> try (do reserved "DISCARDINT"; v <- integer
+ return (DISCARDINT (fromInteger v)))
+ <|> try (do reserved "DISCARDFLOAT"; v <- integer
+ return (DISCARDFLOAT (fromInteger v)))
+ <|> try (do reserved "EVAL"; return (EVAL True))
+ <|> try (do reserved "EVAL_NOUPDATE"; return (EVAL False))
+ <|> try (do reserved "MKCON"; t <- integer; a <- integer;
+ return (MKCON (fromInteger t) (fromInteger a)))
+ <|> try (do reserved "MKTHUNK"; n <- iName []; arg <- integer; arity <- integer
+ return (MKTHUNK n (fromInteger arg) (fromInteger arity)))
+ <|> try (do reserved "MKUNIT"; return MKUNIT)
+ <|> try (do reserved "CALL"; n <- iName []; return (CALL n))
+ <|> try (do reserved "ERROR"; s <- strlit; return (ERROR s))
+ <|> try (do reserved "SPLIT"; return SPLIT)
+ <|> try (do reserved "DUMP"; return DUMP)
+ <|> do reserved "CASE"; s <- sepBy1 pAlt (lchar '|')
+ def <- option Nothing (do reserved "default"; symbol "->";
+ bc <- many1 pInstruction
+ return (Just bc))
+ return (CASE s def)
+ where pAlt = try (do t <- integer; symbol "->"
+ bc <- many1 pInstruction
+ return (fromInteger t, bc))
+
+pValue :: BParser Value
+pValue = try (do x <- integer; lchar 'L'; return (VBigInt x))
+ <|> try (do x <- integer; return (VInt (fromInteger x)))
+ <|> try (do x <- float; return (VFloat x))
+ <|> try (do x <- strlit; return (VString x))
+ <|> try (do x <- chlit; return (VChar x))
+ <|> try (do lchar 'S'; x <- integer; return (VRef (fromInteger x)))
View
@@ -1,20 +1,35 @@
module RTS.Bytecode where
import Core.TT
+import RTS.SC
data Value = VInt Int
| VFloat Double
| VString String
| VChar Char
| VBigInt Integer
| VRef Int
+ deriving Show
+
+data BCOp = PUSH Value
+ | SLIDE Int
+ | DISCARD Int
+ | DISCARDINT Int
+ | DISCARDFLOAT Int
+ | EVAL Bool
+ | MKCON Tag Arity
+ | MKTHUNK Name Int Arity
+ | MKUNIT
+ | CASE [(Int, Bytecode)] (Maybe Bytecode)
+ | SPLIT -- get arguments from constructor form
+ | CALL Name
+ | FOREIGNCALL String CType [CType] -- TT constants for types
+ | ERROR String
+ | DUMP
+ deriving Show
+
+type Bytecode = [BCOp]
+
+data BCProg = BCProg [(Name, Bytecode)]
+ deriving Show
-data Bytecode = PUSH Value
- | SLIDE Int
- | DISCARD Int
- | DISCARDINT Int
- | DISCARDFLOAT Int
- | EVAL Bool
- | MKCON Tag Int
- | MKTHUNK Name Int Int
- | CALL Name
View
@@ -0,0 +1,47 @@
+module RTS.SC where
+
+import Core.TT
+import Core.Evaluate
+import Core.CaseTree
+
+import Control.Monad.State
+
+type CType = Maybe Const
+type Tag = Int
+type Arity = Int
+
+data SCDef = SCDef { sc_args :: [(Name, CType)],
+ sc_def :: SCExp }
+ deriving Show
+
+data SCExp = SVar Name
+ | SApp Name [SCExp]
+ | SFCall String CType [(SCExp, CType)]
+ | SCon Tag [SCExp]
+ | SConst Const
+ | SErased
+ | SCase [SAlt]
+ deriving Show
+
+data SAlt = SConCase Tag [Name] SCExp
+ | SConstCase Const SCExp
+ | SDefaultCase SCExp
+ deriving Show
+
+sclift :: (Name, Def) -> [(Name, SCDef)]
+sclift d = execState (sc d) []
+
+add :: a -> State [a] ()
+add x = do xs <- get
+ put (x : xs)
+
+class Lift s t | s -> t where
+ sc :: s -> State [(Name, SCDef)] t
+
+instance Lift (Name, Def) () where
+ sc (n, d) = do d' <- sc d
+ add (n, d')
+
+instance Lift Def SCDef where
+ sc x = undefined
+

0 comments on commit 38a9365

Please sign in to comment.