c07696d · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Some new bytecode compiling

c07696dEdwin Brady14 years ago

src/Idris/REPL.hs+3

compare with master

unifiedsplit

@@ -21,6 +21,7 @@ import Core.TT

21import Core.Constraints

23import RTS.SC

24+import RTS.Bytecode

25import System.Console.Haskeline as H

26import System.Console.Haskeline as H

26import System.FilePath

27import System.FilePath

@@ -199,6 +200,8 @@ process fn (DebugInfo n)

199 when (not (null d)) $ liftIO $

200 when (not (null d)) $ liftIO $

200 do print (head d)

201 do print (head d)

201 print (sclift (n, head d))

202 print (sclift (n, head d))

203+ putStrLn (showSep "\n"

204+ (map show (bcdefs (sclift (n, head d)))))

202process fn (Info n) = do i <- get

205process fn (Info n) = do i <- get

203 case lookupCtxt Nothing n (idris_classes i) of

206 case lookupCtxt Nothing n (idris_classes i) of

204 [c] -> classInfo c

207 [c] -> classInfo c

src/RTS/BCParser.hs+2−1

@@ -73,7 +73,8 @@ pInstruction =

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))

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

77+ return (CALL n (fromInteger i)))

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

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

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

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

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

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

src/RTS/Bytecode.hs+80−2

@@ -12,7 +12,7 @@ data Value = VInt Int

12 deriving Show

14data BCOp = PUSH Value

15− | SLIDE Int

15+ | SLIDE Int -- Keep top stack value, discard n below it

16 | DISCARD Int

17 | DISCARDINT Int

18 | DISCARDFLOAT Int

@@ -21,8 +21,12 @@ data BCOp = PUSH Value

21 | MKTHUNK Name Int Arity

22 | MKUNIT

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

24+ | INTCASE [(Int, Bytecode)] (Maybe Bytecode)

25+ -- case looks at top stack item, discards immediately,

26+ -- places constructor args on stack, last to first

24 | SPLIT -- get arguments from constructor form

27 | SPLIT -- get arguments from constructor form

25− | CALL Name

28+ | CALL Name Int -- name, number of arguments to take

29+ | CALLVAR Int Int -- stack ref, number of arguments to take

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

30 | FOREIGNCALL String CType [CType] -- TT constants for types

27 | ERROR String

31 | ERROR String

28 | DUMP

32 | DUMP

@@ -33,3 +37,77 @@ type Bytecode = [BCOp]

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

37data BCProg = BCProg [(Name, Bytecode)]

34 deriving Show

38 deriving Show

40+bcdefs :: [(Name, SCDef)] -> [(Name, Bytecode)]

41+bcdefs = map (\ (n, s) -> (n, bc [] s))

42+

43+class BC a where

44+ bc :: [(Name, Int)] -> -- local variables + stack offset

45+ a -> Bytecode

46+

47+offset :: [(Name, Int)] -> [(Name, Int)]

48+offset = map (\ (n, i) -> (n, i+1))

49+

50+-- A bytecode sequence for an expression evaluates that expression and

51+-- places the result at the top of the stack.

52+

53+instance BC SCDef where

54+ bc [] (SCDef args def) = bc (zip (map fst args) [0..]) def

55+ ++ [SLIDE (length args)]

56+

57+instance BC SCExp where

58+ bc locs (SRef n) = case lookup n locs of

59+ Nothing -> [CALL n 0]

60+ Just i -> [PUSH (VRef i)]

61+ bc locs (SApp (SRef f) args)

62+ = bc' locs (reverse args) f

63+ where bc' locs [] n

64+ = case lookup n locs of

65+ Just i -> [CALLVAR i (length args)]

66+ Nothing -> [CALL n (length args)]

67+ bc' locs (x : xs) f = bc locs x ++

68+ bc' (offset locs) xs f

69+ bc locs (SApp e args)

70+ = bc locs e ++ bc' (offset locs) (reverse args) ++ [SLIDE 1]

71+ where bc' locs []

72+ = [CALLVAR (length args) (length args)]

73+ bc' locs (x : xs) = bc locs x ++

74+ bc' (offset locs) xs

75+ bc locs (SLet n v sc)

76+ = bc locs v ++

77+ bc ((n, 0) : offset locs) sc ++

78+ [SLIDE 1]

79+

80+ bc locs (SFCall cname ty args)

81+ = bc' locs (reverse (map fst args))

82+ where bc' locs [] = [FOREIGNCALL cname ty (map snd args)]

83+ bc' locs (x : xs) = bc locs x ++ bc' (offset locs) xs

84+

85+ bc locs (SCon t args)

86+ = bc' locs (reverse args)

87+ where bc' locs [] = [MKCON t (length args)]

88+ bc' locs (x : xs) = bc locs x ++ bc' (offset locs) xs

89+

90+ bc locs (SConst (I i)) = [PUSH (VInt i)]

91+ bc locs (SConst (BI i)) = [PUSH (VBigInt i)]

92+ bc locs (SConst (Fl f)) = [PUSH (VFloat f)]

93+ bc locs (SConst (Ch c)) = [PUSH (VChar c)]

94+ bc locs (SConst (Str s)) = [PUSH (VString s)]

95+ bc locs (SConst _) = [MKUNIT]

96+

97+ bc locs (SError str) = [ERROR str]

98+

99+ bc locs (SCase n alts)

100+ = let (def, cases, ty) = getCases CASE Nothing [] alts in

101+ bc locs (SRef n) ++ [ty cases def]

102+ where getCases ty def cs [] = (def, reverse cs, ty)

103+ getCases ty _ cs (SDefaultCase e : rest)

104+ = getCases ty (Just (bc locs e)) cs rest

105+ getCases _ def cs (SConstCase (I c) e : rest)

106+ = getCases INTCASE def ((c, bc locs e): cs) rest

107+ getCases _ def cs (SConCase t ns e : rest)

108+ = let locs' = addLocs (reverse ns) locs in

109+ getCases CASE def ((t, bc locs' e ++ [SLIDE (length locs')])

110+ : cs) rest

111+ addLocs [] l = l

112+ addLocs (n : ns) locs = addLocs ns ((n, 0) : offset locs)

113+

src/RTS/SC.hs+2−2

@@ -17,8 +17,8 @@ data SCDef = SCDef { sc_args :: [(Name, CType)],

17data SCExp = SRef Name

18 | SApp SCExp [SCExp]

19 | SLet Name SCExp SCExp

20− | SFCall String CType [(SCExp, CType)]

20+ | SFCall String CType [(SCExp, CType)] -- foreign call with types

21− | SCon Tag [SCExp]

21+ | SCon Tag [SCExp] -- constructor, assume saturated (forcing does this)

22 | SConst Const

23 | SError String

24 | SCase Name [SAlt]