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