git.iko.soy/Idris-dev
on master help sign in
Tinker with bytecode
0bb157eEdwin Brady
src/IRTS/Bytecode.hs+62−60
compare with master
unifiedsplit
@@ -5,65 +5,67 @@ import IRTS.Simplified
5import Core.TT
5import Core.TT
6import Data.Maybe
6import Data.Maybe
7
7
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.
9
10
11+data Reg = RVal | L Int | T Int
12+ deriving (Show, Eq)
13+
10−-- data BC = ASSIGN Reg Reg
14+data BC = ASSIGN Reg Reg
11−-- | ASSIGNCONST Reg Const
15+ | ASSIGNCONST Reg Const
12−-- | MKCON Reg Int Int
16+ | MKCON Reg Int [Reg]
13−-- | CASE [(Int, [BC])] (Maybe [BC])
17+ | CASE Reg [(Int, [BC])] (Maybe [BC])
18+ | PROJECT Reg Int Int -- get all args from reg, put them from Int onwards
14−-- | GETARGS Int -- discards afterwards
19+ | GETARGS Int -- discards afterwards
15−-- | CONSTCASE [(Const, [BC])] (Maybe [BC])
20+ | CONSTCASE [(Const, [BC])] (Maybe [BC])
16−-- | CALL Name
21+ | CALL Name
17−-- | TAILCALL Name
22+ | TAILCALL Name
18−-- | PRINTNUM
23+ | PRINTNUM
19−-- | PRINTSTR
24+ | PRINTSTR
20−-- | GROWSTACK Int
25+ | GROWSTACK Int
21−-- | DROPSTACK Int
26+ | DROPSTACK Int
22−-- | SLIDE Int Int -- number to drop, number to keep
27+ | SLIDE Int Int -- number to drop, number to keep
23−-- | OP PrimFn
28+ | OP Reg PrimFn [Reg]
24−-- deriving Show
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
25
71
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
src/IRTS/LParser.hs+4−3
@@ -4,6 +4,7 @@ import Core.CoreParser
4import Core.TT
4import Core.TT
5import IRTS.Lang
5import IRTS.Lang
6import IRTS.Simplified
6import IRTS.Simplified
7+import IRTS.Bytecode
7
8
8import Text.ParserCombinators.Parsec
9import Text.ParserCombinators.Parsec
9import Text.ParserCombinators.Parsec.Error
10import Text.ParserCombinators.Parsec.Error
@@ -47,9 +48,9 @@ fovm f = do defs <- parseFOVM f
47 let ctxtIn = addAlist tagged emptyContext
48 let ctxtIn = addAlist tagged emptyContext
48 let checked = checkDefs ctxtIn tagged
49 let checked = checkDefs ctxtIn tagged
49 print checked
50 print checked
50−-- case checked of
51+ case checked of
51−-- OK c -> do let bc = mapMaybe toBC c
52+ OK c -> do let bc = map toBC c
52−-- print bc
53+ print bc
53
54
54parseFOVM :: FilePath -> IO [(Name, LDecl)]
55parseFOVM :: FilePath -> IO [(Name, LDecl)]
55parseFOVM fname = do putStrLn $ "Reading " ++ fname
56parseFOVM fname = do putStrLn $ "Reading " ++ fname
src/IRTS/Simplified.hs+13−10
@@ -17,12 +17,12 @@ data SExp = SV LVar
17 | SOp PrimFn [LVar]
17 | SOp PrimFn [LVar]
18 deriving Show
18 deriving Show
19
19
20−data SAlt = SConCase Int Name [Name] SExp
20+data SAlt = SConCase Int Int Name [Name] SExp
21 | SConstCase Const SExp
21 | SConstCase Const SExp
22 | SDefaultCase SExp
22 | SDefaultCase SExp
23 deriving Show
23 deriving Show
24
24
25−data SDecl = SFun Name [Name] SExp
25+data SDecl = SFun Name [Name] Int SExp
26 deriving Show
26 deriving Show
27
27
28hvar :: State (LDefs, Int) Int
28hvar :: State (LDefs, Int) Int
@@ -76,7 +76,7 @@ mkapp f args = mkapp' f args [] where
76 return (SLet x e sc)
76 return (SLet x e sc)
77
77
78sAlt (LConCase i n args e) = do e' <- simplify e
78sAlt (LConCase i n args e) = do e' <- simplify e
79− return (SConCase i n args e')
79+ return (SConCase (-1) i n args e')
80sAlt (LConstCase c e) = do e' <- simplify e
80sAlt (LConstCase c e) = do e' <- simplify e
81 return (SConstCase c e')
81 return (SConstCase c e')
82sAlt (LDefaultCase e) = do e' <- simplify e
82sAlt (LDefaultCase e) = do e' <- simplify e
@@ -89,15 +89,18 @@ checkDefs ctxt (con@(n, LConstructor _ _ _) : xs)
89 return xs'
89 return xs'
90checkDefs ctxt ((n, LFun n' args exp) : xs)
90checkDefs ctxt ((n, LFun n' args exp) : xs)
91 = do let sexp = evalState (simplify exp) (ctxt, 0)
91 = do let sexp = evalState (simplify exp) (ctxt, 0)
92− exp' <- scopecheck ctxt (zip args [0..]) sexp
92+ (exp', locs) <- runStateT (scopecheck ctxt (zip args [0..]) sexp) (-1)
93 xs' <- checkDefs ctxt xs
93 xs' <- checkDefs ctxt xs
94− return ((n, SFun n' args exp') : xs')
94+ return ((n, SFun n' args ((locs + 1) - length args) exp') : xs')
95
95
96+lvar v = do i <- get
97+ put (max i v)
98+
96−scopecheck :: LDefs -> [(Name, Int)] -> SExp -> TC SExp
99+scopecheck :: LDefs -> [(Name, Int)] -> SExp -> StateT Int TC SExp
97scopecheck ctxt env tm = sc env tm where
100scopecheck ctxt env tm = sc env tm where
98 sc env (SV (Glob n)) =
101 sc env (SV (Glob n)) =
99 case lookup n (reverse env) of -- most recent first
102 case lookup n (reverse env) of -- most recent first
100− Just i -> return (SV (Loc i))
103+ Just i -> do lvar i; return (SV (Loc i))
101 Nothing -> case lookupCtxt Nothing n ctxt of
104 Nothing -> case lookupCtxt Nothing n ctxt of
102 [LConstructor _ i ar] ->
105 [LConstructor _ i ar] ->
103 if ar == 0 then return (SCon i n [])
106 if ar == 0 then return (SCon i n [])
@@ -141,7 +144,7 @@ scopecheck ctxt env tm = sc env tm where
141
144
142 scVar env (Glob n) =
145 scVar env (Glob n) =
143 case lookup n (reverse env) of -- most recent first
146 case lookup n (reverse env) of -- most recent first
144− Just i -> return (Loc i)
147+ Just i -> do lvar i; return (Loc i)
145 Nothing -> case lookupCtxt Nothing n ctxt of
148 Nothing -> case lookupCtxt Nothing n ctxt of
146 [LConstructor _ i ar] ->
149 [LConstructor _ i ar] ->
147 fail $ "Codegen error : can't pass constructor here"
150 fail $ "Codegen error : can't pass constructor here"
@@ -149,7 +152,7 @@ scopecheck ctxt env tm = sc env tm where
149 [] -> fail $ "Codegen error: No such variable " ++ show n
152 [] -> fail $ "Codegen error: No such variable " ++ show n
150 scVar _ x = return x
153 scVar _ x = return x
151
154
152− scalt env (SConCase i n args e)
155+ scalt env (SConCase _ i n args e)
153 = do let env' = env ++ zip args [length env..]
156 = do let env' = env ++ zip args [length env..]
154 tag <- case lookupCtxt Nothing n ctxt of
157 tag <- case lookupCtxt Nothing n ctxt of
155 [LConstructor _ i ar] ->
158 [LConstructor _ i ar] ->
@@ -158,7 +161,7 @@ scopecheck ctxt env tm = sc env tm where
158 " has arity " ++ show ar
161 " has arity " ++ show ar
159 _ -> fail $ "Codegen error: No constructor " ++ show n
162 _ -> fail $ "Codegen error: No constructor " ++ show n
160 e' <- sc env' e
163 e' <- sc env' e
161− return (SConCase tag n args e')
164+ return (SConCase (length env) tag n args e')
162 scalt env (SConstCase c e) = do e' <- sc env e
165 scalt env (SConstCase c e) = do e' <- sc env e
163 return (SConstCase c e')
166 return (SConstCase c e')
164 scalt env (SDefaultCase e) = do e' <- sc env e
167 scalt env (SDefaultCase e) = do e' <- sc env e