{-# LANGUAGE FlexibleContexts #-}
module IRTS.CodegenC (codegenC) where
import Idris.Core.TT
import IRTS.Bytecode
import IRTS.CodegenCommon
import IRTS.Defunctionalise
import IRTS.Simplified
import IRTS.System
import Util.System
import Control.Monad
import Data.Bits
import Data.Char
import Data.List (intercalate, nubBy)
import Numeric
import System.Exit
import System.FilePath ((<.>), (</>))
import System.IO
import System.Process
codegenC :: CodeGenerator
codegenC :: CodeGenerator
codegenC ci :: CodegenInfo
ci = do [(Name, SDecl)]
-> String
-> OutputType
-> [String]
-> [String]
-> [String]
-> [String]
-> [ExportIFace]
-> Bool
-> DbgLevel
-> IO ()
codegenC' (CodegenInfo -> [(Name, SDecl)]
simpleDecls CodegenInfo
ci)
(CodegenInfo -> String
outputFile CodegenInfo
ci)
(CodegenInfo -> OutputType
outputType CodegenInfo
ci)
(CodegenInfo -> [String]
includes CodegenInfo
ci)
(CodegenInfo -> [String]
compileObjs CodegenInfo
ci)
((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
mkLib (CodegenInfo -> [String]
compileLibs CodegenInfo
ci) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
(String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
incdir (CodegenInfo -> [String]
importDirs CodegenInfo
ci))
(CodegenInfo -> [String]
compilerFlags CodegenInfo
ci)
(CodegenInfo -> [ExportIFace]
exportDecls CodegenInfo
ci)
(CodegenInfo -> Bool
interfaces CodegenInfo
ci)
(CodegenInfo -> DbgLevel
debugLevel CodegenInfo
ci)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CodegenInfo -> Bool
interfaces CodegenInfo
ci) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
[ExportIFace] -> IO ()
codegenH (CodegenInfo -> [ExportIFace]
exportDecls CodegenInfo
ci)
where mkLib :: String -> String
mkLib l :: String
l = "-l" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
l
incdir :: String -> String
incdir i :: String
i = "-I" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
i
codegenC' :: [(Name, SDecl)]
-> String
-> OutputType
-> [FilePath]
-> [String]
-> [String]
-> [String]
-> [ExportIFace]
-> Bool
-> DbgLevel
-> IO ()
codegenC' :: [(Name, SDecl)]
-> String
-> OutputType
-> [String]
-> [String]
-> [String]
-> [String]
-> [ExportIFace]
-> Bool
-> DbgLevel
-> IO ()
codegenC' defs :: [(Name, SDecl)]
defs out :: String
out exec :: OutputType
exec incs :: [String]
incs objs :: [String]
objs libs :: [String]
libs flags :: [String]
flags exports :: [ExportIFace]
exports iface :: Bool
iface dbg :: DbgLevel
dbg
= do
let bc :: [(Name, [BC])]
bc = ((Name, SDecl) -> (Name, [BC]))
-> [(Name, SDecl)] -> [(Name, [BC])]
forall a b. (a -> b) -> [a] -> [b]
map (Name, SDecl) -> (Name, [BC])
toBC [(Name, SDecl)]
defs
let wrappers :: String
wrappers = [(Name, [BC])] -> String
genWrappers [(Name, [BC])]
bc
let h :: String
h = (Name -> String) -> [Name] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Name -> String
toDecl (((Name, [BC]) -> Name) -> [(Name, [BC])] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [BC]) -> Name
forall a b. (a, b) -> a
fst [(Name, [BC])]
bc)
let cc :: String
cc = ((Name, [BC]) -> String) -> [(Name, [BC])] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Name -> [BC] -> String) -> (Name, [BC]) -> String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> [BC] -> String
toC) [(Name, [BC])]
bc
let hi :: String
hi = (Export -> String) -> [Export] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Export -> String
ifaceC ((ExportIFace -> [Export]) -> [ExportIFace] -> [Export]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ExportIFace -> [Export]
getExp [ExportIFace]
exports)
String
d <- IO String
getIdrisCRTSDir
String
mprog <- String -> IO String
readFile (String
d String -> String -> String
</> "idris_main" String -> String -> String
<.> "c")
let cout :: String
cout = [String] -> String
headers [String]
incs String -> String -> String
forall a. [a] -> [a] -> [a]
++ DbgLevel -> String
debug DbgLevel
dbg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
h String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
wrappers String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cc String -> String -> String
forall a. [a] -> [a] -> [a]
++
(if (OutputType
exec OutputType -> OutputType -> Bool
forall a. Eq a => a -> a -> Bool
== OutputType
Executable) then String
mprog else String
hi)
case OutputType
exec of
Raw -> String -> String -> IO ()
writeSource String
out String
cout
_ -> do
(tmpn :: String
tmpn, tmph :: Handle
tmph) <- String -> IO (String, Handle)
tempfile ".c"
Handle -> TextEncoding -> IO ()
hSetEncoding Handle
tmph TextEncoding
utf8
Handle -> String -> IO ()
hPutStr Handle
tmph String
cout
Handle -> IO ()
hFlush Handle
tmph
Handle -> IO ()
hClose Handle
tmph
String
comp <- IO String
getCC
[String]
libFlags <- IO [String]
getLibFlags
[String]
incFlags <- IO [String]
getIncFlags
[String]
envFlags <- IO [String]
getEnvFlags
let stripFlag :: String
stripFlag = if Bool
isDarwin then "-dead_strip" else "-Wl,-gc-sections"
let stackFlags :: [String]
stackFlags = if Bool
isWindows then ["-Wl,--stack,16777216"] else []
let linkFlags :: [String]
linkFlags = String
stripFlag String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
stackFlags
let args :: [String]
args = DbgLevel -> [String]
gccDbg DbgLevel
dbg [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
Bool -> [String]
gccFlags Bool
iface [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
[ "-std=c99", "-pipe"
, "-fdata-sections", "-ffunction-sections"
, "-D_POSIX_C_SOURCE=200809L", "-DHAS_PTHREAD", "-DIDRIS_ENABLE_STATS"
, "-I."] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
objs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
envFlags [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
(if (OutputType
exec OutputType -> OutputType -> Bool
forall a. Eq a => a -> a -> Bool
== OutputType
Executable) then [String]
linkFlags else ["-c"]) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
[String
tmpn] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
(if Bool -> Bool
not Bool
iface then [String]
libFlags else []) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
[String]
incFlags [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
(if Bool -> Bool
not Bool
iface then [String]
libs else []) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
[String]
flags [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
["-o", String
out]
ExitCode
exit <- String -> [String] -> IO ExitCode
rawSystem String
comp [String]
args
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
exit ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> IO ()
putStrLn ("FAILURE: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
comp String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
args)
where
getExp :: ExportIFace -> [Export]
getExp (Export _ _ exp :: [Export]
exp) = [Export]
exp
xs :: [String]
xs =
(String -> String) -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
(\h :: String
h -> "#include \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
h String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\"\n")
([String]
xs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ["idris_rts.h", "idris_bitstring.h", "idris_stdfgn.h"])
debug :: DbgLevel -> String
debug TRACE = "#define IDRIS_TRACE\n\n"
debug _ = ""
gccFlags :: Bool -> [String]
gccFlags i :: Bool
i = if Bool
i then ["-fwrapv"]
else ["-fwrapv", "-fno-strict-overflow"]
gccDbg :: DbgLevel -> [String]
gccDbg DEBUG = ["-g"]
gccDbg _ = []
cname :: Name -> String
cname :: Name -> String
cname n :: Name
n = "_idris_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
cchar (Name -> String
showCG Name
n)
where cchar :: Char -> String
cchar x :: Char
x | Char -> Bool
isAscii Char
x Bool -> Bool -> Bool
&& Char -> Bool
isAlpha Char
x Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
x = [Char
x]
| Bool
otherwise = "_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
x) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "_"
indent :: Int -> String
indent :: Int -> String
indent n :: Int
n = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
*4) ' '
creg :: Reg -> String
creg RVal = "RVAL"
creg (L i :: Int
i) = "LOC(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
creg (T i :: Int
i) = "TOP(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
creg Tmp = "REG1"
toDecl :: Name -> String
toDecl :: Name -> String
toDecl f :: Name
f = "void* " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
cname Name
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ "(VM*, VAL*);\n"
toC :: Name -> [BC] -> String
toC :: Name -> [BC] -> String
toC f :: Name
f code :: [BC]
code
=
"void* " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
cname Name
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ "(VM* vm, VAL* oldbase) {\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "INITFRAME;\nloop:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
(BC -> String) -> [BC] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Int -> BC -> String
bcc Name
f 1) [BC]
code String -> String -> String
forall a. [a] -> [a] -> [a]
++ "}\n\n"
showCStr :: String -> String
showCStr :: String -> String
showCStr s :: String
s = '"' Char -> String -> String
forall a. a -> [a] -> [a]
: (Char -> String -> String) -> String -> String -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (String -> String -> String
forall a. [a] -> [a] -> [a]
(++) (String -> String -> String)
-> (Char -> String) -> Char -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String
showChar) "\"" String
s
where
showChar :: Char -> String
showChar :: Char -> String
showChar '"' = "\\\""
showChar '\\' = "\\\\"
showChar c :: Char
c
| Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0x20 = Int -> String
forall a. (Integral a, Show a) => a -> String
showUTF8 (Char -> Int
ord Char
c)
| Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0x7f = [Char
c]
| Bool
otherwise = [Int] -> String
showHexes (Int -> [Int]
utf8bytes (Char -> Int
ord Char
c))
showUTF8 :: a -> String
showUTF8 c :: a
c = "\"\"\\x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
pad (a -> String -> String
forall a. (Integral a, Show a) => a -> String -> String
showHex a
c "") String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\"\""
showHexes :: [Int] -> String
showHexes = (Int -> String -> String) -> String -> [Int] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (String -> String -> String
forall a. [a] -> [a] -> [a]
(++) (String -> String -> String)
-> (Int -> String) -> Int -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. (Integral a, Show a) => a -> String
showUTF8) ""
utf8bytes :: Int -> [Int]
utf8bytes :: Int -> [Int]
utf8bytes x :: Int
x
| Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0x7f = [Int
x]
| Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0x7ff = let (y :: Int
y : ys :: [Int]
ys) = [Int] -> Integer -> Int -> [Int]
forall t t. (Bits t, Num t, Num t, Eq t) => [t] -> t -> t -> [t]
split [] 2 Int
x in (Int
y Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. 0xc0) Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. 0x80) [Int]
ys
| Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0xffff = let (y :: Int
y : ys :: [Int]
ys) = [Int] -> Integer -> Int -> [Int]
forall t t. (Bits t, Num t, Num t, Eq t) => [t] -> t -> t -> [t]
split [] 3 Int
x in (Int
y Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. 0xe0) Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. 0x80) [Int]
ys
| Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0x10ffff = let (y :: Int
y : ys :: [Int]
ys) = [Int] -> Integer -> Int -> [Int]
forall t t. (Bits t, Num t, Num t, Eq t) => [t] -> t -> t -> [t]
split [] 4 Int
x in (Int
y Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. 0xf0) Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. 0x80) [Int]
ys
| Bool
otherwise = String -> [Int]
forall a. HasCallStack => String -> a
error (String -> [Int]) -> String -> [Int]
forall a b. (a -> b) -> a -> b
$ "Invalid Unicode code point U+" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
forall a. (Integral a, Show a) => a -> String -> String
showHex Int
x ""
where
split :: [t] -> t -> t -> [t]
split acc :: [t]
acc 1 x :: t
x = t
x t -> [t] -> [t]
forall a. a -> [a] -> [a]
: [t]
acc
split acc :: [t]
acc i :: t
i x :: t
x = [t] -> t -> t -> [t]
split (t
x t -> t -> t
forall a. Bits a => a -> a -> a
.&. 0x3f t -> [t] -> [t]
forall a. a -> [a] -> [a]
: [t]
acc) (t
i t -> t -> t
forall a. Num a => a -> a -> a
- 1) (t -> Int -> t
forall a. Bits a => a -> Int -> a
shiftR t
x 6)
pad :: String -> String
pad :: String -> String
pad s :: String
s = case String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s of
1 -> "0" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
2 -> String
s
_ -> String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ "Can't happen: String of invalid length " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s
bcc :: Name -> Int -> BC -> String
bcc :: Name -> Int -> BC -> String
bcc f :: Name
f i :: Int
i (ASSIGN l :: Reg
l r :: Reg
r) = Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ " = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ";\n"
bcc f :: Name
f i :: Int
i (ASSIGNCONST l :: Reg
l c :: Const
c)
= Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ " = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Const -> String
mkConst Const
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ ";\n"
where
mkConst :: Const -> String
mkConst (I i :: Int
i) = "MKINT(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
mkConst (BI i :: Integer
i) = let maxInt :: Integer
maxInt = 2Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^30
in if Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= -Integer
maxInt Bool -> Bool -> Bool
&& Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
maxInt
then "MKINT(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
else "MKBIGC(vm,\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\")"
mkConst (Fl f :: Double
f) = "MKFLOAT(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Double -> String
forall a. Show a => a -> String
show Double
f) String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
mkConst (Ch c :: Char
c) = "MKINT(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c) String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
mkConst (Str s :: String
s) = "MKSTR(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
showCStr String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
mkConst (B8 x :: Word8
x) = "idris_b8const(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "U)"
mkConst (B16 x :: Word16
x) = "idris_b16const(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word16 -> String
forall a. Show a => a -> String
show Word16
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "U)"
mkConst (B32 x :: Word32
x) = "idris_b32const(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word32 -> String
forall a. Show a => a -> String
show Word32
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "UL)"
mkConst (B64 x :: Word64
x) = "idris_b64const(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show Word64
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "ULL)"
mkConst c :: Const
c | Const -> Bool
isTypeConst Const
c = "MKINT(42424242)"
mkConst c :: Const
c = String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ "mkConst of (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Const -> String
forall a. Show a => a -> String
show Const
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ ") not implemented"
bcc f :: Name
f i :: Int
i (UPDATE l :: Reg
l r :: Reg
r) = Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ " = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ";\n"
bcc f :: Name
f i :: Int
i (MKCON l :: Reg
l loc :: Maybe Reg
loc tag :: Int
tag []) | Int
tag Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 256
= Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ " = NULL_CON(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
tag String -> String -> String
forall a. [a] -> [a] -> [a]
++ ");\n"
bcc f :: Name
f i :: Int
i (MKCON l :: Reg
l loc :: Maybe Reg
loc tag :: Int
tag args :: [Reg]
args)
= Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe Reg -> Int -> String
forall a. Show a => Maybe Reg -> a -> String
alloc Maybe Reg
loc Int
tag String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> [Reg] -> String
forall t. (Show t, Num t) => t -> [Reg] -> String
setArgs 0 [Reg]
args String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ " = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
Tmp String -> String -> String
forall a. [a] -> [a] -> [a]
++ ";\n"
where setArgs :: t -> [Reg] -> String
setArgs i :: t
i [] = ""
setArgs i :: t
i (x :: Reg
x : xs :: [Reg]
xs) = "SETARG(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
Tmp String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++
"); " String -> String -> String
forall a. [a] -> [a] -> [a]
++ t -> [Reg] -> String
setArgs (t
i t -> t -> t
forall a. Num a => a -> a -> a
+ 1) [Reg]
xs
alloc :: Maybe Reg -> a -> String
alloc Nothing tag :: a
tag
= "allocCon(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
Tmp String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
tag String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
forall a. Show a => a -> String
show ([Reg] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Reg]
args) String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", 0);\n"
alloc (Just old :: Reg
old) tag :: a
tag
= "updateCon(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
Tmp String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
old String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
tag String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
forall a. Show a => a -> String
show ([Reg] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Reg]
args) String -> String -> String
forall a. [a] -> [a] -> [a]
++ ");\n"
bcc f :: Name
f i :: Int
i (PROJECT l :: Reg
l loc :: Int
loc a :: Int
a) = Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "PROJECT(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ ");\n"
bcc f :: Name
f i :: Int
i (PROJECTINTO r :: Reg
r t :: Reg
t idx :: Int
idx)
= Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ " = GETARG(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
idx String -> String -> String
forall a. [a] -> [a] -> [a]
++ ");\n"
bcc f :: Name
f i :: Int
i (CASE True r :: Reg
r [(_, alt :: [BC]
alt)] Nothing)
= Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> [BC] -> String
showCode Int
i [BC]
alt
where
showCode :: Int -> [BC] -> String
showCode :: Int -> [BC] -> String
showCode i :: Int
i bc :: [BC]
bc = "{\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (BC -> String) -> [BC] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Int -> BC -> String
bcc Name
f (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)) [BC]
bc String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "}\n"
bcc f :: Name
f i :: Int
i (CASE True r :: Reg
r code :: [(Int, [BC])]
code def :: Maybe [BC]
def)
| [(Int, [BC])] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, [BC])]
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 6 Bool -> Bool -> Bool
&& [(Int, [BC])] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, [BC])]
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 1 = Int -> Maybe [BC] -> [(Int, [BC])] -> String
showCase Int
i Maybe [BC]
def [(Int, [BC])]
code
where
showCode :: Int -> [BC] -> String
showCode :: Int -> [BC] -> String
showCode i :: Int
i bc :: [BC]
bc = "{\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (BC -> String) -> [BC] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Int -> BC -> String
bcc Name
f (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)) [BC]
bc String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "}\n"
showCase :: Int -> Maybe [BC] -> [(Int, [BC])] -> String
showCase :: Int -> Maybe [BC] -> [(Int, [BC])] -> String
showCase i :: Int
i Nothing [(t :: Int
t, c :: [BC]
c)] = Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> [BC] -> String
showCode Int
i [BC]
c
showCase i :: Int
i (Just def :: [BC]
def) [] = Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> [BC] -> String
showCode Int
i [BC]
def
showCase i :: Int
i def :: Maybe [BC]
def ((t :: Int
t, c :: [BC]
c) : cs :: [(Int, [BC])]
cs)
= Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "if (CTAG(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ") == " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ ") " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> [BC] -> String
showCode Int
i [BC]
c
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "else\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Maybe [BC] -> [(Int, [BC])] -> String
showCase Int
i Maybe [BC]
def [(Int, [BC])]
cs
bcc f :: Name
f i :: Int
i (CASE safe :: Bool
safe r :: Reg
r code :: [(Int, [BC])]
code def :: Maybe [BC]
def)
= Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "switch(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
ctag Bool
safe String -> String -> String
forall a. [a] -> [a] -> [a]
++ "(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")) {\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
((Int, [BC]) -> String) -> [(Int, [BC])] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> (Int, [BC]) -> String
forall a (t :: * -> *).
(Show a, Foldable t) =>
Int -> (a, t BC) -> String
showCase Int
i) [(Int, [BC])]
code String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> Maybe [BC] -> String
forall (t :: * -> *). Foldable t => Int -> Maybe (t BC) -> String
showDef Int
i Maybe [BC]
def String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "}\n"
where
ctag :: Bool -> String
ctag True = "CTAG"
ctag False = "TAG"
showCase :: Int -> (a, t BC) -> String
showCase i :: Int
i (t :: a
t, bc :: t BC
bc) = Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "case " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ ":\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ (BC -> String) -> t BC -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Int -> BC -> String
bcc Name
f (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)) t BC
bc String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
indent (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "break;\n"
showDef :: Int -> Maybe (t BC) -> String
showDef i :: Int
i Nothing = Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "default:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "return NULL;\n"
showDef i :: Int
i (Just c :: t BC
c) = Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "default:\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ (BC -> String) -> t BC -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Int -> BC -> String
bcc Name
f (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)) t BC
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
indent (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "break;\n"
bcc f :: Name
f i :: Int
i (CONSTCASE r :: Reg
r code :: [(Const, [BC])]
code def :: Maybe [BC]
def)
| [(Const, [BC])] -> Bool
forall b. [(Const, b)] -> Bool
intConsts [(Const, [BC])]
code
= ((Const, [BC]) -> String) -> [(Const, [BC])] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String -> (Const, [BC]) -> String
forall (t :: * -> *).
Foldable t =>
String -> (Const, t BC) -> String
iCase (Reg -> String
creg Reg
r)) [(Const, [BC])]
code String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "{\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Maybe [BC] -> String
forall (t :: * -> *). Foldable t => Int -> Maybe (t BC) -> String
showDefS Int
i Maybe [BC]
def String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "}\n"
| [(Const, [BC])] -> Bool
forall b. [(Const, b)] -> Bool
strConsts [(Const, [BC])]
code
= ((Const, [BC]) -> String) -> [(Const, [BC])] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String -> (Const, [BC]) -> String
forall a (t :: * -> *).
(Show a, Foldable t) =>
String -> (a, t BC) -> String
strCase ("GETSTR(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")")) [(Const, [BC])]
code String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "{\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Maybe [BC] -> String
forall (t :: * -> *). Foldable t => Int -> Maybe (t BC) -> String
showDefS Int
i Maybe [BC]
def String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "}\n"
| [(Const, [BC])] -> Bool
forall b. [(Const, b)] -> Bool
bigintConsts [(Const, [BC])]
code
= ((Const, [BC]) -> String) -> [(Const, [BC])] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String -> (Const, [BC]) -> String
forall (t :: * -> *).
Foldable t =>
String -> (Const, t BC) -> String
biCase (Reg -> String
creg Reg
r)) [(Const, [BC])]
code String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "{\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Maybe [BC] -> String
forall (t :: * -> *). Foldable t => Int -> Maybe (t BC) -> String
showDefS Int
i Maybe [BC]
def String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "}\n"
| Bool
otherwise = String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ "Can't happen: Can't compile const case " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(Const, [BC])] -> String
forall a. Show a => a -> String
show [(Const, [BC])]
code
where
intConsts :: [(Const, b)] -> Bool
intConsts ((I _, _ ) : _) = Bool
True
intConsts ((Ch _, _ ) : _) = Bool
True
intConsts ((B8 _, _ ) : _) = Bool
True
intConsts ((B16 _, _ ) : _) = Bool
True
intConsts ((B32 _, _ ) : _) = Bool
True
intConsts ((B64 _, _ ) : _) = Bool
True
intConsts _ = Bool
False
bigintConsts :: [(Const, b)] -> Bool
bigintConsts ((BI _, _ ) : _) = Bool
True
bigintConsts _ = Bool
False
strConsts :: [(Const, b)] -> Bool
strConsts ((Str _, _ ) : _) = Bool
True
strConsts _ = Bool
False
strCase :: String -> (a, t BC) -> String
strCase sv :: String
sv (s :: a
s, bc :: t BC
bc) =
Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "if (strcmp(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sv String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ ") == 0) {\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
(BC -> String) -> t BC -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Int -> BC -> String
bcc Name
f (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)) t BC
bc String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "} else\n"
biCase :: String -> (Const, t BC) -> String
biCase bv :: String
bv (BI b :: Integer
b, bc :: t BC
bc) =
Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "if (bigEqConst(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
bv String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
b String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")) {\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ (BC -> String) -> t BC -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Int -> BC -> String
bcc Name
f (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)) t BC
bc String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "} else\n"
iCase :: String -> (Const, t BC) -> String
iCase v :: String
v (I b :: Int
b, bc :: t BC
bc) =
Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "if (GETINT(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ ") == " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
b String -> String -> String
forall a. [a] -> [a] -> [a]
++ ") {\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ (BC -> String) -> t BC -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Int -> BC -> String
bcc Name
f (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)) t BC
bc String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "} else\n"
iCase v :: String
v (Ch b :: Char
b, bc :: t BC
bc) =
Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "if (GETINT(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ ") == " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
b) String -> String -> String
forall a. [a] -> [a] -> [a]
++ ") {\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ (BC -> String) -> t BC -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Int -> BC -> String
bcc Name
f (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)) t BC
bc String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "} else\n"
iCase v :: String
v (B8 w :: Word8
w, bc :: t BC
bc) =
Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "if (GETBITS8(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ ") == " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Word8 -> Int
forall a. Enum a => a -> Int
fromEnum Word8
w) String -> String -> String
forall a. [a] -> [a] -> [a]
++ ") {\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ (BC -> String) -> t BC -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Int -> BC -> String
bcc Name
f (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)) t BC
bc String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "} else\n"
iCase v :: String
v (B16 w :: Word16
w, bc :: t BC
bc) =
Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "if (GETBITS16(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ ") == " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Word16 -> Int
forall a. Enum a => a -> Int
fromEnum Word16
w) String -> String -> String
forall a. [a] -> [a] -> [a]
++ ") {\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ (BC -> String) -> t BC -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Int -> BC -> String
bcc Name
f (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)) t BC
bc String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "} else\n"
iCase v :: String
v (B32 w :: Word32
w, bc :: t BC
bc) =
Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "if (GETBITS32(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ ") == " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Word32 -> Int
forall a. Enum a => a -> Int
fromEnum Word32
w) String -> String -> String
forall a. [a] -> [a] -> [a]
++ ") {\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ (BC -> String) -> t BC -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Int -> BC -> String
bcc Name
f (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)) t BC
bc String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "} else\n"
iCase v :: String
v (B64 w :: Word64
w, bc :: t BC
bc) =
Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "if (GETBITS64(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ ") == " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Word64 -> Int
forall a. Enum a => a -> Int
fromEnum Word64
w) String -> String -> String
forall a. [a] -> [a] -> [a]
++ ") {\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ (BC -> String) -> t BC -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Int -> BC -> String
bcc Name
f (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)) t BC
bc String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "} else\n"
showDefS :: Int -> Maybe (t BC) -> String
showDefS i :: Int
i Nothing = ""
showDefS i :: Int
i (Just c :: t BC
c) = (BC -> String) -> t BC -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Int -> BC -> String
bcc Name
f (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)) t BC
c
bcc f :: Name
f i :: Int
i (CALL n :: Name
n) = Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "CALL(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
cname Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ ");\n"
bcc f :: Name
f i :: Int
i (TAILCALL n :: Name
n)
| Name
f Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n = Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "goto loop;\n"
| Bool
otherwise = Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "TAILCALL(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
cname Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ ");\n"
bcc f :: Name
f i :: Int
i (SLIDE n :: Int
n) = Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "SLIDE(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ ");\n"
bcc f :: Name
f i :: Int
i REBASE = Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "REBASE;\n"
bcc f :: Name
f i :: Int
i (RESERVE 0) = ""
bcc f :: Name
f i :: Int
i (RESERVE n :: Int
n) = Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "RESERVE(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ ");\n"
bcc f :: Name
f i :: Int
i (RESERVENOALLOC 0) = ""
bcc f :: Name
f i :: Int
i (RESERVENOALLOC n :: Int
n) = Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "RESERVENOALLOC(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ ");\n"
bcc f :: Name
f i :: Int
i (ADDTOP 0) = ""
bcc f :: Name
f i :: Int
i (ADDTOP n :: Int
n) = Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "ADDTOP(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ ");\n"
bcc f :: Name
f i :: Int
i (TOPBASE n :: Int
n) = Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "TOPBASE(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ ");\n"
bcc f :: Name
f i :: Int
i (BASETOP n :: Int
n) = Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "BASETOP(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ ");\n"
bcc f :: Name
f i :: Int
i STOREOLD = Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "STOREOLD;\n"
bcc f :: Name
f i :: Int
i (OP l :: Reg
l fn :: PrimFn
fn args :: [Reg]
args) = Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> PrimFn -> [Reg] -> String
doOp (Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ " = ") PrimFn
fn [Reg]
args String -> String -> String
forall a. [a] -> [a] -> [a]
++ ";\n"
bcc f :: Name
f i :: Int
i (FOREIGNCALL l :: Reg
l rty :: FDesc
rty (FStr ('#':name :: String
name)) [])
= Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++
FType -> String -> String -> String
c_irts (FDesc -> FType
toFType FDesc
rty) (Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ " = ") String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ ";\n"
bcc f :: Name
f i :: Int
i (FOREIGNCALL l :: Reg
l rty :: FDesc
rty (FStr fn :: String
fn@('&':name :: String
name)) [])
= Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++
FType -> String -> String -> String
c_irts (FDesc -> FType
toFType FDesc
rty) (Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ " = ") String
fn String -> String -> String
forall a. [a] -> [a] -> [a]
++ ";\n"
bcc f :: Name
f i :: Int
i (FOREIGNCALL l :: Reg
l rty :: FDesc
rty (FStr fn :: String
fn) (x :: (FDesc, Reg)
x:xs :: [(FDesc, Reg)]
xs)) | String
fn String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "%wrapper"
= Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++
FType -> String -> String -> String
c_irts (FDesc -> FType
toFType FDesc
rty) (Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ " = ")
("_idris_get_wrapper(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg ((FDesc, Reg) -> Reg
forall a b. (a, b) -> b
snd (FDesc, Reg)
x) String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")") String -> String -> String
forall a. [a] -> [a] -> [a]
++ ";\n"
bcc f :: Name
f i :: Int
i (FOREIGNCALL l :: Reg
l rty :: FDesc
rty (FStr fn :: String
fn) (x :: (FDesc, Reg)
x:xs :: [(FDesc, Reg)]
xs)) | String
fn String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "%dynamic"
= Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ FType -> String -> String -> String
c_irts (FDesc -> FType
toFType FDesc
rty) (Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ " = ")
("(*(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> FDesc -> [(FDesc, Reg)] -> String
forall b. String -> FDesc -> [(FDesc, b)] -> String
cFnSig "" FDesc
rty [(FDesc, Reg)]
xs String -> String -> String
forall a. [a] -> [a] -> [a]
++ ") GETPTR(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg ((FDesc, Reg) -> Reg
forall a b. (a, b) -> b
snd (FDesc, Reg)
x) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "))" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
showSep "," (((FDesc, Reg) -> String) -> [(FDesc, Reg)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (FDesc, Reg) -> String
fcall [(FDesc, Reg)]
xs) String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")") String -> String -> String
forall a. [a] -> [a] -> [a]
++ ";\n"
bcc f :: Name
f i :: Int
i (FOREIGNCALL l :: Reg
l rty :: FDesc
rty (FStr fn :: String
fn) args :: [(FDesc, Reg)]
args)
= Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++
FType -> String -> String -> String
c_irts (FDesc -> FType
toFType FDesc
rty) (Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ " = ")
(String
fn String -> String -> String
forall a. [a] -> [a] -> [a]
++ "(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
showSep "," (((FDesc, Reg) -> String) -> [(FDesc, Reg)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (FDesc, Reg) -> String
fcall [(FDesc, Reg)]
args) String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")") String -> String -> String
forall a. [a] -> [a] -> [a]
++ ";\n"
bcc f :: Name
f i :: Int
i (FOREIGNCALL l :: Reg
l rty :: FDesc
rty _ args :: [(FDesc, Reg)]
args) = String -> String
forall a. HasCallStack => String -> a
error "Foreign Function calls cannot be partially applied, without being inlined."
bcc f :: Name
f i :: Int
i (NULL r :: Reg
r) = Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ " = NULL;\n"
bcc f :: Name
f i :: Int
i (ERROR str :: String
str) = Int -> String
indent Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "fprintf(stderr, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ "); fprintf(stderr, \"\\n\"); exit(-1);\n"
fcall :: (FDesc, Reg) -> String
fcall (t :: FDesc
t, arg :: Reg
arg) = FType -> String -> String
irts_c (FDesc -> FType
toFType FDesc
t) (Reg -> String
creg Reg
arg)
toAType :: FDesc -> ArithTy
toAType (FCon i :: Name
i)
| Name
i Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_IntChar" = IntTy -> ArithTy
ATInt IntTy
ITChar
| Name
i Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_IntNative" = IntTy -> ArithTy
ATInt IntTy
ITNative
| Name
i Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_IntBits8" = IntTy -> ArithTy
ATInt (NativeTy -> IntTy
ITFixed NativeTy
IT8)
| Name
i Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_IntBits16" = IntTy -> ArithTy
ATInt (NativeTy -> IntTy
ITFixed NativeTy
IT16)
| Name
i Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_IntBits32" = IntTy -> ArithTy
ATInt (NativeTy -> IntTy
ITFixed NativeTy
IT32)
| Name
i Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_IntBits64" = IntTy -> ArithTy
ATInt (NativeTy -> IntTy
ITFixed NativeTy
IT64)
toAType t :: FDesc
t = String -> ArithTy
forall a. HasCallStack => String -> a
error (FDesc -> String
forall a. Show a => a -> String
show FDesc
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ " not defined in toAType")
toFType :: FDesc -> FType
toFType (FCon c :: Name
c)
| Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_Str" = FType
FString
| Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_Float" = ArithTy -> FType
FArith ArithTy
ATFloat
| Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_Ptr" = FType
FPtr
| Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_MPtr" = FType
FManagedPtr
| Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_CData" = FType
FCData
| Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_Unit" = FType
FUnit
toFType (FApp c :: Name
c [_,ity :: FDesc
ity])
| Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_IntT" = ArithTy -> FType
FArith (FDesc -> ArithTy
toAType FDesc
ity)
| Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_FnT" = FDesc -> FType
toFunType FDesc
ity
toFType (FApp c :: Name
c [_])
| Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_Any" = FType
FAny
toFType t :: FDesc
t = FType
FAny
toFunType :: FDesc -> FType
toFunType (FApp c :: Name
c [_,ity :: FDesc
ity])
| Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_FnBase" = FType
FFunction
| Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_FnIO" = FType
FFunctionIO
toFunType (FApp c :: Name
c [_,_,_,ity :: FDesc
ity])
| Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_Fn" = FDesc -> FType
toFunType FDesc
ity
toFunType _ = FType
FAny
c_irts :: FType -> String -> String -> String
c_irts (FArith (ATInt ITNative)) l :: String
l x :: String
x = String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ "MKINT((i_int)(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "))"
c_irts (FArith (ATInt ITChar)) l :: String
l x :: String
x = FType -> String -> String -> String
c_irts (ArithTy -> FType
FArith (IntTy -> ArithTy
ATInt IntTy
ITNative)) String
l String
x
c_irts (FArith (ATInt (ITFixed ity :: NativeTy
ity))) l :: String
l x :: String
x
= String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_b" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (NativeTy -> Int
nativeTyWidth NativeTy
ity) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "const(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
c_irts FString l :: String
l x :: String
x = String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ "MKSTR(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
c_irts FUnit l :: String
l x :: String
x = String
x
c_irts FPtr l :: String
l x :: String
x = String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ "MKPTR(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
c_irts FManagedPtr l :: String
l x :: String
x = String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x
c_irts (FArith ATFloat) l :: String
l x :: String
x = String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ "MKFLOAT(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
c_irts FCData l :: String
l x :: String
x = String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ "MKCDATA(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
c_irts FAny l :: String
l x :: String
x = String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x
c_irts FFunction l :: String
l x :: String
x = String -> String
forall a. HasCallStack => String -> a
error "Return of function from foreign call is not supported"
c_irts FFunctionIO l :: String
l x :: String
x = String -> String
forall a. HasCallStack => String -> a
error "Return of function from foreign call is not supported"
irts_c :: FType -> String -> String
irts_c (FArith (ATInt ITNative)) x :: String
x = "GETINT(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
irts_c (FArith (ATInt ITChar)) x :: String
x = FType -> String -> String
irts_c (ArithTy -> FType
FArith (IntTy -> ArithTy
ATInt IntTy
ITNative)) String
x
irts_c (FArith (ATInt (ITFixed ity :: NativeTy
ity))) x :: String
x
= "GETBITS" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (NativeTy -> Int
nativeTyWidth NativeTy
ity) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
irts_c FString x :: String
x = "GETSTR(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
irts_c FUnit x :: String
x = String
x
irts_c FPtr x :: String
x = "GETPTR(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
irts_c FManagedPtr x :: String
x = "GETMPTR(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
irts_c (FArith ATFloat) x :: String
x = "GETFLOAT(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
irts_c FCData x :: String
x = "GETCDATA(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
irts_c FAny x :: String
x = String
x
irts_c FFunctionIO x :: String
x = String -> String
wrapped String
x
irts_c FFunction x :: String
x = String -> String
wrapped String
x
cFnSig :: String -> FDesc -> [(FDesc, b)] -> String
cFnSig name :: String
name rty :: FDesc
rty [] = FDesc -> String
ctype FDesc
rty String -> String -> String
forall a. [a] -> [a] -> [a]
++ " (*" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")(void) "
cFnSig name :: String
name rty :: FDesc
rty args :: [(FDesc, b)]
args = FDesc -> String
ctype FDesc
rty String -> String -> String
forall a. [a] -> [a] -> [a]
++ " (*" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")("
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
showSep "," (((FDesc, b) -> String) -> [(FDesc, b)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (FDesc -> String
ctype (FDesc -> String) -> ((FDesc, b) -> FDesc) -> (FDesc, b) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FDesc, b) -> FDesc
forall a b. (a, b) -> a
fst) [(FDesc, b)]
args) String -> String -> String
forall a. [a] -> [a] -> [a]
++ ") "
wrapped :: String -> String
wrapped x :: String
x = "_idris_get_wrapper(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
bitOp :: String -> String -> NativeTy -> [Reg] -> String
bitOp v :: String
v op :: String
op ty :: NativeTy
ty args :: [Reg]
args = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_b" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (NativeTy -> Int
nativeTyWidth NativeTy
ty) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
op String -> String -> String
forall a. [a] -> [a] -> [a]
++ "(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate ", " ((Reg -> String) -> [Reg] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Reg -> String
creg [Reg]
args) String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
bitCoerce :: String -> String -> NativeTy -> NativeTy -> Reg -> String
bitCoerce v :: String
v op :: String
op input :: NativeTy
input output :: NativeTy
output arg :: Reg
arg
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_b" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (NativeTy -> Int
nativeTyWidth NativeTy
input) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
op String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (NativeTy -> Int
nativeTyWidth NativeTy
output) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
arg String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
signedTy :: NativeTy -> String
signedTy :: NativeTy -> String
signedTy t :: NativeTy
t = "int" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (NativeTy -> Int
nativeTyWidth NativeTy
t) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "_t"
wrapGMP :: String -> String
wrapGMP op :: String
op
= "idris_requireAlloc(vm, 65536); " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
op String -> String -> String
forall a. [a] -> [a] -> [a]
++ "; idris_doneAlloc(vm)"
doOp :: String -> PrimFn -> [Reg] -> String
doOp v :: String
v (LPlus (ATInt ITNative)) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "ADD(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LMinus (ATInt ITNative)) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "INTOP(-," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LTimes (ATInt ITNative)) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "MULT(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LUDiv ITNative) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "UINTOP(/," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LSDiv (ATInt ITNative)) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "INTOP(/," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LURem ITNative) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "UINTOP(%," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LSRem (ATInt ITNative)) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "INTOP(%," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LAnd ITNative) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "INTOP(&," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LOr ITNative) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "INTOP(|," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LXOr ITNative) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "INTOP(^," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LSHL ITNative) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "INTOP(<<," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LLSHR ITNative) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "UINTOP(>>," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LASHR ITNative) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "INTOP(>>," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LCompl ITNative) [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "INTOP(~," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LEq (ATInt ITNative)) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "INTOP(==," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LSLt (ATInt ITNative)) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "INTOP(<," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LSLe (ATInt ITNative)) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "INTOP(<=," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LSGt (ATInt ITNative)) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "INTOP(>," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LSGe (ATInt ITNative)) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "INTOP(>=," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LLt ITNative) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "UINTOP(<," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LLe ITNative) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "UINTOP(<=," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LGt ITNative) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "UINTOP(>," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LGe ITNative) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "UINTOP(>=," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LPlus (ATInt ITChar)) [l :: Reg
l, r :: Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (ArithTy -> PrimFn
LPlus (IntTy -> ArithTy
ATInt IntTy
ITNative)) [Reg
l, Reg
r]
doOp v :: String
v (LMinus (ATInt ITChar)) [l :: Reg
l, r :: Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (ArithTy -> PrimFn
LMinus (IntTy -> ArithTy
ATInt IntTy
ITNative)) [Reg
l, Reg
r]
doOp v :: String
v (LTimes (ATInt ITChar)) [l :: Reg
l, r :: Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (ArithTy -> PrimFn
LTimes (IntTy -> ArithTy
ATInt IntTy
ITNative)) [Reg
l, Reg
r]
doOp v :: String
v (LUDiv ITChar) [l :: Reg
l, r :: Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> PrimFn
LUDiv IntTy
ITNative) [Reg
l, Reg
r]
doOp v :: String
v (LSDiv (ATInt ITChar)) [l :: Reg
l, r :: Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (ArithTy -> PrimFn
LSDiv (IntTy -> ArithTy
ATInt IntTy
ITNative)) [Reg
l, Reg
r]
doOp v :: String
v (LURem ITChar) [l :: Reg
l, r :: Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> PrimFn
LURem IntTy
ITNative) [Reg
l, Reg
r]
doOp v :: String
v (LSRem (ATInt ITChar)) [l :: Reg
l, r :: Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (ArithTy -> PrimFn
LSRem (IntTy -> ArithTy
ATInt IntTy
ITNative)) [Reg
l, Reg
r]
doOp v :: String
v (LAnd ITChar) [l :: Reg
l, r :: Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> PrimFn
LAnd IntTy
ITNative) [Reg
l, Reg
r]
doOp v :: String
v (LOr ITChar) [l :: Reg
l, r :: Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> PrimFn
LOr IntTy
ITNative) [Reg
l, Reg
r]
doOp v :: String
v (LXOr ITChar) [l :: Reg
l, r :: Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> PrimFn
LXOr IntTy
ITNative) [Reg
l, Reg
r]
doOp v :: String
v (LSHL ITChar) [l :: Reg
l, r :: Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> PrimFn
LSHL IntTy
ITNative) [Reg
l, Reg
r]
doOp v :: String
v (LLSHR ITChar) [l :: Reg
l, r :: Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> PrimFn
LLSHR IntTy
ITNative) [Reg
l, Reg
r]
doOp v :: String
v (LASHR ITChar) [l :: Reg
l, r :: Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> PrimFn
LASHR IntTy
ITNative) [Reg
l, Reg
r]
doOp v :: String
v (LCompl ITChar) [x :: Reg
x] = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> PrimFn
LCompl IntTy
ITNative) [Reg
x]
doOp v :: String
v (LEq (ATInt ITChar)) [l :: Reg
l, r :: Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (ArithTy -> PrimFn
LEq (IntTy -> ArithTy
ATInt IntTy
ITNative)) [Reg
l, Reg
r]
doOp v :: String
v (LSLt (ATInt ITChar)) [l :: Reg
l, r :: Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (ArithTy -> PrimFn
LSLt (IntTy -> ArithTy
ATInt IntTy
ITNative)) [Reg
l, Reg
r]
doOp v :: String
v (LSLe (ATInt ITChar)) [l :: Reg
l, r :: Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (ArithTy -> PrimFn
LSLe (IntTy -> ArithTy
ATInt IntTy
ITNative)) [Reg
l, Reg
r]
doOp v :: String
v (LSGt (ATInt ITChar)) [l :: Reg
l, r :: Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (ArithTy -> PrimFn
LSGt (IntTy -> ArithTy
ATInt IntTy
ITNative)) [Reg
l, Reg
r]
doOp v :: String
v (LSGe (ATInt ITChar)) [l :: Reg
l, r :: Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (ArithTy -> PrimFn
LSGe (IntTy -> ArithTy
ATInt IntTy
ITNative)) [Reg
l, Reg
r]
doOp v :: String
v (LLt ITChar) [l :: Reg
l, r :: Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> PrimFn
LLt IntTy
ITNative) [Reg
l, Reg
r]
doOp v :: String
v (LLe ITChar) [l :: Reg
l, r :: Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> PrimFn
LLe IntTy
ITNative) [Reg
l, Reg
r]
doOp v :: String
v (LGt ITChar) [l :: Reg
l, r :: Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> PrimFn
LGt IntTy
ITNative) [Reg
l, Reg
r]
doOp v :: String
v (LGe ITChar) [l :: Reg
l, r :: Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> PrimFn
LGe IntTy
ITNative) [Reg
l, Reg
r]
doOp v :: String
v (LPlus ATFloat) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "FLOATOP(+," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LMinus ATFloat) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "FLOATOP(-," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LTimes ATFloat) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "FLOATOP(*," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LSDiv ATFloat) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "FLOATOP(/," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LEq ATFloat) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "FLOATBOP(==," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LSLt ATFloat) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "FLOATBOP(<," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LSLe ATFloat) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "FLOATBOP(<=," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LSGt ATFloat) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "FLOATBOP(>," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LSGe ATFloat) [l :: Reg
l, r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "FLOATBOP(>=," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LIntFloat ITBig) [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_castBigFloat(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LFloatInt ITBig) [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_castFloatBig(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LPlus (ATInt ITBig)) [l :: Reg
l, r :: Reg
r] = String -> String
wrapGMP (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_bigPlus(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LMinus (ATInt ITBig)) [l :: Reg
l, r :: Reg
r] = String -> String
wrapGMP (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_bigMinus(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LTimes (ATInt ITBig)) [l :: Reg
l, r :: Reg
r] = String -> String
wrapGMP (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_bigTimes(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LSDiv (ATInt ITBig)) [l :: Reg
l, r :: Reg
r] = String -> String
wrapGMP (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_bigDivide(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LSRem (ATInt ITBig)) [l :: Reg
l, r :: Reg
r] = String -> String
wrapGMP (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_bigMod(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LAnd ITBig) [l :: Reg
l, r :: Reg
r] = String -> String
wrapGMP (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_bigAnd(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LOr ITBig) [l :: Reg
l, r :: Reg
r] = String -> String
wrapGMP (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_bigOr(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LSHL ITBig) [l :: Reg
l, r :: Reg
r] = String -> String
wrapGMP (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_bigShiftLeft(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LLSHR ITBig) [l :: Reg
l, r :: Reg
r] = String -> String
wrapGMP (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_bigLShiftRight(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LASHR ITBig) [l :: Reg
l, r :: Reg
r] = String -> String
wrapGMP (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_bigAShiftRight(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LEq (ATInt ITBig)) [l :: Reg
l, r :: Reg
r] = String -> String
wrapGMP (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_bigEq(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LSLt (ATInt ITBig)) [l :: Reg
l, r :: Reg
r] = String -> String
wrapGMP (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_bigLt(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LSLe (ATInt ITBig)) [l :: Reg
l, r :: Reg
r] = String -> String
wrapGMP (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_bigLe(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LSGt (ATInt ITBig)) [l :: Reg
l, r :: Reg
r] = String -> String
wrapGMP (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_bigGt(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LSGe (ATInt ITBig)) [l :: Reg
l, r :: Reg
r] = String -> String
wrapGMP (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_bigGe(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LIntFloat ITNative) [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_castIntFloat(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LFloatInt ITNative) [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_castFloatInt(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LSExt ITNative ITBig) [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_castIntBig(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LTrunc ITBig ITNative) [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_castBigInt(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LStrInt ITBig) [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_castStrBig(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LIntStr ITBig) [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_castBigStr(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LIntStr ITNative) [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_castIntStr(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LStrInt ITNative) [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_castStrInt(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LIntStr (ITFixed _)) [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_castBitsStr(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v LFloatStr [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_castFloatStr(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v LStrFloat [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_castStrFloat(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LSLt (ATInt (ITFixed ty :: NativeTy
ty))) [x :: Reg
x, y :: Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v "SLt" NativeTy
ty [Reg
x, Reg
y]
doOp v :: String
v (LSLe (ATInt (ITFixed ty :: NativeTy
ty))) [x :: Reg
x, y :: Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v "SLte" NativeTy
ty [Reg
x, Reg
y]
doOp v :: String
v (LEq (ATInt (ITFixed ty :: NativeTy
ty))) [x :: Reg
x, y :: Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v "Eq" NativeTy
ty [Reg
x, Reg
y]
doOp v :: String
v (LSGe (ATInt (ITFixed ty :: NativeTy
ty))) [x :: Reg
x, y :: Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v "SGte" NativeTy
ty [Reg
x, Reg
y]
doOp v :: String
v (LSGt (ATInt (ITFixed ty :: NativeTy
ty))) [x :: Reg
x, y :: Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v "SGt" NativeTy
ty [Reg
x, Reg
y]
doOp v :: String
v (LLt (ITFixed ty :: NativeTy
ty)) [x :: Reg
x, y :: Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v "Lt" NativeTy
ty [Reg
x, Reg
y]
doOp v :: String
v (LLe (ITFixed ty :: NativeTy
ty)) [x :: Reg
x, y :: Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v "Lte" NativeTy
ty [Reg
x, Reg
y]
doOp v :: String
v (LGe (ITFixed ty :: NativeTy
ty)) [x :: Reg
x, y :: Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v "Gte" NativeTy
ty [Reg
x, Reg
y]
doOp v :: String
v (LGt (ITFixed ty :: NativeTy
ty)) [x :: Reg
x, y :: Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v "Gt" NativeTy
ty [Reg
x, Reg
y]
doOp v :: String
v (LSHL (ITFixed ty :: NativeTy
ty)) [x :: Reg
x, y :: Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v "Shl" NativeTy
ty [Reg
x, Reg
y]
doOp v :: String
v (LLSHR (ITFixed ty :: NativeTy
ty)) [x :: Reg
x, y :: Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v "LShr" NativeTy
ty [Reg
x, Reg
y]
doOp v :: String
v (LASHR (ITFixed ty :: NativeTy
ty)) [x :: Reg
x, y :: Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v "AShr" NativeTy
ty [Reg
x, Reg
y]
doOp v :: String
v (LAnd (ITFixed ty :: NativeTy
ty)) [x :: Reg
x, y :: Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v "And" NativeTy
ty [Reg
x, Reg
y]
doOp v :: String
v (LOr (ITFixed ty :: NativeTy
ty)) [x :: Reg
x, y :: Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v "Or" NativeTy
ty [Reg
x, Reg
y]
doOp v :: String
v (LXOr (ITFixed ty :: NativeTy
ty)) [x :: Reg
x, y :: Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v "Xor" NativeTy
ty [Reg
x, Reg
y]
doOp v :: String
v (LCompl (ITFixed ty :: NativeTy
ty)) [x :: Reg
x] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v "Compl" NativeTy
ty [Reg
x]
doOp v :: String
v (LPlus (ATInt (ITFixed ty :: NativeTy
ty))) [x :: Reg
x, y :: Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v "Plus" NativeTy
ty [Reg
x, Reg
y]
doOp v :: String
v (LMinus (ATInt (ITFixed ty :: NativeTy
ty))) [x :: Reg
x, y :: Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v "Minus" NativeTy
ty [Reg
x, Reg
y]
doOp v :: String
v (LTimes (ATInt (ITFixed ty :: NativeTy
ty))) [x :: Reg
x, y :: Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v "Times" NativeTy
ty [Reg
x, Reg
y]
doOp v :: String
v (LUDiv (ITFixed ty :: NativeTy
ty)) [x :: Reg
x, y :: Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v "UDiv" NativeTy
ty [Reg
x, Reg
y]
doOp v :: String
v (LSDiv (ATInt (ITFixed ty :: NativeTy
ty))) [x :: Reg
x, y :: Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v "SDiv" NativeTy
ty [Reg
x, Reg
y]
doOp v :: String
v (LURem (ITFixed ty :: NativeTy
ty)) [x :: Reg
x, y :: Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v "URem" NativeTy
ty [Reg
x, Reg
y]
doOp v :: String
v (LSRem (ATInt (ITFixed ty :: NativeTy
ty))) [x :: Reg
x, y :: Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v "SRem" NativeTy
ty [Reg
x, Reg
y]
doOp v :: String
v (LSExt (ITFixed from :: NativeTy
from) ITBig) [x :: Reg
x]
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "MKBIGSI(vm, (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ NativeTy -> String
signedTy NativeTy
from String -> String -> String
forall a. [a] -> [a] -> [a]
++ ") GETBITS" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (NativeTy -> Int
nativeTyWidth NativeTy
from) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "))"
doOp v :: String
v (LSExt ITNative (ITFixed to :: NativeTy
to)) [x :: Reg
x]
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_b" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (NativeTy -> Int
nativeTyWidth NativeTy
to) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "const(vm, GETINT(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "))"
doOp v :: String
v (LSExt ITChar (ITFixed to :: NativeTy
to)) [x :: Reg
x]
= String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> IntTy -> PrimFn
LSExt IntTy
ITNative (NativeTy -> IntTy
ITFixed NativeTy
to)) [Reg
x]
doOp v :: String
v (LSExt (ITFixed from :: NativeTy
from) ITNative) [x :: Reg
x]
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "MKINT((i_int)((" String -> String -> String
forall a. [a] -> [a] -> [a]
++ NativeTy -> String
signedTy NativeTy
from String -> String -> String
forall a. [a] -> [a] -> [a]
++ ") GETBITS" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (NativeTy -> Int
nativeTyWidth NativeTy
from) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")))"
doOp v :: String
v (LSExt (ITFixed from :: NativeTy
from) ITChar) [x :: Reg
x]
= String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> IntTy -> PrimFn
LSExt (NativeTy -> IntTy
ITFixed NativeTy
from) IntTy
ITNative) [Reg
x]
doOp v :: String
v (LSExt (ITFixed from :: NativeTy
from) (ITFixed to :: NativeTy
to)) [x :: Reg
x]
| NativeTy -> Int
nativeTyWidth NativeTy
from Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< NativeTy -> Int
nativeTyWidth NativeTy
to = String -> String -> NativeTy -> NativeTy -> Reg -> String
bitCoerce String
v "S" NativeTy
from NativeTy
to Reg
x
doOp v :: String
v (LZExt ITNative (ITFixed to :: NativeTy
to)) [x :: Reg
x]
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_b" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (NativeTy -> Int
nativeTyWidth NativeTy
to) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "const(vm, (uintptr_t)GETINT(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "))"
doOp v :: String
v (LZExt ITChar (ITFixed to :: NativeTy
to)) [x :: Reg
x]
= String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> IntTy -> PrimFn
LZExt IntTy
ITNative (NativeTy -> IntTy
ITFixed NativeTy
to)) [Reg
x]
doOp v :: String
v (LZExt (ITFixed from :: NativeTy
from) ITNative) [x :: Reg
x]
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "MKINT((i_int)GETBITS" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (NativeTy -> Int
nativeTyWidth NativeTy
from) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "))"
doOp v :: String
v (LZExt (ITFixed from :: NativeTy
from) ITChar) [x :: Reg
x]
= String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> IntTy -> PrimFn
LZExt (NativeTy -> IntTy
ITFixed NativeTy
from) IntTy
ITNative) [Reg
x]
doOp v :: String
v (LZExt (ITFixed from :: NativeTy
from) ITBig) [x :: Reg
x]
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "MKBIGUI(vm, GETBITS" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (NativeTy -> Int
nativeTyWidth NativeTy
from) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "))"
doOp v :: String
v (LZExt ITNative ITBig) [x :: Reg
x]
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "MKBIGUI(vm, (uintptr_t)GETINT(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "))"
doOp v :: String
v (LZExt (ITFixed from :: NativeTy
from) (ITFixed to :: NativeTy
to)) [x :: Reg
x]
| NativeTy -> Int
nativeTyWidth NativeTy
from Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< NativeTy -> Int
nativeTyWidth NativeTy
to = String -> String -> NativeTy -> NativeTy -> Reg -> String
bitCoerce String
v "Z" NativeTy
from NativeTy
to Reg
x
doOp v :: String
v (LTrunc ITNative (ITFixed to :: NativeTy
to)) [x :: Reg
x]
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_b" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (NativeTy -> Int
nativeTyWidth NativeTy
to) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "const(vm, GETINT(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "))"
doOp v :: String
v (LTrunc ITChar (ITFixed to :: NativeTy
to)) [x :: Reg
x]
= String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> IntTy -> PrimFn
LTrunc IntTy
ITNative (NativeTy -> IntTy
ITFixed NativeTy
to)) [Reg
x]
doOp v :: String
v (LTrunc (ITFixed from :: NativeTy
from) ITNative) [x :: Reg
x]
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "MKINT((i_int)GETBITS" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (NativeTy -> Int
nativeTyWidth NativeTy
from) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "))"
doOp v :: String
v (LTrunc (ITFixed from :: NativeTy
from) ITChar) [x :: Reg
x]
= String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> IntTy -> PrimFn
LTrunc (NativeTy -> IntTy
ITFixed NativeTy
from) IntTy
ITNative) [Reg
x]
doOp v :: String
v (LTrunc ITBig (ITFixed IT64)) [x :: Reg
x]
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_b64const(vm, ISINT(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ") ? GETINT(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ") : idris_truncBigB64(GETMPZ(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")))"
doOp v :: String
v (LTrunc ITBig (ITFixed to :: NativeTy
to)) [x :: Reg
x]
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_b" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (NativeTy -> Int
nativeTyWidth NativeTy
to) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "const(vm, ISINT(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ") ? GETINT(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ") : mpz_get_ui(GETMPZ(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")))"
doOp v :: String
v (LTrunc (ITFixed from :: NativeTy
from) (ITFixed to :: NativeTy
to)) [x :: Reg
x]
| NativeTy -> Int
nativeTyWidth NativeTy
from Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> NativeTy -> Int
nativeTyWidth NativeTy
to = String -> String -> NativeTy -> NativeTy -> Reg -> String
bitCoerce String
v "T" NativeTy
from NativeTy
to Reg
x
doOp v :: String
v LFExp [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String -> String
flUnOp "exp" (Reg -> String
creg Reg
x)
doOp v :: String
v LFLog [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String -> String
flUnOp "log" (Reg -> String
creg Reg
x)
doOp v :: String
v LFSin [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String -> String
flUnOp "sin" (Reg -> String
creg Reg
x)
doOp v :: String
v LFCos [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String -> String
flUnOp "cos" (Reg -> String
creg Reg
x)
doOp v :: String
v LFTan [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String -> String
flUnOp "tan" (Reg -> String
creg Reg
x)
doOp v :: String
v LFASin [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String -> String
flUnOp "asin" (Reg -> String
creg Reg
x)
doOp v :: String
v LFACos [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String -> String
flUnOp "acos" (Reg -> String
creg Reg
x)
doOp v :: String
v LFATan [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String -> String
flUnOp "atan" (Reg -> String
creg Reg
x)
doOp v :: String
v LFSqrt [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String -> String
flUnOp "sqrt" (Reg -> String
creg Reg
x)
doOp v :: String
v LFFloor [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String -> String
flUnOp "floor" (Reg -> String
creg Reg
x)
doOp v :: String
v LFCeil [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String -> String
flUnOp "ceil" (Reg -> String
creg Reg
x)
doOp v :: String
v LFNegate [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "MKFLOAT(vm, -GETFLOAT(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Reg -> String
creg Reg
x) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "))"
doOp v :: String
v LFATan2 [y :: Reg
y, x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "MKFLOAT(vm, atan2(GETFLOAT(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
y String -> String -> String
forall a. [a] -> [a] -> [a]
++ "), GETFLOAT(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")))"
doOp v :: String
v LStrConcat [l :: Reg
l,r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_concat(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v LStrLt [l :: Reg
l,r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_strlt(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v LStrEq [l :: Reg
l,r :: Reg
r] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_streq(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v LReadStr [_] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_readStr(vm, stdin)"
doOp v :: String
v LWriteStr [_,s :: Reg
s]
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "MKINT((i_int)(idris_writeStr(stdout"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ ",GETSTR("
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ "))))"
doOp v :: String
v LStrHead [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_strHead(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v LStrTail [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_strTail(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v LStrCons [x :: Reg
x, y :: Reg
y] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_strCons(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
y String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v LStrIndex [x :: Reg
x, y :: Reg
y] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_strIndex(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
y String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v LStrRev [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_strRev(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v LStrLen [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_strlen(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v LStrSubstr [x :: Reg
x,y :: Reg
y,z :: Reg
z] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_substr(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
y String -> String -> String
forall a. [a] -> [a] -> [a]
++ "," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
z String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v LFork [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "MKPTR(vm, vmThread(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
cname (Int -> String -> Name
sMN 0 "EVAL") String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "))"
doOp v :: String
v LPar [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x
doOp v :: String
v (LChInt ITNative) args :: [Reg]
args = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg ([Reg] -> Reg
forall a. [a] -> a
last [Reg]
args)
doOp v :: String
v (LChInt ITChar) args :: [Reg]
args = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> PrimFn
LChInt IntTy
ITNative) [Reg]
args
doOp v :: String
v (LIntCh ITNative) args :: [Reg]
args = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg ([Reg] -> Reg
forall a. [a] -> a
last [Reg]
args)
doOp v :: String
v (LIntCh ITChar) args :: [Reg]
args = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> PrimFn
LIntCh IntTy
ITNative) [Reg]
args
doOp v :: String
v LSystemInfo [x :: Reg
x] = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_systemInfo(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v LCrash [x :: Reg
x] = "idris_crash(GETSTR(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "))"
doOp v :: String
v LNoOp args :: [Reg]
args = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg ([Reg] -> Reg
forall a. [a] -> a
last [Reg]
args)
doOp v :: String
v (LExternal rf :: Name
rf) [_,x :: Reg
x]
| Name
rf Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__readFile"
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_readStr(vm, GETPTR(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "))"
doOp v :: String
v (LExternal rf :: Name
rf) [_,len :: Reg
len,x :: Reg
x]
| Name
rf Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__readChars"
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_readChars(vm, GETINT(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
len String -> String -> String
forall a. [a] -> [a] -> [a]
++
"), GETPTR(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "))"
doOp v :: String
v (LExternal wf :: Name
wf) [_,x :: Reg
x,s :: Reg
s]
| Name
wf Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__writeFile"
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "MKINT((i_int)(idris_writeStr(GETPTR(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x
String -> String -> String
forall a. [a] -> [a] -> [a]
++ "),GETSTR("
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ "))))"
doOp v :: String
v (LExternal si :: Name
si) [] | Name
si Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__stdin" = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "MKPTR(vm, stdin)"
doOp v :: String
v (LExternal so :: Name
so) [] | Name
so Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__stdout" = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "MKPTR(vm, stdout)"
doOp v :: String
v (LExternal se :: Name
se) [] | Name
se Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__stderr" = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "MKPTR(vm, stderr)"
doOp v :: String
v (LExternal vm :: Name
vm) [_] | Name
vm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__vm" = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "MKPTR(vm, vm)"
doOp v :: String
v (LExternal nul :: Name
nul) [] | Name
nul Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__null" = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "MKPTR(vm, NULL)"
doOp v :: String
v (LExternal nul :: Name
nul) [] | Name
nul Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__managedNull" = String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "MKPTR(vm, NULL)"
doOp v :: String
v (LExternal eqp :: Name
eqp) [x :: Reg
x, y :: Reg
y] | Name
eqp Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__eqPtr"
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "MKINT((i_int)(GETPTR(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ") == GETPTR(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
y String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")))"
doOp v :: String
v (LExternal eqp :: Name
eqp) [x :: Reg
x, y :: Reg
y] | Name
eqp Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__eqManagedPtr"
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "MKINT((i_int)(GETMPTR(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ") == GETMPTR(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
y String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")))"
doOp v :: String
v (LExternal rp :: Name
rp) [p :: Reg
p, i :: Reg
i] | Name
rp Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__registerPtr"
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "MKMPTR(vm, GETPTR(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ "), GETINT(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "))"
doOp v :: String
v (LExternal pk :: Name
pk) [_, p :: Reg
p, o :: Reg
o] | Name
pk Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__peek8"
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_peekB8(vm," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ "," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
o String -> String -> String
forall a. [a] -> [a] -> [a]
++")"
doOp v :: String
v (LExternal pk :: Name
pk) [_, p :: Reg
p, o :: Reg
o, x :: Reg
x] | Name
pk Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__poke8"
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_pokeB8(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ "," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
o String -> String -> String
forall a. [a] -> [a] -> [a]
++ "," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LExternal pk :: Name
pk) [_, p :: Reg
p, o :: Reg
o] | Name
pk Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__peek16"
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_peekB16(vm," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ "," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
o String -> String -> String
forall a. [a] -> [a] -> [a]
++")"
doOp v :: String
v (LExternal pk :: Name
pk) [_, p :: Reg
p, o :: Reg
o, x :: Reg
x] | Name
pk Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__poke16"
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_pokeB16(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ "," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
o String -> String -> String
forall a. [a] -> [a] -> [a]
++ "," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LExternal pk :: Name
pk) [_, p :: Reg
p, o :: Reg
o] | Name
pk Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__peek32"
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_peekB32(vm," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ "," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
o String -> String -> String
forall a. [a] -> [a] -> [a]
++")"
doOp v :: String
v (LExternal pk :: Name
pk) [_, p :: Reg
p, o :: Reg
o, x :: Reg
x] | Name
pk Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__poke32"
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_pokeB32(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ "," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
o String -> String -> String
forall a. [a] -> [a] -> [a]
++ "," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LExternal pk :: Name
pk) [_, p :: Reg
p, o :: Reg
o] | Name
pk Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__peek64"
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_peekB64(vm," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ "," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
o String -> String -> String
forall a. [a] -> [a] -> [a]
++")"
doOp v :: String
v (LExternal pk :: Name
pk) [_, p :: Reg
p, o :: Reg
o, x :: Reg
x] | Name
pk Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__poke64"
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_pokeB64(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ "," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
o String -> String -> String
forall a. [a] -> [a] -> [a]
++ "," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LExternal pk :: Name
pk) [_, p :: Reg
p, o :: Reg
o] | Name
pk Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__peekPtr"
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_peekPtr(vm," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ "," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
o String -> String -> String
forall a. [a] -> [a] -> [a]
++")"
doOp v :: String
v (LExternal pk :: Name
pk) [_, p :: Reg
p, o :: Reg
o, x :: Reg
x] | Name
pk Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__pokePtr"
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_pokePtr(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ "," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
o String -> String -> String
forall a. [a] -> [a] -> [a]
++ "," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LExternal pk :: Name
pk) [_, p :: Reg
p, o :: Reg
o, x :: Reg
x] | Name
pk Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__pokeDouble"
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_pokeDouble(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ "," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
o String -> String -> String
forall a. [a] -> [a] -> [a]
++ "," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LExternal pk :: Name
pk) [_, p :: Reg
p, o :: Reg
o] | Name
pk Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__peekDouble"
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_peekDouble(vm," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ "," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
o String -> String -> String
forall a. [a] -> [a] -> [a]
++")"
doOp v :: String
v (LExternal pk :: Name
pk) [_, p :: Reg
p, o :: Reg
o, x :: Reg
x] | Name
pk Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__pokeSingle"
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_pokeSingle(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ "," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
o String -> String -> String
forall a. [a] -> [a] -> [a]
++ "," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
doOp v :: String
v (LExternal pk :: Name
pk) [_, p :: Reg
p, o :: Reg
o] | Name
pk Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__peekSingle"
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "idris_peekSingle(vm," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ "," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
o String -> String -> String
forall a. [a] -> [a] -> [a]
++")"
doOp v :: String
v (LExternal pk :: Name
pk) [] | Name
pk Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__sizeofPtr"
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "MKINT(sizeof(void*))"
doOp v :: String
v (LExternal mpt :: Name
mpt) [p :: Reg
p] | Name
mpt Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__asPtr"
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "MKPTR(vm, GETMPTR("String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p String -> String -> String
forall a. [a] -> [a] -> [a]
++"))"
doOp v :: String
v (LExternal offs :: Name
offs) [p :: Reg
p, n :: Reg
n] | Name
offs Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__ptrOffset"
= String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "MKPTR(vm, (void *)((char *)GETPTR(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ ") + GETINT(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")))"
doOp _ op :: PrimFn
op args :: [Reg]
args = String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ "doOp not implemented (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (PrimFn, [Reg]) -> String
forall a. Show a => a -> String
show (PrimFn
op, [Reg]
args) String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
flUnOp :: String -> String -> String
flUnOp :: String -> String -> String
flUnOp name :: String
name val :: String
val = "MKFLOAT(vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ "(GETFLOAT(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
val String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")))"
ifaceC :: Export -> String
ifaceC :: Export -> String
ifaceC (ExportData n :: FDesc
n) = "typedef VAL " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FDesc -> String
cdesc FDesc
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ ";\n"
ifaceC (ExportFun n :: Name
n cn :: FDesc
cn ret :: FDesc
ret args :: [FDesc]
args)
= FDesc -> String
ctype FDesc
ret String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FDesc -> String
cdesc FDesc
cn String -> String -> String
forall a. [a] -> [a] -> [a]
++
"(VM* vm" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(String, FDesc)] -> String
showArgs ([String] -> [FDesc] -> [(String, FDesc)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
argNames [FDesc]
args) String -> String -> String
forall a. [a] -> [a] -> [a]
++ ") {\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> [(String, FDesc)] -> FDesc -> String
mkBody Name
n ([String] -> [FDesc] -> [(String, FDesc)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
argNames [FDesc]
args) FDesc
ret String -> String -> String
forall a. [a] -> [a] -> [a]
++ "}\n\n"
where showArgs :: [(String, FDesc)] -> String
showArgs [] = ""
showArgs ((n :: String
n, t :: FDesc
t) : ts :: [(String, FDesc)]
ts) = ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FDesc -> String
ctype FDesc
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++
[(String, FDesc)] -> String
showArgs [(String, FDesc)]
ts
argNames :: [String]
argNames = (String -> String -> String) -> [String] -> [String] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith String -> String -> String
forall a. [a] -> [a] -> [a]
(++) (String -> [String]
forall a. a -> [a]
repeat "arg") ((Integer -> String) -> [Integer] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> String
forall a. Show a => a -> String
show [0..])
mkBody :: Name -> [(String, FDesc)] -> FDesc -> String
mkBody n :: Name
n as_in :: [(String, FDesc)]
as_in t :: FDesc
t
= Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "INITFRAME;\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "RESERVE(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max ([(String, FDesc)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, FDesc)]
as) 3) String -> String -> String
forall a. [a] -> [a] -> [a]
++ ");\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
Integer -> [(String, FDesc)] -> String
forall t. (Show t, Num t) => t -> [(String, FDesc)] -> String
push 0 [(String, FDesc)]
as String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall p. p -> String
call Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ FDesc -> String
retval FDesc
t
where
as :: [(String, FDesc)]
as = case FDesc
t of
FIO t -> [(String, FDesc)]
as_in [(String, FDesc)] -> [(String, FDesc)] -> [(String, FDesc)]
forall a. [a] -> [a] -> [a]
++ [("NULL", FDesc
FUnknown)]
_ -> [(String, FDesc)]
as_in
push :: t -> [(String, FDesc)] -> String
push i :: t
i [] = ""
push i :: t
i ((n :: String
n, t :: FDesc
t) : ts :: [(String, FDesc)]
ts) = Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ FType -> String -> String -> String
c_irts (FDesc -> FType
toFType FDesc
t)
("TOP(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ ") = ") String
n
String -> String -> String
forall a. [a] -> [a] -> [a]
++ ";\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ t -> [(String, FDesc)] -> String
push (t
i t -> t -> t
forall a. Num a => a -> a -> a
+ 1) [(String, FDesc)]
ts
call :: p -> String
call _ = Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "STOREOLD;\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "BASETOP(0);\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "ADDTOP(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([(String, FDesc)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, FDesc)]
as) String -> String -> String
forall a. [a] -> [a] -> [a]
++ ");\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "CALL(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
cname Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ ");\n"
retval :: FDesc -> String
retval (FIO t :: FDesc
t) = FDesc -> String
retval FDesc
t
retval t :: FDesc
t = Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "return " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FType -> String -> String
irts_c (FDesc -> FType
toFType FDesc
t) "RVAL" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ";\n"
ctype :: FDesc -> String
ctype (FCon c :: Name
c)
| Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_Str" = "char*"
| Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_Float" = "float"
| Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_Ptr" = "void*"
| Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_MPtr" = "void*"
| Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_Unit" = "void"
ctype (FApp c :: Name
c [_,ity :: FDesc
ity])
| Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_IntT" = FDesc -> String
carith FDesc
ity
ctype (FApp c :: Name
c [_])
| Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_Any" = "VAL"
ctype (FStr s :: String
s) = String
s
ctype FUnknown = "void*"
ctype (FIO t :: FDesc
t) = FDesc -> String
ctype FDesc
t
ctype t :: FDesc
t = String -> String
forall a. HasCallStack => String -> a
error "Can't happen: Not a valid interface type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FDesc -> String
forall a. Show a => a -> String
show FDesc
t
carith :: FDesc -> String
carith (FCon i :: Name
i)
| Name
i Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_IntChar" = "char"
| Name
i Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_IntNative" = "int"
| Name
i Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_IntBits8" = "uint8_t"
| Name
i Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_IntBits16" = "uint16_t"
| Name
i Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_IntBits32" = "uint32_t"
| Name
i Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_IntBits64" = "uint64_t"
carith t :: FDesc
t = String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ "Can't happen: Not an exportable arithmetic type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FDesc -> String
forall a. Show a => a -> String
show FDesc
t
cdesc :: FDesc -> String
cdesc (FStr s :: String
s) = String
s
cdesc s :: FDesc
s = String -> String
forall a. HasCallStack => String -> a
error "Can't happen: Not a valid C name"
codegenH :: [ExportIFace] -> IO ()
codegenH :: [ExportIFace] -> IO ()
codegenH es :: [ExportIFace]
es = (ExportIFace -> IO ()) -> [ExportIFace] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ExportIFace -> IO ()
writeIFace [ExportIFace]
es
writeIFace :: ExportIFace -> IO ()
writeIFace :: ExportIFace -> IO ()
writeIFace (Export ffic :: Name
ffic hdr :: String
hdr exps :: [Export]
exps)
| Name
ffic Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> [String] -> Name
sNS (String -> Name
sUN "FFI_C") ["FFI_C"]
= do let hfile :: String
hfile = "#ifndef " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
hdr_guard String
hdr String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"#define " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
hdr_guard String
hdr String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"#include <idris_rts.h>\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
(Export -> String) -> [Export] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Export -> String
hdr_export [Export]
exps String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"#endif\n\n"
String -> String -> IO ()
writeFile String
hdr String
hfile
| Bool
otherwise = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
hdr_guard :: String -> String
hdr_guard x :: String
x = "__" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
hchar String
x
where hchar :: Char -> Char
hchar x :: Char
x | Char -> Bool
isAlphaNum Char
x = Char -> Char
toUpper Char
x
hchar _ = '_'
hdr_export :: Export -> String
hdr_export :: Export -> String
hdr_export (ExportData n :: FDesc
n) = "typedef VAL " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FDesc -> String
cdesc FDesc
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ ";\n"
hdr_export (ExportFun n :: Name
n cn :: FDesc
cn ret :: FDesc
ret args :: [FDesc]
args)
= FDesc -> String
ctype FDesc
ret String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FDesc -> String
cdesc FDesc
cn String -> String -> String
forall a. [a] -> [a] -> [a]
++
"(VM* vm" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(String, FDesc)] -> String
showArgs ([String] -> [FDesc] -> [(String, FDesc)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
argNames [FDesc]
args) String -> String -> String
forall a. [a] -> [a] -> [a]
++ ");\n"
where showArgs :: [(String, FDesc)] -> String
showArgs [] = ""
showArgs ((n :: String
n, t :: FDesc
t) : ts :: [(String, FDesc)]
ts) = ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FDesc -> String
ctype FDesc
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++
[(String, FDesc)] -> String
showArgs [(String, FDesc)]
ts
argNames :: [String]
argNames = (String -> String -> String) -> [String] -> [String] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith String -> String -> String
forall a. [a] -> [a] -> [a]
(++) (String -> [String]
forall a. a -> [a]
repeat "arg") ((Integer -> String) -> [Integer] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> String
forall a. Show a => a -> String
show [0..])
genWrappers :: [(Name, [BC])] -> String
genWrappers :: [(Name, [BC])] -> String
genWrappers bcs :: [(Name, [BC])]
bcs = let
tags :: [(FDesc, Int)]
tags = ((FDesc, Int) -> (FDesc, Int) -> Bool)
-> [(FDesc, Int)] -> [(FDesc, Int)]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (\x :: (FDesc, Int)
x y :: (FDesc, Int)
y -> (FDesc, Int) -> Int
forall a b. (a, b) -> b
snd (FDesc, Int)
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (FDesc, Int) -> Int
forall a b. (a, b) -> b
snd (FDesc, Int)
y) ([(FDesc, Int)] -> [(FDesc, Int)])
-> [(FDesc, Int)] -> [(FDesc, Int)]
forall a b. (a -> b) -> a -> b
$ ((Name, [BC]) -> [(FDesc, Int)])
-> [(Name, [BC])] -> [(FDesc, Int)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([BC] -> [(FDesc, Int)]
getCallback ([BC] -> [(FDesc, Int)])
-> ((Name, [BC]) -> [BC]) -> (Name, [BC]) -> [(FDesc, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, [BC]) -> [BC]
forall a b. (a, b) -> b
snd) [(Name, [BC])]
bcs
in
case [(FDesc, Int)]
tags of
[] -> ""
t :: [(FDesc, Int)]
t -> ((FDesc, Int) -> String) -> [(FDesc, Int)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (FDesc, Int) -> String
genWrapper [(FDesc, Int)]
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(FDesc, Int)] -> String
genDispatcher [(FDesc, Int)]
t
genDispatcher :: [(FDesc, Int)] -> String
genDispatcher :: [(FDesc, Int)] -> String
genDispatcher tags :: [(FDesc, Int)]
tags = "void* _idris_get_wrapper(VAL con)\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"{\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "switch(TAG(con)) {\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
((FDesc, Int) -> String) -> [(FDesc, Int)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (FDesc, Int) -> String
forall a. (a, Int) -> String
makeSwitch [(FDesc, Int)]
tags String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "}\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "fprintf(stderr, \"No wrapper for callback\");\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "exit(-1);\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"}\n\n"
where
makeSwitch :: (a, Int) -> String
makeSwitch (_, tag :: Int
tag) =
Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "case " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
tag String -> String -> String
forall a. [a] -> [a] -> [a]
++ ":\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent 2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "return (void*) &" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
wrapperName Int
tag String -> String -> String
forall a. [a] -> [a] -> [a]
++ ";\n"
genWrapper :: (FDesc, Int) -> String
genWrapper :: (FDesc, Int) -> String
genWrapper (desc :: FDesc
desc, tag :: Int
tag) | (FDesc -> FType
toFType FDesc
desc) FType -> FType -> Bool
forall a. Eq a => a -> a -> Bool
== FType
FFunctionIO =
String -> String
forall a. HasCallStack => String -> a
error "Cannot create C callbacks for IO functions, wrap them with unsafePerformIO.\n"
genWrapper (desc :: FDesc
desc, tag :: Int
tag) = String
ret String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
wrapperName Int
tag String -> String -> String
forall a. [a] -> [a] -> [a]
++ "(" String -> String -> String
forall a. [a] -> [a] -> [a]
++
[((String, FDesc), Integer)] -> String
forall a b. Show a => [((String, b), a)] -> String
renderArgs [((String, FDesc), Integer)]
argList String -> String -> String
forall a. [a] -> [a] -> [a]
++")\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"{\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
(if String
ret String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= "void" then Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ret String -> String -> String
forall a. [a] -> [a] -> [a]
++ " ret;\n" else "") String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "VM* vm = get_vm();\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "if (vm == NULL) {\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent 2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "vm = idris_vm();\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "}\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "INITFRAME;\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "RESERVE(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) String -> String -> String
forall a. [a] -> [a] -> [a]
++ ");\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "allocCon(REG1, vm, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
tag String -> String -> String
forall a. [a] -> [a] -> [a]
++ ",0 , 0);\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "TOP(0) = REG1;\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
[((String, FDesc), Integer)] -> String
forall a a. Show a => [((a, FDesc), a)] -> String
applyArgs [((String, FDesc), Integer)]
argList String -> String -> String
forall a. [a] -> [a] -> [a]
++
if String
ret String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= "void"
then Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "ret = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FType -> String -> String
irts_c (FDesc -> FType
toFType FDesc
ft) "RVAL" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ";\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "return ret;\n}\n\n"
else "}\n\n"
where
(ret :: String
ret, ft :: FDesc
ft) = FDesc -> (String, FDesc)
rty FDesc
desc
argList :: [((String, FDesc), Integer)]
argList = [(String, FDesc)] -> [Integer] -> [((String, FDesc), Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip (FDesc -> [(String, FDesc)]
args FDesc
desc) [0..]
len :: Int
len = [((String, FDesc), Integer)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [((String, FDesc), Integer)]
argList
applyArgs :: [((a, FDesc), a)] -> String
applyArgs (x :: ((a, FDesc), a)
x:y :: ((a, FDesc), a)
y:xs :: [((a, FDesc), a)]
xs) = Integer -> [((a, FDesc), a)] -> String
forall t a a.
(Show t, Show a, Num t) =>
t -> [((a, FDesc), a)] -> String
push 1 [((a, FDesc), a)
x] String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "STOREOLD;\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "BASETOP(0);\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "ADDTOP(2);\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "CALL(_idris__123_APPLY_95_0_125_);\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "TOP(0)=REG1;\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
[((a, FDesc), a)] -> String
applyArgs (((a, FDesc), a)
y((a, FDesc), a) -> [((a, FDesc), a)] -> [((a, FDesc), a)]
forall a. a -> [a] -> [a]
:[((a, FDesc), a)]
xs)
applyArgs x :: [((a, FDesc), a)]
x = Integer -> [((a, FDesc), a)] -> String
forall t a a.
(Show t, Show a, Num t) =>
t -> [((a, FDesc), a)] -> String
push 1 [((a, FDesc), a)]
x String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "STOREOLD;\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "BASETOP(0);\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "ADDTOP(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([((a, FDesc), a)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [((a, FDesc), a)]
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) String -> String -> String
forall a. [a] -> [a] -> [a]
++ ");\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "CALL(_idris__123_APPLY_95_0_125_);\n"
renderArgs :: [((String, b), a)] -> String
renderArgs [] = "void"
renderArgs [((s :: String
s, _), n :: a
n)] = String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ " a" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (a -> String
forall a. Show a => a -> String
show a
n)
renderArgs (((s :: String
s, _), n :: a
n):xs :: [((String, b), a)]
xs) = String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ " a" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (a -> String
forall a. Show a => a -> String
show a
n) String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++
[((String, b), a)] -> String
renderArgs [((String, b), a)]
xs
rty :: FDesc -> (String, FDesc)
rty (FApp c :: Name
c [_,ty :: FDesc
ty])
| Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_FnBase" = (FDesc -> String
ctype FDesc
ty, FDesc
ty)
| Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_FnIO" = (FDesc -> String
ctype FDesc
ty, FDesc
ty)
| Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_FnT" = FDesc -> (String, FDesc)
rty FDesc
ty
rty (FApp c :: Name
c [_,_,ty :: FDesc
ty,fn :: FDesc
fn])
| Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_Fn" = FDesc -> (String, FDesc)
rty FDesc
fn
rty x :: FDesc
x = ("", FDesc
x)
args :: FDesc -> [(String, FDesc)]
args (FApp c :: Name
c [_,ty :: FDesc
ty])
| Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_FnBase" = []
| Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_FnIO" = []
| Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_FnT" = FDesc -> [(String, FDesc)]
args FDesc
ty
args (FApp c :: Name
c [_,_,ty :: FDesc
ty,fn :: FDesc
fn])
| FDesc -> FType
toFType FDesc
ty FType -> FType -> Bool
forall a. Eq a => a -> a -> Bool
== FType
FUnit = []
| Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "C_Fn" = (FDesc -> String
ctype FDesc
ty, FDesc
ty) (String, FDesc) -> [(String, FDesc)] -> [(String, FDesc)]
forall a. a -> [a] -> [a]
: FDesc -> [(String, FDesc)]
args FDesc
fn
args _ = []
push :: t -> [((a, FDesc), a)] -> String
push i :: t
i [] = ""
push i :: t
i (((c :: a
c, t :: FDesc
t), n :: a
n) : ts :: [((a, FDesc), a)]
ts) = Int -> String
indent 1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ FType -> String -> String -> String
c_irts (FDesc -> FType
toFType FDesc
t)
("TOP(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ ") = ") ("a" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n)
String -> String -> String
forall a. [a] -> [a] -> [a]
++ ";\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ t -> [((a, FDesc), a)] -> String
push (t
i t -> t -> t
forall a. Num a => a -> a -> a
+ 1) [((a, FDesc), a)]
ts
wrapperName :: Int -> String
wrapperName :: Int -> String
wrapperName tag :: Int
tag = "_idris_wrapper_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
tag
getCallback :: [BC] -> [(FDesc, Int)]
getCallback :: [BC] -> [(FDesc, Int)]
getCallback bc :: [BC]
bc = [BC] -> [(FDesc, Int)]
getCallback' ([BC] -> [BC]
forall a. [a] -> [a]
reverse [BC]
bc)
where
getCallback' :: [BC] -> [(FDesc, Int)]
getCallback' (x :: BC
x:xs :: [BC]
xs) = case BC -> [(FDesc, Reg)]
hasCallback BC
x of
[] -> [BC] -> [(FDesc, Int)]
getCallback' [BC]
xs
cbs :: [(FDesc, Reg)]
cbs -> case [(FDesc, Reg)] -> [BC] -> [(FDesc, Int)]
forall a. [(a, Reg)] -> [BC] -> [(a, Int)]
findCons [(FDesc, Reg)]
cbs [BC]
xs of
[] -> String -> [(FDesc, Int)]
forall a. HasCallStack => String -> a
error "Idris function couldn't be wrapped."
x :: [(FDesc, Int)]
x -> [(FDesc, Int)]
x
getCallback' [] = []
findCons :: [(a, Reg)] -> [BC] -> [(a, Int)]
findCons (c :: (a, Reg)
c:cs :: [(a, Reg)]
cs) xs :: [BC]
xs = (a, Reg) -> [BC] -> [(a, Int)]
forall a. (a, Reg) -> [BC] -> [(a, Int)]
findCon (a, Reg)
c [BC]
xs [(a, Int)] -> [(a, Int)] -> [(a, Int)]
forall a. [a] -> [a] -> [a]
++ [(a, Reg)] -> [BC] -> [(a, Int)]
findCons [(a, Reg)]
cs [BC]
xs
findCons [] _ = []
findCon :: (a, Reg) -> [BC] -> [(a, Int)]
findCon c :: (a, Reg)
c ((MKCON l :: Reg
l loc :: Maybe Reg
loc tag :: Int
tag args :: [Reg]
args):xs :: [BC]
xs) | (a, Reg) -> Reg
forall a b. (a, b) -> b
snd (a, Reg)
c Reg -> Reg -> Bool
forall a. Eq a => a -> a -> Bool
== Reg
l =
if [Reg] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Reg]
args
then [((a, Reg) -> a
forall a b. (a, b) -> a
fst (a, Reg)
c, Int
tag)]
else String -> [(a, Int)]
forall a. HasCallStack => String -> a
error "Can't wrap a closure as callback."
findCon c :: (a, Reg)
c (_:xs :: [BC]
xs) = (a, Reg) -> [BC] -> [(a, Int)]
findCon (a, Reg)
c [BC]
xs
findCon c :: (a, Reg)
c [] = []
hasCallback :: BC -> [(FDesc, Reg)]
hasCallback :: BC -> [(FDesc, Reg)]
hasCallback (FOREIGNCALL l :: Reg
l rty :: FDesc
rty (FStr fn :: String
fn) args :: [(FDesc, Reg)]
args) = ((FDesc, Reg) -> Bool) -> [(FDesc, Reg)] -> [(FDesc, Reg)]
forall a. (a -> Bool) -> [a] -> [a]
filter (FDesc, Reg) -> Bool
forall b. (FDesc, b) -> Bool
isFn [(FDesc, Reg)]
args
where
isFn :: (FDesc, b) -> Bool
isFn (desc :: FDesc
desc,_) = case FDesc -> FType
toFType FDesc
desc of
FFunction -> Bool
True
FFunctionIO -> Bool
True
_ -> Bool
False
hasCallback _ = []