git.iko.soy/Idris-dev
on master help sign in
Idris-dev/src/IRTS/Bytecode.hs
191 lines 6.0 kB history raw
1{-|
2Module : IRTS.Bytecode
3Description : Bytecode for a stack based VM (e.g. for generating C code with an accurate hand written GC)
6License : BSD3
7Maintainer : The Idris Community.
10BASE: Current stack frame's base
11TOP: Top of stack
12OLDBASE: Passed in to each function, the previous stack frame's base
14L i refers to the stack item at BASE + i
15T i refers to the stack item at TOP + i
17RVal is a register in which computed values (essentially, what a function
18returns) are stored.
20-}
21module IRTS.Bytecode where
24import Idris.Core.TT
25import IRTS.Defunctionalise
26import IRTS.Simplified
28import Data.Maybe
30data Reg = RVal | L Int | T Int | Tmp
31 deriving (Show, Eq)
33data BC =
34 -- | reg1 = reg2
35 ASSIGN Reg Reg
37 -- | reg = const
38 | ASSIGNCONST Reg Const
40 -- | reg1 = reg2 (same as assign, it seems)
41 | UPDATE Reg Reg
43 -- | reg = constructor, where constructor consists of a tag and
44 -- values from registers, e.g. (cons tag args)
45 -- the 'Maybe Reg', if set, is a register which can be overwritten
46 -- (i.e. safe for mutable update), though this can be ignored
47 | MKCON Reg (Maybe Reg) Int [Reg]
49 -- | Matching on value of reg: usually (but not always) there are
50 -- constructors, hence "Int" for patterns (that's a tag on which
51 -- we should match), and the following [BC] is just a list of
52 -- instructions for the corresponding case. The last argument is
53 -- for default case. When it's not necessary a constructor in the
54 -- reg, the Bool should be False, indicating that it's not safe to
55 -- work with that as with a constructor, so a check should be
56 -- added. If it's not a constructor, default case should be used.
57 | CASE Bool
58 Reg [(Int, [BC])] (Maybe [BC])
60 -- | get a value from register, which should be a constructor, and
61 -- put its arguments into the stack, starting from (base + int1)
62 -- and onwards; second Int provides arity
63 | PROJECT Reg Int Int
65 -- | probably not used
66 | PROJECTINTO Reg Reg Int -- project argument from one reg into another
68 -- | same as CASE, but there's an exact value (not constructor) in reg
69 | CONSTCASE Reg [(Const, [BC])] (Maybe [BC])
71 -- | just call a function, passing MYOLDBASE (see below) to it
72 | CALL Name
74 -- | same, perhaps exists just for TCO
75 | TAILCALL Name
77 -- | set reg to (apply string args),
78 | FOREIGNCALL Reg FDesc FDesc [(FDesc, Reg)]
80 -- | move this number of elements from TOP to BASE
81 | SLIDE Int
83 -- | set BASE = OLDBASE
84 | REBASE
86 -- | reserve n more stack items (i.e. check there's space, grow if
87 -- necessary)
88 | RESERVE Int
89 | RESERVENOALLOC Int
91 -- | move the top of stack up
92 | ADDTOP Int
94 -- | set TOP = BASE + n
95 | TOPBASE Int
97 -- | set BASE = TOP + n
98 | BASETOP Int
100 -- | set MYOLDBASE = BASE, where MYOLDBASE is a function-local
101 -- variable, set to OLDBASE by default, and passed on function
102 -- call to called functions as their OLDBASE
103 | STOREOLD
105 -- | reg = apply primitive_function args
106 | OP Reg PrimFn [Reg]
108 -- | clear reg
109 | NULL Reg
111 -- | throw an error
112 | ERROR String
113 deriving Show
115toBC :: (Name, SDecl) -> (Name, [BC])
116toBC (n, SFun n' args locs exp)
117 = (n, reserve locs ++ bc RVal exp True)
118 where reserve 0 = []
119 reserve n = [RESERVE n, ADDTOP n]
121clean True = [TOPBASE 0, REBASE]
122clean False = []
124bc :: Reg -> SExp -> Bool -> -- returning
125 [BC]
126bc reg (SV (Glob n)) r = bc reg (SApp False n []) r
127bc reg (SV (Loc i)) r = assign reg (L i) ++ clean r
128bc reg (SApp False f vs) r =
129 if argCount == 0
130 then moveReg 0 vs ++ [STOREOLD, BASETOP 0, CALL f] ++ ret
131 else RESERVENOALLOC argCount : moveReg 0 vs ++
132 [STOREOLD, BASETOP 0, ADDTOP argCount, CALL f] ++ ret
133 where
134 ret = assign reg RVal ++ clean r
135 argCount = length vs
136bc reg (SApp True f vs) r
137 = RESERVENOALLOC (length vs) : moveReg 0 vs
138 ++ [SLIDE (length vs), TOPBASE (length vs), TAILCALL f]
139bc reg (SForeign t fname args) r
140 = FOREIGNCALL reg t fname (map farg args) : clean r
141 where farg (ty, Loc i) = (ty, L i)
142bc reg (SLet (Loc i) e sc) r = bc (L i) e False ++ bc reg sc r
143bc reg (SUpdate (Loc i) sc) r = bc reg sc False ++ [ASSIGN (L i) reg]
144 ++ clean r
145-- bc reg (SUpdate x sc) r = bc reg sc r -- can't update, just do it
146bc reg (SCon atloc i _ vs) r
147 = MKCON reg (getAllocLoc atloc) i (map getL vs) : clean r
148 where getL (Loc x) = L x
149 getAllocLoc (Just (Loc x)) = Just (L x)
150 getAllocLoc _ = Nothing
151bc reg (SProj (Loc l) i) r = PROJECTINTO reg (L l) i : clean r
152bc reg (SConst i) r = ASSIGNCONST reg i : clean r
153bc reg (SOp p vs) r = OP reg p (map getL vs) : clean r
154 where getL (Loc x) = L x
155bc reg (SError str) r = [ERROR str]
156bc reg SNothing r = NULL reg : clean r
157bc reg (SCase up (Loc l) alts) r
158 | isConst alts = constCase reg (L l) alts r
159 | otherwise = conCase True reg (L l) alts r
160bc reg (SChkCase (Loc l) alts) r
161 = conCase False reg (L l) alts r
162bc reg t r = error $ "Can't compile " ++ show t
164isConst [] = False
165isConst (SConstCase _ _ : xs) = True
166isConst (SConCase _ _ _ _ _ : xs) = False
167isConst (_ : xs) = False
169moveReg off [] = []
170moveReg off (Loc x : xs) = assign (T off) (L x) ++ moveReg (off + 1) xs
172assign r1 r2 | r1 == r2 = []
173 | otherwise = [ASSIGN r1 r2]
175conCase safe reg l xs r = [CASE safe l (mapMaybe (caseAlt l reg r) xs)
176 (defaultAlt reg xs r)]
178constCase reg l xs r = [CONSTCASE l (mapMaybe (constAlt l reg r) xs)
179 (defaultAlt reg xs r)]
181caseAlt l reg r (SConCase lvar tag _ args e)
182 = Just (tag, PROJECT l lvar (length args) : bc reg e r)
183caseAlt l reg r _ = Nothing
185constAlt l reg r (SConstCase c e)
186 = Just (c, bc reg e r)
187constAlt l reg r _ = Nothing
189defaultAlt reg [] r = Nothing
190defaultAlt reg (SDefaultCase e : _) r = Just (bc reg e r)
191defaultAlt reg (_ : xs) r = defaultAlt reg xs r