@@ -12,7 +12,7 @@ data Value = VInt Int
1212 deriving Show
1313
1414data BCOp = PUSH Value
15− | SLIDE Int
15+ | SLIDE Int -- Keep top stack value, discard n below it
1616 | DISCARD Int
1717 | DISCARDINT Int
1818 | DISCARDFLOAT Int
@@ -21,8 +21,12 @@ data BCOp = PUSH Value
2121 | MKTHUNK Name Int Arity
2222 | MKUNIT
2323 | CASE [(Int, Bytecode)] (Maybe Bytecode)
24+ | INTCASE [(Int, Bytecode)] (Maybe Bytecode)
25+ -- case looks at top stack item, discards immediately,
26+ -- places constructor args on stack, last to first
2427 | SPLIT -- get arguments from constructor form
25− | CALL Name
28+ | CALL Name Int -- name, number of arguments to take
29+ | CALLVAR Int Int -- stack ref, number of arguments to take
2630 | FOREIGNCALL String CType [CType] -- TT constants for types
2731 | ERROR String
2832 | DUMP
@@ -33,3 +37,77 @@ type Bytecode = [BCOp]
3337data BCProg = BCProg [(Name, Bytecode)]
3438 deriving Show
3539
40+bcdefs :: [(Name, SCDef)] -> [(Name, Bytecode)]
41+bcdefs = map (\ (n, s) -> (n, bc [] s))
42+
43+class BC a where
44+ bc :: [(Name, Int)] -> -- local variables + stack offset
45+ a -> Bytecode
46+
47+offset :: [(Name, Int)] -> [(Name, Int)]
48+offset = map (\ (n, i) -> (n, i+1))
49+
50+-- A bytecode sequence for an expression evaluates that expression and
51+-- places the result at the top of the stack.
52+
53+instance BC SCDef where
54+ bc [] (SCDef args def) = bc (zip (map fst args) [0..]) def
55+ ++ [SLIDE (length args)]
56+
57+instance BC SCExp where
58+ bc locs (SRef n) = case lookup n locs of
59+ Nothing -> [CALL n 0]
60+ Just i -> [PUSH (VRef i)]
61+ bc locs (SApp (SRef f) args)
62+ = bc' locs (reverse args) f
63+ where bc' locs [] n
64+ = case lookup n locs of
65+ Just i -> [CALLVAR i (length args)]
66+ Nothing -> [CALL n (length args)]
67+ bc' locs (x : xs) f = bc locs x ++
68+ bc' (offset locs) xs f
69+ bc locs (SApp e args)
70+ = bc locs e ++ bc' (offset locs) (reverse args) ++ [SLIDE 1]
71+ where bc' locs []
72+ = [CALLVAR (length args) (length args)]
73+ bc' locs (x : xs) = bc locs x ++
74+ bc' (offset locs) xs
75+ bc locs (SLet n v sc)
76+ = bc locs v ++
77+ bc ((n, 0) : offset locs) sc ++
78+ [SLIDE 1]
79+
80+ bc locs (SFCall cname ty args)
81+ = bc' locs (reverse (map fst args))
82+ where bc' locs [] = [FOREIGNCALL cname ty (map snd args)]
83+ bc' locs (x : xs) = bc locs x ++ bc' (offset locs) xs
84+
85+ bc locs (SCon t args)
86+ = bc' locs (reverse args)
87+ where bc' locs [] = [MKCON t (length args)]
88+ bc' locs (x : xs) = bc locs x ++ bc' (offset locs) xs
89+
90+ bc locs (SConst (I i)) = [PUSH (VInt i)]
91+ bc locs (SConst (BI i)) = [PUSH (VBigInt i)]
92+ bc locs (SConst (Fl f)) = [PUSH (VFloat f)]
93+ bc locs (SConst (Ch c)) = [PUSH (VChar c)]
94+ bc locs (SConst (Str s)) = [PUSH (VString s)]
95+ bc locs (SConst _) = [MKUNIT]
96+
97+ bc locs (SError str) = [ERROR str]
98+
99+ bc locs (SCase n alts)
100+ = let (def, cases, ty) = getCases CASE Nothing [] alts in
101+ bc locs (SRef n) ++ [ty cases def]
102+ where getCases ty def cs [] = (def, reverse cs, ty)
103+ getCases ty _ cs (SDefaultCase e : rest)
104+ = getCases ty (Just (bc locs e)) cs rest
105+ getCases _ def cs (SConstCase (I c) e : rest)
106+ = getCases INTCASE def ((c, bc locs e): cs) rest
107+ getCases _ def cs (SConCase t ns e : rest)
108+ = let locs' = addLocs (reverse ns) locs in
109+ getCases CASE def ((t, bc locs' e ++ [SLIDE (length locs')])
110+ : cs) rest
111+ addLocs [] l = l
112+ addLocs (n : ns) locs = addLocs ns ((n, 0) : offset locs)
113+