git.iko.soy/Idris-dev
on 496cf41 help sign in
Idris-dev/src/RTS/Bytecode.hs
114 lines 4.7 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 Int | 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, (Int, Bytecode))]
41bcdefs xs = map (\ (n, s) -> (n, bc xs s)) xs
43bc all (SCDef args max c) = (length args,
44 BGetArgs (map fst args) (bcExp all max (length args) c))
46bcExp all v arity x
47 = let (code, max) = runState (bc' True arity x) v
48 space = max - arity in
49 if (space > 0) then BReserve space code else code
50 where
51 ref i = do s <- get
52 when (i > s) $ put i
53 next = do s <- get
54 put (s + 1)
55 return s
56 scarity n = case lookup n all of
57 Just (SCDef args _ _) -> length args
59 bc' :: Bool -> Int -> SCExp -> State Int Bytecode
60 bc' tl d (SRef n) = if tl then return $ BTailApp (BP n (scarity n)) []
61 else return $ BApp (BP n (scarity n)) []
62 bc' tl d (SLoc i) = do ref i; return $ BAtom (BL i)
63 bc' tl d (SApp f args)
64 = do f' <- case f of
65 SRef n -> return $ BAtom (BP n (scarity n))
66 _ -> bc' False d f
67 args' <- mapM (bc' False d) args
68 let bapp = if tl then BTailApp else BApp
69 case f' of
70 BAtom r -> mkApp (\x -> bapp r x) args' []
71 bc -> do v <- next
72 mkApp (\x -> BLet v bc (bapp (BL v) x)) args' []
73 bc' tl d (SLazyApp f args) = do args' <- mapM (bc' False d) args
74 -- let bapp = if tl then BTailApp else BApp
75 mkApp (\x -> BLazy (BP f (scarity f)) x) args' []
76 bc' tl d (SLet n val sc) = do v' <- bc' False d val
77 sc' <- bc' False (d + 1) sc
78 return $ BLet d v' sc'
79 bc' tl d (SCon t args) = do args' <- mapM (bc' False d) args
80 mkApp (\x -> BCon t x) args' []
81 bc' tl d (SFCall c t args) = do args' <- mapM (bc' False d) (map fst args)
82 mkFApp c t (zip args' (map snd args)) []
83 bc' tl d (SConst c) = return $ BAtom (BC c)
84 bc' tl d (SError s) = return $ BError s
85 bc' tl d (SCase e alts) = do e' <- bc' False d e
86 alts' <- mapM (bcAlt tl d) alts
87 case e' of
88 BAtom (BL i) -> return $ BCase i alts'
89 bc -> do v <- next
90 return $ BLet v bc (BCase v alts')
91 bc' tl d (SPrimOp p args) = do args' <- mapM (bc' tl d) args
92 mkApp (\x -> BPrimOp p x) args' []
94 mkApp ap [] locs = return $ ap locs
95 mkApp ap (BAtom (BL i) : as) locs = mkApp ap as (locs ++ [BL i])
96 mkApp ap (a : as) locs = do v <- next
97 app <- mkApp ap as (locs ++ [BL v])
98 return $ BLet v a app
100 bcAlt tl d (SConCase t args e) = do e' <- bc' tl (d + length args) e
101 return $ BConCase t args d e'
102 bcAlt tl d (SConstCase i e) = do e' <- bc' tl d e
103 return $ BConstCase i e'
104 bcAlt tl d (SDefaultCase e) = do e' <- bc' tl d e
105 return $ BDefaultCase e'
107 mkFApp c ty [] locs = return $ BFCall c ty locs
108 mkFApp c ty ((BAtom (BL i), t) : as) locs
109 = mkFApp c ty as (locs ++ [(BL i, t)])
110 mkFApp c ty ((a, t) : as) locs
111 = do v <- next
112 app <- mkFApp c ty as (locs ++ [(BL v, t)])
113 return $ BLet v a app