@@ -7,126 +7,94 @@ import Core.Evaluate
77import Idris.AbsSyntax
88import RTS.SC
99
10−data SValue = VInt Int
11− | VFloat Double
12− | VString String
13− | VChar Char
14− | VBigInt Integer
15− | VRef Int
16− deriving Show
10+import Control.Monad.State
11+
12+type Local = Int
1713
18−data BCOp = PUSH SValue
19− | SLIDE Int -- Keep top stack value, discard n below it
20− | DISCARD Int
21− | DISCARDINT Int
22− | DISCARDFLOAT Int
23− | EVAL Bool
24− | MKCON Tag Arity
25− | MKTHUNK Name Int Arity
26− | MKUNIT
27− | CASE [(Int, Bytecode)] (Maybe Bytecode)
28− | INTCASE [(Int, Bytecode)] (Maybe Bytecode)
29− -- case looks at top stack item, discards immediately,
30− -- places constructor args on stack, last to first (first at ref 0)
31− | SPLIT -- get arguments from constructor form
32− | CALL Name Int -- name, number of arguments to take
33− | CLOSURE Name Int -- as CALL, but always make the closure
34− | CALLVAR Int Int -- stack ref, number of arguments to take
35− | FOREIGNCALL String CType [CType] -- TT constants for types
36− | PRIMOP SPrim [Int] -- apply to list of stack references
37− | ERROR String
38− | DUMP
14+data BAtom = BP Name | BL Local | BC Const
3915 deriving Show
4016
41−type Bytecode = [BCOp]
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)
20+
21+data Bytecode = BAtom BAtom
22+ | BApp BAtom [BAtom]
23+ | BLazy BAtom [BAtom]
24+ | BLet Local Bytecode Bytecode
25+ | BEval Local Bytecode
26+ | BFCall String CType [(BAtom, CType)]
27+ | BCon Tag [BAtom]
28+ | BCase Local [BAlt]
29+ | BPrimOp SPrim [BAtom]
30+ | BError String
31+ | GetArgs [Name] Bytecode -- get function arguments
32+ | Reserve Int Bytecode -- reserve stack space, clear on exit
33+ deriving Show
4234
43−data BCProg = BCProg [(Name, Bytecode)]
35+data BAlt = BConCase Tag [Name] Bytecode
36+ | BConstCase Const Bytecode
37+ | BDefaultCase Bytecode
4438 deriving Show
4539
4640bcdefs :: [(Name, SCDef)] -> [(Name, Bytecode)]
47−bcdefs = map (\ (n, s) -> (n, bc [] s))
48−
49−class BC a where
50− bc :: [(Name, Int)] -> -- local variables + stack offset
51− a -> Bytecode
52−
53−offset :: [(Name, Int)] -> [(Name, Int)]
54−offset = map (\ (n, i) -> (n, i+1))
55−
56−-- A bytecode sequence for an expression evaluates that expression and
57−-- places the result at the top of the stack.
58−
59−instance BC SCDef where
60− bc [] (SCDef args def) = bc (zip (map fst args) [0..]) def
61− ++ [SLIDE (length args)]
62−
63−instance BC SCExp where
64− bc locs (SRef n) = case lookup n locs of
65− Nothing -> [CALL n 0]
66− Just i -> [PUSH (VRef i)]
67− bc locs (SApp (SRef f) args)
68− = bc' locs (reverse args) f
69− where bc' locs [] n
70− = case lookup n locs of
71− Just i -> [CALLVAR i (length args)]
72− Nothing -> [CALL n (length args)]
73− bc' locs (x : xs) f = bc locs x ++
74− bc' (offset locs) xs f
75− bc locs (SApp e args)
76− = bc locs e ++ bc' (offset locs) (reverse args) ++ [SLIDE 1]
77− where bc' locs []
78− = [CALLVAR (length args) (length args)]
79− bc' locs (x : xs) = bc locs x ++
80− bc' (offset locs) xs
81− bc locs (SLazyApp f args)
82− = bc' locs (reverse args) f
83− where bc' locs [] n
84− = case lookup n locs of
85− Just i -> error "Internal error: Lazy call"
86− Nothing -> [CLOSURE n (length args)]
87− bc' locs (x : xs) f = bc locs x ++
88− bc' (offset locs) xs f
89− bc locs (SLet n v sc)
90− = bc locs v ++
91− bc ((n, 0) : offset locs) sc ++
92− [SLIDE 1]
93−
94− bc locs (SFCall cname ty args)
95− = bc' locs (reverse (map fst args))
96− where bc' locs [] = [FOREIGNCALL cname ty (map snd args)]
97− bc' locs (x : xs) = bc locs x ++ EVAL True : bc' (offset locs) xs
98−
99− bc locs (SCon t args)
100− = bc' locs (reverse args)
101− where bc' locs [] = [MKCON t (length args)]
102− bc' locs (x : xs) = bc locs x ++ bc' (offset locs) xs
103−
104− bc locs (SConst (I i)) = [PUSH (VInt i)]
105− bc locs (SConst (BI i)) = [PUSH (VBigInt i)]
106− bc locs (SConst (Fl f)) = [PUSH (VFloat f)]
107− bc locs (SConst (Ch c)) = [PUSH (VChar c)]
108− bc locs (SConst (Str s)) = [PUSH (VString s)]
109− bc locs (SConst _) = [MKUNIT]
110−
111− bc locs (SError str) = [ERROR str]
112−
113− bc locs (SCase n alts)
114− = let (def, cases, ty) = getCases CASE Nothing [] alts in
115− bc locs (SRef n) ++ [EVAL True, ty cases def]
116− where getCases ty def cs [] = (def, reverse cs, ty)
117− getCases ty _ cs (SDefaultCase e : rest)
118− = getCases ty (Just (bc locs e)) cs rest
119− getCases _ def cs (SConstCase (I c) e : rest)
120− = getCases INTCASE def ((c, bc locs e): cs) rest
121− getCases _ def cs (SConCase t ns e : rest)
122− = let locs' = addLocs (reverse ns) locs in
123− getCases CASE def ((t, bc locs' e ++ [SLIDE (length locs')])
124− : cs) rest
125− addLocs [] l = l
126− addLocs (n : ns) locs = addLocs ns ((n, 0) : offset locs)
127−
128− bc locs (SPrimOp p args)
129− = bc' locs (reverse args)
130− where bc' locs [] = [PRIMOP p [0..length args-1]]
131− bc' locs (x : xs) = bc locs x ++ EVAL True : bc' (offset locs) xs
41+bcdefs = map (\ (n, s) -> (n, bc s))
42+
43+bc (SCDef args max c) = GetArgs (map fst args) (bcExp max (length args) c)
44+
45+bcExp v arity x
46+ = let (code, max) = runState (bc' x) v
47+ space = max - arity in
48+ if (space > 0) then Reserve 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
55+
56+ bc' :: SCExp -> State Int Bytecode
57+ bc' (SRef n) = return $ BAtom (BP n)
58+ bc' (SLoc i) = do ref i; return $ BAtom (BL i)
59+ bc' (SApp f args) = do f' <- bc' f
60+ args' <- mapM bc' args
61+ case f' of
62+ BAtom r -> mkApp (\x -> BApp r x) args' []
63+ bc -> do v <- next
64+ mkApp (\x -> BLet v bc (BApp (BL v) x)) args' []
65+ bc' (SLazyApp f args) = do args' <- mapM bc' args
66+ mkApp (\x -> BApp (BP f) x) args' []
67+ bc' (SCon t args) = do args' <- mapM bc' args
68+ mkApp (\x -> BCon t x) args' []
69+ bc' (SFCall c t args) = do args' <- mapM bc' (map fst args)
70+ mkFApp c t (zip args' (map snd args)) []
71+ bc' (SConst c) = return $ BAtom (BC c)
72+ bc' (SError s) = return $ BError s
73+ bc' (SCase e alts) = do e' <- bc' e
74+ alts' <- mapM bcAlt alts
75+ case e' of
76+ BAtom (BL i) -> return $ BCase i alts'
77+ bc -> do v <- next
78+ return $ BLet v bc (BCase v alts')
79+ bc' (SPrimOp p args) = do args' <- mapM bc' args
80+ mkApp (\x -> BPrimOp p x) args' []
81+
82+ mkApp ap [] locs = return $ ap locs
83+ mkApp ap (BAtom (BL i) : as) locs = mkApp ap as (locs ++ [BL i])
84+ mkApp ap (a : as) locs = do v <- next
85+ app <- mkApp ap as (locs ++ [BL v])
86+ return $ BLet v a app
87+
88+ bcAlt (SConCase t args e) = do e' <- bc' e
89+ return $ BConCase t args e'
90+ bcAlt (SConstCase i e) = do e' <- bc' e
91+ return $ BConstCase i e'
92+ bcAlt (SDefaultCase e) = do e' <- bc' e
93+ return $ BDefaultCase e'
94+
95+ mkFApp c ty [] locs = return $ BFCall c ty locs
96+ mkFApp c ty ((BAtom (BL i), t) : as) locs = mkFApp c ty as (locs ++ [(BL i, t)])
97+ mkFApp c ty ((a, t) : as) locs = do v <- next
98+ app <- mkFApp c ty as (locs ++ [(BL v, t)])
99+ return $ BLet v a app
132100