@@ -24,7 +24,8 @@ data CExp = CAtom CAtom
2424data CVal = CTag Local | CIntVal Local
2525 deriving Show
2626
27−-- Assignment is to the return value, or some local register
27+-- Assignment is to the return value, or some local reference
28+-- Local reference <n> means <top of stack> - <n>
2829data Reg = RVal | LVar Local
2930 deriving Show
3031
@@ -42,41 +43,42 @@ type PreC = [CInst]
4243preCdefs :: [(Name, Bytecode)] -> [(Name, (Int, PreC))]
4344preCdefs = map (\ (n, b) -> (n, preC b))
4445
45−atom (BP n) = CP n
46−atom (BL n) = CL n
47−atom (BC c) = CC c
46+atom res (BP n) = CP n
47+atom res (BL n) = CL (res - n)
48+atom res (BC c) = CC c
4849
4950preC :: Bytecode -> (Int, PreC)
50−preC (BGetArgs ns bc) = (length ns, pc RVal bc)
51− where pc loc (BAtom b) = [ASSIGN loc (CAtom (atom b))]
52− pc loc (BApp f as) = [ASSIGN loc (CApp (atom f) (map atom as))]
53− pc loc (BTailApp f as) = [TAILCALL (atom f) (map atom as)]
54− pc loc (BLazy f as) = [ASSIGN loc (CLazy (atom f) (map atom as))]
55− pc loc (BLet x val sc) = pc (LVar x) val ++ pc loc sc
56− pc loc (BFCall c t args)
57− = [ASSIGN loc (CFCall c t (map (\ (a, ty) -> (atom a, ty)) args))]
58− pc loc (BCon t args) = [ASSIGN loc (CCon t (map atom args))]
59− pc loc (BPrimOp s args)
60− = [ASSIGN loc (CPrimOp s (map atom args))]
61− pc loc (BError s) = [ERROR s]
62− pc loc (BCase l alts)
63− = EVAL l :
64− SWITCH (caseTy alts l) (map (pcAlt loc l) (filter notDef alts))
65− (getDefault loc alts) : []
66− pc loc (BReserve s bc) = RESERVE s : pc loc bc
51+preC (BGetArgs ns bc) = (length ns, pc RVal (length ns) bc)
52+ where pc loc d (BAtom b) = [ASSIGN loc (CAtom (atom d b))]
53+ pc loc d (BApp f as) = [ASSIGN loc (CApp (atom d f) (map (atom d) as))]
54+ pc loc d (BTailApp f as) = [TAILCALL (atom d f) (map (atom d) as)]
55+ pc loc d (BLazy f as) = [ASSIGN loc (CLazy (atom d f) (map (atom d) as))]
56+ pc loc d (BLet x val sc) = pc (LVar (d - x)) d val ++ pc loc d sc
57+ pc loc d (BFCall c t args)
58+ = [ASSIGN loc (CFCall c t (map (\ (a, ty) -> (atom d a, ty)) args))]
59+ pc loc d (BCon t args) = [ASSIGN loc (CCon t (map (atom d) args))]
60+ pc loc d (BPrimOp s args)
61+ = [ASSIGN loc (CPrimOp s (map (atom d) args))]
62+ pc loc d (BError s) = [ERROR s]
63+ pc loc d (BCase l alts)
64+ = EVAL (d - l) :
65+ SWITCH (caseTy alts (d - l))
66+ (map (pcAlt loc d l) (filter notDef alts))
67+ (getDefault loc d alts) : []
68+ pc loc d (BReserve s bc) = RESERVE s : pc loc (d + s) bc
6769
6870 notDef (BDefaultCase _) = False
6971 notDef _ = True
7072
71− pcAlt loc var (BConCase t args l bc)
72− = (t, PROJECT var l (length args) :
73− pc loc bc)
74− pcAlt loc var (BConstCase (I c) bc)
75− = (c, pc loc bc)
73+ pcAlt loc d var (BConCase t args l bc)
74+ = (t, PROJECT (d - var) (d - l) (length args) :
75+ pc loc d bc)
76+ pcAlt loc d var (BConstCase (I c) bc)
77+ = (c, pc loc d bc)
7678
77− getDefault loc (BDefaultCase bc : _) = pc loc bc
78− getDefault loc (_ : xs) = getDefault loc xs
79− getDefault loc [] = []
79+ getDefault loc d (BDefaultCase bc : _) = pc loc d bc
80+ getDefault loc d (_ : xs) = getDefault loc d xs
81+ getDefault loc d [] = []
8082
8183 caseTy (BConCase _ _ _ _ : _) = CTag
8284 caseTy (BConstCase _ _ : _) = CIntVal