@@ -0,0 +1,96 @@
1+module RTS.CodegenC where
2+
3+import Core.TT
4+import RTS.PreC
5+import RTS.SC
6+
7+import Data.Char
8+
9+cdefs :: [(Name, (Int, PreC))] -> String
10+cdefs xs = concatMap (\ (n, (i, c)) -> proto n) xs ++ "\n" ++
11+ concatMap (\ (n, (i, c)) -> codegenC n i c) xs
12+
13+codegenC :: Name -> Int -> PreC -> String
14+codegenC n args prec
15+ = "void " ++ cname n ++ "(VM* vm) {\n" ++
16+ concatMap (cg 1) prec ++ "}\n\n"
17+
18+indent i = take (i * 4) (repeat ' ')
19+
20+reg RVal = "vm->ret"
21+reg (LVar v) = "*(vm->stack-" ++ show v ++ ")"
22+
23+catom :: CAtom -> String
24+catom (CL l) = reg (LVar l)
25+catom (CC (I i)) = "MKINT(" ++ show i ++ ")"
26+catom (CP n) = cname n
27+
28+assignCon i r tag args
29+ = indent i ++ reg r ++ " = MKCON(" ++ show tag ++ ", " ++
30+ show (length args) ++ ");\n" ++
31+ indent i ++ setArgs 0 args ++ "\n"
32+ where
33+ setArgs i [] = ""
34+ setArgs i (a : as) = "SETARG(" ++ reg r ++ ", " ++
35+ show i ++ ", " ++ catom a ++ "); "
36+ ++ setArgs (i + 1) as
37+
38+assignFn i r f args
39+ = indent i ++ "EXTEND(" ++ show (length args) ++ ");\n" ++
40+ indent i ++ setArgs 1 (reverse args) ++ "\n"
41+ -- indent i ++ "CALL(" ++ reg r ++ ", " ++ cname f ++ ");\n"
42+ where
43+ setArgs i [] = ""
44+ setArgs i (a : as) = reg (LVar i) ++ " = " ++ catom a ++ "; "
45+ ++ setArgs (i + 1) as
46+
47+tailCall i d f args
48+ = indent i ++ "EXTEND(" ++ show (length args) ++ ");\n" ++
49+ indent i ++ setArgs 1 (reverse args) ++ "\n"
50+-- indent i ++ "TAILCALL(" ++ show d ++ ", " ++ cname f ++ ");\n"
51+ where
52+ setArgs i [] = ""
53+ setArgs i (a : as) = reg (LVar i) ++ " = " ++ catom a ++ "; "
54+ ++ setArgs (i + 1) as
55+
56+cg :: Int -> CInst -> String
57+cg i (ASSIGN r (CCon t args))
58+ = assignCon i r t args
59+cg i (ASSIGN r (CApp f args))
60+ = assignFn i r f args
61+cg i (ASSIGN r (CAtom e)) = indent i ++ reg r ++ " = " ++ catom e ++ ";\n"
62+cg i (RESERVE s) = indent i ++ "EXTEND(" ++ show s ++ ");\n"
63+cg i (CLEAR s) = indent i ++ "CLEAR(" ++ show s ++ ");\n"
64+cg i (EVAL e) = indent i ++ "EVAL(" ++ reg (LVar e) ++ ");\n"
65+cg i (PROJECT scr loc num)
66+ = indent i ++ "PROJECT(" ++ reg (LVar scr) ++ ", " ++
67+ reg (LVar loc) ++ ", " ++ show num ++ ");\n"
68+cg i (SWITCH v bs def)
69+ = indent i ++ "switch(" ++ sval v ++ ") {\n" ++
70+ concatMap branch bs ++
71+ indent i ++ "default:\n" ++ concatMap (cg (i+1)) def ++
72+ indent (i+1) ++ "break;\n" ++
73+ indent i ++ "};\n"
74+ where sval (CTag l) = "TAG(" ++ reg (LVar l) ++ ")"
75+ sval (CIntVal l) = "GETINT(" ++ reg (LVar l) ++ ")"
76+
77+ branch (t, c) = indent i ++ "case " ++ show t ++ ":\n" ++
78+ concatMap (cg (i+1)) c ++
79+ indent (i+1) ++ "break;\n"
80+cg i (TAILCALL d f args) = tailCall i d f args
81+cg i (ERROR s) = indent i ++ "ERROR(" ++ show s ++ ")\n";
82+cg i _ = indent i ++ "NOT DONE;\n"
83+
84+cname :: Name -> String
85+cname (UN s) = "_I_" ++ toC s
86+cname (MN i s) = "_M_I_" ++ show i ++ "_" ++ toC s
87+cname (NS n ss) = "_" ++ showSep "_" (map toC ss) ++ cname n
88+
89+toC s = concatMap special s
90+ where special c | isAlphaNum c = [c]
91+ | c == '_' = "__"
92+ | otherwise = "_" ++ show (fromEnum c) ++ "_"
93+
94+proto :: Name -> String
95+proto n = "void " ++ cname n ++ "(VM* vm);\n"
96+