git.iko.soy/Idris-dev
on master help sign in
Invoke gcc directly
168706fEdwin Brady
src/IRTS/CodegenC.hs+76
compare with master
unifiedsplit
@@ -1,11 +1,67 @@
1+{-# LANGUAGE CPP #-}
2+
1module IRTS.CodegenC where
3module IRTS.CodegenC where
2
4
3import IRTS.Bytecode
5import IRTS.Bytecode
4import IRTS.Lang
6import IRTS.Lang
7+import IRTS.Simplified
5import Core.TT
8import Core.TT
6import Paths_idris
9import Paths_idris
7
10
8import Data.Char
11import 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"
9
65
10cname :: Name -> String
66cname :: Name -> String
11cname n = "_idris_" ++ concatMap cchar (show n)
67cname n = "_idris_" ++ concatMap cchar (show n)
@@ -77,6 +133,10 @@ bcc i (TOPBASE n) = indent i ++ "TOPBASE(" ++ show n ++ ");\n"
77bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"
133bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"
78bcc i STOREOLD = indent i ++ "STOREOLD;\n"
134bcc i STOREOLD = indent i ++ "STOREOLD;\n"
79bcc i (OP l fn args) = indent i ++ creg l ++ " = " ++ doOp fn args ++ ";\n"
135bcc 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)
80-- bcc i _ = indent i ++ "// not done yet\n"
140-- bcc i _ = indent i ++ "// not done yet\n"
81
141
82c_irts FInt x = "MKINT((i_int)(" ++ x ++ ")"
142c_irts FInt x = "MKINT((i_int)(" ++ x ++ ")"
@@ -130,3 +190,19 @@ doOp LPrintNum [x] = "NULL; printf(\"%ld\\n\", GETINT(" ++ creg x ++ "))"
130doOp LPrintStr [x] = "NULL; puts(GETSTR(" ++ creg x ++ "))"
190doOp LPrintStr [x] = "NULL; puts(GETSTR(" ++ creg x ++ "))"
131doOp _ _ = "FAIL"
191doOp _ _ = "FAIL"
132
192
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
src/IRTS/LParser.hs+1−17
@@ -46,23 +46,7 @@ lchar = lexeme.char
46
46
47fovm :: FilePath -> IO ()
47fovm :: FilePath -> IO ()
48fovm f = do defs <- parseFOVM f
48fovm f = do defs <- parseFOVM f
49− let tagged = addTags defs
49+ codegenC defs "a.out" True [] "" DEBUG
50− let ctxtIn = addAlist tagged emptyContext
51− let checked = checkDefs ctxtIn tagged
52− -- print checked
53− case checked of
54− OK c -> do let bc = map toBC c
55− -- print bc
56− let h = concatMap toDecl (map fst bc)
57− let cc = concatMap (uncurry toC) bc
58− putStrLn "#include <idris_rts.h>\n"
59− putStrLn "#define IDRIS_DEBUG\n"
60− putStrLn h
61− putStrLn cc
62− d <- getDataDir
63− mprog <- readFile (d ++ "/rts/idris_main.c")
64− putStrLn mprog
65− err -> print err
66
50
67parseFOVM :: FilePath -> IO [(Name, LDecl)]
51parseFOVM :: FilePath -> IO [(Name, LDecl)]
68parseFOVM fname = do -- putStrLn $ "Reading " ++ fname
52parseFOVM fname = do -- putStrLn $ "Reading " ++ fname