@@ -5,65 +5,67 @@ import IRTS.Simplified
55import Core.TT
66import Data.Maybe
77
8−-- data Reg = RVal | CaseVar | L Int
8+-- TODO: Need L to refer from the bottom of the current stack frame,
9+-- T from the top.
910
10−-- data BC = ASSIGN Reg Reg
11−-- | ASSIGNCONST Reg Const
12−-- | MKCON Reg Int Int
13−-- | CASE [(Int, [BC])] (Maybe [BC])
14−-- | GETARGS Int -- discards afterwards
15−-- | CONSTCASE [(Const, [BC])] (Maybe [BC])
16−-- | CALL Name
17−-- | TAILCALL Name
18−-- | PRINTNUM
19−-- | PRINTSTR
20−-- | GROWSTACK Int
21−-- | DROPSTACK Int
22−-- | SLIDE Int Int -- number to drop, number to keep
23−-- | OP PrimFn
24−-- deriving Show
11+data Reg = RVal | L Int | T Int
12+ deriving (Show, Eq)
13+
14+data BC = ASSIGN Reg Reg
15+ | ASSIGNCONST Reg Const
16+ | MKCON Reg Int [Reg]
17+ | CASE Reg [(Int, [BC])] (Maybe [BC])
18+ | PROJECT Reg Int Int -- get all args from reg, put them from Int onwards
19+ | GETARGS Int -- discards afterwards
20+ | CONSTCASE [(Const, [BC])] (Maybe [BC])
21+ | CALL Name
22+ | TAILCALL Name
23+ | PRINTNUM
24+ | PRINTSTR
25+ | GROWSTACK Int
26+ | DROPSTACK Int
27+ | SLIDE Int Int -- number to drop, number to keep
28+ | OP Reg PrimFn [Reg]
29+ deriving Show
30+
31+toBC :: (Name, SDecl) -> (Name, [BC])
32+toBC (n, SFun n' args locs exp)
33+ = (n, GROWSTACK locs : bc RVal exp (length args + locs))
34+
35+clean 0 = []
36+clean c = [DROPSTACK c]
37+
38+bc :: Reg -> SExp -> Int -> [BC]
39+bc reg (SV (Glob n)) c = [CALL n] ++ assign reg RVal ++ clean c
40+bc reg (SV (Loc i)) c = assign reg (L i) ++ clean c
41+bc reg (SApp tc f vs) c
42+ = GROWSTACK (length vs) : moveReg (c + length vs) vs
43+ ++ [CALL f] ++ assign reg RVal ++ clean c
44+bc reg (SLet (Loc i) e sc) c = bc (L i) e 0 ++ bc reg sc c
45+bc reg (SCon i _ vs) c = MKCON reg i (map getL vs) : clean c
46+ where getL (Loc x) = L x
47+bc reg (SConst i) c = ASSIGNCONST reg i : clean c
48+bc reg (SOp p vs) c = OP reg p (map getL vs) : clean c
49+ where getL (Loc x) = L x
50+bc reg (SCase (Loc l) alts) c
51+ | isConst alts = undefined -- constCase reg c l alts
52+ | otherwise = conCase reg c (L l) alts : clean c
53+
54+isConst [] = False
55+isConst (SConstCase _ _ : xs) = True
56+isConst (SConCase _ _ _ _ _ : xs) = False
57+isConst (_ : xs) = False
58+
59+moveReg off [] = []
60+moveReg off (Loc x : xs) = assign (L off) (L x) ++ moveReg (off + 1) xs
61+
62+assign r1 r2 | r1 == r2 = []
63+ | otherwise = [ASSIGN r1 r2]
64+
65+conCase reg c l xs = CASE l (mapMaybe (caseAlt l reg c) xs)
66+ Nothing
67+
68+caseAlt l reg c (SConCase lvar tag _ args e)
69+ = Just (tag, PROJECT l lvar (length args) : bc reg e c)
70+caseAlt l reg c _ = Nothing
2571
26−-- toBC :: (Name, LDecl) -> Maybe (Name, [BC])
27−-- toBC (n, LConstructor _ _ _) = Nothing
28−-- toBC (n, LFun n' args exp) = let cleanup = [SLIDE (length args) 1] in
29−-- Just (n, bc (length args - 1) exp cleanup)
30−--
31−-- bc :: Int -> LExp -> [BC] -> [BC]
32−-- bc top (LV (Glob n)) c = [CALL n] ++ c
33−-- bc top (LV (Loc i)) c = [PUSH (top-i)] ++ c
34−-- bc top (LApp tc fn args) c
35−-- = bcArgs top args ++
36−-- if tc then [SLIDE top (length args), TAILCALL fn]
37−-- else [CALL fn] ++ c
38−-- bc top (LCon tag _ args) c
39−-- = bcArgs top args ++ [MKCON tag (length args)] ++ c
40−-- bc top (LConst i) c = [PUSHCONST i] ++ c
41−-- bc top (LCase e alts) c = bc top e [] ++
42−-- if constCase alts then bcCaseConst top alts
43−-- else bcCase top alts
44−-- ++ c
45−-- bc top (LLet _ v e) c = bc top v [] ++ bc (top + 1) e [] ++ c
46−-- bc top (LOp prim args) c = bcArgs top args ++ [OP prim] ++ c
47−--
48−-- bcArgs top [] = []
49−-- bcArgs top (x : xs) = bc top x [] ++ bcArgs (top + 1) xs
50−--
51−-- constCase (LConstCase _ _ : _) = True
52−-- constCase (LConCase _ _ _ _ : _) = False
53−-- constCase (_ : xs) = constCase xs
54−-- constCase _ = False
55−--
56−-- bcCase top xs = [CASE (mapMaybe (conClause top) xs) (defaultCase top xs)]
57−-- bcCaseConst top xs = [CONSTCASE (mapMaybe (constClause top) xs) (defaultCase top xs)]
58−--
59−-- conClause top (LConCase tag _ args e) = Just (tag, GETARGS (length args) :
60−-- bc (top + length args) e []
61−-- ++ [SLIDE (length args) 1])
62−-- conClause top _ = Nothing
63−--
64−-- constClause top (LConstCase c e) = Just (c, bc top e [])
65−-- constClause top _ = Nothing
66−--
67−-- defaultCase top [] = Nothing
68−-- defaultCase top (LDefaultCase e : xs) = Just (bc top e [])
69−-- defaultCase top (_ : xs) = defaultCase top xs