git.iko.soy/Idris-dev
on 2fc1fc6 help sign in
Idris-dev/src/IRTS/CodegenC.hs
1019 lines 46 kB history raw
1{-|
2Module : IRTS.CodegenC
3Description : The default code generator for Idris, generating C code.
4Copyright :
5License : BSD3
6Maintainer : The Idris Community.
7-}
8module IRTS.CodegenC (codegenC) where
10import Idris.AbsSyntax hiding (getBC)
11import Idris.Core.TT
12import IRTS.Bytecode
13import IRTS.CodegenCommon
14import IRTS.Defunctionalise
15import IRTS.Lang
16import IRTS.Simplified
17import IRTS.System
19import Util.System
21import Control.Monad
22import Data.Bits
23import Data.Char
24import Numeric
25import Data.List (find, intercalate, nubBy, partition)
26import qualified Data.Text as T
27import System.Exit
28import System.FilePath ((<.>), (</>))
29import System.IO
30import System.Process
31import System.Directory
32import System.FilePath ((</>), (<.>))
33import Control.Monad
34import Control.Monad.RWS
36import Debug.Trace
38codegenC :: CodeGenerator
39codegenC ci = do codegenC' (simpleDecls ci)
40 (outputFile ci)
41 (outputType ci)
42 (includes ci)
43 (compileObjs ci)
44 (map mkLib (compileLibs ci) ++
45 map incdir (importDirs ci))
46 (compilerFlags ci)
47 (exportDecls ci)
48 (interfaces ci)
49 (debugLevel ci)
50 when (interfaces ci) $
51 codegenH (exportDecls ci)
53 where mkLib l = "-l" ++ l
54 incdir i = "-I" ++ i
56codegenC' :: [(Name, SDecl)]
57 -> String -- ^ output file name
58 -> OutputType -- ^ generate executable if True, only .o if False
59 -> [FilePath] -- ^ include files
60 -> [String] -- ^ extra object files
61 -> [String] -- ^ extra compiler flags (libraries)
62 -> [String] -- ^ extra compiler flags (anything)
63 -> [ExportIFace]
64 -> Bool -- ^ interfaces too (so make a .o instead)
65 -> DbgLevel
66 -> IO ()
67codegenC' defs out exec incs objs libs flags exports iface dbg
68 = do -- print defs
69 let bc = map toBC defs
70 let wrappers = genWrappers bc
71 let h = concatMap toDecl (map fst bc)
72 let (state, cc) = execRWS (generateSrc bc) 0
73 (CS { fnName = Nothing,
74 level = 1 })
75 let hi = concatMap ifaceC (concatMap getExp exports)
76 d <- getIdrisCRTSDir
77 mprog <- readFile (d </> "idris_main" <.> "c")
78 let cout = headers incs ++ debug dbg ++ h ++ wrappers ++ cc ++
79 (if (exec == Executable) then mprog else hi)
80 case exec of
81 Raw -> writeSource out cout
82 _ -> do
83 (tmpn, tmph) <- tempfile ".c"
84 hPutStr tmph cout
85 hFlush tmph
86 hClose tmph
87 comp <- getCC
88 libFlags <- getLibFlags
89 incFlags <- getIncFlags
90 envFlags <- getEnvFlags
91 let stackFlag = if isWindows then ["-Wl,--stack,16777216"] else []
92 let args = [gccDbg dbg] ++
93 gccFlags iface ++
94 -- # Any flags defined here which alter the RTS API must also be added to config.mk
95 ["-DHAS_PTHREAD", "-DIDRIS_ENABLE_STATS",
96 "-I."] ++ objs ++ envFlags ++
97 (if (exec == Executable) then [] else ["-c"]) ++
98 [tmpn] ++
99 (if not iface then libFlags else []) ++
100 incFlags ++
101 (if not iface then libs else []) ++
102 flags ++ stackFlag ++
103 ["-o", out]
104-- putStrLn (show args)
105 exit <- rawSystem comp args
106 when (exit /= ExitSuccess) $
107 putStrLn ("FAILURE: " ++ show comp ++ " " ++ show args)
108 where
109 getExp (Export _ _ exp) = exp
111headers xs =
112 concatMap
113 (\h -> "#include \"" ++ h ++ "\"\n")
114 (xs ++ ["idris_rts.h", "idris_bitstring.h", "idris_stdfgn.h"])
116debug TRACE = "#define IDRIS_TRACE\n\n"
117debug _ = ""
119-- We're using signed integers now. Make sure we get consistent semantics
120-- out of them from gcc. See e.g. http://thiemonagel.de/2010/01/signed-integer-overflow/
121gccFlags i = if i then ["-fwrapv"]
122 else ["-fwrapv", "-fno-strict-overflow"]
124gccDbg DEBUG = "-g"
125gccDbg TRACE = "-O2"
126gccDbg _ = "-O2"
128cname :: Name -> String
129cname n = "_idris_" ++ concatMap cchar (showCG n)
130 where cchar x | isAlpha x || isDigit x = [x]
131 | otherwise = "_" ++ show (fromEnum x) ++ "_"
133indent :: Int -> String
134indent n = replicate (n*4) ' '
136creg RVal = "RVAL"
137creg (L i) = "LOC(" ++ show i ++ ")"
138creg (T i) = "TOP(" ++ show i ++ ")"
139creg Tmp = "REG1"
141toDecl :: Name -> String
142toDecl f = "void " ++ cname f ++ "(VM*, VAL*);\n"
144generateSrc :: [(Name, [BC])] -> RWS Int String CState ()
145generateSrc bc = mapM_ toC bc
147toC :: (Name, [BC]) -> RWS Int String CState ()
148toC (f, code) = do
149 modify (\s -> s { fnName = Just f })
150 s <- get
151 tell $ "void " ++ cname f ++ "(VM* vm, VAL* oldbase) {\n"
152 tell $ indent (level s) ++ "INITFRAME;\n"
153 bcc code
154 tell $ "}\n\n"
156showCStr :: String -> String
157showCStr s = '"' : foldr ((++) . showChar) "\"" s
158 where
159 showChar :: Char -> String
160 showChar '"' = "\\\""
161 showChar '\\' = "\\\\"
162 showChar c
163 -- Note: we need the double quotes around the codes because otherwise
164 -- "\n3" would get encoded as "\x0a3", which is incorrect.
165 -- Instead, we opt for "\x0a""3" and let the C compiler deal with it.
166 | ord c < 0x20 = showUTF8 (ord c)
167 | ord c < 0x7f = [c] -- 0x7f = \DEL
168 | otherwise = showHexes (utf8bytes (ord c))
170 showUTF8 c = "\"\"\\x" ++ pad (showHex c "") ++ "\"\""
171 showHexes = foldr ((++) . showUTF8) ""
173 utf8bytes :: Int -> [Int]
174 utf8bytes x
175 | x <= 0x7f = [x]
176 | x <= 0x7ff = let (y : ys) = split [] 2 x in (y .|. 0xc0) : map (.|. 0x80) ys
177 | x <= 0xffff = let (y : ys) = split [] 3 x in (y .|. 0xe0) : map (.|. 0x80) ys
178 | x <= 0x10ffff = let (y : ys) = split [] 4 x in (y .|. 0xf0) : map (.|. 0x80) ys
179 | otherwise = error $ "Invalid Unicode code point U+" ++ showHex x ""
180 where
181 split acc 1 x = x : acc
182 split acc i x = split (x .&. 0x3f : acc) (i - 1) (shiftR x 6)
184 pad :: String -> String
185 pad s = case length s of
186 1 -> "0" ++ s
187 2 -> s
188 _ -> error $ "Can't happen: String of invalid length " ++ show s
190data CState = CS {
191 fnName :: Maybe Name,
192 level :: Int
196bcc :: [BC] -> RWS Int String CState ()
197bcc [] = return ()
198bcc ((ASSIGN l r):xs) = do
199 i <- get
200 tell $ indent (level i) ++ creg l ++ " = " ++ creg r ++ ";\n"
201 bcc xs
202bcc ((ASSIGNCONST l c):xs) = do
203 i <- get
204 tell $ indent (level i) ++ creg l ++ " = " ++ mkConst c ++ ";\n"
205 bcc xs
206 where
207 mkConst (I i) = "MKINT(" ++ show i ++ ")"
208 mkConst (BI i) | i < (2^30) = "MKINT(" ++ show i ++ ")"
209 | otherwise = "MKBIGC(vm,\"" ++ show i ++ "\")"
210 mkConst (Fl f) = "MKFLOAT(vm, " ++ show f ++ ")"
211 mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")"
212 mkConst (Str s) = "MKSTR(vm, " ++ showCStr s ++ ")"
213 mkConst (B8 x) = "idris_b8const(vm, " ++ show x ++ "U)"
214 mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ "U)"
215 mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ "UL)"
216 mkConst (B64 x) = "idris_b64const(vm, " ++ show x ++ "ULL)"
217 -- if it's a type constant, we won't use it, but equally it shouldn't
218 -- report an error. These might creep into generated for various reasons
219 -- (especially if erasure is disabled).
220 mkConst c | isTypeConst c = "MKINT(42424242)"
221 mkConst c = error $ "mkConst of (" ++ show c ++ ") not implemented"
223bcc ((UPDATE l r):xs) = do
224 i <- get
225 tell $ indent (level i) ++ creg l ++ " = " ++ creg r ++ ";\n"
226 bcc xs
227bcc ((MKCON l loc tag []):xs) | tag < 256 = do
228 i <- get
229 tell $ indent (level i) ++ creg l ++ " = NULL_CON(" ++ show tag ++ ");\n"
230 bcc xs
231bcc ((MKCON l loc tag args):xs) = do
232 i <- get
233 let tab = indent (level i)
234 tell $ tab ++ alloc loc tag ++
235 tab ++ setArgs 0 args ++ "\n" ++
236 tab ++ creg l ++ " = " ++ creg Tmp ++ ";\n"
237 bcc xs
238 where showArg r = ", " ++ creg r
239 setArgs i [] = ""
240 setArgs i (x : xs) = "SETARG(" ++ creg Tmp ++ ", " ++ show i ++ ", " ++ creg x ++
241 "); " ++ setArgs (i + 1) xs
242 alloc Nothing tag
243 = "allocCon(" ++ creg Tmp ++ ", vm, " ++ show tag ++ ", " ++
244 show (length args) ++ ", 0);\n"
245 alloc (Just old) tag
246 = "updateCon(" ++ creg Tmp ++ ", " ++ creg old ++ ", " ++ show tag ++ ", " ++
247 show (length args) ++ ");\n"
249bcc ((PROJECT l loc a):xs) = do
250 i <- get
251 tell $ indent (level i) ++ "PROJECT(vm, " ++ creg l ++ ", "
252 ++ show loc ++ ", " ++ show a ++ ");\n"
253 bcc xs
254bcc ((PROJECTINTO r t idx):xs) = do
255 i <- get
256 tell $ indent (level i) ++ creg r ++ " = GETARG(" ++ creg t
257 ++ ", " ++ show idx ++ ");\n"
258 bcc xs
259bcc ((CASE True r code def):xs)
260 | length code < 4 = do
261 showCases def code
262 bcc xs
263 where
264 showCode bc = do
265 w <- getBC bc xs
266 i <- get
267 tell $ "{\n" ++ w ++ indent (level i) ++ "}\n"
269 showCases Nothing [(t, c)] = do
270 i <- get
271 tell $ indent (level i)
272 showCode c
273 showCases (Just def) [] = do
274 i <- get
275 tell $ indent (level i)
276 showCode def
277 showCases def ((t, c) : cs) = do
278 i <- get
279 tell $ indent (level i) ++ "if (CTAG(" ++ creg r ++ ") == "
280 ++ show t ++ ") "
281 showCode c
282 tell $ indent (level i) ++ "else\n"
283 showCases def cs
285bcc ((CASE safe r code def):xs) = do
286 i <- get
287 tell $ indent (level i) ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n"
288 mapM showCase code
289 showDef def
290 tell $ indent (level i) ++ "}\n"
291 bcc xs
292 where
293 ctag True = "CTAG"
294 ctag False = "TAG"
296 showCase (t, bc) = do
297 w <- getBC bc xs
298 is <- get
299 let i = level is
300 tell $ indent i ++ "case " ++ show t ++ ":\n"
301 ++ w ++ indent (i + 1) ++ "break;\n"
302 showDef Nothing = return $ ()
303 showDef (Just c) = do
304 w <- getBC c xs
305 is <- get
306 let i = level is
307 tell $ indent i ++ "default:\n" ++ w ++ indent (i + 1) ++ "break;\n"
309bcc ((CONSTCASE r code def):xs)
310 | intConsts code
311 = do
312 is <- get
313 let i = level is
314 codes <- mapM getCode code
315 defs <- showDefS def
316 tell $ concatMap (iCase i (creg r)) codes
317 tell $ indent i ++ "{\n" ++ defs ++ indent i ++ "}\n"
318 bcc xs
319 | strConsts code
320 = do
321 is <- get
322 let i = level is
323 codes <- mapM getCode code
324 defs <- showDefS def
325 tell $ concatMap (strCase i ("GETSTR(" ++ creg r ++ ")")) codes
326 ++ indent i ++ "{\n" ++ defs ++ indent i ++ "}\n"
327 bcc xs
328 | bigintConsts code
329 = do
330 is <- get
331 let i = level is
332 codes <- mapM getCode code
333 defs <- showDefS def
334 tell $ concatMap (biCase i (creg r)) codes ++
335 indent i ++ "{\n" ++ defs ++ indent i ++ "}\n"
336 bcc xs
337 | otherwise = error $ "Can't happen: Can't compile const case " ++ show code
338 where
339 intConsts ((I _, _ ) : _) = True
340 intConsts ((Ch _, _ ) : _) = True
341 intConsts ((B8 _, _ ) : _) = True
342 intConsts ((B16 _, _ ) : _) = True
343 intConsts ((B32 _, _ ) : _) = True
344 intConsts ((B64 _, _ ) : _) = True
345 intConsts _ = False
347 bigintConsts ((BI _, _ ) : _) = True
348 bigintConsts _ = False
350 strConsts ((Str _, _ ) : _) = True
351 strConsts _ = False
353 getCode (x, code) = do
354 c <- getBC code xs
355 return (x, c)
357 strCase i sv (s, bc) =
358 indent i ++ "if (strcmp(" ++ sv ++ ", " ++ show s ++ ") == 0) {\n" ++
359 bc ++ indent i ++ "} else\n"
360 biCase i bv (BI b, bc) =
361 indent i ++ "if (bigEqConst(" ++ bv ++ ", " ++ show b ++ ")) {\n"
362 ++ bc ++ indent i ++ "} else\n"
363 iCase i v (I b, bc) =
364 indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show b ++ ") {\n"
365 ++ bc ++ indent i ++ "} else\n"
366 iCase i v (Ch b, bc) =
367 indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show (fromEnum b) ++ ") {\n"
368 ++ bc ++ indent i ++ "} else\n"
369 iCase i v (B8 w, bc) =
370 indent i ++ "if (GETBITS8(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"
371 ++ bc ++ indent i ++ "} else\n"
372 iCase i v (B16 w, bc) =
373 indent i ++ "if (GETBITS16(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"
374 ++ bc ++ indent i ++ "} else\n"
375 iCase i v (B32 w, bc) =
376 indent i ++ "if (GETBITS32(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"
377 ++ bc ++ indent i ++ "} else\n"
378 iCase i v (B64 w, bc) =
379 indent i ++ "if (GETBITS64(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"
380 ++ bc ++ indent i ++ "} else\n"
382 showDefS Nothing = return ""
383 showDefS (Just c) = getBC c xs
385bcc (CALL n:xs) = do
386 i <- get
387 tell $ indent (level i) ++ "CALL(" ++ cname n ++ ");\n"
388 bcc xs
389bcc (TAILCALL n:xs) = do
390 i <- get
391 tell $ indent (level i) ++ "TAILCALL(" ++ cname n ++ ");\n"
392 bcc xs
393bcc ((SLIDE n):xs) = do
394 i <- get
395 tell $ indent (level i) ++ "SLIDE(vm, " ++ show n ++ ");\n"
396 bcc xs
397bcc (REBASE:xs) = do
398 i <- get
399 tell $ indent (level i)++ "REBASE;\n"
400 bcc xs
401bcc ((RESERVE 0):xs) = bcc xs
402bcc ((RESERVE n):xs) = do
403 i <- get
404 tell $ indent (level i) ++ "RESERVE(" ++ show n ++ ");\n"
405 bcc xs
406bcc ((ADDTOP 0):xs) = bcc xs
407bcc ((ADDTOP n):xs) = do
408 i <- get
409 tell $ indent (level i) ++ "ADDTOP(" ++ show n ++ ");\n"
410 bcc xs
411bcc ((TOPBASE n):xs) = do
412 i <- get
413 tell $ indent (level i) ++ "TOPBASE(" ++ show n ++ ");\n"
414 bcc xs
415bcc ((BASETOP n):xs) = do
416 i <- get
417 tell $ indent (level i) ++ "BASETOP(" ++ show n ++ ");\n"
418 bcc xs
419bcc (STOREOLD:xs) = do
420 i <- get
421 tell $ indent (level i) ++ "STOREOLD;\n"
422 bcc xs
423bcc ((OP l fn args):xs) = do
424 i <- get
425 tell $ indent (level i) ++ doOp (creg l ++ " = ") fn args ++ ";\n"
426 bcc xs
427bcc ((FOREIGNCALL l rty (FStr fn@('&':name)) []):xs) = do
428 i <- get
429 tell $ indent (level i) ++ c_irts (toFType rty) (creg l ++ " = ") fn ++ ";\n"
430 bcc xs
431bcc ((FOREIGNCALL l rty (FStr fn) (x:xs)):zs) | fn == "%wrapper"
432 = do
433 i <- get
434 tell $ indent (level i) ++ c_irts (toFType rty) (creg l ++ " = ")
435 ("_idris_get_wrapper(" ++ creg (snd x) ++ ")") ++ ";\n"
436 bcc zs
437bcc ((FOREIGNCALL l rty (FStr fn) (x:xs)):zs) | fn == "%dynamic"
438 = do
439 i <- get
440 tell $ indent (level i) ++ c_irts (toFType rty) (creg l ++ " = ")
441 ("(*(" ++ cFnSig "" rty xs ++ ") GETPTR(" ++ creg (snd x) ++ "))" ++
442 "(" ++ showSep "," (map fcall xs) ++ ")") ++ ";\n"
443 bcc zs
444bcc ((FOREIGNCALL l rty (FStr fn) args):xs) = do
445 i <- get
446 tell $ indent (level i) ++ c_irts (toFType rty) (creg l ++ " = ")
447 (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"
448 bcc xs
449bcc ((FOREIGNCALL l rty _ args):_) = error "Foreign Function calls cannot be partially applied, without being inlined."
450bcc ((NULL r):xs) = do
451 i <- get
452 tell $ indent (level i) ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed
453 bcc xs
454bcc ((ERROR str):xs) = do
455 i <- get
456 tell $ indent (level i) ++ "fprintf(stderr, "
457 ++ show str ++ "); fprintf(stderr, \"\\n\"); exit(-1);\n"
458 bcc xs
459-- bcc i c = error (show c) -- indent i ++ "// not done yet\n"
461getBC code xs = do
462 i <- get
463 let (a, s, w) = runRWS (bcc code) 0 (i { level = level i + 1 })
464 return w
466fcall (t, arg) = irts_c (toFType t) (creg arg)
467-- Deconstruct the Foreign type in the defunctionalised expression and build
468-- a foreign type description for c_irts and irts_c
469toAType (FCon i)
470 | i == sUN "C_IntChar" = ATInt ITChar
471 | i == sUN "C_IntNative" = ATInt ITNative
472 | i == sUN "C_IntBits8" = ATInt (ITFixed IT8)
473 | i == sUN "C_IntBits16" = ATInt (ITFixed IT16)
474 | i == sUN "C_IntBits32" = ATInt (ITFixed IT32)
475 | i == sUN "C_IntBits64" = ATInt (ITFixed IT64)
476toAType t = error (show t ++ " not defined in toAType")
478toFType (FCon c)
479 | c == sUN "C_Str" = FString
480 | c == sUN "C_Float" = FArith ATFloat
481 | c == sUN "C_Ptr" = FPtr
482 | c == sUN "C_MPtr" = FManagedPtr
483 | c == sUN "C_CData" = FCData
484 | c == sUN "C_Unit" = FUnit
485toFType (FApp c [_,ity])
486 | c == sUN "C_IntT" = FArith (toAType ity)
487 | c == sUN "C_FnT" = toFunType ity
488toFType (FApp c [_])
489 | c == sUN "C_Any" = FAny
490toFType t = FAny
492toFunType (FApp c [_,ity])
493 | c == sUN "C_FnBase" = FFunction
494 | c == sUN "C_FnIO" = FFunctionIO
495toFunType (FApp c [_,_,_,ity])
496 | c == sUN "C_Fn" = toFunType ity
497toFunType _ = FAny
499c_irts (FArith (ATInt ITNative)) l x = l ++ "MKINT((i_int)(" ++ x ++ "))"
500c_irts (FArith (ATInt ITChar)) l x = c_irts (FArith (ATInt ITNative)) l x
501c_irts (FArith (ATInt (ITFixed ity))) l x
502 = l ++ "idris_b" ++ show (nativeTyWidth ity) ++ "const(vm, " ++ x ++ ")"
503c_irts FString l x = l ++ "MKSTR(vm, " ++ x ++ ")"
504c_irts FUnit l x = x
505c_irts FPtr l x = l ++ "MKPTR(vm, " ++ x ++ ")"
506c_irts FManagedPtr l x = l ++ "MKMPTR(vm, " ++ x ++ ")"
507c_irts (FArith ATFloat) l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"
508c_irts FCData l x = l ++ "MKCDATA(vm, " ++ x ++ ")"
509c_irts FAny l x = l ++ x
510c_irts FFunction l x = error "Return of function from foreign call is not supported"
511c_irts FFunctionIO l x = error "Return of function from foreign call is not supported"
513irts_c (FArith (ATInt ITNative)) x = "GETINT(" ++ x ++ ")"
514irts_c (FArith (ATInt ITChar)) x = irts_c (FArith (ATInt ITNative)) x
515irts_c (FArith (ATInt (ITFixed ity))) x
516 = "(" ++ x ++ "->info.bits" ++ show (nativeTyWidth ity) ++ ")"
517irts_c FString x = "GETSTR(" ++ x ++ ")"
518irts_c FUnit x = x
519irts_c FPtr x = "GETPTR(" ++ x ++ ")"
520irts_c FManagedPtr x = "GETMPTR(" ++ x ++ ")"
521irts_c (FArith ATFloat) x = "GETFLOAT(" ++ x ++ ")"
522irts_c FCData x = "GETCDATA(" ++ x ++ ")"
523irts_c FAny x = x
524irts_c FFunctionIO x = wrapped x
525irts_c FFunction x = wrapped x
527cFnSig name rty [] = ctype rty ++ " (*" ++ name ++ ")(void) "
528cFnSig name rty args = ctype rty ++ " (*" ++ name ++ ")("
529 ++ showSep "," (map (ctype . fst) args) ++ ") "
531wrapped x = "_idris_get_wrapper(" ++ x ++ ")"
533bitOp v op ty args = v ++ "idris_b" ++ show (nativeTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")"
535bitCoerce v op input output arg
536 = v ++ "idris_b" ++ show (nativeTyWidth input) ++ op ++ show (nativeTyWidth output) ++ "(vm, " ++ creg arg ++ ")"
538signedTy :: NativeTy -> String
539signedTy t = "int" ++ show (nativeTyWidth t) ++ "_t"
541doOp v (LPlus (ATInt ITNative)) [l, r] = v ++ "ADD(" ++ creg l ++ ", " ++ creg r ++ ")"
542doOp v (LMinus (ATInt ITNative)) [l, r] = v ++ "INTOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
543doOp v (LTimes (ATInt ITNative)) [l, r] = v ++ "MULT(" ++ creg l ++ ", " ++ creg r ++ ")"
544doOp v (LUDiv ITNative) [l, r] = v ++ "UINTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
545doOp v (LSDiv (ATInt ITNative)) [l, r] = v ++ "INTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
546doOp v (LURem ITNative) [l, r] = v ++ "UINTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"
547doOp v (LSRem (ATInt ITNative)) [l, r] = v ++ "INTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"
548doOp v (LAnd ITNative) [l, r] = v ++ "INTOP(&," ++ creg l ++ ", " ++ creg r ++ ")"
549doOp v (LOr ITNative) [l, r] = v ++ "INTOP(|," ++ creg l ++ ", " ++ creg r ++ ")"
550doOp v (LXOr ITNative) [l, r] = v ++ "INTOP(^," ++ creg l ++ ", " ++ creg r ++ ")"
551doOp v (LSHL ITNative) [l, r] = v ++ "INTOP(<<," ++ creg l ++ ", " ++ creg r ++ ")"
552doOp v (LLSHR ITNative) [l, r] = v ++ "UINTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"
553doOp v (LASHR ITNative) [l, r] = v ++ "INTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"
554doOp v (LCompl ITNative) [x] = v ++ "INTOP(~," ++ creg x ++ ")"
555doOp v (LEq (ATInt ITNative)) [l, r] = v ++ "INTOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
556doOp v (LSLt (ATInt ITNative)) [l, r] = v ++ "INTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
557doOp v (LSLe (ATInt ITNative)) [l, r] = v ++ "INTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
558doOp v (LSGt (ATInt ITNative)) [l, r] = v ++ "INTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
559doOp v (LSGe (ATInt ITNative)) [l, r] = v ++ "INTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
560doOp v (LLt ITNative) [l, r] = v ++ "UINTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
561doOp v (LLe ITNative) [l, r] = v ++ "UINTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
562doOp v (LGt ITNative) [l, r] = v ++ "UINTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
563doOp v (LGe ITNative) [l, r] = v ++ "UINTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
565doOp v (LPlus (ATInt ITChar)) [l, r] = doOp v (LPlus (ATInt ITNative)) [l, r]
566doOp v (LMinus (ATInt ITChar)) [l, r] = doOp v (LMinus (ATInt ITNative)) [l, r]
567doOp v (LTimes (ATInt ITChar)) [l, r] = doOp v (LTimes (ATInt ITNative)) [l, r]
568doOp v (LUDiv ITChar) [l, r] = doOp v (LUDiv ITNative) [l, r]
569doOp v (LSDiv (ATInt ITChar)) [l, r] = doOp v (LSDiv (ATInt ITNative)) [l, r]
570doOp v (LURem ITChar) [l, r] = doOp v (LURem ITNative) [l, r]
571doOp v (LSRem (ATInt ITChar)) [l, r] = doOp v (LSRem (ATInt ITNative)) [l, r]
572doOp v (LAnd ITChar) [l, r] = doOp v (LAnd ITNative) [l, r]
573doOp v (LOr ITChar) [l, r] = doOp v (LOr ITNative) [l, r]
574doOp v (LXOr ITChar) [l, r] = doOp v (LXOr ITNative) [l, r]
575doOp v (LSHL ITChar) [l, r] = doOp v (LSHL ITNative) [l, r]
576doOp v (LLSHR ITChar) [l, r] = doOp v (LLSHR ITNative) [l, r]
577doOp v (LASHR ITChar) [l, r] = doOp v (LASHR ITNative) [l, r]
578doOp v (LCompl ITChar) [x] = doOp v (LCompl ITNative) [x]
579doOp v (LEq (ATInt ITChar)) [l, r] = doOp v (LEq (ATInt ITNative)) [l, r]
580doOp v (LSLt (ATInt ITChar)) [l, r] = doOp v (LSLt (ATInt ITNative)) [l, r]
581doOp v (LSLe (ATInt ITChar)) [l, r] = doOp v (LSLe (ATInt ITNative)) [l, r]
582doOp v (LSGt (ATInt ITChar)) [l, r] = doOp v (LSGt (ATInt ITNative)) [l, r]
583doOp v (LSGe (ATInt ITChar)) [l, r] = doOp v (LSGe (ATInt ITNative)) [l, r]
584doOp v (LLt ITChar) [l, r] = doOp v (LLt ITNative) [l, r]
585doOp v (LLe ITChar) [l, r] = doOp v (LLe ITNative) [l, r]
586doOp v (LGt ITChar) [l, r] = doOp v (LGt ITNative) [l, r]
587doOp v (LGe ITChar) [l, r] = doOp v (LGe ITNative) [l, r]
589doOp v (LPlus ATFloat) [l, r] = v ++ "FLOATOP(+," ++ creg l ++ ", " ++ creg r ++ ")"
590doOp v (LMinus ATFloat) [l, r] = v ++ "FLOATOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
591doOp v (LTimes ATFloat) [l, r] = v ++ "FLOATOP(*," ++ creg l ++ ", " ++ creg r ++ ")"
592doOp v (LSDiv ATFloat) [l, r] = v ++ "FLOATOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
593doOp v (LEq ATFloat) [l, r] = v ++ "FLOATBOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
594doOp v (LSLt ATFloat) [l, r] = v ++ "FLOATBOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
595doOp v (LSLe ATFloat) [l, r] = v ++ "FLOATBOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
596doOp v (LSGt ATFloat) [l, r] = v ++ "FLOATBOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
597doOp v (LSGe ATFloat) [l, r] = v ++ "FLOATBOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
599doOp v (LIntFloat ITBig) [x] = v ++ "idris_castBigFloat(vm, " ++ creg x ++ ")"
600doOp v (LFloatInt ITBig) [x] = v ++ "idris_castFloatBig(vm, " ++ creg x ++ ")"
601doOp v (LPlus (ATInt ITBig)) [l, r] = v ++ "idris_bigPlus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
602doOp v (LMinus (ATInt ITBig)) [l, r] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
603doOp v (LTimes (ATInt ITBig)) [l, r] = v ++ "idris_bigTimes(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
604doOp v (LSDiv (ATInt ITBig)) [l, r] = v ++ "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
605doOp v (LSRem (ATInt ITBig)) [l, r] = v ++ "idris_bigMod(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
606doOp v (LAnd ITBig) [l, r] = v ++ "idris_bigAnd(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
607doOp v (LOr ITBig) [l, r] = v ++ "idris_bigOr(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
608doOp v (LSHL ITBig) [l, r] = v ++ "idris_bigShiftLeft(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
609doOp v (LLSHR ITBig) [l, r] = v ++ "idris_bigLShiftRight(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
610doOp v (LASHR ITBig) [l, r] = v ++ "idris_bigAShiftRight(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
611doOp v (LEq (ATInt ITBig)) [l, r] = v ++ "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
612doOp v (LSLt (ATInt ITBig)) [l, r] = v ++ "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
613doOp v (LSLe (ATInt ITBig)) [l, r] = v ++ "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
614doOp v (LSGt (ATInt ITBig)) [l, r] = v ++ "idris_bigGt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
615doOp v (LSGe (ATInt ITBig)) [l, r] = v ++ "idris_bigGe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
617doOp v (LIntFloat ITNative) [x] = v ++ "idris_castIntFloat(" ++ creg x ++ ")"
618doOp v (LFloatInt ITNative) [x] = v ++ "idris_castFloatInt(" ++ creg x ++ ")"
619doOp v (LSExt ITNative ITBig) [x] = v ++ "idris_castIntBig(vm, " ++ creg x ++ ")"
620doOp v (LTrunc ITBig ITNative) [x] = v ++ "idris_castBigInt(vm, " ++ creg x ++ ")"
621doOp v (LStrInt ITBig) [x] = v ++ "idris_castStrBig(vm, " ++ creg x ++ ")"
622doOp v (LIntStr ITBig) [x] = v ++ "idris_castBigStr(vm, " ++ creg x ++ ")"
623doOp v (LIntStr ITNative) [x] = v ++ "idris_castIntStr(vm, " ++ creg x ++ ")"
624doOp v (LStrInt ITNative) [x] = v ++ "idris_castStrInt(vm, " ++ creg x ++ ")"
625doOp v (LIntStr (ITFixed _)) [x] = v ++ "idris_castBitsStr(vm, " ++ creg x ++ ")"
626doOp v LFloatStr [x] = v ++ "idris_castFloatStr(vm, " ++ creg x ++ ")"
627doOp v LStrFloat [x] = v ++ "idris_castStrFloat(vm, " ++ creg x ++ ")"
629doOp v (LSLt (ATInt (ITFixed ty))) [x, y] = bitOp v "SLt" ty [x, y]
630doOp v (LSLe (ATInt (ITFixed ty))) [x, y] = bitOp v "SLte" ty [x, y]
631doOp v (LEq (ATInt (ITFixed ty))) [x, y] = bitOp v "Eq" ty [x, y]
632doOp v (LSGe (ATInt (ITFixed ty))) [x, y] = bitOp v "SGte" ty [x, y]
633doOp v (LSGt (ATInt (ITFixed ty))) [x, y] = bitOp v "SGt" ty [x, y]
634doOp v (LLt (ITFixed ty)) [x, y] = bitOp v "Lt" ty [x, y]
635doOp v (LLe (ITFixed ty)) [x, y] = bitOp v "Lte" ty [x, y]
636doOp v (LGe (ITFixed ty)) [x, y] = bitOp v "Gte" ty [x, y]
637doOp v (LGt (ITFixed ty)) [x, y] = bitOp v "Gt" ty [x, y]
639doOp v (LSHL (ITFixed ty)) [x, y] = bitOp v "Shl" ty [x, y]
640doOp v (LLSHR (ITFixed ty)) [x, y] = bitOp v "LShr" ty [x, y]
641doOp v (LASHR (ITFixed ty)) [x, y] = bitOp v "AShr" ty [x, y]
642doOp v (LAnd (ITFixed ty)) [x, y] = bitOp v "And" ty [x, y]
643doOp v (LOr (ITFixed ty)) [x, y] = bitOp v "Or" ty [x, y]
644doOp v (LXOr (ITFixed ty)) [x, y] = bitOp v "Xor" ty [x, y]
645doOp v (LCompl (ITFixed ty)) [x] = bitOp v "Compl" ty [x]
647doOp v (LPlus (ATInt (ITFixed ty))) [x, y] = bitOp v "Plus" ty [x, y]
648doOp v (LMinus (ATInt (ITFixed ty))) [x, y] = bitOp v "Minus" ty [x, y]
649doOp v (LTimes (ATInt (ITFixed ty))) [x, y] = bitOp v "Times" ty [x, y]
650doOp v (LUDiv (ITFixed ty)) [x, y] = bitOp v "UDiv" ty [x, y]
651doOp v (LSDiv (ATInt (ITFixed ty))) [x, y] = bitOp v "SDiv" ty [x, y]
652doOp v (LURem (ITFixed ty)) [x, y] = bitOp v "URem" ty [x, y]
653doOp v (LSRem (ATInt (ITFixed ty))) [x, y] = bitOp v "SRem" ty [x, y]
655doOp v (LSExt (ITFixed from) ITBig) [x]
656 = v ++ "MKBIGSI(vm, (" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
657doOp v (LSExt ITNative (ITFixed to)) [x]
658 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"
659doOp v (LSExt ITChar (ITFixed to)) [x]
660 = doOp v (LSExt ITNative (ITFixed to)) [x]
661doOp v (LSExt (ITFixed from) ITNative) [x]
662 = v ++ "MKINT((i_int)((" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ "))"
663doOp v (LSExt (ITFixed from) ITChar) [x]
664 = doOp v (LSExt (ITFixed from) ITNative) [x]
665doOp v (LSExt (ITFixed from) (ITFixed to)) [x]
666 | nativeTyWidth from < nativeTyWidth to = bitCoerce v "S" from to x
667doOp v (LZExt ITNative (ITFixed to)) [x]
668 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, (uintptr_t)GETINT(" ++ creg x ++ "))"
669doOp v (LZExt ITChar (ITFixed to)) [x]
670 = doOp v (LZExt ITNative (ITFixed to)) [x]
671doOp v (LZExt (ITFixed from) ITNative) [x]
672 = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
673doOp v (LZExt (ITFixed from) ITChar) [x]
674 = doOp v (LZExt (ITFixed from) ITNative) [x]
675doOp v (LZExt (ITFixed from) ITBig) [x]
676 = v ++ "MKBIGUI(vm, " ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
677doOp v (LZExt ITNative ITBig) [x]
678 = v ++ "MKBIGUI(vm, (uintptr_t)GETINT(" ++ creg x ++ "))"
679doOp v (LZExt (ITFixed from) (ITFixed to)) [x]
680 | nativeTyWidth from < nativeTyWidth to = bitCoerce v "Z" from to x
681doOp v (LTrunc ITNative (ITFixed to)) [x]
682 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"
683doOp v (LTrunc ITChar (ITFixed to)) [x]
684 = doOp v (LTrunc ITNative (ITFixed to)) [x]
685doOp v (LTrunc (ITFixed from) ITNative) [x]
686 = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
687doOp v (LTrunc (ITFixed from) ITChar) [x]
688 = doOp v (LTrunc (ITFixed from) ITNative) [x]
689doOp v (LTrunc ITBig (ITFixed IT64)) [x]
690 = v ++ "idris_b64const(vm, ISINT(" ++ creg x ++ ") ? GETINT(" ++ creg x ++ ") : idris_truncBigB64(GETMPZ(" ++ creg x ++ ")))"
691doOp v (LTrunc ITBig (ITFixed to)) [x]
692 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, ISINT(" ++ creg x ++ ") ? GETINT(" ++ creg x ++ ") : mpz_get_ui(GETMPZ(" ++ creg x ++ ")))"
693doOp v (LTrunc (ITFixed from) (ITFixed to)) [x]
694 | nativeTyWidth from > nativeTyWidth to = bitCoerce v "T" from to x
696doOp v LFExp [x] = v ++ flUnOp "exp" (creg x)
697doOp v LFLog [x] = v ++ flUnOp "log" (creg x)
698doOp v LFSin [x] = v ++ flUnOp "sin" (creg x)
699doOp v LFCos [x] = v ++ flUnOp "cos" (creg x)
700doOp v LFTan [x] = v ++ flUnOp "tan" (creg x)
701doOp v LFASin [x] = v ++ flUnOp "asin" (creg x)
702doOp v LFACos [x] = v ++ flUnOp "acos" (creg x)
703doOp v LFATan [x] = v ++ flUnOp "atan" (creg x)
704doOp v LFSqrt [x] = v ++ flUnOp "sqrt" (creg x)
705doOp v LFFloor [x] = v ++ flUnOp "floor" (creg x)
706doOp v LFCeil [x] = v ++ flUnOp "ceil" (creg x)
707doOp v LFNegate [x] = v ++ "MKFLOAT(vm, -GETFLOAT(" ++ (creg x) ++ "))"
709-- String functions which don't need to know we're UTF8
710doOp v LStrConcat [l,r] = v ++ "idris_concat(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
711doOp v LStrLt [l,r] = v ++ "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
712doOp v LStrEq [l,r] = v ++ "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
714doOp v LReadStr [_] = v ++ "idris_readStr(vm, stdin)"
715doOp v LWriteStr [_,s]
716 = v ++ "MKINT((i_int)(idris_writeStr(stdout"
717 ++ ",GETSTR("
718 ++ creg s ++ "))))"
721-- String functions which need to know we're UTF8
722doOp v LStrHead [x] = v ++ "idris_strHead(vm, " ++ creg x ++ ")"
723doOp v LStrTail [x] = v ++ "idris_strTail(vm, " ++ creg x ++ ")"
724doOp v LStrCons [x, y] = v ++ "idris_strCons(vm, " ++ creg x ++ "," ++ creg y ++ ")"
725doOp v LStrIndex [x, y] = v ++ "idris_strIndex(vm, " ++ creg x ++ "," ++ creg y ++ ")"
726doOp v LStrRev [x] = v ++ "idris_strRev(vm, " ++ creg x ++ ")"
727doOp v LStrLen [x] = v ++ "idris_strlen(vm, " ++ creg x ++ ")"
728doOp v LStrSubstr [x,y,z] = v ++ "idris_substr(vm, " ++ creg x ++ "," ++ creg y ++ "," ++ creg z ++ ")"
730doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (sMN 0 "EVAL") ++ ", " ++ creg x ++ "))"
731doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"
732doOp v (LChInt ITNative) args = v ++ creg (last args)
733doOp v (LChInt ITChar) args = doOp v (LChInt ITNative) args
734doOp v (LIntCh ITNative) args = v ++ creg (last args)
735doOp v (LIntCh ITChar) args = doOp v (LIntCh ITNative) args
737doOp v LSystemInfo [x] = v ++ "idris_systemInfo(vm, " ++ creg x ++ ")"
738doOp v LCrash [x] = "idris_crash(GETSTR(" ++ creg x ++ "))"
739doOp v LNoOp args = v ++ creg (last args)
741-- Pointer primitives (declared as %extern in Builtins.idr)
742doOp v (LExternal rf) [_,x]
743 | rf == sUN "prim__readFile"
744 = v ++ "idris_readStr(vm, GETPTR(" ++ creg x ++ "))"
745doOp v (LExternal rf) [_,len,x]
746 | rf == sUN "prim__readChars"
747 = v ++ "idris_readChars(vm, GETINT(" ++ creg len ++
748 "), GETPTR(" ++ creg x ++ "))"
749doOp v (LExternal wf) [_,x,s]
750 | wf == sUN "prim__writeFile"
751 = v ++ "MKINT((i_int)(idris_writeStr(GETPTR(" ++ creg x
752 ++ "),GETSTR("
753 ++ creg s ++ "))))"
754doOp v (LExternal si) [] | si == sUN "prim__stdin" = v ++ "MKPTR(vm, stdin)"
755doOp v (LExternal so) [] | so == sUN "prim__stdout" = v ++ "MKPTR(vm, stdout)"
756doOp v (LExternal se) [] | se == sUN "prim__stderr" = v ++ "MKPTR(vm, stderr)"
758doOp v (LExternal vm) [_] | vm == sUN "prim__vm" = v ++ "MKPTR(vm, vm)"
759doOp v (LExternal nul) [] | nul == sUN "prim__null" = v ++ "MKPTR(vm, NULL)"
760doOp v (LExternal eqp) [x, y] | eqp == sUN "prim__eqPtr"
761 = v ++ "MKINT((i_int)(GETPTR(" ++ creg x ++ ") == GETPTR(" ++ creg y ++ ")))"
762doOp v (LExternal eqp) [x, y] | eqp == sUN "prim__eqManagedPtr"
763 = v ++ "MKINT((i_int)(GETMPTR(" ++ creg x ++ ") == GETMPTR(" ++ creg y ++ ")))"
764doOp v (LExternal rp) [p, i] | rp == sUN "prim__registerPtr"
765 = v ++ "MKMPTR(vm, GETPTR(" ++ creg p ++ "), GETINT(" ++ creg i ++ "))"
766doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peek8"
767 = v ++ "idris_peekB8(vm," ++ creg p ++ "," ++ creg o ++")"
768doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__poke8"
769 = v ++ "idris_pokeB8(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"
770doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peek16"
771 = v ++ "idris_peekB16(vm," ++ creg p ++ "," ++ creg o ++")"
772doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__poke16"
773 = v ++ "idris_pokeB16(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"
774doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peek32"
775 = v ++ "idris_peekB32(vm," ++ creg p ++ "," ++ creg o ++")"
776doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__poke32"
777 = v ++ "idris_pokeB32(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"
778doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peek64"
779 = v ++ "idris_peekB64(vm," ++ creg p ++ "," ++ creg o ++")"
780doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__poke64"
781 = v ++ "idris_pokeB64(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"
782doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peekPtr"
783 = v ++ "idris_peekPtr(vm," ++ creg p ++ "," ++ creg o ++")"
784doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__pokePtr"
785 = v ++ "idris_pokePtr(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"
786doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__pokeDouble"
787 = v ++ "idris_pokeDouble(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"
788doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peekDouble"
789 = v ++ "idris_peekDouble(vm," ++ creg p ++ "," ++ creg o ++")"
790doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__pokeSingle"
791 = v ++ "idris_pokeSingle(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"
792doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peekSingle"
793 = v ++ "idris_peekSingle(vm," ++ creg p ++ "," ++ creg o ++")"
794doOp v (LExternal pk) [] | pk == sUN "prim__sizeofPtr"
795 = v ++ "MKINT(sizeof(void*))"
796doOp v (LExternal mpt) [p] | mpt == sUN "prim__asPtr"
797 = v ++ "MKPTR(vm, GETMPTR("++ creg p ++"))"
798doOp v (LExternal offs) [p, n] | offs == sUN "prim__ptrOffset"
799 = v ++ "MKPTR(vm, (void *)((char *)GETPTR(" ++ creg p ++ ") + GETINT(" ++ creg n ++ ")))"
800doOp _ op args = error $ "doOp not implemented (" ++ show (op, args) ++ ")"
803flUnOp :: String -> String -> String
804flUnOp name val = "MKFLOAT(vm, " ++ name ++ "(GETFLOAT(" ++ val ++ ")))"
806-------------------- Interface file generation
808-- First, the wrappers in the C file
810ifaceC :: Export -> String
811ifaceC (ExportData n) = "typedef VAL " ++ cdesc n ++ ";\n"
812ifaceC (ExportFun n cn ret args)
813 = ctype ret ++ " " ++ cdesc cn ++
814 "(VM* vm" ++ showArgs (zip argNames args) ++ ") {\n"
815 ++ mkBody n (zip argNames args) ret ++ "}\n\n"
816 where showArgs [] = ""
817 showArgs ((n, t) : ts) = ", " ++ ctype t ++ " " ++ n ++
818 showArgs ts
820 argNames = zipWith (++) (repeat "arg") (map show [0..])
822mkBody n as t = indent 1 ++ "INITFRAME;\n" ++
823 indent 1 ++ "RESERVE(" ++ show (max (length as) 3) ++ ");\n" ++
824 push 0 as ++ call n ++ retval t
825 where push i [] = ""
826 push i ((n, t) : ts) = indent 1 ++ c_irts (toFType t)
827 ("TOP(" ++ show i ++ ") = ") n
828 ++ ";\n" ++ push (i + 1) ts
830 call _ = indent 1 ++ "STOREOLD;\n" ++
831 indent 1 ++ "BASETOP(0);\n" ++
832 indent 1 ++ "ADDTOP(" ++ show (length as) ++ ");\n" ++
833 indent 1 ++ "CALL(" ++ cname n ++ ");\n"
835 retval (FIO t)
836 = indent 1 ++ "TOP(0) = NULL;\n" ++
837 indent 1 ++ "TOP(1) = NULL;\n" ++
838 indent 1 ++ "TOP(2) = RVAL;\n" ++
839 indent 1 ++ "STOREOLD;\n" ++
840 indent 1 ++ "BASETOP(0);\n" ++
841 indent 1 ++ "ADDTOP(3);\n" ++
842 indent 1 ++ "CALL(" ++ cname (sUN "call__IO") ++ ");\n" ++
843 retval t
844 retval t = indent 1 ++ "return " ++ irts_c (toFType t) "RVAL" ++ ";\n"
846ctype (FCon c)
847 | c == sUN "C_Str" = "char*"
848 | c == sUN "C_Float" = "float"
849 | c == sUN "C_Ptr" = "void*"
850 | c == sUN "C_MPtr" = "void*"
851 | c == sUN "C_Unit" = "void"
852ctype (FApp c [_,ity])
853 | c == sUN "C_IntT" = carith ity
854ctype (FApp c [_])
855 | c == sUN "C_Any" = "VAL"
856ctype (FStr s) = s
857ctype FUnknown = "void*"
858ctype (FIO t) = ctype t
859ctype t = error "Can't happen: Not a valid interface type " ++ show t
861carith (FCon i)
862 | i == sUN "C_IntChar" = "char"
863 | i == sUN "C_IntNative" = "int"
864 | i == sUN "C_IntBits8" = "uint8_t"
865 | i == sUN "C_IntBits16" = "uint16_t"
866 | i == sUN "C_IntBits32" = "uint32_t"
867 | i == sUN "C_IntBits64" = "uint64_t"
868carith t = error $ "Can't happen: Not an exportable arithmetic type " ++ show t
870cdesc (FStr s) = s
871cdesc s = error "Can't happen: Not a valid C name"
873-- Then, the header files
875codegenH :: [ExportIFace] -> IO ()
876codegenH es = mapM_ writeIFace es
878writeIFace :: ExportIFace -> IO ()
879writeIFace (Export ffic hdr exps)
880 | ffic == sNS (sUN "FFI_C") ["FFI_C"]
881 = do let hfile = "#ifndef " ++ hdr_guard hdr ++ "\n" ++
882 "#define " ++ hdr_guard hdr ++ "\n\n" ++
883 "#include <idris_rts.h>\n\n" ++
884 concatMap hdr_export exps ++ "\n" ++
885 "#endif\n\n"
886 writeFile hdr hfile
887 | otherwise = return ()
889hdr_guard x = "__" ++ map hchar x
890 where hchar x | isAlphaNum x = toUpper x
891 hchar _ = '_'
893hdr_export :: Export -> String
894hdr_export (ExportData n) = "typedef VAL " ++ cdesc n ++ ";\n"
895hdr_export (ExportFun n cn ret args)
896 = ctype ret ++ " " ++ cdesc cn ++
897 "(VM* vm" ++ showArgs (zip argNames args) ++ ");\n"
898 where showArgs [] = ""
899 showArgs ((n, t) : ts) = ", " ++ ctype t ++ " " ++ n ++
900 showArgs ts
902 argNames = zipWith (++) (repeat "arg") (map show [0..])
904------------------ Callback wrapper generation ----------------
905-- Generate callback wrappers and a function to select the
906-- correct wrapper function to pass.
907-- TODO: This is limited to functions that are specified in
908-- the foreign call. Otherwise we would have to generate wrappers for all
909-- functions with correct arity or do flow analysis
910-- to find all possible inputs to the foreign call.
911genWrappers :: [(Name, [BC])] -> String
912genWrappers bcs = let
913 tags = nubBy (\x y -> snd x == snd y) $ concatMap (getCallback . snd) bcs
914 in
915 case tags of
916 [] -> ""
917 t -> concatMap genWrapper t ++ genDispatcher t
919genDispatcher :: [(FDesc, Int)] -> String
920genDispatcher tags = "void* _idris_get_wrapper(VAL con)\n" ++
921 "{\n" ++
922 indent 1 ++ "switch(TAG(con)) {\n" ++
923 concatMap makeSwitch tags ++
924 indent 1 ++ "}\n" ++
925 indent 1 ++ "fprintf(stderr, \"No wrapper for callback\");\n" ++
926 indent 1 ++ "exit(-1);\n" ++
927 "}\n\n"
928 where
929 makeSwitch (_, tag) =
930 indent 1 ++ "case " ++ show tag ++ ":\n" ++
931 indent 2 ++ "return (void*) &" ++ wrapperName tag ++ ";\n"
933genWrapper :: (FDesc, Int) -> String
934genWrapper (desc, tag) | (toFType desc) == FFunctionIO =
935 error "Cannot create C callbacks for IO functions, wrap them with unsafePerformIO.\n"
936genWrapper (desc, tag) = ret ++ " " ++ wrapperName tag ++ "(" ++
937 renderArgs argList ++")\n" ++
938 "{\n" ++
939 (if ret /= "void" then indent 1 ++ ret ++ " ret;\n" else "") ++
940 indent 1 ++ "VM* vm = get_vm();\n" ++
941 indent 1 ++ "if (vm == NULL) {\n" ++
942 indent 2 ++ "vm = idris_vm();\n" ++
943 indent 1 ++ "}\n" ++
944 indent 1 ++ "INITFRAME;\n" ++
945 indent 1 ++ "RESERVE(" ++ show (len + 1) ++ ");\n" ++
946 indent 1 ++ "allocCon(REG1, vm, " ++ show tag ++ ",0 , 0);\n" ++
947 indent 1 ++ "TOP(0) = REG1;\n" ++
948 applyArgs argList ++
949 if ret /= "void"
950 then indent 1 ++ "ret = " ++ irts_c (toFType ft) "RVAL" ++ ";\n"
951 ++ indent 1 ++ "return ret;\n}\n\n"
952 else "}\n\n"
953 where
954 (ret, ft) = rty desc
955 argList = zip (args desc) [0..]
956 len = length argList
958 applyArgs (x:y:xs) = push 1 [x] ++
959 indent 1 ++ "STOREOLD;\n" ++
960 indent 1 ++ "BASETOP(0);\n" ++
961 indent 1 ++ "ADDTOP(2);\n" ++
962 indent 1 ++ "CALL(_idris__123_APPLY_95_0_125_);\n" ++
963 indent 1 ++ "TOP(0)=REG1;\n" ++
964 applyArgs (y:xs)
965 applyArgs x = push 1 x ++
966 indent 1 ++ "STOREOLD;\n" ++
967 indent 1 ++ "BASETOP(0);\n" ++
968 indent 1 ++ "ADDTOP(" ++ show (length x + 1) ++ ");\n" ++
969 indent 1 ++ "CALL(_idris__123_APPLY_95_0_125_);\n"
970 renderArgs [] = "void"
971 renderArgs [((s, _), n)] = s ++ " a" ++ (show n)
972 renderArgs (((s, _), n):xs) = s ++ " a" ++ (show n) ++ ", " ++
973 renderArgs xs
974 rty (FApp c [_,ty])
975 | c == sUN "C_FnBase" = (ctype ty, ty)
976 | c == sUN "C_FnIO" = (ctype ty, ty)
977 | c == sUN "C_FnT" = rty ty
978 rty (FApp c [_,_,ty,fn])
979 | c == sUN "C_Fn" = rty fn
980 rty x = ("", x)
981 args (FApp c [_,ty])
982 | c == sUN "C_FnBase" = []
983 | c == sUN "C_FnIO" = []
984 | c == sUN "C_FnT" = args ty
985 args (FApp c [_,_,ty,fn])
986 | toFType ty == FUnit = []
987 | c == sUN "C_Fn" = (ctype ty, ty) : args fn
988 args _ = []
989 push i [] = ""
990 push i (((c, t), n) : ts) = indent 1 ++ c_irts (toFType t)
991 ("TOP(" ++ show i ++ ") = ") ("a" ++ show n)
992 ++ ";\n" ++ push (i + 1) ts
994wrapperName :: Int -> String
995wrapperName tag = "_idris_wrapper_" ++ show tag
997getCallback :: [BC] -> [(FDesc, Int)]
998getCallback bc = getCallback' (reverse bc)
999 where
1000 getCallback' (x:xs) = case hasCallback x of
1001 [] -> getCallback' xs
1002 cbs -> case findCons cbs xs of
1003 [] -> error "Idris function couldn't be wrapped."
1004 x -> x
1005 getCallback' [] = []
1006 findCons (c:cs) xs = findCon c xs ++ findCons cs xs
1007 findCons [] _ = []
1008 findCon c ((MKCON l loc tag args):xs) | snd c == l = [(fst c, tag)]
1009 findCon c (_:xs) = findCon c xs
1010 findCon c [] = []
1012hasCallback :: BC -> [(FDesc, Reg)]
1013hasCallback (FOREIGNCALL l rty (FStr fn) args) = filter isFn args
1014 where
1015 isFn (desc,_) = case toFType desc of
1016 FFunction -> True
1017 FFunctionIO -> True
1018 _ -> False
1019hasCallback _ = []