38a9365 · Idris-dev · git.iko.soy

Makefile+1−1

@@ -19,7 +19,7 @@ relib: .PHONY

1919 make -C lib IDRIS=../dist/build/idris/idris

2020

2121linecount : .PHONY

22− wc -l src/Idris/*.hs src/Core/*.hs

22+ wc -l src/Idris/*.hs src/Core/*.hs src/RTS/*.hs

2323

2424.PHONY:

2525

idris.cabal+2

@@ -68,6 +68,8 @@ Executable idris

6868

6969 Util.Pretty,

7070

71+ RTS.BCParser, RTS.Bytecode, RTS.Assembler, RTS.SC,

72+

7173 Paths_idris

7274

7375 Build-depends: base>=4 && <5, parsec, mtl, Cabal, haskeline,

rts/closure.c+6

@@ -86,6 +86,12 @@ VAL mkCon(VM* vm, int tag, int arity) {

8686 VAL* v = POP;

8787 *argptr++ = v;

8888 }

89+}

90+

91+// if 'update' is set, update the value at the top of the stack

92+// otherwise, replace it with a new value

8993

94+void EVAL(int update) {

95+

9096}

9197

rts/closure.h+2

@@ -76,4 +76,6 @@ VAL mkStr(VM* vm, char* str);

7676VAL mkThunk(VM* vm, func fn, int args, int arity);

7777VAL mkCon(VM* vm, int tag, int arity);

7878

79+void EVAL(int update);

80+

7981#endif

src/Idris/AbsSyntax.hs+1

@@ -418,6 +418,7 @@ data Opt = Filename String

418418 | Verbose

419419 | IBCSubDir String

420420 | ImportDir String

421+ | BCAsm String

421422 deriving Eq

422423

423424

src/Main.hs+31−15

@@ -24,6 +24,11 @@ import Idris.ElabDecls

2424import Idris.Primitives

2525import Idris.Imports

2626import Idris.Error

27+

28+import RTS.BCParser

29+import RTS.Bytecode

30+import RTS.Assembler

31+

2732import Paths_idris

2833

2934-- Main program reads command line options, parses the main program, and gets

@@ -40,6 +45,8 @@ runIdris opts =

4045 let output = opt getOutput opts

4146 let ibcsubdir = opt getIBCSubDir opts

4247 let importdirs = opt getImportDir opts

48+ let bcs = opt getBC opts

49+

4350 when (Ver `elem` opts) $ liftIO showver

4451 when (Usage `elem` opts) $ liftIO usage

4552 when (ShowIncs `elem` opts) $ liftIO showIncs

@@ -48,6 +55,10 @@ runIdris opts =

4855 setVerbose runrepl

4956 when (Verbose `elem` opts) $ setVerbose True

5057 mapM_ makeOption opts

58+ -- if we have the --bytecode flag, drop into the bytecode assembler

59+ case bcs of

60+ [] -> return ()

61+ xs -> liftIO $ mapM_ bcAsm xs

5162 case ibcsubdir of

5263 [] -> setIBCSubDir ""

5364 (d:_) -> setIBCSubDir d

@@ -77,6 +88,10 @@ getFile :: Opt -> Maybe String

7788getFile (Filename str) = Just str

7889getFile _ = Nothing

7990

91+getBC :: Opt -> Maybe String

92+getBC (BCAsm str) = Just str

93+getBC _ = Nothing

94+

8095getOutput :: Opt -> Maybe String

8196getOutput (Output str) = Just str

8297getOutput _ = Nothing

@@ -108,22 +123,23 @@ showIncs = do dir <- getDataDir

108123

109124parseArgs :: [String] -> IO [Opt]

110125parseArgs [] = return []

111−parseArgs ("--log":lvl:ns) = liftM (OLogging (read lvl) : ) (parseArgs ns)

112−parseArgs ("--noprelude":ns) = liftM (NoPrelude : ) (parseArgs ns)

113−parseArgs ("--check":ns) = liftM (NoREPL : ) (parseArgs ns)

114−parseArgs ("-o":n:ns) = liftM (\x -> NoREPL : Output n : x) (parseArgs ns)

115−parseArgs ("--typecase":ns) = liftM (TypeCase : ) (parseArgs ns)

116−parseArgs ("--typeintype":ns) = liftM (TypeInType : ) (parseArgs ns)

117−parseArgs ("--nocoverage":ns) = liftM (NoCoverage : ) (parseArgs ns)

126+parseArgs ("--log":lvl:ns) = liftM (OLogging (read lvl) : ) (parseArgs ns)

127+parseArgs ("--noprelude":ns) = liftM (NoPrelude : ) (parseArgs ns)

128+parseArgs ("--check":ns) = liftM (NoREPL : ) (parseArgs ns)

129+parseArgs ("-o":n:ns) = liftM (\x -> NoREPL : Output n : x) (parseArgs ns)

130+parseArgs ("--typecase":ns) = liftM (TypeCase : ) (parseArgs ns)

131+parseArgs ("--typeintype":ns) = liftM (TypeInType : ) (parseArgs ns)

132+parseArgs ("--nocoverage":ns) = liftM (NoCoverage : ) (parseArgs ns)

118133parseArgs ("--errorcontext":ns) = liftM (ErrContext : ) (parseArgs ns)

119−parseArgs ("--help":ns) = liftM (Usage : ) (parseArgs ns)

120−parseArgs ("--link":ns) = liftM (ShowLibs : ) (parseArgs ns)

121−parseArgs ("--include":ns) = liftM (ShowIncs : ) (parseArgs ns)

122−parseArgs ("--version":ns) = liftM (Ver : ) (parseArgs ns)

123−parseArgs ("--verbose":ns) = liftM (Verbose : ) (parseArgs ns)

124−parseArgs ("--ibcsubdir":n:ns) = liftM (IBCSubDir n : ) (parseArgs ns)

125−parseArgs ("-i":n:ns) = liftM (ImportDir n : ) (parseArgs ns)

126−parseArgs (n:ns) = liftM (Filename n : ) (parseArgs ns)

134+parseArgs ("--help":ns) = liftM (Usage : ) (parseArgs ns)

135+parseArgs ("--link":ns) = liftM (ShowLibs : ) (parseArgs ns)

136+parseArgs ("--include":ns) = liftM (ShowIncs : ) (parseArgs ns)

137+parseArgs ("--version":ns) = liftM (Ver : ) (parseArgs ns)

138+parseArgs ("--verbose":ns) = liftM (Verbose : ) (parseArgs ns)

139+parseArgs ("--ibcsubdir":n:ns) = liftM (IBCSubDir n : ) (parseArgs ns)

140+parseArgs ("-i":n:ns) = liftM (ImportDir n : ) (parseArgs ns)

141+parseArgs ("--bytecode":n:ns) = liftM (\x -> NoREPL : BCAsm n : x) (parseArgs ns)

142+parseArgs (n:ns) = liftM (Filename n : ) (parseArgs ns)

127143

128144ver = showVersion version

129145

src/RTS/Assembler.hsnew file+8

@@ -0,0 +1,8 @@

1+module RTS.Assembler where

2+

3+import RTS.BCParser

4+import RTS.Bytecode

5+

6+bcAsm :: FilePath -> IO ()

7+bcAsm f = do bc <- parseFile f

8+ print bc

src/RTS/BCParser.hs+56

@@ -1,6 +1,9 @@

11module RTS.BCParser where

22

33import Core.CoreParser

4+import Core.TT

5+

6+import RTS.Bytecode

47

58import Text.ParserCombinators.Parsec

69import Text.ParserCombinators.Parsec.Error

@@ -37,3 +40,56 @@ float = PTok.float lexer

3740strlit = PTok.stringLiteral lexer

3841chlit = PTok.charLiteral lexer

3942lchar = lexeme.char

43+

44+parseFile :: FilePath -> IO BCProg

45+parseFile fname = do fp <- readFile fname

46+ case runParser pProgram () fname fp of

47+ Left err-> fail (show err)

48+ Right x -> return x

49+

50+pProgram :: BParser BCProg

51+pProgram = do fs <- many1 pFun

52+ return $ BCProg fs

53+

54+pFun :: BParser (Name, Bytecode)

55+pFun = do n <- iName []

56+ lchar ':'

57+ bc <- many1 pInstruction

58+ return (n, bc)

59+

60+pInstruction :: BParser BCOp

61+pInstruction =

62+ try (do reserved "PUSH"; v <- pValue; return (PUSH v))

63+ <|> try (do reserved "SLIDE"; v <- integer; return (SLIDE (fromInteger v)))

64+ <|> try (do reserved "DISCARD"; v <- integer; return (DISCARD (fromInteger v)))

65+ <|> try (do reserved "DISCARDINT"; v <- integer

66+ return (DISCARDINT (fromInteger v)))

67+ <|> try (do reserved "DISCARDFLOAT"; v <- integer

68+ return (DISCARDFLOAT (fromInteger v)))

69+ <|> try (do reserved "EVAL"; return (EVAL True))

70+ <|> try (do reserved "EVAL_NOUPDATE"; return (EVAL False))

71+ <|> try (do reserved "MKCON"; t <- integer; a <- integer;

72+ return (MKCON (fromInteger t) (fromInteger a)))

73+ <|> try (do reserved "MKTHUNK"; n <- iName []; arg <- integer; arity <- integer

74+ return (MKTHUNK n (fromInteger arg) (fromInteger arity)))

75+ <|> try (do reserved "MKUNIT"; return MKUNIT)

76+ <|> try (do reserved "CALL"; n <- iName []; return (CALL n))

77+ <|> try (do reserved "ERROR"; s <- strlit; return (ERROR s))

78+ <|> try (do reserved "SPLIT"; return SPLIT)

79+ <|> try (do reserved "DUMP"; return DUMP)

80+ <|> do reserved "CASE"; s <- sepBy1 pAlt (lchar '|')

81+ def <- option Nothing (do reserved "default"; symbol "->";

82+ bc <- many1 pInstruction

83+ return (Just bc))

84+ return (CASE s def)

85+ where pAlt = try (do t <- integer; symbol "->"

86+ bc <- many1 pInstruction

87+ return (fromInteger t, bc))

88+

89+pValue :: BParser Value

90+pValue = try (do x <- integer; lchar 'L'; return (VBigInt x))

91+ <|> try (do x <- integer; return (VInt (fromInteger x)))

92+ <|> try (do x <- float; return (VFloat x))

93+ <|> try (do x <- strlit; return (VString x))

94+ <|> try (do x <- chlit; return (VChar x))

95+ <|> try (do lchar 'S'; x <- integer; return (VRef (fromInteger x)))

src/RTS/Bytecode.hs+24−9

@@ -1,6 +1,7 @@

11module RTS.Bytecode where

22

33import Core.TT

4+import RTS.SC

45

56data Value = VInt Int

67 | VFloat Double

@@ -8,13 +9,27 @@ data Value = VInt Int

89 | VChar Char

910 | VBigInt Integer

1011 | VRef Int

12+ deriving Show

13+

14+data BCOp = PUSH Value

15+ | SLIDE Int

16+ | DISCARD Int

17+ | DISCARDINT Int

18+ | DISCARDFLOAT Int

19+ | EVAL Bool

20+ | MKCON Tag Arity

21+ | MKTHUNK Name Int Arity

22+ | MKUNIT

23+ | CASE [(Int, Bytecode)] (Maybe Bytecode)

24+ | SPLIT -- get arguments from constructor form

25+ | CALL Name

26+ | FOREIGNCALL String CType [CType] -- TT constants for types

27+ | ERROR String

28+ | DUMP

29+ deriving Show

30+

31+type Bytecode = [BCOp]

32+

33+data BCProg = BCProg [(Name, Bytecode)]

34+ deriving Show

1135

12−data Bytecode = PUSH Value

13− | SLIDE Int

14− | DISCARD Int

15− | DISCARDINT Int

16− | DISCARDFLOAT Int

17− | EVAL Bool

18− | MKCON Tag Int

19− | MKTHUNK Name Int Int

20− | CALL Name

src/RTS/SC.hsnew file+47

@@ -0,0 +1,47 @@

1+module RTS.SC where

2+

3+import Core.TT

4+import Core.Evaluate

5+import Core.CaseTree

6+

7+import Control.Monad.State

8+

9+type CType = Maybe Const

10+type Tag = Int

11+type Arity = Int

12+

13+data SCDef = SCDef { sc_args :: [(Name, CType)],

14+ sc_def :: SCExp }

15+ deriving Show

16+

17+data SCExp = SVar Name

18+ | SApp Name [SCExp]

19+ | SFCall String CType [(SCExp, CType)]

20+ | SCon Tag [SCExp]

21+ | SConst Const

22+ | SErased

23+ | SCase [SAlt]

24+ deriving Show

25+

26+data SAlt = SConCase Tag [Name] SCExp

27+ | SConstCase Const SCExp

28+ | SDefaultCase SCExp

29+ deriving Show

30+

31+sclift :: (Name, Def) -> [(Name, SCDef)]

32+sclift d = execState (sc d) []

33+

34+add :: a -> State [a] ()

35+add x = do xs <- get

36+ put (x : xs)

37+

38+class Lift s t | s -> t where

39+ sc :: s -> State [(Name, SCDef)] t

40+

41+instance Lift (Name, Def) () where

42+ sc (n, d) = do d' <- sc d

43+ add (n, d')

44+

45+instance Lift Def SCDef where

46+ sc x = undefined

47+