git.iko.soy/Idris-dev
on master help sign in
Started C generation
fa0ecdeEdwin Brady
idris.cabal+1−1
compare with master
unifiedsplit
@@ -68,7 +68,7 @@ Executable idris
68
68
69 Util.Pretty,
69 Util.Pretty,
70
70
71− RTS.Bytecode, RTS.SC, RTS.PreC,
71+ RTS.Bytecode, RTS.SC, RTS.PreC, RTS.CodegenC,
72
72
73 Paths_idris
73 Paths_idris
74
74
src/Idris/REPL.hs+4
@@ -23,6 +23,7 @@ import Core.Constraints
23import RTS.SC
23import RTS.SC
24import RTS.Bytecode
24import RTS.Bytecode
25import RTS.PreC
25import RTS.PreC
26+import RTS.CodegenC
26
27
27import System.Console.Haskeline as H
28import System.Console.Haskeline as H
28import System.FilePath
29import System.FilePath
@@ -204,12 +205,15 @@ process fn (DebugInfo n)
204 let scs = toSC prims (n, head d)
205 let scs = toSC prims (n, head d)
205 let bcs = bcdefs scs
206 let bcs = bcdefs scs
206 let pcs = preCdefs bcs
207 let pcs = preCdefs bcs
208+ let code = cdefs pcs
207 putStrLn "Supercombinators:\n"
209 putStrLn "Supercombinators:\n"
208 print (toSC prims (n, head d))
210 print (toSC prims (n, head d))
209 putStrLn "\nBytecode:\n"
211 putStrLn "\nBytecode:\n"
210 putStrLn (showSep "\n" (map show bcs))
212 putStrLn (showSep "\n" (map show bcs))
211 putStrLn "\nPre-C:\n"
213 putStrLn "\nPre-C:\n"
212 putStrLn (showSep "\n" (map show pcs))
214 putStrLn (showSep "\n" (map show pcs))
215+ putStrLn "\nCode:\n"
216+ putStrLn code
213process fn (Info n) = do i <- get
217process fn (Info n) = do i <- get
214 case lookupCtxt Nothing n (idris_classes i) of
218 case lookupCtxt Nothing n (idris_classes i) of
215 [c] -> classInfo c
219 [c] -> classInfo c
src/RTS/Bytecode.hs+5−2
@@ -54,10 +54,13 @@ bcExp v arity x
54 return s
54 return s
55
55
56 bc' :: Bool -> Int -> SCExp -> State Int Bytecode
56 bc' :: Bool -> Int -> SCExp -> State Int Bytecode
57− bc' tl d (SRef n) = return $ BAtom (BP n)
57+ bc' tl d (SRef n) = if tl then return $ BTailApp (BP n) []
58+ else return $ BApp (BP n) []
58 bc' tl d (SLoc i) = do ref i; return $ BAtom (BL i)
59 bc' tl d (SLoc i) = do ref i; return $ BAtom (BL i)
59 bc' tl d (SApp f args)
60 bc' tl d (SApp f args)
61+ = do f' <- case f of
62+ SRef n -> return $ BAtom (BP n)
60− = do f' <- bc' False d f
63+ _ -> bc' False d f
61 args' <- mapM (bc' False d) args
64 args' <- mapM (bc' False d) args
62 let bapp = if tl then BTailApp else BApp
65 let bapp = if tl then BTailApp else BApp
63 case f' of
66 case f' of
src/RTS/CodegenC.hsnew file+96
@@ -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+
src/RTS/PreC.hs+7−3
@@ -14,6 +14,7 @@ data CAtom = CP Name | CL Local | CC Const
14
14
15data CExp = CAtom CAtom
15data CExp = CAtom CAtom
16 | CApp CAtom [CAtom]
16 | CApp CAtom [CAtom]
17+ | CExactApp CAtom [CAtom]
17 | CTailApp CAtom [CAtom]
18 | CTailApp CAtom [CAtom]
18 | CLazy CAtom [CAtom]
19 | CLazy CAtom [CAtom]
19 | CFCall String CType [(CAtom, CType)]
20 | CFCall String CType [(CAtom, CType)]
@@ -31,11 +32,13 @@ data Reg = RVal | LVar Local
31
32
32data CInst = ASSIGN Reg CExp
33data CInst = ASSIGN Reg CExp
33 | RESERVE Int
34 | RESERVE Int
35+ | CLEAR Int
34 | EVAL Local
36 | EVAL Local
35 | PROJECT Local Local Int
37 | PROJECT Local Local Int
36 | SWITCH CVal [(Int, PreC)] PreC
38 | SWITCH CVal [(Int, PreC)] PreC
37 | ERROR String
39 | ERROR String
40+ | TAILCALL Int -- number of stack items to clear
38− | TAILCALL CAtom [CAtom]
41+ CAtom [CAtom]
39 deriving Show
42 deriving Show
40
43
41type PreC = [CInst]
44type PreC = [CInst]
@@ -51,7 +54,7 @@ preC :: Bytecode -> (Int, PreC)
51preC (BGetArgs ns bc) = (length ns, pc RVal (length ns) bc)
54preC (BGetArgs ns bc) = (length ns, pc RVal (length ns) bc)
52 where pc loc d (BAtom b) = [ASSIGN loc (CAtom (atom d b))]
55 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))]
56 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)]
57+ pc loc d (BTailApp f as) = [TAILCALL d (atom d f) (map (atom d) as)]
55 pc loc d (BLazy f as) = [ASSIGN loc (CLazy (atom d f) (map (atom d) as))]
58 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
59 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)
60 pc loc d (BFCall c t args)
@@ -65,7 +68,8 @@ preC (BGetArgs ns bc) = (length ns, pc RVal (length ns) bc)
65 SWITCH (caseTy alts (d - l))
68 SWITCH (caseTy alts (d - l))
66 (map (pcAlt loc d l) (filter notDef alts))
69 (map (pcAlt loc d l) (filter notDef alts))
67 (getDefault loc d alts) : []
70 (getDefault loc d alts) : []
68− pc loc d (BReserve s bc) = RESERVE s : pc loc (d + s) bc
71+ pc loc d (BReserve s bc) = RESERVE s : pc loc (d + s) bc ++
72+ [CLEAR s]
69
73
70 notDef (BDefaultCase _) = False
74 notDef (BDefaultCase _) = False
71 notDef _ = True
75 notDef _ = True