@@ -1,11 +1,67 @@
1+{-# LANGUAGE CPP #-}
2+
13module IRTS.CodegenC where
24
35import IRTS.Bytecode
46import IRTS.Lang
7+import IRTS.Simplified
58import Core.TT
69import Paths_idris
710
811import Data.Char
12+import System.Process
13+import System.Exit
14+import System.IO
15+import System.Directory
16+import System.Environment
17+import Control.Monad
18+
19+data DbgLevel = NONE | DEBUG | TRACE
20+
21+codegenC :: [(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 ()
28+codegenC defs out exec incs libs dbg
29+ = do let tagged = addTags defs
30+ let ctxtIn = addAlist tagged emptyContext
31+ let checked = checkDefs ctxtIn tagged
32+ case checked of
33+ OK c -> do let bc = map toBC c
34+ let h = concatMap toDecl (map fst bc)
35+ let cc = concatMap (uncurry toC) bc
36+ d <- getDataDir
37+ mprog <- readFile (d ++ "/rts/idris_main.c")
38+ let cout = headers incs ++ debug dbg ++ h ++ cc ++
39+ (if exec then mprog else "")
40+ (tmpn, tmph) <- tempfile
41+ hPutStr tmph cout
42+ hFlush tmph
43+ hClose tmph
44+ let gcc = "gcc -x c " ++
45+ (if exec then "" else " - c ") ++
46+ gccDbg dbg ++
47+ " " ++ tmpn ++
48+ " `idris --link` `idris --include` " ++ libs ++
49+ " -lidris_rts -o " ++ out
50+ exit <- system gcc
51+ when (exit /= ExitSuccess) $
52+ putStrLn ("FAILURE: " ++ gcc)
53+
54+ Error e -> fail $ "Can't happen: Something went wrong in codegenC\n" ++ show e
55+
56+headers [] = "#include <idris_rts.h>\n\n"
57+headers (x : xs) = "#include <" ++ x ++ ">\n" ++ headers xs
58+
59+debug DEBUG = "#define IDRIS_DEBUG\n\n"
60+debug _ = ""
61+
62+gccDbg DEBUG = "-g"
63+gccDbg TRACE = "-g"
64+gccDbg _ = "-O2"
965
1066cname :: Name -> String
1167cname n = "_idris_" ++ concatMap cchar (show n)
@@ -77,6 +133,10 @@ bcc i (TOPBASE n) = indent i ++ "TOPBASE(" ++ show n ++ ");\n"
77133bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"
78134bcc i STOREOLD = indent i ++ "STOREOLD;\n"
79135bcc i (OP l fn args) = indent i ++ creg l ++ " = " ++ doOp fn args ++ ";\n"
136+bcc i (FOREIGNCALL l LANG_C rty fn args)
137+ = indent i ++ creg l ++ " = " ++
138+ c_irts rty (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"
139+ where fcall (t, arg) = irts_c t (creg l)
80140-- bcc i _ = indent i ++ "// not done yet\n"
81141
82142c_irts FInt x = "MKINT((i_int)(" ++ x ++ ")"
@@ -130,3 +190,19 @@ doOp LPrintNum [x] = "NULL; printf(\"%ld\\n\", GETINT(" ++ creg x ++ "))"
130190doOp LPrintStr [x] = "NULL; puts(GETSTR(" ++ creg x ++ "))"
131191doOp _ _ = "FAIL"
132192
193+tempfile :: IO (FilePath, Handle)
194+tempfile = do env <- environment "TMPDIR"
195+ let dir = case env of
196+ Nothing -> "/tmp"
197+ (Just d) -> d
198+ openTempFile dir "idris"
199+
200+environment :: String -> IO (Maybe String)
201+environment x = catch (do e <- getEnv x
202+ return (Just e))
203+#if MIN_VERSION_base(4,6,0)
204+ (\y-> do return (y::SomeException); return Nothing)
205+#endif
206+#if !MIN_VERSION_base(4,6,0)
207+ (\_-> return Nothing)
208+#endif