git.iko.soy/Idris-dev
on 3812df8 help sign in
Idris-dev/src/IRTS/CodegenC.hs
210 lines 8.6 kB history raw
1{-# LANGUAGE CPP #-}
3module IRTS.CodegenC where
5import IRTS.Bytecode
6import IRTS.Lang
7import IRTS.Simplified
8import Core.TT
9import Paths_idris
11import Data.Char
12import System.Process
13import System.Exit
14import System.IO
15import System.Directory
16import System.Environment
17import Control.Monad
19data DbgLevel = NONE | DEBUG | TRACE
21codegenC :: [(Name, LDecl)] ->
22 String -> -- output file name
23 Bool -> -- generate executable if True, only .o if False
24 [FilePath] -> -- include files
25 String -> -- extra compiler flags
26 DbgLevel ->
27 IO ()
28codegenC defs out exec incs libs dbg
29 = do -- print defs
30 let tagged = addTags defs
31 let ctxtIn = addAlist tagged emptyContext
32 let checked = checkDefs ctxtIn tagged
33 case checked of
34 OK c -> do let bc = map toBC c
35 let h = concatMap toDecl (map fst bc)
36 let cc = concatMap (uncurry toC) bc
37 d <- getDataDir
38 mprog <- readFile (d ++ "/rts/idris_main.c")
39 let cout = headers incs ++ debug dbg ++ h ++ cc ++
40 (if exec then mprog else "")
41 (tmpn, tmph) <- tempfile
42 hPutStr tmph cout
43 hFlush tmph
44 hClose tmph
45 let gcc = "gcc -x c " ++
46 (if exec then "" else " - c ") ++
47 gccDbg dbg ++
48 " " ++ tmpn ++
49 " `idris --link` `idris --include` " ++ libs ++
50 " -lidris_rts -o " ++ out
51-- putStrLn cout
52 exit <- system gcc
53 when (exit /= ExitSuccess) $
54 putStrLn ("FAILURE: " ++ gcc)
56 Error e -> fail $ "Can't happen: Something went wrong in codegenC\n" ++ show e
58headers [] = "#include <idris_rts.h>\n\n"
59headers (x : xs) = "#include <" ++ x ++ ">\n" ++ headers xs
61debug TRACE = "#define IDRIS_DEBUG\n\n"
62debug _ = ""
64gccDbg DEBUG = "-g"
65gccDbg TRACE = "-g"
66gccDbg _ = "-O2"
68cname :: Name -> String
69cname n = "_idris_" ++ concatMap cchar (show n)
70 where cchar x | isAlpha x || isDigit x = [x]
71 | otherwise = "_" ++ show (fromEnum x) ++ "_"
73indent i = take (i * 4) (repeat ' ')
75creg RVal = "RVAL"
76creg (L i) = "LOC(" ++ show i ++ ")"
77creg (T i) = "TOP(" ++ show i ++ ")"
79toDecl :: Name -> String
80toDecl f = "void " ++ cname f ++ "(VM*, VAL*);\n"
82toC :: Name -> [BC] -> String
83toC f code
84 = -- "/* " ++ show code ++ "*/\n\n" ++
85 "void " ++ cname f ++ "(VM* vm, VAL* oldbase) {\n" ++
86 indent 1 ++ "INITFRAME;\n" ++
87 concatMap (bcc 1) code ++ "}\n\n"
89bcc :: Int -> BC -> String
90bcc i (ASSIGN l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"
91bcc i (ASSIGNCONST l c)
92 = indent i ++ creg l ++ " = " ++ mkConst c ++ ";\n"
93 where
94 mkConst (I i) = "MKINT(" ++ show i ++ ")"
95 mkConst (BI i) = "MKINT(" ++ show i ++ ")" -- TODO
96 mkConst (Fl f) = "MKFLOAT(vm, " ++ show f ++ ")"
97 mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")"
98 mkConst (Str s) = "MKSTR(vm, " ++ show s ++ ")"
99 mkConst _ = "MKINT(42424242)"
100bcc i (MKCON l tag args)
101 = indent i ++ creg l ++ " = MKCON(vm, " ++ show tag ++ ", " ++
102 show (length args) ++ concatMap showArg args ++ ");\n"
103 where showArg r = ", " ++ creg r
104bcc i (PROJECT l loc a) = indent i ++ "PROJECT(vm, " ++ creg l ++ ", " ++ show loc ++
105 ", " ++ show a ++ ");\n"
106bcc i (CASE r code def)
107 = indent i ++ "switch(TAG(" ++ creg r ++ ")) {\n" ++
108 concatMap (showCase i) code ++
109 showDef i def ++
110 indent i ++ "}\n"
111 where
112 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"
113 ++ concatMap (bcc (i+1)) bc ++ indent (i + 1) ++ "break;\n"
114 showDef i Nothing = ""
115 showDef i (Just c) = indent i ++ "default:\n"
116 ++ concatMap (bcc (i+1)) c ++ indent (i + 1) ++ "break;\n"
117bcc i (CONSTCASE r code def)
118 = indent i ++ "switch(GETINT(" ++ creg r ++ ")) {\n" ++
119 concatMap (showCase i) code ++
120 showDef i def ++
121 indent i ++ "}\n"
122 where
123 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"
124 ++ concatMap (bcc (i+1)) bc ++ indent (i + 1) ++ "break;\n"
125 showDef i Nothing = ""
126 showDef i (Just c) = indent i ++ "default:\n"
127 ++ concatMap (bcc (i+1)) c ++ indent (i + 1) ++ "break;\n"
128bcc i (CALL n) = indent i ++ "CALL(" ++ cname n ++ ");\n"
129bcc i (TAILCALL n) = indent i ++ "TAILCALL(" ++ cname n ++ ");\n"
130bcc i (SLIDE n) = indent i ++ "SLIDE(vm, " ++ show n ++ ");\n"
131bcc i REBASE = indent i ++ "REBASE;\n"
132bcc i (RESERVE n) = indent i ++ "RESERVE(" ++ show n ++ ");\n"
133bcc i (ADDTOP n) = indent i ++ "ADDTOP(" ++ show n ++ ");\n"
134bcc i (TOPBASE n) = indent i ++ "TOPBASE(" ++ show n ++ ");\n"
135bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"
136bcc i STOREOLD = indent i ++ "STOREOLD;\n"
137bcc i (OP l fn args) = indent i ++ creg l ++ " = " ++ doOp fn args ++ ";\n"
138bcc i (FOREIGNCALL l LANG_C rty fn args)
139 = indent i ++ creg l ++ " = " ++
140 c_irts rty (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"
141 where fcall (t, arg) = irts_c t (creg arg)
142-- bcc i _ = indent i ++ "// not done yet\n"
144c_irts FInt x = "MKINT((i_int)(" ++ x ++ ")"
145c_irts FString x = "MKSTR(" ++ x ++ ")"
146c_irts FUnit x = "MKINT(42424242)"
147c_irts FPtr x = "MKPTR(" ++ x ++ ")"
148c_irts FDouble x = "MKFLOAT(vm, " ++ x ++ ")"
149c_irts FAny x = x
151irts_c FInt x = "GETINT(" ++ x ++ ")"
152irts_c FString x = "GETSTR(" ++ x ++ ")"
153irts_c FUnit x = x
154irts_c FPtr x = "GETPTR(" ++ x ++ ")"
155irts_c FDouble x = "GETFLOAT(" ++ x ++ ")"
156irts_c FAny x = x
158doOp LPlus [l, r] = "ADD(" ++ creg l ++ ", " ++ creg r ++ ")"
159doOp LMinus [l, r] = "INTOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
160doOp LTimes [l, r] = "MULT(" ++ creg l ++ ", " ++ creg r ++ ")"
161doOp LDiv [l, r] = "INTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
162doOp LEq [l, r] = "INTOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
163doOp LLt [l, r] = "INTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
164doOp LLe [l, r] = "INTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
165doOp LGt [l, r] = "INTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
166doOp LGe [l, r] = "INTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
168doOp LFPlus [l, r] = "FLOATOP(+" ++ creg l ++ ", " ++ creg r ++ ")"
169doOp LFMinus [l, r] = "FLOATOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
170doOp LFTimes [l, r] = "FLOATOP(*" ++ creg l ++ ", " ++ creg r ++ ")"
171doOp LFDiv [l, r] = "FLOATOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
172doOp LFEq [l, r] = "FLOATBOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
173doOp LFLt [l, r] = "FLOATBOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
174doOp LFLe [l, r] = "FLOATBOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
175doOp LFGt [l, r] = "FLOATBOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
176doOp LFGe [l, r] = "FLOATBOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
178doOp LStrConcat [l,r] = "idris_concat(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
179doOp LStrLt [l,r] = "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
180doOp LStrEq [l,r] = "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
181doOp LStrLen [x] = "idris_strlen(vm, " ++ creg x ++ ")"
183doOp LIntFloat [x] = "idris_castIntFloat(" ++ creg x ++ ")"
184doOp LFloatInt [x] = "idris_castFloatInt(" ++ creg x ++ ")"
185doOp LIntStr [x] = "idris_castIntStr(vm, " ++ creg x ++ ")"
186doOp LStrInt [x] = "idris_castFloatStr(vm, " ++ creg x ++ ")"
187doOp LFloatStr [x] = "idris_castFloatStr(vm, " ++ creg x ++ ")"
188doOp LStrFloat [x] = "idris_castStrFloat(vm, " ++ creg x ++ ")"
190doOp LReadStr [] = "idris_readStr(vm, stdin)"
191doOp LPrintNum [x] = "NULL; printf(\"%ld\\n\", GETINT(" ++ creg x ++ "))"
192doOp LPrintStr [x] = "NULL; puts(GETSTR(" ++ creg x ++ "))"
193doOp _ _ = "FAIL"
195tempfile :: IO (FilePath, Handle)
196tempfile = do env <- environment "TMPDIR"
197 let dir = case env of
198 Nothing -> "/tmp"
199 (Just d) -> d
200 openTempFile dir "idris"
202environment :: String -> IO (Maybe String)
203environment x = catch (do e <- getEnv x
204 return (Just e))
205#if MIN_VERSION_base(4,6,0)
206 (\y-> do return (y::SomeException); return Nothing)
207#endif
208#if !MIN_VERSION_base(4,6,0)
209 (\_-> return Nothing)
210#endif