@@ -5,9 +5,11 @@ Copyright :
5License : BSD3
5License : BSD3
6Maintainer : The Idris Community.
6Maintainer : The Idris Community.
8+{-# LANGUAGE FlexibleContexts #-}
8module IRTS.CodegenC (codegenC) where
10module IRTS.CodegenC (codegenC) where
10−import Idris.AbsSyntax
12+import Idris.AbsSyntax hiding (getBC)
11import Idris.Core.TT
13import Idris.Core.TT
12import IRTS.Bytecode
14import IRTS.Bytecode
13import IRTS.CodegenCommon
15import IRTS.CodegenCommon
@@ -19,10 +21,12 @@ import IRTS.System
19import Util.System
21import Util.System
21import Control.Monad
23import Control.Monad
25+import Control.Monad.RWS
22import Data.Bits
26import Data.Bits
23import Data.Char
27import Data.Char
24−import Data.List (intercalate, nubBy)
28+import Data.List (find, intercalate, nubBy, partition)
25−import Debug.Trace
29+import qualified Data.Text as T
26import Numeric
30import Numeric
27import System.Directory
31import System.Directory
28import System.Exit
32import System.Exit
@@ -30,6 +34,8 @@ import System.FilePath ((<.>), (</>))
30import System.IO
34import System.IO
31import System.Process
35import System.Process
33codegenC :: CodeGenerator
39codegenC :: CodeGenerator
34codegenC ci = do codegenC' (simpleDecls ci)
40codegenC ci = do codegenC' (simpleDecls ci)
35 (outputFile ci)
41 (outputFile ci)
@@ -64,7 +70,9 @@ codegenC' defs out exec incs objs libs flags exports iface dbg
64 let bc = map toBC defs
70 let bc = map toBC defs
65 let wrappers = genWrappers bc
71 let wrappers = genWrappers bc
66 let h = concatMap toDecl (map fst bc)
72 let h = concatMap toDecl (map fst bc)
67− let cc = concatMap (uncurry toC) bc
73+ let (state, cc) = execRWS (generateSrc bc) 0
74+ (CS { fnName = Nothing,
68 let hi = concatMap ifaceC (concatMap getExp exports)
76 let hi = concatMap ifaceC (concatMap getExp exports)
69 d <- getIdrisCRTSDir
77 d <- getIdrisCRTSDir
70 mprog <- readFile (d </> "idris_main" <.> "c")
78 mprog <- readFile (d </> "idris_main" <.> "c")
@@ -134,12 +142,17 @@ creg Tmp = "REG1"
134toDecl :: Name -> String
142toDecl :: Name -> String
135toDecl f = "void " ++ cname f ++ "(VM*, VAL*);\n"
143toDecl f = "void " ++ cname f ++ "(VM*, VAL*);\n"
137−toC :: Name -> [BC] -> String
145+generateSrc :: [(Name, [BC])] -> RWS Int String CState ()
146+generateSrc bc = mapM_ toC bc
148+toC :: (Name, [BC]) -> RWS Int String CState ()
138−toC f code
149+toC (f, code) = do
139− = -- "/* " ++ show code ++ "*/\n\n" ++
150+ modify (\s -> s { fnName = Just f })
140− "void " ++ cname f ++ "(VM* vm, VAL* oldbase) {\n" ++
152+ tell $ "void " ++ cname f ++ "(VM* vm, VAL* oldbase) {\n"
141− indent 1 ++ "INITFRAME;\n" ++
153+ tell $ indent (level s) ++ "INITFRAME;\n"
142− concatMap (bcc 1) code ++ "}\n\n"
154+ bcc code
144showCStr :: String -> String
157showCStr :: String -> String
145showCStr s = '"' : foldr ((++) . showChar) "\"" s
158showCStr s = '"' : foldr ((++) . showChar) "\"" s
@@ -175,10 +188,22 @@ showCStr s = '"' : foldr ((++) . showChar) "\"" s
176 _ -> error $ "Can't happen: String of invalid length " ++ show s
189 _ -> error $ "Can't happen: String of invalid length " ++ show s
192+ fnName :: Maybe Name,
178−bcc :: Int -> BC -> String
197+bcc :: [BC] -> RWS Int String CState ()
199+bcc ((ASSIGN l r):xs) = do
179−bcc i (ASSIGN l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"
201+ tell $ indent (level i) ++ creg l ++ " = " ++ creg r ++ ";\n"
180−bcc i (ASSIGNCONST l c)
203+bcc ((ASSIGNCONST l c):xs) = do
181− = indent i ++ creg l ++ " = " ++ mkConst c ++ ";\n"
205+ tell $ indent (level i) ++ creg l ++ " = " ++ mkConst c ++ ";\n"
183 mkConst (I i) = "MKINT(" ++ show i ++ ")"
208 mkConst (I i) = "MKINT(" ++ show i ++ ")"
184 mkConst (BI i) | i < (2^30) = "MKINT(" ++ show i ++ ")"
209 mkConst (BI i) | i < (2^30) = "MKINT(" ++ show i ++ ")"
@@ -196,16 +221,21 @@ bcc i (ASSIGNCONST l c)
196 mkConst c | isTypeConst c = "MKINT(42424242)"
221 mkConst c | isTypeConst c = "MKINT(42424242)"
197 mkConst c = error $ "mkConst of (" ++ show c ++ ") not implemented"
222 mkConst c = error $ "mkConst of (" ++ show c ++ ") not implemented"
224+bcc ((UPDATE l r):xs) = do
199−bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"
226+ tell $ indent (level i) ++ creg l ++ " = " ++ creg r ++ ";\n"
200−bcc i (MKCON l loc tag []) | tag < 256
228+bcc ((MKCON l loc tag []):xs) | tag < 256 = do
201− = indent i ++ creg l ++ " = NULL_CON(" ++ show tag ++ ");\n"
230+ tell $ indent (level i) ++ creg l ++ " = NULL_CON(" ++ show tag ++ ");\n"
202−bcc i (MKCON l loc tag args)
232+bcc ((MKCON l loc tag args):xs) = do
234+ let tab = indent (level i)
203− = indent i ++ alloc loc tag ++
235+ tell $ tab ++ alloc loc tag ++
204− indent i ++ setArgs 0 args ++ "\n" ++
236+ tab ++ setArgs 0 args ++ "\n" ++
205− indent i ++ creg l ++ " = " ++ creg Tmp ++ ";\n"
237+ tab ++ creg l ++ " = " ++ creg Tmp ++ ";\n"
207−-- "MKCON(vm, " ++ creg l ++ ", " ++ show tag ++ ", " ++
208−-- show (length args) ++ concatMap showArg args ++ ");\n"
209 where showArg r = ", " ++ creg r
239 where showArg r = ", " ++ creg r
210 setArgs i [] = ""
240 setArgs i [] = ""
211 setArgs i (x : xs) = "SETARG(" ++ creg Tmp ++ ", " ++ show i ++ ", " ++ creg x ++
241 setArgs i (x : xs) = "SETARG(" ++ creg Tmp ++ ", " ++ show i ++ ", " ++ creg x ++
@@ -217,52 +247,94 @@ bcc i (MKCON l loc tag args)
217 = "updateCon(" ++ creg Tmp ++ ", " ++ creg old ++ ", " ++ show tag ++ ", " ++
247 = "updateCon(" ++ creg Tmp ++ ", " ++ creg old ++ ", " ++ show tag ++ ", " ++
218 show (length args) ++ ");\n"
248 show (length args) ++ ");\n"
250+bcc ((PROJECT l loc a):xs) = do
220−bcc i (PROJECT l loc a) = indent i ++ "PROJECT(vm, " ++ creg l ++ ", " ++ show loc ++
252+ tell $ indent (level i) ++ "PROJECT(vm, " ++ creg l ++ ", "
221− ", " ++ show a ++ ");\n"
253+ ++ show loc ++ ", " ++ show a ++ ");\n"
222−bcc i (PROJECTINTO r t idx)
255+bcc ((PROJECTINTO r t idx):xs) = do
223− = indent i ++ creg r ++ " = GETARG(" ++ creg t ++ ", " ++ show idx ++ ");\n"
257+ tell $ indent (level i) ++ creg r ++ " = GETARG(" ++ creg t
258+ ++ ", " ++ show idx ++ ");\n"
224−bcc i (CASE True r code def)
260+bcc ((CASE True r code def):xs)
225− | length code < 4 = showCase i def code
261+ | length code < 4 = do
227− showCode :: Int -> [BC] -> String
265+ showCode bc = do
228− showCode i bc = "{\n" ++ concatMap (bcc (i + 1)) bc ++
266+ w <- getBC bc xs
229− indent i ++ "}\n"
268+ tell $ "{\n" ++ w ++ indent (level i) ++ "}\n"
231− showCase :: Int -> Maybe [BC] -> [(Int, [BC])] -> String
270+ showCases Nothing [(t, c)] = do
232− showCase i Nothing [(t, c)] = indent i ++ showCode i c
271+ i <- get
233− showCase i (Just def) [] = indent i ++ showCode i def
272+ tell $ indent (level i)
274+ showCases (Just def) [] = do
276+ tell $ indent (level i)
234− showCase i def ((t, c) : cs)
278+ showCases def ((t, c) : cs) = do
235− = indent i ++ "if (CTAG(" ++ creg r ++ ") == " ++ show t ++ ") " ++ showCode i c
280+ tell $ indent (level i) ++ "if (CTAG(" ++ creg r ++ ") == "
236− ++ indent i ++ "else\n" ++ showCase i def cs
283+ tell $ indent (level i) ++ "else\n"
237−
284+ showCases def cs
238−bcc i (CASE safe r code def)
286+bcc ((CASE safe r code def):xs) = do
239− = indent i ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n" ++
288+ tell $ indent (level i) ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n"
240− concatMap (showCase i) code ++
289+ mapM showCase code
241− showDef i def ++
290+ showDef def
242− indent i ++ "}\n"
291+ tell $ indent (level i) ++ "}\n"
244 ctag True = "CTAG"
294 ctag True = "CTAG"
245 ctag False = "TAG"
295 ctag False = "TAG"
297+ showCase (t, bc) = do
247− showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"
301+ tell $ indent i ++ "case " ++ show t ++ ":\n"
248− ++ concatMap (bcc (i+1)) bc ++ indent (i + 1) ++ "break;\n"
302+ ++ w ++ indent (i + 1) ++ "break;\n"
249− showDef i Nothing = ""
303+ showDef Nothing = return $ ()
250− showDef i (Just c) = indent i ++ "default:\n"
304+ showDef (Just c) = do
251− ++ concatMap (bcc (i+1)) c ++ indent (i + 1) ++ "break;\n"
308+ tell $ indent i ++ "default:\n" ++ w ++ indent (i + 1) ++ "break;\n"
252−bcc i (CONSTCASE r code def)
310+bcc ((CONSTCASE r code def):xs)
253 | intConsts code
311 | intConsts code
254−-- = indent i ++ "switch(GETINT(" ++ creg r ++ ")) {\n" ++
312+ = do
255−-- concatMap (showCase i) code ++
313+ is <- get
256−-- showDef i def ++
314+ let i = level is
257−-- indent i ++ "}\n"
315+ codes <- mapM getCode code
258− = concatMap (iCase (creg r)) code ++
316+ defs <- showDefS def
259− indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
317+ tell $ concatMap (iCase i (creg r)) codes
318+ tell $ indent i ++ "{\n" ++ defs ++ indent i ++ "}\n"
260 | strConsts code
320 | strConsts code
324+ codes <- mapM getCode code
325+ defs <- showDefS def
261− = concatMap (strCase ("GETSTR(" ++ creg r ++ ")")) code ++
326+ tell $ concatMap (strCase i ("GETSTR(" ++ creg r ++ ")")) codes
262− indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
327+ ++ indent i ++ "{\n" ++ defs ++ indent i ++ "}\n"
263 | bigintConsts code
329 | bigintConsts code
333+ codes <- mapM getCode code
334+ defs <- showDefS def
264− = concatMap (biCase (creg r)) code ++
335+ tell $ concatMap (biCase i (creg r)) codes ++
265− indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"
336+ indent i ++ "{\n" ++ defs ++ indent i ++ "}\n"
266 | otherwise = error $ "Can't happen: Can't compile const case " ++ show code
338 | otherwise = error $ "Can't happen: Can't compile const case " ++ show code
268 intConsts ((I _, _ ) : _) = True
340 intConsts ((I _, _ ) : _) = True
@@ -279,72 +351,119 @@ bcc i (CONSTCASE r code def)
279 strConsts ((Str _, _ ) : _) = True
351 strConsts ((Str _, _ ) : _) = True
280 strConsts _ = False
352 strConsts _ = False
354+ getCode (x, code) = do
282− strCase sv (s, bc) =
358+ strCase i sv (s, bc) =
283 indent i ++ "if (strcmp(" ++ sv ++ ", " ++ show s ++ ") == 0) {\n" ++
359 indent i ++ "if (strcmp(" ++ sv ++ ", " ++ show s ++ ") == 0) {\n" ++
284− concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
360+ bc ++ indent i ++ "} else\n"
285− biCase bv (BI b, bc) =
361+ biCase i bv (BI b, bc) =
286 indent i ++ "if (bigEqConst(" ++ bv ++ ", " ++ show b ++ ")) {\n"
362 indent i ++ "if (bigEqConst(" ++ bv ++ ", " ++ show b ++ ")) {\n"
287− ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
363+ ++ bc ++ indent i ++ "} else\n"
288− iCase v (I b, bc) =
364+ iCase i v (I b, bc) =
289 indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show b ++ ") {\n"
365 indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show b ++ ") {\n"
290− ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
366+ ++ bc ++ indent i ++ "} else\n"
291− iCase v (Ch b, bc) =
367+ iCase i v (Ch b, bc) =
292 indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show (fromEnum b) ++ ") {\n"
368 indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show (fromEnum b) ++ ") {\n"
293− ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
369+ ++ bc ++ indent i ++ "} else\n"
294− iCase v (B8 w, bc) =
370+ iCase i v (B8 w, bc) =
295 indent i ++ "if (GETBITS8(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"
371 indent i ++ "if (GETBITS8(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"
296− ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
372+ ++ bc ++ indent i ++ "} else\n"
297− iCase v (B16 w, bc) =
373+ iCase i v (B16 w, bc) =
298 indent i ++ "if (GETBITS16(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"
374 indent i ++ "if (GETBITS16(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"
299− ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
375+ ++ bc ++ indent i ++ "} else\n"
300− iCase v (B32 w, bc) =
376+ iCase i v (B32 w, bc) =
301 indent i ++ "if (GETBITS32(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"
377 indent i ++ "if (GETBITS32(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"
302− ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
378+ ++ bc ++ indent i ++ "} else\n"
303− iCase v (B64 w, bc) =
379+ iCase i v (B64 w, bc) =
304 indent i ++ "if (GETBITS64(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"
380 indent i ++ "if (GETBITS64(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"
305− ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"
381+ ++ bc ++ indent i ++ "} else\n"
306− showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"
382+
307− ++ concatMap (bcc (i+1)) bc ++
383+ showDefS Nothing = return ""
308− indent (i + 1) ++ "break;\n"
384+ showDefS (Just c) = getBC c xs
309− showDef i Nothing = ""
385+
310− showDef i (Just c) = indent i ++ "default:\n"
386+bcc (CALL n:xs) = do
311− ++ concatMap (bcc (i+1)) c ++
387+ i <- get
312− indent (i + 1) ++ "break;\n"
313− showDefS i Nothing = ""
314− showDefS i (Just c) = concatMap (bcc (i+1)) c
316−bcc i (CALL n) = indent i ++ "CALL(" ++ cname n ++ ");\n"
388+ tell $ indent (level i) ++ "CALL(" ++ cname n ++ ");\n"
390+bcc (TAILCALL n:xs) = do
317−bcc i (TAILCALL n) = indent i ++ "TAILCALL(" ++ cname n ++ ");\n"
392+ tell $ indent (level i) ++ "TAILCALL(" ++ cname n ++ ");\n"
394+bcc ((SLIDE n):xs) = do
318−bcc i (SLIDE n) = indent i ++ "SLIDE(vm, " ++ show n ++ ");\n"
396+ tell $ indent (level i) ++ "SLIDE(vm, " ++ show n ++ ");\n"
319−bcc i REBASE = indent i ++ "REBASE;\n"
400+ tell $ indent (level i)++ "REBASE;\n"
320−bcc i (RESERVE 0) = ""
402+bcc ((RESERVE 0):xs) = bcc xs
403+bcc ((RESERVE n):xs) = do
321−bcc i (RESERVE n) = indent i ++ "RESERVE(" ++ show n ++ ");\n"
405+ tell $ indent (level i) ++ "RESERVE(" ++ show n ++ ");\n"
322−bcc i (ADDTOP 0) = ""
407+bcc ((ADDTOP 0):xs) = bcc xs
408+bcc ((ADDTOP n):xs) = do
323−bcc i (ADDTOP n) = indent i ++ "ADDTOP(" ++ show n ++ ");\n"
410+ tell $ indent (level i) ++ "ADDTOP(" ++ show n ++ ");\n"
412+bcc ((TOPBASE n):xs) = do
324−bcc i (TOPBASE n) = indent i ++ "TOPBASE(" ++ show n ++ ");\n"
414+ tell $ indent (level i) ++ "TOPBASE(" ++ show n ++ ");\n"
416+bcc ((BASETOP n):xs) = do
325−bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"
418+ tell $ indent (level i) ++ "BASETOP(" ++ show n ++ ");\n"
420+bcc (STOREOLD:xs) = do
326−bcc i STOREOLD = indent i ++ "STOREOLD;\n"
422+ tell $ indent (level i) ++ "STOREOLD;\n"
424+bcc ((OP l fn args):xs) = do
327−bcc i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n"
426+ tell $ indent (level i) ++ doOp (creg l ++ " = ") fn args ++ ";\n"
328−bcc i (FOREIGNCALL l rty (FStr fn@('&':name)) [])
428+bcc ((FOREIGNCALL l rty (FStr fn@('&':name)) []):xs) = do
329− = indent i ++
429+ i <- get
330− c_irts (toFType rty) (creg l ++ " = ") fn ++ ";\n"
430+ tell $ indent (level i) ++ c_irts (toFType rty) (creg l ++ " = ") fn ++ ";\n"
331−bcc i (FOREIGNCALL l rty (FStr fn) (x:xs)) | fn == "%wrapper"
432+bcc ((FOREIGNCALL l rty (FStr fn) (x:xs)):zs) | fn == "%wrapper"
332− = indent i ++
433+ = do
333− c_irts (toFType rty) (creg l ++ " = ")
435+ tell $ indent (level i) ++ c_irts (toFType rty) (creg l ++ " = ")
334 ("_idris_get_wrapper(" ++ creg (snd x) ++ ")") ++ ";\n"
436 ("_idris_get_wrapper(" ++ creg (snd x) ++ ")") ++ ";\n"
335−bcc i (FOREIGNCALL l rty (FStr fn) (x:xs)) | fn == "%dynamic"
438+bcc ((FOREIGNCALL l rty (FStr fn) (x:xs)):zs) | fn == "%dynamic"
336− = indent i ++ c_irts (toFType rty) (creg l ++ " = ")
441+ tell $ indent (level i) ++ c_irts (toFType rty) (creg l ++ " = ")
337 ("(*(" ++ cFnSig "" rty xs ++ ") GETPTR(" ++ creg (snd x) ++ "))" ++
442 ("(*(" ++ cFnSig "" rty xs ++ ") GETPTR(" ++ creg (snd x) ++ "))" ++
338 "(" ++ showSep "," (map fcall xs) ++ ")") ++ ";\n"
443 "(" ++ showSep "," (map fcall xs) ++ ")") ++ ";\n"
339−bcc i (FOREIGNCALL l rty (FStr fn) args)
445+bcc ((FOREIGNCALL l rty (FStr fn) args):xs) = do
340− = indent i ++
446+ i <- get
341− c_irts (toFType rty) (creg l ++ " = ")
447+ tell $ indent (level i) ++ c_irts (toFType rty) (creg l ++ " = ")
342− (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"
448+ (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"
343−bcc i (FOREIGNCALL l rty _ args) = error "Foreign Function calls cannot be partially applied, without being inlined."
450+bcc ((FOREIGNCALL l rty _ args):_) = error "Foreign Function calls cannot be partially applied, without being inlined."
451+bcc ((NULL r):xs) = do
344−bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed
453+ tell $ indent (level i) ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed
455+bcc ((ERROR str):xs) = do
457+ tell $ indent (level i) ++ "fprintf(stderr, "
345−bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); fprintf(stderr, \"\\n\"); exit(-1);\n"
458+ ++ show str ++ "); fprintf(stderr, \"\\n\"); exit(-1);\n"
346-- bcc i c = error (show c) -- indent i ++ "// not done yet\n"
460-- bcc i c = error (show c) -- indent i ++ "// not done yet\n"
464+ let (a, s, w) = runRWS (bcc code) 0 (i { level = level i + 1 })
348fcall (t, arg) = irts_c (toFType t) (creg arg)
467fcall (t, arg) = irts_c (toFType t) (creg arg)
349-- Deconstruct the Foreign type in the defunctionalised expression and build
468-- Deconstruct the Foreign type in the defunctionalised expression and build
350-- a foreign type description for c_irts and irts_c
469-- a foreign type description for c_irts and irts_c