git.iko.soy/Idris-dev
on cdc823a help sign in
Idris-dev/src/RTS/PreC.hs
103 lines 3.4 kB history raw
1module RTS.PreC where
3-- A representation close to the code we'll be outputting
5import Core.TT
7import RTS.Bytecode
8import RTS.SC
10import Control.Monad.State
12data CAtom = CP Name Int | CL Local | CC Const
13 deriving Show
15data CExp = CAtom CAtom
16 | CApp CAtom [CAtom]
17 | CExactApp Name [CAtom]
18 | CLazy CAtom [CAtom]
19 | CFCall String CType [(CAtom, CType)]
20 | CPrimOp SPrim [CAtom]
21 | CCon Tag [CAtom]
22 deriving Show
24data CVal = CTag Local | CIntVal Local
25 deriving Show
27-- Assignment is to the return value, or some local reference
28-- Local reference <n> means <top of stack> - <n>
29data Reg = RVal | LVar Local
30 deriving Show
32data CInst = ASSIGN Reg CExp
33 | RESERVE Int
34 | CLEAR Int
35 | EVAL Local
36 | PROJECT Local Local Int
37 | SWITCH CVal [(Int, PreC)] PreC
38 | ERROR String
39 | TAILCALL Int -- number of stack items to clear
40 CAtom [CAtom]
41 | TAILCALLEXACT Int Name [CAtom]
42 deriving Show
44type PreC = [CInst]
46preCdefs :: [(Name, (Int, Bytecode))] -> [(Name, (Int, PreC))]
47preCdefs xs = map (\ (n, (i, b)) -> (n, preC xs b)) xs
49atom res (BP n i) = CP n i
50atom res (BL n) = CL (res - n)
51atom res (BC c) = CC c
53preC :: [(Name, (Int, Bytecode))] -> Bytecode -> (Int, PreC)
54preC all (BGetArgs ns bc) = (length ns, pc RVal (length ns) bc)
55 where arity n = do (i, b) <- lookup n all
56 return i
57 exact (BP n i) as = i == length as
58 exact _ as = False
60 getName (BP n i) = n
62 pc loc d (BAtom b) = [ASSIGN loc (CAtom (atom d b))]
63 pc loc d (BApp f as)
64 | exact f as = [ASSIGN loc (CExactApp (getName f) (map (atom d) as))]
65 | otherwise = [ASSIGN loc (CApp (atom d f) (map (atom d) as))]
66 pc loc d (BTailApp f as)
67 | exact f as = [TAILCALLEXACT d (getName f) (map (atom d) as)]
68 | otherwise = [TAILCALL d (atom d f) (map (atom d) as)]
69 pc loc d (BLazy f as) = [ASSIGN loc (CLazy (atom d f) (map (atom d) as))]
70 pc loc d (BLet x val sc) = pc (LVar (d - x)) d val ++ pc loc d sc
71 pc loc d (BFCall c t args)
72 = [ASSIGN loc (CFCall c t (map (\ (a, ty) -> (atom d a, ty)) args))]
73 pc loc d (BCon t args) = [ASSIGN loc (CCon t (map (atom d) args))]
74 pc loc d (BPrimOp s args)
75 = [ASSIGN loc (CPrimOp s (map (atom d) args))]
76 pc loc d (BError s) = [ERROR s]
77 pc loc d (BCase l alts)
78 = EVAL (d - l) :
79 SWITCH (caseTy alts (d - l))
80 (map (pcAlt loc d l) (filter notDef alts))
81 (getDefault loc d alts) : []
82 pc loc d (BReserve s bc) = RESERVE s : pc loc (d + s) bc ++
83 [CLEAR s]
85 notDef (BDefaultCase _) = False
86 notDef _ = True
88 pcAlt loc d var (BConCase t args l bc)
89 = (t, PROJECT (d - var) (d - l) (length args) :
90 pc loc d bc)
91 pcAlt loc d var (BConstCase (I c) bc)
92 = (c, pc loc d bc)
94 getDefault loc d (BDefaultCase bc : _) = pc loc d bc
95 getDefault loc d (_ : xs) = getDefault loc d xs
96 getDefault loc d [] = []
98 caseTy (BConCase _ _ _ _ : _) = CTag
99 caseTy (BConstCase _ _ : _) = CIntVal
100 caseTy (_ : xs) = caseTy xs
101 caseTy [] = CTag