git.iko.soy/Idris-dev
on fa0ecde help sign in
Idris-dev/src/RTS/Bytecode.hs
111 lines 4.5 kB history raw
1module RTS.Bytecode where
3import Core.TT
4import Core.CaseTree
5import Core.Evaluate
7import Idris.AbsSyntax
8import RTS.SC
10import Control.Monad.State
12type Local = Int
14data BAtom = BP Name | BL Local | BC Const
15 deriving Show
17-- Like SC, but with explicit evaluation, de Bruijn levels for locals, and all
18-- intermediate values put into variables (which can be stored on the stack or
19-- in registers when generating code)
21data Bytecode = BAtom BAtom
22 | BApp BAtom [BAtom]
23 | BTailApp BAtom [BAtom]
24 | BLazy BAtom [BAtom]
25 | BLet Local Bytecode Bytecode
26 | BFCall String CType [(BAtom, CType)]
27 | BCon Tag [BAtom]
28 | BCase Local [BAlt]
29 | BPrimOp SPrim [BAtom]
30 | BError String
31 | BGetArgs [Name] Bytecode -- get function arguments
32 | BReserve Int Bytecode -- reserve stack space, clear on exit
33 deriving Show
35data BAlt = BConCase Tag [Name] Int Bytecode
36 | BConstCase Const Bytecode
37 | BDefaultCase Bytecode
38 deriving Show
40bcdefs :: [(Name, SCDef)] -> [(Name, Bytecode)]
41bcdefs = map (\ (n, s) -> (n, bc s))
43bc (SCDef args max c) = BGetArgs (map fst args) (bcExp max (length args) c)
45bcExp v arity x
46 = let (code, max) = runState (bc' True arity x) v
47 space = max - arity in
48 if (space > 0) then BReserve space code else code
49 where
50 ref i = do s <- get
51 when (i > s) $ put i
52 next = do s <- get
53 put (s + 1)
54 return s
56 bc' :: Bool -> Int -> SCExp -> State Int Bytecode
57 bc' tl d (SRef n) = if tl then return $ BTailApp (BP n) []
58 else return $ BApp (BP n) []
59 bc' tl d (SLoc i) = do ref i; return $ BAtom (BL i)
60 bc' tl d (SApp f args)
61 = do f' <- case f of
62 SRef n -> return $ BAtom (BP n)
63 _ -> bc' False d f
64 args' <- mapM (bc' False d) args
65 let bapp = if tl then BTailApp else BApp
66 case f' of
67 BAtom r -> mkApp (\x -> bapp r x) args' []
68 bc -> do v <- next
69 mkApp (\x -> BLet v bc (bapp (BL v) x)) args' []
70 bc' tl d (SLazyApp f args) = do args' <- mapM (bc' False d) args
71 let bapp = if tl then BTailApp else BApp
72 mkApp (\x -> bapp (BP f) x) args' []
73 bc' tl d (SLet n val sc) = do v' <- bc' False d val
74 sc' <- bc' False (d + 1) sc
75 return $ BLet d v' sc'
76 bc' tl d (SCon t args) = do args' <- mapM (bc' False d) args
77 mkApp (\x -> BCon t x) args' []
78 bc' tl d (SFCall c t args) = do args' <- mapM (bc' False d) (map fst args)
79 mkFApp c t (zip args' (map snd args)) []
80 bc' tl d (SConst c) = return $ BAtom (BC c)
81 bc' tl d (SError s) = return $ BError s
82 bc' tl d (SCase e alts) = do e' <- bc' False d e
83 alts' <- mapM (bcAlt tl d) alts
84 case e' of
85 BAtom (BL i) -> return $ BCase i alts'
86 bc -> do v <- next
87 return $ BLet v bc (BCase v alts')
88 bc' tl d (SPrimOp p args) = do args' <- mapM (bc' tl d) args
89 mkApp (\x -> BPrimOp p x) args' []
91 mkApp ap [] locs = return $ ap locs
92 mkApp ap (BAtom (BL i) : as) locs = mkApp ap as (locs ++ [BL i])
93 mkApp ap (a : as) locs = do v <- next
94 app <- mkApp ap as (locs ++ [BL v])
95 return $ BLet v a app
97 bcAlt tl d (SConCase t args e) = do e' <- bc' tl (d + length args) e
98 return $ BConCase t args d e'
99 bcAlt tl d (SConstCase i e) = do e' <- bc' tl d e
100 return $ BConstCase i e'
101 bcAlt tl d (SDefaultCase e) = do e' <- bc' tl d e
102 return $ BDefaultCase e'
104 mkFApp c ty [] locs = return $ BFCall c ty locs
105 mkFApp c ty ((BAtom (BL i), t) : as) locs
106 = mkFApp c ty as (locs ++ [(BL i, t)])
107 mkFApp c ty ((a, t) : as) locs
108 = do v <- next
109 app <- mkFApp c ty as (locs ++ [(BL v, t)])
110 return $ BLet v a app