@@ -0,0 +1,76 @@
1+module IRTS.DumpBC where
2+
3+import IRTS.Lang
4+import IRTS.Simplified
5+import Core.TT
6+
7+import IRTS.Bytecode
8+import Data.List
9+
10+interMap :: [a] -> [b] -> (a -> [b]) -> [b]
11+interMap xs y f = concat (intersperse y (map f xs))
12+
13+indent :: Int -> String
14+indent n = replicate (n*4) ' '
15+
16+serializeReg :: Reg -> String
17+serializeReg (L n) = "L" ++ show n
18+serializeReg (T n) = "T" ++ show n
19+serializeReg r = show r
20+
21+serializeCase :: Show a => Int -> (a, [BC]) -> String
22+serializeCase n (x, bcs) =
23+ indent n ++ show x ++ ":\n" ++ interMap bcs "\n" (serializeBC (n + 1))
24+
25+serializeDefault :: Int -> [BC] -> String
26+serializeDefault n bcs =
27+ indent n ++ "default:\n" ++ interMap bcs "\n" (serializeBC (n + 1))
28+
29+serializeBC :: Int -> BC -> String
30+serializeBC n bc = indent n ++
31+ case bc of
32+ ASSIGN a b ->
33+ "ASSIGN " ++ serializeReg a ++ " " ++ serializeReg b
34+ ASSIGNCONST a b ->
35+ "ASSIGNCONST " ++ serializeReg a ++ " " ++ show b
36+ UPDATE a b ->
37+ "UPDATE " ++ serializeReg a ++ " " ++ serializeReg b
38+ MKCON a b xs ->
39+ "MKCON " ++ serializeReg a ++ " " ++ show b ++ " [" ++ (interMap xs ", " serializeReg) ++ "]"
40+ CASE r cases def ->
41+ "CASE " ++ serializeReg r ++ ":\n" ++ interMap cases "\n" (serializeCase (n + 1)) ++
42+ maybe "" (\def' -> "\n" ++ serializeDefault (n + 1) def') def
43+ PROJECT a b c ->
44+ "PROJECT " ++ serializeReg a ++ " " ++ show b ++ " " ++ show c
45+ PROJECTINTO a b c ->
46+ "PROJECTINTO " ++ serializeReg a ++ " " ++ serializeReg b ++ " " ++ show c
47+ CONSTCASE r cases def ->
48+ "CONSTCASE " ++ serializeReg r ++ ":\n" ++ interMap cases "\n" (serializeCase (n + 1)) ++
49+ maybe "" (\def' -> "\n" ++ serializeDefault (n + 1) def') def
50+ CALL x -> "CALL " ++ show x
51+ TAILCALL x -> "TAILCALL " ++ show x
52+ FOREIGNCALL r _ ret name args ->
53+ "FOREIGNCALL " ++ serializeReg r ++ " \"" ++ name ++ "\" " ++ show ret ++
54+ " [" ++ interMap args ", " (\(ty, r) -> serializeReg r ++ " : " ++ show ty) ++ "]"
55+ SLIDE n -> "SLIDE " ++ show n
56+ REBASE -> "REBASE"
57+ RESERVE n -> "RESERVE " ++ show n
58+ ADDTOP n -> "ADDTOP " ++ show n
59+ TOPBASE n -> "TOPBASE " ++ show n
60+ BASETOP n -> "BASETOP " ++ show n
61+ STOREOLD -> "STOREOLD"
62+ OP a b c ->
63+ "OP " ++ serializeReg a ++ " " ++ show b ++ " [" ++ interMap c ", " serializeReg ++ "]"
64+ NULL r -> "NULL " ++ show r
65+ ERROR s -> "ERROR \"" ++ s ++ "\"" -- FIXME: s may contain quotes
66+
67+serialize :: [(Name, [BC])] -> String
68+serialize decls =
69+ interMap decls "\n\n" serializeDecl
70+ where
71+ serializeDecl :: (Name, [BC]) -> String
72+ serializeDecl (name, bcs) =
73+ show name ++ ":\n" ++ interMap bcs "\n" (serializeBC 1)
74+
75+dumpBC :: [(Name, SDecl)] -> String -> IO ()
76+dumpBC c output = writeFile output $ serialize $ map toBC c