git.iko.soy/Idris-dev
on 7afa310 help sign in
Idris-dev/src/IRTS/DumpBC.hs
78 lines 3.1 kB history raw
1module IRTS.DumpBC where
3import IRTS.Lang
4import IRTS.Simplified
5import Idris.Core.TT
7import IRTS.Bytecode
8import Data.List
10interMap :: [a] -> [b] -> (a -> [b]) -> [b]
11interMap xs y f = concat (intersperse y (map f xs))
13indent :: Int -> String
14indent n = replicate (n*4) ' '
16serializeReg :: Reg -> String
17serializeReg (L n) = "L" ++ show n
18serializeReg (T n) = "T" ++ show n
19serializeReg r = show r
21serializeCase :: Show a => Int -> (a, [BC]) -> String
22serializeCase n (x, bcs) =
23 indent n ++ show x ++ ":\n" ++ interMap bcs "\n" (serializeBC (n + 1))
25serializeDefault :: Int -> [BC] -> String
26serializeDefault n bcs =
27 indent n ++ "default:\n" ++ interMap bcs "\n" (serializeBC (n + 1))
29serializeBC :: Int -> BC -> String
30serializeBC 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 Nothing b xs ->
39 "MKCON " ++ serializeReg a ++ " " ++ show b ++ " [" ++ (interMap xs ", " serializeReg) ++ "]"
40 MKCON a (Just r) b xs ->
41 "MKCON@" ++ serializeReg r ++ " " ++ serializeReg a ++ " " ++ show b ++ " [" ++ (interMap xs ", " serializeReg) ++ "]"
42 CASE safe r cases def ->
43 "CASE " ++ serializeReg r ++ ":\n" ++ interMap cases "\n" (serializeCase (n + 1)) ++
44 maybe "" (\def' -> "\n" ++ serializeDefault (n + 1) def') def
45 PROJECT a b c ->
46 "PROJECT " ++ serializeReg a ++ " " ++ show b ++ " " ++ show c
47 PROJECTINTO a b c ->
48 "PROJECTINTO " ++ serializeReg a ++ " " ++ serializeReg b ++ " " ++ show c
49 CONSTCASE r cases def ->
50 "CONSTCASE " ++ serializeReg r ++ ":\n" ++ interMap cases "\n" (serializeCase (n + 1)) ++
51 maybe "" (\def' -> "\n" ++ serializeDefault (n + 1) def') def
52 CALL x -> "CALL " ++ show x
53 TAILCALL x -> "TAILCALL " ++ show x
54 FOREIGNCALL r _ ret name args ->
55 "FOREIGNCALL " ++ serializeReg r ++ " \"" ++ name ++ "\" " ++ show ret ++
56 " [" ++ interMap args ", " (\(ty, r) -> serializeReg r ++ " : " ++ show ty) ++ "]"
57 SLIDE n -> "SLIDE " ++ show n
58 REBASE -> "REBASE"
59 RESERVE n -> "RESERVE " ++ show n
60 ADDTOP n -> "ADDTOP " ++ show n
61 TOPBASE n -> "TOPBASE " ++ show n
62 BASETOP n -> "BASETOP " ++ show n
63 STOREOLD -> "STOREOLD"
64 OP a b c ->
65 "OP " ++ serializeReg a ++ " " ++ show b ++ " [" ++ interMap c ", " serializeReg ++ "]"
66 NULL r -> "NULL " ++ serializeReg r
67 ERROR s -> "ERROR \"" ++ s ++ "\"" -- FIXME: s may contain quotes
68 -- Issue #1596
69serialize :: [(Name, [BC])] -> String
70serialize decls =
71 interMap decls "\n\n" serializeDecl
72 where
73 serializeDecl :: (Name, [BC]) -> String
74 serializeDecl (name, bcs) =
75 show name ++ ":\n" ++ interMap bcs "\n" (serializeBC 1)
77dumpBC :: [(Name, SDecl)] -> String -> IO ()
78dumpBC c output = writeFile output $ serialize $ map toBC c