{-|
Module      : IRTS.CodegenC
Description : The default code generator for Idris, generating C code.

License     : BSD3
Maintainer  : The Idris Community.
-}
{-# 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 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)
                           (forall a b. (a -> b) -> [a] -> [b]
map String -> String
mkLib (CodegenInfo -> [String]
compileLibs CodegenInfo
ci) forall a. [a] -> [a] -> [a]
++
                               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)
                 forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CodegenInfo -> Bool
interfaces CodegenInfo
ci) forall a b. (a -> b) -> a -> b
$
                   [ExportIFace] -> IO ()
codegenH (CodegenInfo -> [ExportIFace]
exportDecls CodegenInfo
ci)

  where mkLib :: String -> String
mkLib String
l = String
"-l" forall a. [a] -> [a] -> [a]
++ String
l
        incdir :: String -> String
incdir String
i = String
"-I" forall a. [a] -> [a] -> [a]
++ String
i

codegenC' :: [(Name, SDecl)]
          -> String        -- ^ output file name
          -> OutputType    -- ^ generate executable if True, only .o if False
          -> [FilePath]    -- ^ include files
          -> [String]      -- ^ extra object files
          -> [String]      -- ^ extra compiler flags (libraries)
          -> [String]      -- ^ extra compiler flags (anything)
          -> [ExportIFace]
          -> Bool          -- ^ interfaces too (so make a .o instead)
          -> DbgLevel
          -> IO ()
codegenC' :: [(Name, SDecl)]
-> String
-> OutputType
-> [String]
-> [String]
-> [String]
-> [String]
-> [ExportIFace]
-> Bool
-> DbgLevel
-> IO ()
codegenC' [(Name, SDecl)]
defs String
out OutputType
exec [String]
incs [String]
objs [String]
libs [String]
flags [ExportIFace]
exports Bool
iface DbgLevel
dbg
    = do -- print defs
         let bc :: [(Name, [BC])]
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 = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Name -> String
toDecl (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Name, [BC])]
bc)
         let cc :: String
cc = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> [BC] -> String
toC) [(Name, [BC])]
bc
         let hi :: String
hi = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Export -> String
ifaceC (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
</> String
"idris_main" String -> String -> String
<.> String
"c")
         let cout :: String
cout = [String] -> String
headers [String]
incs forall a. [a] -> [a] -> [a]
++ DbgLevel -> String
debug DbgLevel
dbg forall a. [a] -> [a] -> [a]
++ String
h forall a. [a] -> [a] -> [a]
++ String
wrappers forall a. [a] -> [a] -> [a]
++ String
cc forall a. [a] -> [a] -> [a]
++
                     (if (OutputType
exec forall a. Eq a => a -> a -> Bool
== OutputType
Executable) then String
mprog else String
hi)
         case OutputType
exec of
           OutputType
Raw -> String -> String -> IO ()
writeSource String
out String
cout
           OutputType
_ -> do
             (String
tmpn, Handle
tmph) <- String -> IO (String, Handle)
tempfile String
".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 String
"-dead_strip" else String
"-Wl,-gc-sections"
             let stackFlags :: [String]
stackFlags = if Bool
isWindows then [String
"-Wl,--stack,16777216"] else []
             let linkFlags :: [String]
linkFlags = String
stripFlag forall a. a -> [a] -> [a]
: [String]
stackFlags
             let args :: [String]
args = DbgLevel -> [String]
gccDbg DbgLevel
dbg forall a. [a] -> [a] -> [a]
++
                        Bool -> [String]
gccFlags Bool
iface forall a. [a] -> [a] -> [a]
++
                        -- # Any flags defined here which alter the RTS API must also be added to config.mk
                        [ String
"-std=c99", String
"-pipe"
                        , String
"-fdata-sections", String
"-ffunction-sections"
                        , String
"-D_POSIX_C_SOURCE=200809L", String
"-DHAS_PTHREAD", String
"-DIDRIS_ENABLE_STATS"
                        , String
"-I."] forall a. [a] -> [a] -> [a]
++ [String]
objs forall a. [a] -> [a] -> [a]
++ [String]
envFlags forall a. [a] -> [a] -> [a]
++
                        (if (OutputType
exec forall a. Eq a => a -> a -> Bool
== OutputType
Executable) then [String]
linkFlags else [String
"-c"]) forall a. [a] -> [a] -> [a]
++
                        [String
tmpn] forall a. [a] -> [a] -> [a]
++
                        (if Bool -> Bool
not Bool
iface then [String]
libFlags else []) forall a. [a] -> [a] -> [a]
++
                        [String]
incFlags forall a. [a] -> [a] -> [a]
++
                        (if Bool -> Bool
not Bool
iface then [String]
libs else []) forall a. [a] -> [a] -> [a]
++
                        [String]
flags forall a. [a] -> [a] -> [a]
++
                        [String
"-o", String
out]
--              putStrLn (show args)
             ExitCode
exit <- String -> [String] -> IO ExitCode
rawSystem String
comp [String]
args
             forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
exit forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess) forall a b. (a -> b) -> a -> b
$
                String -> IO ()
putStrLn (String
"FAILURE: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
comp forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [String]
args)
  where
    getExp :: ExportIFace -> [Export]
getExp (Export Name
_ String
_ [Export]
exp) = [Export]
exp

headers :: [String] -> String
headers [String]
xs =
  forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
    (\String
h -> String
"#include \"" forall a. [a] -> [a] -> [a]
++ String
h forall a. [a] -> [a] -> [a]
++ String
"\"\n")
    ([String]
xs forall a. [a] -> [a] -> [a]
++ [String
"idris_rts.h", String
"idris_bitstring.h", String
"idris_stdfgn.h"])

debug :: DbgLevel -> String
debug DbgLevel
TRACE = String
"#define IDRIS_TRACE\n\n"
debug DbgLevel
_ = String
""

-- We're using signed integers now. Make sure we get consistent semantics
-- out of them from gcc. See e.g. http://thiemonagel.de/2010/01/signed-integer-overflow/
gccFlags :: Bool -> [String]
gccFlags Bool
i = if Bool
i then [String
"-fwrapv"]
                  else [String
"-fwrapv", String
"-fno-strict-overflow"]

gccDbg :: DbgLevel -> [String]
gccDbg DbgLevel
DEBUG = [String
"-g"]
gccDbg DbgLevel
_ = []

cname :: Name -> String
cname :: Name -> String
cname Name
n = String
"_idris_" forall a. [a] -> [a] -> [a]
++ 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 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
"_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Enum a => a -> Int
fromEnum Char
x) forall a. [a] -> [a] -> [a]
++ String
"_"

indent :: Int -> String
indent :: Int -> String
indent Int
n = forall a. Int -> a -> [a]
replicate (Int
nforall a. Num a => a -> a -> a
*Int
4) Char
' '

creg :: Reg -> String
creg Reg
RVal = String
"RVAL"
creg (L Int
i) = String
"LOC(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i forall a. [a] -> [a] -> [a]
++ String
")"
creg (T Int
i) = String
"TOP(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i forall a. [a] -> [a] -> [a]
++ String
")"
creg Reg
Tmp = String
"REG1"

toDecl :: Name -> String
toDecl :: Name -> String
toDecl Name
f = String
"void* " forall a. [a] -> [a] -> [a]
++ Name -> String
cname Name
f forall a. [a] -> [a] -> [a]
++ String
"(VM*, VAL*);\n"

toC :: Name -> [BC] -> String
toC :: Name -> [BC] -> String
toC Name
f [BC]
code
    = -- "/* " ++ show code ++ "*/\n\n" ++
      String
"void* " forall a. [a] -> [a] -> [a]
++ Name -> String
cname Name
f forall a. [a] -> [a] -> [a]
++ String
"(VM* vm, VAL* oldbase) {\n" forall a. [a] -> [a] -> [a]
++
                  Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"INITFRAME;\nloop:\n" forall a. [a] -> [a] -> [a]
++
                  forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Int -> BC -> String
bcc Name
f Int
1) [BC]
code forall a. [a] -> [a] -> [a]
++ String
"}\n\n"

showCStr :: String -> String
showCStr :: String -> String
showCStr String
s = Char
'"' forall a. a -> [a] -> [a]
: forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a. [a] -> [a] -> [a]
(++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String
showChar) String
"\"" String
s
  where
    showChar :: Char -> String
    showChar :: Char -> String
showChar Char
'"'  = String
"\\\""
    showChar Char
'\\' = String
"\\\\"
    showChar Char
c
        -- Note: we need the double quotes around the codes because otherwise
        -- "\n3" would get encoded as "\x0a3", which is incorrect.
        -- Instead, we opt for "\x0a""3" and let the C compiler deal with it.
        | Char -> Int
ord Char
c forall a. Ord a => a -> a -> Bool
< Int
0x20  = forall {a}. (Integral a, Show a) => a -> String
showUTF8 (Char -> Int
ord Char
c)
        | Char -> Int
ord Char
c forall a. Ord a => a -> a -> Bool
< Int
0x7f  = [Char
c]    -- 0x7f = \DEL
        | Bool
otherwise = [Int] -> String
showHexes (Int -> [Int]
utf8bytes (Char -> Int
ord Char
c))

    showUTF8 :: a -> String
showUTF8 a
c = String
"\"\"\\x" forall a. [a] -> [a] -> [a]
++ String -> String
pad (forall a. (Integral a, Show a) => a -> String -> String
showHex a
c String
"") forall a. [a] -> [a] -> [a]
++ String
"\"\""
    showHexes :: [Int] -> String
showHexes = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a. [a] -> [a] -> [a]
(++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. (Integral a, Show a) => a -> String
showUTF8) String
""

    utf8bytes :: Int -> [Int]
    utf8bytes :: Int -> [Int]
utf8bytes Int
x
        | Int
x forall a. Ord a => a -> a -> Bool
<= Int
0x7f     = [Int
x]
        | Int
x forall a. Ord a => a -> a -> Bool
<= Int
0x7ff    = let (Int
y : [Int]
ys) = forall {t} {t}.
(Bits t, Num t, Num t, Eq t) =>
[t] -> t -> t -> [t]
split [] Integer
2 Int
x in (Int
y forall a. Bits a => a -> a -> a
.|. Int
0xc0) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall a. Bits a => a -> a -> a
.|. Int
0x80) [Int]
ys
        | Int
x forall a. Ord a => a -> a -> Bool
<= Int
0xffff   = let (Int
y : [Int]
ys) = forall {t} {t}.
(Bits t, Num t, Num t, Eq t) =>
[t] -> t -> t -> [t]
split [] Integer
3 Int
x in (Int
y forall a. Bits a => a -> a -> a
.|. Int
0xe0) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall a. Bits a => a -> a -> a
.|. Int
0x80) [Int]
ys
        | Int
x forall a. Ord a => a -> a -> Bool
<= Int
0x10ffff = let (Int
y : [Int]
ys) = forall {t} {t}.
(Bits t, Num t, Num t, Eq t) =>
[t] -> t -> t -> [t]
split [] Integer
4 Int
x in (Int
y forall a. Bits a => a -> a -> a
.|. Int
0xf0) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall a. Bits a => a -> a -> a
.|. Int
0x80) [Int]
ys
        | Bool
otherwise = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Invalid Unicode code point U+" forall a. [a] -> [a] -> [a]
++ forall a. (Integral a, Show a) => a -> String -> String
showHex Int
x String
""
      where
        split :: [t] -> t -> t -> [t]
split [t]
acc t
1 t
x = t
x forall a. a -> [a] -> [a]
: [t]
acc
        split [t]
acc t
i t
x = [t] -> t -> t -> [t]
split (t
x forall a. Bits a => a -> a -> a
.&. t
0x3f forall a. a -> [a] -> [a]
: [t]
acc) (t
i forall a. Num a => a -> a -> a
- t
1) (forall a. Bits a => a -> Int -> a
shiftR t
x Int
6)

    pad :: String -> String
    pad :: String -> String
pad String
s = case forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s of
                 Int
1 -> String
"0" forall a. [a] -> [a] -> [a]
++ String
s
                 Int
2 -> String
s
                 Int
_ -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Can't happen: String of invalid length " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
s

bcc :: Name -> Int -> BC -> String
bcc :: Name -> Int -> BC -> String
bcc Name
f Int
i (ASSIGN Reg
l Reg
r) = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
" = " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
";\n"
bcc Name
f Int
i (ASSIGNCONST Reg
l Const
c)
    = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
" = " forall a. [a] -> [a] -> [a]
++ Const -> String
mkConst Const
c forall a. [a] -> [a] -> [a]
++ String
";\n"
  where
    mkConst :: Const -> String
mkConst (I Int
i) = String
"MKINT(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i forall a. [a] -> [a] -> [a]
++ String
")"
    mkConst (BI Integer
i) = let maxInt :: Integer
maxInt = Integer
2forall a b. (Num a, Integral b) => a -> b -> a
^Integer
30
                     in if Integer
i forall a. Ord a => a -> a -> Bool
>= -Integer
maxInt Bool -> Bool -> Bool
&& Integer
i forall a. Ord a => a -> a -> Bool
< Integer
maxInt
                        then String
"MKINT(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
i forall a. [a] -> [a] -> [a]
++ String
")"
                        else String
"MKBIGC(vm,\"" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
i forall a. [a] -> [a] -> [a]
++ String
"\")"
    mkConst (Fl Double
f) = String
"MKFLOAT(vm, " forall a. [a] -> [a] -> [a]
++ (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Double
f) forall a. [a] -> [a] -> [a]
++ String
")"
    mkConst (Ch Char
c) = String
"MKINT(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Enum a => a -> Int
fromEnum Char
c) forall a. [a] -> [a] -> [a]
++ String
")"
    mkConst (Str String
s) = String
"MKSTR(vm, " forall a. [a] -> [a] -> [a]
++ String -> String
showCStr String
s forall a. [a] -> [a] -> [a]
++ String
")"
    mkConst (B8  Word8
x) = String
"idris_b8const(vm, "  forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word8
x forall a. [a] -> [a] -> [a]
++ String
"U)"
    mkConst (B16 Word16
x) = String
"idris_b16const(vm, " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word16
x forall a. [a] -> [a] -> [a]
++ String
"U)"
    mkConst (B32 Word32
x) = String
"idris_b32const(vm, " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word32
x forall a. [a] -> [a] -> [a]
++ String
"UL)"
    mkConst (B64 Word64
x) = String
"idris_b64const(vm, " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word64
x forall a. [a] -> [a] -> [a]
++ String
"ULL)"
    -- if it's a type constant, we won't use it, but equally it shouldn't
    -- report an error. These might creep into generated for various reasons
    -- (especially if erasure is disabled).
    mkConst Const
c | Const -> Bool
isTypeConst Const
c = String
"MKINT(42424242)"
    mkConst Const
c = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"mkConst of (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Const
c forall a. [a] -> [a] -> [a]
++ String
") not implemented"

bcc Name
f Int
i (UPDATE Reg
l Reg
r) = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
" = " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
";\n"
bcc Name
f Int
i (MKCON Reg
l Maybe Reg
loc Int
tag []) | Int
tag forall a. Ord a => a -> a -> Bool
< Int
256
    = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
" = NULL_CON(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
tag forall a. [a] -> [a] -> [a]
++ String
");\n"
bcc Name
f Int
i (MKCON Reg
l Maybe Reg
loc Int
tag [Reg]
args)
    = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ forall {a}. Show a => Maybe Reg -> a -> String
alloc Maybe Reg
loc Int
tag forall a. [a] -> [a] -> [a]
++
      Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ forall {t}. (Show t, Num t) => t -> [Reg] -> String
setArgs Integer
0 [Reg]
args forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++
      Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
" = " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
Tmp forall a. [a] -> [a] -> [a]
++ String
";\n"
  where setArgs :: t -> [Reg] -> String
setArgs t
i [] = String
""
        setArgs t
i (Reg
x : [Reg]
xs) = String
"SETARG(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
Tmp forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
i forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++
                             String
"); " forall a. [a] -> [a] -> [a]
++ t -> [Reg] -> String
setArgs (t
i forall a. Num a => a -> a -> a
+ t
1) [Reg]
xs
        alloc :: Maybe Reg -> a -> String
alloc Maybe Reg
Nothing a
tag
            = String
"allocCon(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
Tmp forall a. [a] -> [a] -> [a]
++ String
", vm, " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
tag forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++
                    forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Reg]
args) forall a. [a] -> [a] -> [a]
++ String
", 0);\n"
        alloc (Just Reg
old) a
tag
            = String
"updateCon(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
Tmp forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
old forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
tag forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++
                    forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Reg]
args) forall a. [a] -> [a] -> [a]
++ String
");\n"

bcc Name
f Int
i (PROJECT Reg
l Int
loc Int
a) = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"PROJECT(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
loc forall a. [a] -> [a] -> [a]
++
                                      String
", " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
a forall a. [a] -> [a] -> [a]
++ String
");\n"
bcc Name
f Int
i (PROJECTINTO Reg
r Reg
t Int
idx)
    = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
" = GETARG(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
t forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
idx forall a. [a] -> [a] -> [a]
++ String
");\n"
bcc Name
f Int
i (CASE Bool
True Reg
r [(Int
_, [BC]
alt)] Maybe [BC]
Nothing)
    = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ Int -> [BC] -> String
showCode Int
i [BC]
alt
  where
    showCode :: Int -> [BC] -> String
    showCode :: Int -> [BC] -> String
showCode Int
i [BC]
bc = String
"{\n" forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Int -> BC -> String
bcc Name
f (Int
i forall a. Num a => a -> a -> a
+ Int
1)) [BC]
bc forall a. [a] -> [a] -> [a]
++
                    Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"}\n"
bcc Name
f Int
i (CASE Bool
True Reg
r [(Int, [BC])]
code Maybe [BC]
def)
    | forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, [BC])]
code forall a. Ord a => a -> a -> Bool
< Int
6 Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, [BC])]
code forall a. Ord a => a -> a -> Bool
> Int
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 Int
i [BC]
bc = String
"{\n" forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Int -> BC -> String
bcc Name
f (Int
i forall a. Num a => a -> a -> a
+ Int
1)) [BC]
bc forall a. [a] -> [a] -> [a]
++
                    Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"}\n"

    showCase :: Int -> Maybe [BC] -> [(Int, [BC])] -> String
    showCase :: Int -> Maybe [BC] -> [(Int, [BC])] -> String
showCase Int
i Maybe [BC]
Nothing [(Int
t, [BC]
c)] = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ Int -> [BC] -> String
showCode Int
i [BC]
c
    showCase Int
i (Just [BC]
def) [] = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ Int -> [BC] -> String
showCode Int
i [BC]
def
    showCase Int
i Maybe [BC]
def ((Int
t, [BC]
c) : [(Int, [BC])]
cs)
        = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"if (CTAG(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
") == " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
t forall a. [a] -> [a] -> [a]
++ String
") " forall a. [a] -> [a] -> [a]
++ Int -> [BC] -> String
showCode Int
i [BC]
c
           forall a. [a] -> [a] -> [a]
++ Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"else\n" forall a. [a] -> [a] -> [a]
++ Int -> Maybe [BC] -> [(Int, [BC])] -> String
showCase Int
i Maybe [BC]
def [(Int, [BC])]
cs

bcc Name
f Int
i (CASE Bool
safe Reg
r [(Int, [BC])]
code Maybe [BC]
def)
    = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"switch(" forall a. [a] -> [a] -> [a]
++ Bool -> String
ctag Bool
safe forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")) {\n" forall a. [a] -> [a] -> [a]
++
      forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall {a} {t :: * -> *}.
(Show a, Foldable t) =>
Int -> (a, t BC) -> String
showCase Int
i) [(Int, [BC])]
code forall a. [a] -> [a] -> [a]
++
      forall {t :: * -> *}. Foldable t => Int -> Maybe (t BC) -> String
showDef Int
i Maybe [BC]
def forall a. [a] -> [a] -> [a]
++
      Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"}\n"
  where
    ctag :: Bool -> String
ctag Bool
True = String
"CTAG"
    ctag Bool
False = String
"TAG"

    showCase :: Int -> (a, t BC) -> String
showCase Int
i (a
t, t BC
bc) = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"case " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
t forall a. [a] -> [a] -> [a]
++ String
":\n"
                         forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Int -> BC -> String
bcc Name
f (Int
iforall a. Num a => a -> a -> a
+Int
1)) t BC
bc forall a. [a] -> [a] -> [a]
++ Int -> String
indent (Int
i forall a. Num a => a -> a -> a
+ Int
1) forall a. [a] -> [a] -> [a]
++ String
"break;\n"
    showDef :: Int -> Maybe (t BC) -> String
showDef Int
i Maybe (t BC)
Nothing = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"default:\n" forall a. [a] -> [a] -> [a]
++
                        Int -> String
indent (Int
i forall a. Num a => a -> a -> a
+ Int
1) forall a. [a] -> [a] -> [a]
++ String
"return NULL;\n"
    showDef Int
i (Just t BC
c) = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"default:\n"
                         forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Int -> BC -> String
bcc Name
f (Int
iforall a. Num a => a -> a -> a
+Int
1)) t BC
c forall a. [a] -> [a] -> [a]
++ Int -> String
indent (Int
i forall a. Num a => a -> a -> a
+ Int
1) forall a. [a] -> [a] -> [a]
++ String
"break;\n"
bcc Name
f Int
i (CONSTCASE Reg
r [(Const, [BC])]
code Maybe [BC]
def)
   | forall {b}. [(Const, b)] -> Bool
intConsts [(Const, [BC])]
code
--      = indent i ++ "switch(GETINT(" ++ creg r ++ ")) {\n" ++
--        concatMap (showCase i) code ++
--        showDef i def ++
--        indent i ++ "}\n"
     = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall {t :: * -> *}.
Foldable t =>
String -> (Const, t BC) -> String
iCase (Reg -> String
creg Reg
r)) [(Const, [BC])]
code forall a. [a] -> [a] -> [a]
++
       Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"{\n" forall a. [a] -> [a] -> [a]
++ forall {t :: * -> *}. Foldable t => Int -> Maybe (t BC) -> String
showDefS Int
i Maybe [BC]
def forall a. [a] -> [a] -> [a]
++ Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"}\n"
   | forall {b}. [(Const, b)] -> Bool
strConsts [(Const, [BC])]
code
     = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall {a} {t :: * -> *}.
(Show a, Foldable t) =>
String -> (a, t BC) -> String
strCase (String
"GETSTR(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")")) [(Const, [BC])]
code forall a. [a] -> [a] -> [a]
++
       Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"{\n" forall a. [a] -> [a] -> [a]
++ forall {t :: * -> *}. Foldable t => Int -> Maybe (t BC) -> String
showDefS Int
i Maybe [BC]
def forall a. [a] -> [a] -> [a]
++ Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"}\n"
   | forall {b}. [(Const, b)] -> Bool
bigintConsts [(Const, [BC])]
code
     = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall {t :: * -> *}.
Foldable t =>
String -> (Const, t BC) -> String
biCase (Reg -> String
creg Reg
r)) [(Const, [BC])]
code forall a. [a] -> [a] -> [a]
++
       Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"{\n" forall a. [a] -> [a] -> [a]
++ forall {t :: * -> *}. Foldable t => Int -> Maybe (t BC) -> String
showDefS Int
i Maybe [BC]
def forall a. [a] -> [a] -> [a]
++ Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"}\n"
   | Bool
otherwise = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Can't happen: Can't compile const case " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [(Const, [BC])]
code
  where
    intConsts :: [(Const, b)] -> Bool
intConsts ((I Int
_, b
_ ) : [(Const, b)]
_) = Bool
True
    intConsts ((Ch Char
_, b
_ ) : [(Const, b)]
_) = Bool
True
    intConsts ((B8 Word8
_, b
_ ) : [(Const, b)]
_) = Bool
True
    intConsts ((B16 Word16
_, b
_ ) : [(Const, b)]
_) = Bool
True
    intConsts ((B32 Word32
_, b
_ ) : [(Const, b)]
_) = Bool
True
    intConsts ((B64 Word64
_, b
_ ) : [(Const, b)]
_) = Bool
True
    intConsts [(Const, b)]
_ = Bool
False

    bigintConsts :: [(Const, b)] -> Bool
bigintConsts ((BI Integer
_, b
_ ) : [(Const, b)]
_) = Bool
True
    bigintConsts [(Const, b)]
_ = Bool
False

    strConsts :: [(Const, b)] -> Bool
strConsts ((Str String
_, b
_ ) : [(Const, b)]
_) = Bool
True
    strConsts [(Const, b)]
_ = Bool
False

    strCase :: String -> (a, t BC) -> String
strCase String
sv (a
s, t BC
bc) =
        Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"if (strcmp(" forall a. [a] -> [a] -> [a]
++ String
sv forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
s forall a. [a] -> [a] -> [a]
++ String
") == 0) {\n" forall a. [a] -> [a] -> [a]
++
           forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Int -> BC -> String
bcc Name
f (Int
iforall a. Num a => a -> a -> a
+Int
1)) t BC
bc forall a. [a] -> [a] -> [a]
++ Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"} else\n"
    biCase :: String -> (Const, t BC) -> String
biCase String
bv (BI Integer
b, t BC
bc) =
        Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"if (bigEqConst(" forall a. [a] -> [a] -> [a]
++ String
bv forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
b forall a. [a] -> [a] -> [a]
++ String
")) {\n"
           forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Int -> BC -> String
bcc Name
f (Int
iforall a. Num a => a -> a -> a
+Int
1)) t BC
bc forall a. [a] -> [a] -> [a]
++ Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"} else\n"
    iCase :: String -> (Const, t BC) -> String
iCase String
v (I Int
b, t BC
bc) =
        Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"if (GETINT(" forall a. [a] -> [a] -> [a]
++ String
v forall a. [a] -> [a] -> [a]
++ String
") == " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
b forall a. [a] -> [a] -> [a]
++ String
") {\n"
           forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Int -> BC -> String
bcc Name
f (Int
iforall a. Num a => a -> a -> a
+Int
1)) t BC
bc forall a. [a] -> [a] -> [a]
++ Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"} else\n"
    iCase String
v (Ch Char
b, t BC
bc) =
        Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"if (GETINT(" forall a. [a] -> [a] -> [a]
++ String
v forall a. [a] -> [a] -> [a]
++ String
") == " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Enum a => a -> Int
fromEnum Char
b) forall a. [a] -> [a] -> [a]
++ String
") {\n"
           forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Int -> BC -> String
bcc Name
f (Int
iforall a. Num a => a -> a -> a
+Int
1)) t BC
bc forall a. [a] -> [a] -> [a]
++ Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"} else\n"
    iCase String
v (B8 Word8
w, t BC
bc) =
        Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"if (GETBITS8(" forall a. [a] -> [a] -> [a]
++ String
v forall a. [a] -> [a] -> [a]
++ String
") == " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Enum a => a -> Int
fromEnum Word8
w) forall a. [a] -> [a] -> [a]
++ String
") {\n"
           forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Int -> BC -> String
bcc Name
f (Int
iforall a. Num a => a -> a -> a
+Int
1)) t BC
bc forall a. [a] -> [a] -> [a]
++ Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"} else\n"
    iCase String
v (B16 Word16
w, t BC
bc) =
        Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"if (GETBITS16(" forall a. [a] -> [a] -> [a]
++ String
v forall a. [a] -> [a] -> [a]
++ String
") == " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Enum a => a -> Int
fromEnum Word16
w) forall a. [a] -> [a] -> [a]
++ String
") {\n"
           forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Int -> BC -> String
bcc Name
f (Int
iforall a. Num a => a -> a -> a
+Int
1)) t BC
bc forall a. [a] -> [a] -> [a]
++ Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"} else\n"
    iCase String
v (B32 Word32
w, t BC
bc) =
        Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"if (GETBITS32(" forall a. [a] -> [a] -> [a]
++ String
v forall a. [a] -> [a] -> [a]
++ String
") == " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Enum a => a -> Int
fromEnum Word32
w) forall a. [a] -> [a] -> [a]
++ String
") {\n"
           forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Int -> BC -> String
bcc Name
f (Int
iforall a. Num a => a -> a -> a
+Int
1)) t BC
bc forall a. [a] -> [a] -> [a]
++ Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"} else\n"
    iCase String
v (B64 Word64
w, t BC
bc) =
        Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"if (GETBITS64(" forall a. [a] -> [a] -> [a]
++ String
v forall a. [a] -> [a] -> [a]
++ String
") == " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Enum a => a -> Int
fromEnum Word64
w) forall a. [a] -> [a] -> [a]
++ String
") {\n"
           forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Int -> BC -> String
bcc Name
f (Int
iforall a. Num a => a -> a -> a
+Int
1)) t BC
bc forall a. [a] -> [a] -> [a]
++ Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"} else\n"
    showDefS :: Int -> Maybe (t BC) -> String
showDefS Int
i Maybe (t BC)
Nothing = String
""
    showDefS Int
i (Just t BC
c) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Int -> BC -> String
bcc Name
f (Int
iforall a. Num a => a -> a -> a
+Int
1)) t BC
c

bcc Name
f Int
i (CALL Name
n) = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"CALL(" forall a. [a] -> [a] -> [a]
++ Name -> String
cname Name
n forall a. [a] -> [a] -> [a]
++ String
");\n"
bcc Name
f Int
i (TAILCALL Name
n)
    | Name
f forall a. Eq a => a -> a -> Bool
== Name
n = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"goto loop;\n"
    | Bool
otherwise = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"TAILCALL(" forall a. [a] -> [a] -> [a]
++ Name -> String
cname Name
n forall a. [a] -> [a] -> [a]
++ String
");\n"
bcc Name
f Int
i (SLIDE Int
n) = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"SLIDE(vm, " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n forall a. [a] -> [a] -> [a]
++ String
");\n"
bcc Name
f Int
i BC
REBASE = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"REBASE;\n"
bcc Name
f Int
i (RESERVE Int
0) = String
""
bcc Name
f Int
i (RESERVE Int
n) = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"RESERVE(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n forall a. [a] -> [a] -> [a]
++ String
");\n"
bcc Name
f Int
i (RESERVENOALLOC Int
0) = String
""
bcc Name
f Int
i (RESERVENOALLOC Int
n) = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"RESERVENOALLOC(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n forall a. [a] -> [a] -> [a]
++ String
");\n"
bcc Name
f Int
i (ADDTOP Int
0) = String
""
bcc Name
f Int
i (ADDTOP Int
n) = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"ADDTOP(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n forall a. [a] -> [a] -> [a]
++ String
");\n"
bcc Name
f Int
i (TOPBASE Int
n) = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"TOPBASE(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n forall a. [a] -> [a] -> [a]
++ String
");\n"
bcc Name
f Int
i (BASETOP Int
n) = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"BASETOP(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n forall a. [a] -> [a] -> [a]
++ String
");\n"
bcc Name
f Int
i BC
STOREOLD = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"STOREOLD;\n"
bcc Name
f Int
i (OP Reg
l PrimFn
fn [Reg]
args) = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String -> PrimFn -> [Reg] -> String
doOp (Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
" = ") PrimFn
fn [Reg]
args forall a. [a] -> [a] -> [a]
++ String
";\n"
bcc Name
f Int
i (FOREIGNCALL Reg
l FDesc
rty (FStr (Char
'#':String
name)) [])
      = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++
        FType -> String -> String -> String
c_irts (FDesc -> FType
toFType FDesc
rty) (Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
" = ") String
name forall a. [a] -> [a] -> [a]
++ String
";\n"
bcc Name
f Int
i (FOREIGNCALL Reg
l FDesc
rty (FStr fn :: String
fn@(Char
'&':String
name)) [])
      = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++
        FType -> String -> String -> String
c_irts (FDesc -> FType
toFType FDesc
rty) (Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
" = ") String
fn forall a. [a] -> [a] -> [a]
++ String
";\n"
bcc Name
f Int
i (FOREIGNCALL Reg
l FDesc
rty (FStr String
fn) ((FDesc, Reg)
x:[(FDesc, Reg)]
xs)) | String
fn forall a. Eq a => a -> a -> Bool
== String
"%wrapper"
      = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++
        FType -> String -> String -> String
c_irts (FDesc -> FType
toFType FDesc
rty) (Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
" = ")
            (String
"_idris_get_wrapper(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg (forall a b. (a, b) -> b
snd (FDesc, Reg)
x) forall a. [a] -> [a] -> [a]
++ String
")") forall a. [a] -> [a] -> [a]
++ String
";\n"
bcc Name
f Int
i (FOREIGNCALL Reg
l FDesc
rty (FStr String
fn) ((FDesc, Reg)
x:[(FDesc, Reg)]
xs)) | String
fn forall a. Eq a => a -> a -> Bool
== String
"%dynamic"
      = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ FType -> String -> String -> String
c_irts (FDesc -> FType
toFType FDesc
rty) (Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
" = ")
            (String
"(*(" forall a. [a] -> [a] -> [a]
++ forall {b}. String -> FDesc -> [(FDesc, b)] -> String
cFnSig String
"" FDesc
rty [(FDesc, Reg)]
xs forall a. [a] -> [a] -> [a]
++ String
") GETPTR(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg (forall a b. (a, b) -> b
snd (FDesc, Reg)
x) forall a. [a] -> [a] -> [a]
++ String
"))" forall a. [a] -> [a] -> [a]
++
             String
"(" forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
showSep String
"," (forall a b. (a -> b) -> [a] -> [b]
map (FDesc, Reg) -> String
fcall [(FDesc, Reg)]
xs) forall a. [a] -> [a] -> [a]
++ String
")") forall a. [a] -> [a] -> [a]
++ String
";\n"
bcc Name
f Int
i (FOREIGNCALL Reg
l FDesc
rty (FStr String
fn) [(FDesc, Reg)]
args)
      = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++
        FType -> String -> String -> String
c_irts (FDesc -> FType
toFType FDesc
rty) (Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
" = ")
                   (String
fn forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
showSep String
"," (forall a b. (a -> b) -> [a] -> [b]
map (FDesc, Reg) -> String
fcall [(FDesc, Reg)]
args) forall a. [a] -> [a] -> [a]
++ String
")") forall a. [a] -> [a] -> [a]
++ String
";\n"
bcc Name
f Int
i (FOREIGNCALL Reg
l FDesc
rty FDesc
_ [(FDesc, Reg)]
args) = forall a. HasCallStack => String -> a
error String
"Foreign Function calls cannot be partially applied, without being inlined."
bcc Name
f Int
i (NULL Reg
r) = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
" = NULL;\n" -- clear, so it'll be GCed
bcc Name
f Int
i (ERROR String
str) = Int -> String
indent Int
i forall a. [a] -> [a] -> [a]
++ String
"fprintf(stderr, " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
str forall a. [a] -> [a] -> [a]
++ String
"); fprintf(stderr, \"\\n\"); exit(-1);\n"
-- bcc f i c = error (show c) -- indent i ++ "// not done yet\n"

fcall :: (FDesc, Reg) -> String
fcall (FDesc
t, Reg
arg) = FType -> String -> String
irts_c (FDesc -> FType
toFType FDesc
t) (Reg -> String
creg Reg
arg)
-- Deconstruct the Foreign type in the defunctionalised expression and build
-- a foreign type description for c_irts and irts_c
toAType :: FDesc -> ArithTy
toAType (FCon Name
i)
    | Name
i forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_IntChar" = IntTy -> ArithTy
ATInt IntTy
ITChar
    | Name
i forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_IntNative" = IntTy -> ArithTy
ATInt IntTy
ITNative
    | Name
i forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_IntBits8" = IntTy -> ArithTy
ATInt (NativeTy -> IntTy
ITFixed NativeTy
IT8)
    | Name
i forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_IntBits16" = IntTy -> ArithTy
ATInt (NativeTy -> IntTy
ITFixed NativeTy
IT16)
    | Name
i forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_IntBits32" = IntTy -> ArithTy
ATInt (NativeTy -> IntTy
ITFixed NativeTy
IT32)
    | Name
i forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_IntBits64" = IntTy -> ArithTy
ATInt (NativeTy -> IntTy
ITFixed NativeTy
IT64)
toAType FDesc
t = forall a. HasCallStack => String -> a
error (forall a. Show a => a -> String
show FDesc
t forall a. [a] -> [a] -> [a]
++ String
" not defined in toAType")

toFType :: FDesc -> FType
toFType (FCon Name
c)
    | Name
c forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_Str" = FType
FString
    | Name
c forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_Float" = ArithTy -> FType
FArith ArithTy
ATFloat
    | Name
c forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_Ptr" = FType
FPtr
    | Name
c forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_MPtr" = FType
FManagedPtr
    | Name
c forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_CData" = FType
FCData
    | Name
c forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_Unit" = FType
FUnit
toFType (FApp Name
c [FDesc
_,FDesc
ity])
    | Name
c forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_IntT" = ArithTy -> FType
FArith (FDesc -> ArithTy
toAType FDesc
ity)
    | Name
c forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_FnT" = FDesc -> FType
toFunType FDesc
ity
toFType (FApp Name
c [FDesc
_])
    | Name
c forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_Any" = FType
FAny
toFType FDesc
t = FType
FAny

toFunType :: FDesc -> FType
toFunType (FApp Name
c [FDesc
_,FDesc
ity])
    | Name
c forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_FnBase" = FType
FFunction
    | Name
c forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_FnIO" = FType
FFunctionIO
toFunType (FApp Name
c [FDesc
_,FDesc
_,FDesc
_,FDesc
ity])
    | Name
c forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_Fn" = FDesc -> FType
toFunType FDesc
ity
toFunType FDesc
_ = FType
FAny

c_irts :: FType -> String -> String -> String
c_irts (FArith (ATInt IntTy
ITNative)) String
l String
x = String
l forall a. [a] -> [a] -> [a]
++ String
"MKINT((i_int)(" forall a. [a] -> [a] -> [a]
++ String
x forall a. [a] -> [a] -> [a]
++ String
"))"
c_irts (FArith (ATInt IntTy
ITChar))  String
l 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 NativeTy
ity))) String
l String
x
    = String
l forall a. [a] -> [a] -> [a]
++ String
"idris_b" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (NativeTy -> Int
nativeTyWidth NativeTy
ity) forall a. [a] -> [a] -> [a]
++ String
"const(vm, " forall a. [a] -> [a] -> [a]
++ String
x forall a. [a] -> [a] -> [a]
++ String
")"
c_irts FType
FString String
l String
x = String
l forall a. [a] -> [a] -> [a]
++ String
"MKSTR(vm, " forall a. [a] -> [a] -> [a]
++ String
x forall a. [a] -> [a] -> [a]
++ String
")"
c_irts FType
FUnit String
l String
x = String
x
c_irts FType
FPtr String
l String
x = String
l forall a. [a] -> [a] -> [a]
++ String
"MKPTR(vm, " forall a. [a] -> [a] -> [a]
++ String
x forall a. [a] -> [a] -> [a]
++ String
")"
c_irts FType
FManagedPtr String
l String
x = String
l forall a. [a] -> [a] -> [a]
++ String
x
c_irts (FArith ArithTy
ATFloat) String
l String
x = String
l forall a. [a] -> [a] -> [a]
++ String
"MKFLOAT(vm, " forall a. [a] -> [a] -> [a]
++ String
x forall a. [a] -> [a] -> [a]
++ String
")"
c_irts FType
FCData String
l String
x = String
l forall a. [a] -> [a] -> [a]
++ String
"MKCDATA(vm, " forall a. [a] -> [a] -> [a]
++ String
x forall a. [a] -> [a] -> [a]
++ String
")"
c_irts FType
FAny String
l String
x = String
l forall a. [a] -> [a] -> [a]
++ String
x
c_irts FType
FFunction String
l String
x = forall a. HasCallStack => String -> a
error String
"Return of function from foreign call is not supported"
c_irts FType
FFunctionIO String
l String
x = forall a. HasCallStack => String -> a
error String
"Return of function from foreign call is not supported"

irts_c :: FType -> String -> String
irts_c (FArith (ATInt IntTy
ITNative)) String
x = String
"GETINT(" forall a. [a] -> [a] -> [a]
++ String
x forall a. [a] -> [a] -> [a]
++ String
")"
irts_c (FArith (ATInt IntTy
ITChar)) String
x = FType -> String -> String
irts_c (ArithTy -> FType
FArith (IntTy -> ArithTy
ATInt IntTy
ITNative)) String
x
irts_c (FArith (ATInt (ITFixed NativeTy
ity))) String
x
    = String
"GETBITS" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (NativeTy -> Int
nativeTyWidth NativeTy
ity) forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ String
x forall a. [a] -> [a] -> [a]
++ String
")"
irts_c FType
FString String
x = String
"GETSTR(" forall a. [a] -> [a] -> [a]
++ String
x forall a. [a] -> [a] -> [a]
++ String
")"
irts_c FType
FUnit String
x = String
x
irts_c FType
FPtr String
x = String
"GETPTR(" forall a. [a] -> [a] -> [a]
++ String
x forall a. [a] -> [a] -> [a]
++ String
")"
irts_c FType
FManagedPtr String
x = String
"GETMPTR(" forall a. [a] -> [a] -> [a]
++ String
x forall a. [a] -> [a] -> [a]
++ String
")"
irts_c (FArith ArithTy
ATFloat) String
x = String
"GETFLOAT(" forall a. [a] -> [a] -> [a]
++ String
x forall a. [a] -> [a] -> [a]
++ String
")"
irts_c FType
FCData String
x = String
"GETCDATA(" forall a. [a] -> [a] -> [a]
++ String
x forall a. [a] -> [a] -> [a]
++ String
")"
irts_c FType
FAny String
x = String
x
irts_c FType
FFunctionIO String
x = String -> String
wrapped String
x
irts_c FType
FFunction String
x = String -> String
wrapped String
x

cFnSig :: String -> FDesc -> [(FDesc, b)] -> String
cFnSig String
name FDesc
rty [] = FDesc -> String
ctype FDesc
rty forall a. [a] -> [a] -> [a]
++ String
" (*" forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
")(void) "
cFnSig String
name FDesc
rty [(FDesc, b)]
args = FDesc -> String
ctype FDesc
rty forall a. [a] -> [a] -> [a]
++ String
" (*" forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
")("
        forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
showSep String
"," (forall a b. (a -> b) -> [a] -> [b]
map (FDesc -> String
ctype forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(FDesc, b)]
args) forall a. [a] -> [a] -> [a]
++ String
") "

wrapped :: String -> String
wrapped String
x = String
"_idris_get_wrapper(" forall a. [a] -> [a] -> [a]
++ String
x forall a. [a] -> [a] -> [a]
++ String
")"

bitOp :: String -> String -> NativeTy -> [Reg] -> String
bitOp String
v String
op NativeTy
ty [Reg]
args = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_b" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (NativeTy -> Int
nativeTyWidth NativeTy
ty) forall a. [a] -> [a] -> [a]
++ String
op forall a. [a] -> [a] -> [a]
++ String
"(vm, " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map Reg -> String
creg [Reg]
args) forall a. [a] -> [a] -> [a]
++ String
")"

bitCoerce :: String -> String -> NativeTy -> NativeTy -> Reg -> String
bitCoerce String
v String
op NativeTy
input NativeTy
output Reg
arg
    = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_b" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (NativeTy -> Int
nativeTyWidth NativeTy
input) forall a. [a] -> [a] -> [a]
++ String
op forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (NativeTy -> Int
nativeTyWidth NativeTy
output) forall a. [a] -> [a] -> [a]
++ String
"(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
arg forall a. [a] -> [a] -> [a]
++ String
")"

signedTy :: NativeTy -> String
signedTy :: NativeTy -> String
signedTy NativeTy
t = String
"int" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (NativeTy -> Int
nativeTyWidth NativeTy
t) forall a. [a] -> [a] -> [a]
++ String
"_t"

-- Need to ensure we have enough spare *before* GMP operations because they
-- use the idris allocator but outside our control, and if it GCs in the middle
-- then things get moved which leads to trouble...
-- I'm just guessing how much it'll need. This is a TMP HACK. Sorry.
wrapGMP :: String -> String
wrapGMP String
op
   = String
"idris_requireAlloc(vm, 65536); " forall a. [a] -> [a] -> [a]
++ String
op forall a. [a] -> [a] -> [a]
++ String
"; idris_doneAlloc(vm)"

doOp :: String -> PrimFn -> [Reg] -> String
doOp String
v (LPlus (ATInt IntTy
ITNative)) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"ADD(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LMinus (ATInt IntTy
ITNative)) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"INTOP(-," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LTimes (ATInt IntTy
ITNative)) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"MULT(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LUDiv IntTy
ITNative) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"UINTOP(/," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LSDiv (ATInt IntTy
ITNative)) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"INTOP(/," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LURem IntTy
ITNative) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"UINTOP(%," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LSRem (ATInt IntTy
ITNative)) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"INTOP(%," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LAnd IntTy
ITNative) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"INTOP(&," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LOr IntTy
ITNative) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"INTOP(|," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LXOr IntTy
ITNative) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"INTOP(^," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LSHL IntTy
ITNative) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"INTOP(<<," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LLSHR IntTy
ITNative) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"UINTOP(>>," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LASHR IntTy
ITNative) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"INTOP(>>," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LCompl IntTy
ITNative) [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String
"INTOP(~," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LEq (ATInt IntTy
ITNative)) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"INTOP(==," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LSLt (ATInt IntTy
ITNative)) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"INTOP(<," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LSLe (ATInt IntTy
ITNative)) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"INTOP(<=," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LSGt (ATInt IntTy
ITNative)) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"INTOP(>," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LSGe (ATInt IntTy
ITNative)) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"INTOP(>=," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LLt IntTy
ITNative) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"UINTOP(<," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LLe IntTy
ITNative) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"UINTOP(<=," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LGt IntTy
ITNative) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"UINTOP(>," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LGe IntTy
ITNative) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"UINTOP(>=," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"

doOp String
v (LPlus (ATInt IntTy
ITChar)) [Reg
l, Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (ArithTy -> PrimFn
LPlus (IntTy -> ArithTy
ATInt IntTy
ITNative)) [Reg
l, Reg
r]
doOp String
v (LMinus (ATInt IntTy
ITChar)) [Reg
l, Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (ArithTy -> PrimFn
LMinus (IntTy -> ArithTy
ATInt IntTy
ITNative)) [Reg
l, Reg
r]
doOp String
v (LTimes (ATInt IntTy
ITChar)) [Reg
l, Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (ArithTy -> PrimFn
LTimes (IntTy -> ArithTy
ATInt IntTy
ITNative)) [Reg
l, Reg
r]
doOp String
v (LUDiv IntTy
ITChar) [Reg
l, Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> PrimFn
LUDiv IntTy
ITNative) [Reg
l, Reg
r]
doOp String
v (LSDiv (ATInt IntTy
ITChar)) [Reg
l, Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (ArithTy -> PrimFn
LSDiv (IntTy -> ArithTy
ATInt IntTy
ITNative)) [Reg
l, Reg
r]
doOp String
v (LURem IntTy
ITChar) [Reg
l, Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> PrimFn
LURem IntTy
ITNative) [Reg
l, Reg
r]
doOp String
v (LSRem (ATInt IntTy
ITChar)) [Reg
l, Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (ArithTy -> PrimFn
LSRem (IntTy -> ArithTy
ATInt IntTy
ITNative)) [Reg
l, Reg
r]
doOp String
v (LAnd IntTy
ITChar) [Reg
l, Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> PrimFn
LAnd IntTy
ITNative) [Reg
l, Reg
r]
doOp String
v (LOr IntTy
ITChar) [Reg
l, Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> PrimFn
LOr IntTy
ITNative) [Reg
l, Reg
r]
doOp String
v (LXOr IntTy
ITChar) [Reg
l, Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> PrimFn
LXOr IntTy
ITNative) [Reg
l, Reg
r]
doOp String
v (LSHL IntTy
ITChar) [Reg
l, Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> PrimFn
LSHL IntTy
ITNative) [Reg
l, Reg
r]
doOp String
v (LLSHR IntTy
ITChar) [Reg
l, Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> PrimFn
LLSHR IntTy
ITNative) [Reg
l, Reg
r]
doOp String
v (LASHR IntTy
ITChar) [Reg
l, Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> PrimFn
LASHR IntTy
ITNative) [Reg
l, Reg
r]
doOp String
v (LCompl IntTy
ITChar) [Reg
x] = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> PrimFn
LCompl IntTy
ITNative) [Reg
x]
doOp String
v (LEq (ATInt IntTy
ITChar)) [Reg
l, Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (ArithTy -> PrimFn
LEq (IntTy -> ArithTy
ATInt IntTy
ITNative)) [Reg
l, Reg
r]
doOp String
v (LSLt (ATInt IntTy
ITChar)) [Reg
l, Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (ArithTy -> PrimFn
LSLt (IntTy -> ArithTy
ATInt IntTy
ITNative)) [Reg
l, Reg
r]
doOp String
v (LSLe (ATInt IntTy
ITChar)) [Reg
l, Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (ArithTy -> PrimFn
LSLe (IntTy -> ArithTy
ATInt IntTy
ITNative)) [Reg
l, Reg
r]
doOp String
v (LSGt (ATInt IntTy
ITChar)) [Reg
l, Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (ArithTy -> PrimFn
LSGt (IntTy -> ArithTy
ATInt IntTy
ITNative)) [Reg
l, Reg
r]
doOp String
v (LSGe (ATInt IntTy
ITChar)) [Reg
l, Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (ArithTy -> PrimFn
LSGe (IntTy -> ArithTy
ATInt IntTy
ITNative)) [Reg
l, Reg
r]
doOp String
v (LLt IntTy
ITChar) [Reg
l, Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> PrimFn
LLt IntTy
ITNative) [Reg
l, Reg
r]
doOp String
v (LLe IntTy
ITChar) [Reg
l, Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> PrimFn
LLe IntTy
ITNative) [Reg
l, Reg
r]
doOp String
v (LGt IntTy
ITChar) [Reg
l, Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> PrimFn
LGt IntTy
ITNative) [Reg
l, Reg
r]
doOp String
v (LGe IntTy
ITChar) [Reg
l, Reg
r] = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> PrimFn
LGe IntTy
ITNative) [Reg
l, Reg
r]

doOp String
v (LPlus ArithTy
ATFloat) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"FLOATOP(+," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LMinus ArithTy
ATFloat) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"FLOATOP(-," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LTimes ArithTy
ATFloat) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"FLOATOP(*," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LSDiv ArithTy
ATFloat) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"FLOATOP(/," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LEq ArithTy
ATFloat) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"FLOATBOP(==," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LSLt ArithTy
ATFloat) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"FLOATBOP(<," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LSLe ArithTy
ATFloat) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"FLOATBOP(<=," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LSGt ArithTy
ATFloat) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"FLOATBOP(>," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LSGe ArithTy
ATFloat) [Reg
l, Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"FLOATBOP(>=," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"

doOp String
v (LIntFloat IntTy
ITBig) [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_castBigFloat(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LFloatInt IntTy
ITBig) [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_castFloatBig(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LPlus (ATInt IntTy
ITBig)) [Reg
l, Reg
r] = String -> String
wrapGMP forall a b. (a -> b) -> a -> b
$ String
v forall a. [a] -> [a] -> [a]
++ String
"idris_bigPlus(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LMinus (ATInt IntTy
ITBig)) [Reg
l, Reg
r] = String -> String
wrapGMP forall a b. (a -> b) -> a -> b
$ String
v forall a. [a] -> [a] -> [a]
++ String
"idris_bigMinus(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LTimes (ATInt IntTy
ITBig)) [Reg
l, Reg
r] = String -> String
wrapGMP forall a b. (a -> b) -> a -> b
$ String
v forall a. [a] -> [a] -> [a]
++ String
"idris_bigTimes(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LSDiv (ATInt IntTy
ITBig)) [Reg
l, Reg
r] = String -> String
wrapGMP forall a b. (a -> b) -> a -> b
$ String
v forall a. [a] -> [a] -> [a]
++ String
"idris_bigDivide(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LSRem (ATInt IntTy
ITBig)) [Reg
l, Reg
r] = String -> String
wrapGMP forall a b. (a -> b) -> a -> b
$ String
v forall a. [a] -> [a] -> [a]
++ String
"idris_bigMod(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LAnd IntTy
ITBig) [Reg
l, Reg
r] = String -> String
wrapGMP forall a b. (a -> b) -> a -> b
$ String
v forall a. [a] -> [a] -> [a]
++ String
"idris_bigAnd(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LOr IntTy
ITBig) [Reg
l, Reg
r] = String -> String
wrapGMP forall a b. (a -> b) -> a -> b
$ String
v forall a. [a] -> [a] -> [a]
++ String
"idris_bigOr(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LSHL IntTy
ITBig) [Reg
l, Reg
r] = String -> String
wrapGMP forall a b. (a -> b) -> a -> b
$ String
v forall a. [a] -> [a] -> [a]
++ String
"idris_bigShiftLeft(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LLSHR IntTy
ITBig) [Reg
l, Reg
r] = String -> String
wrapGMP forall a b. (a -> b) -> a -> b
$ String
v forall a. [a] -> [a] -> [a]
++ String
"idris_bigLShiftRight(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LASHR IntTy
ITBig) [Reg
l, Reg
r] = String -> String
wrapGMP forall a b. (a -> b) -> a -> b
$ String
v forall a. [a] -> [a] -> [a]
++ String
"idris_bigAShiftRight(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LEq (ATInt IntTy
ITBig)) [Reg
l, Reg
r] = String -> String
wrapGMP forall a b. (a -> b) -> a -> b
$ String
v forall a. [a] -> [a] -> [a]
++ String
"idris_bigEq(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LSLt (ATInt IntTy
ITBig)) [Reg
l, Reg
r] = String -> String
wrapGMP forall a b. (a -> b) -> a -> b
$ String
v forall a. [a] -> [a] -> [a]
++ String
"idris_bigLt(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LSLe (ATInt IntTy
ITBig)) [Reg
l, Reg
r] = String -> String
wrapGMP forall a b. (a -> b) -> a -> b
$ String
v forall a. [a] -> [a] -> [a]
++ String
"idris_bigLe(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LSGt (ATInt IntTy
ITBig)) [Reg
l, Reg
r] = String -> String
wrapGMP forall a b. (a -> b) -> a -> b
$ String
v forall a. [a] -> [a] -> [a]
++ String
"idris_bigGt(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LSGe (ATInt IntTy
ITBig)) [Reg
l, Reg
r] = String -> String
wrapGMP forall a b. (a -> b) -> a -> b
$ String
v forall a. [a] -> [a] -> [a]
++ String
"idris_bigGe(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"

doOp String
v (LIntFloat IntTy
ITNative) [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_castIntFloat(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LFloatInt IntTy
ITNative) [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_castFloatInt(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LSExt IntTy
ITNative IntTy
ITBig) [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_castIntBig(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LTrunc IntTy
ITBig IntTy
ITNative) [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_castBigInt(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LStrInt IntTy
ITBig) [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_castStrBig(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LIntStr IntTy
ITBig) [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_castBigStr(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LIntStr IntTy
ITNative) [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_castIntStr(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LStrInt IntTy
ITNative) [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_castStrInt(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LIntStr (ITFixed NativeTy
_)) [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_castBitsStr(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v PrimFn
LFloatStr [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_castFloatStr(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v PrimFn
LStrFloat [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_castStrFloat(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
")"

doOp String
v (LSLt (ATInt (ITFixed NativeTy
ty))) [Reg
x, Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v String
"SLt" NativeTy
ty [Reg
x, Reg
y]
doOp String
v (LSLe (ATInt (ITFixed NativeTy
ty))) [Reg
x, Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v String
"SLte" NativeTy
ty [Reg
x, Reg
y]
doOp String
v (LEq (ATInt (ITFixed NativeTy
ty))) [Reg
x, Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v String
"Eq" NativeTy
ty [Reg
x, Reg
y]
doOp String
v (LSGe (ATInt (ITFixed NativeTy
ty))) [Reg
x, Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v String
"SGte" NativeTy
ty [Reg
x, Reg
y]
doOp String
v (LSGt (ATInt (ITFixed NativeTy
ty))) [Reg
x, Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v String
"SGt" NativeTy
ty [Reg
x, Reg
y]
doOp String
v (LLt (ITFixed NativeTy
ty)) [Reg
x, Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v String
"Lt" NativeTy
ty [Reg
x, Reg
y]
doOp String
v (LLe (ITFixed NativeTy
ty)) [Reg
x, Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v String
"Lte" NativeTy
ty [Reg
x, Reg
y]
doOp String
v (LGe (ITFixed NativeTy
ty)) [Reg
x, Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v String
"Gte" NativeTy
ty [Reg
x, Reg
y]
doOp String
v (LGt (ITFixed NativeTy
ty)) [Reg
x, Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v String
"Gt" NativeTy
ty [Reg
x, Reg
y]

doOp String
v (LSHL (ITFixed NativeTy
ty)) [Reg
x, Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v String
"Shl" NativeTy
ty [Reg
x, Reg
y]
doOp String
v (LLSHR (ITFixed NativeTy
ty)) [Reg
x, Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v String
"LShr" NativeTy
ty [Reg
x, Reg
y]
doOp String
v (LASHR (ITFixed NativeTy
ty)) [Reg
x, Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v String
"AShr" NativeTy
ty [Reg
x, Reg
y]
doOp String
v (LAnd (ITFixed NativeTy
ty)) [Reg
x, Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v String
"And" NativeTy
ty [Reg
x, Reg
y]
doOp String
v (LOr (ITFixed NativeTy
ty)) [Reg
x, Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v String
"Or" NativeTy
ty [Reg
x, Reg
y]
doOp String
v (LXOr (ITFixed NativeTy
ty)) [Reg
x, Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v String
"Xor" NativeTy
ty [Reg
x, Reg
y]
doOp String
v (LCompl (ITFixed NativeTy
ty)) [Reg
x] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v String
"Compl" NativeTy
ty [Reg
x]

doOp String
v (LPlus (ATInt (ITFixed NativeTy
ty))) [Reg
x, Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v String
"Plus" NativeTy
ty [Reg
x, Reg
y]
doOp String
v (LMinus (ATInt (ITFixed NativeTy
ty))) [Reg
x, Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v String
"Minus" NativeTy
ty [Reg
x, Reg
y]
doOp String
v (LTimes (ATInt (ITFixed NativeTy
ty))) [Reg
x, Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v String
"Times" NativeTy
ty [Reg
x, Reg
y]
doOp String
v (LUDiv (ITFixed NativeTy
ty)) [Reg
x, Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v String
"UDiv" NativeTy
ty [Reg
x, Reg
y]
doOp String
v (LSDiv (ATInt (ITFixed NativeTy
ty))) [Reg
x, Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v String
"SDiv" NativeTy
ty [Reg
x, Reg
y]
doOp String
v (LURem (ITFixed NativeTy
ty)) [Reg
x, Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v String
"URem" NativeTy
ty [Reg
x, Reg
y]
doOp String
v (LSRem (ATInt (ITFixed NativeTy
ty))) [Reg
x, Reg
y] = String -> String -> NativeTy -> [Reg] -> String
bitOp String
v String
"SRem" NativeTy
ty [Reg
x, Reg
y]

doOp String
v (LSExt (ITFixed NativeTy
from) IntTy
ITBig) [Reg
x]
    = String
v forall a. [a] -> [a] -> [a]
++ String
"MKBIGSI(vm, (" forall a. [a] -> [a] -> [a]
++ NativeTy -> String
signedTy NativeTy
from forall a. [a] -> [a] -> [a]
++ String
") GETBITS" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (NativeTy -> Int
nativeTyWidth NativeTy
from) forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
"))"
doOp String
v (LSExt IntTy
ITNative (ITFixed NativeTy
to)) [Reg
x]
    = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_b" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (NativeTy -> Int
nativeTyWidth NativeTy
to) forall a. [a] -> [a] -> [a]
++ String
"const(vm, GETINT(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
"))"
doOp String
v (LSExt IntTy
ITChar (ITFixed NativeTy
to)) [Reg
x]
    = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> IntTy -> PrimFn
LSExt IntTy
ITNative (NativeTy -> IntTy
ITFixed NativeTy
to)) [Reg
x]
doOp String
v (LSExt (ITFixed NativeTy
from) IntTy
ITNative) [Reg
x]
    = String
v forall a. [a] -> [a] -> [a]
++ String
"MKINT((i_int)((" forall a. [a] -> [a] -> [a]
++ NativeTy -> String
signedTy NativeTy
from forall a. [a] -> [a] -> [a]
++ String
") GETBITS" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (NativeTy -> Int
nativeTyWidth NativeTy
from) forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
")))"
doOp String
v (LSExt (ITFixed NativeTy
from) IntTy
ITChar) [Reg
x]
    = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> IntTy -> PrimFn
LSExt (NativeTy -> IntTy
ITFixed NativeTy
from) IntTy
ITNative) [Reg
x]
doOp String
v (LSExt (ITFixed NativeTy
from) (ITFixed NativeTy
to)) [Reg
x]
    | NativeTy -> Int
nativeTyWidth NativeTy
from forall a. Ord a => a -> a -> Bool
< NativeTy -> Int
nativeTyWidth NativeTy
to = String -> String -> NativeTy -> NativeTy -> Reg -> String
bitCoerce String
v String
"S" NativeTy
from NativeTy
to Reg
x
doOp String
v (LZExt IntTy
ITNative (ITFixed NativeTy
to)) [Reg
x]
    = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_b" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (NativeTy -> Int
nativeTyWidth NativeTy
to) forall a. [a] -> [a] -> [a]
++ String
"const(vm, (uintptr_t)GETINT(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
"))"
doOp String
v (LZExt IntTy
ITChar (ITFixed NativeTy
to)) [Reg
x]
    = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> IntTy -> PrimFn
LZExt IntTy
ITNative (NativeTy -> IntTy
ITFixed NativeTy
to)) [Reg
x]
doOp String
v (LZExt (ITFixed NativeTy
from) IntTy
ITNative) [Reg
x]
    = String
v forall a. [a] -> [a] -> [a]
++ String
"MKINT((i_int)GETBITS" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (NativeTy -> Int
nativeTyWidth NativeTy
from) forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
"))"
doOp String
v (LZExt (ITFixed NativeTy
from) IntTy
ITChar) [Reg
x]
    = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> IntTy -> PrimFn
LZExt (NativeTy -> IntTy
ITFixed NativeTy
from) IntTy
ITNative) [Reg
x]
doOp String
v (LZExt (ITFixed NativeTy
from) IntTy
ITBig) [Reg
x]
    = String
v forall a. [a] -> [a] -> [a]
++ String
"MKBIGUI(vm, GETBITS" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (NativeTy -> Int
nativeTyWidth NativeTy
from) forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
"))"
doOp String
v (LZExt IntTy
ITNative IntTy
ITBig) [Reg
x]
    = String
v forall a. [a] -> [a] -> [a]
++ String
"MKBIGUI(vm, (uintptr_t)GETINT(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
"))"
doOp String
v (LZExt (ITFixed NativeTy
from) (ITFixed NativeTy
to)) [Reg
x]
    | NativeTy -> Int
nativeTyWidth NativeTy
from forall a. Ord a => a -> a -> Bool
< NativeTy -> Int
nativeTyWidth NativeTy
to = String -> String -> NativeTy -> NativeTy -> Reg -> String
bitCoerce String
v String
"Z" NativeTy
from NativeTy
to Reg
x
doOp String
v (LTrunc IntTy
ITNative (ITFixed NativeTy
to)) [Reg
x]
    = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_b" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (NativeTy -> Int
nativeTyWidth NativeTy
to) forall a. [a] -> [a] -> [a]
++ String
"const(vm, GETINT(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
"))"
doOp String
v (LTrunc IntTy
ITChar (ITFixed NativeTy
to)) [Reg
x]
    = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> IntTy -> PrimFn
LTrunc IntTy
ITNative (NativeTy -> IntTy
ITFixed NativeTy
to)) [Reg
x]
doOp String
v (LTrunc (ITFixed NativeTy
from) IntTy
ITNative) [Reg
x]
    = String
v forall a. [a] -> [a] -> [a]
++ String
"MKINT((i_int)GETBITS" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (NativeTy -> Int
nativeTyWidth NativeTy
from) forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
"))"
doOp String
v (LTrunc (ITFixed NativeTy
from) IntTy
ITChar) [Reg
x]
    = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> IntTy -> PrimFn
LTrunc (NativeTy -> IntTy
ITFixed NativeTy
from) IntTy
ITNative) [Reg
x]
doOp String
v (LTrunc IntTy
ITBig (ITFixed NativeTy
IT64)) [Reg
x]
    = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_b64const(vm, ISINT(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
") ? GETINT(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
") : idris_truncBigB64(GETMPZ(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
")))"
doOp String
v (LTrunc IntTy
ITBig (ITFixed NativeTy
to)) [Reg
x]
    = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_b" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (NativeTy -> Int
nativeTyWidth NativeTy
to) forall a. [a] -> [a] -> [a]
++ String
"const(vm, ISINT(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
") ? GETINT(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
") : mpz_get_ui(GETMPZ(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
")))"
doOp String
v (LTrunc (ITFixed NativeTy
from) (ITFixed NativeTy
to)) [Reg
x]
    | NativeTy -> Int
nativeTyWidth NativeTy
from forall a. Ord a => a -> a -> Bool
> NativeTy -> Int
nativeTyWidth NativeTy
to = String -> String -> NativeTy -> NativeTy -> Reg -> String
bitCoerce String
v String
"T" NativeTy
from NativeTy
to Reg
x

doOp String
v PrimFn
LFExp [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String -> String -> String
flUnOp String
"exp" (Reg -> String
creg Reg
x)
doOp String
v PrimFn
LFLog [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String -> String -> String
flUnOp String
"log" (Reg -> String
creg Reg
x)
doOp String
v PrimFn
LFSin [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String -> String -> String
flUnOp String
"sin" (Reg -> String
creg Reg
x)
doOp String
v PrimFn
LFCos [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String -> String -> String
flUnOp String
"cos" (Reg -> String
creg Reg
x)
doOp String
v PrimFn
LFTan [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String -> String -> String
flUnOp String
"tan" (Reg -> String
creg Reg
x)
doOp String
v PrimFn
LFASin [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String -> String -> String
flUnOp String
"asin" (Reg -> String
creg Reg
x)
doOp String
v PrimFn
LFACos [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String -> String -> String
flUnOp String
"acos" (Reg -> String
creg Reg
x)
doOp String
v PrimFn
LFATan [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String -> String -> String
flUnOp String
"atan" (Reg -> String
creg Reg
x)
doOp String
v PrimFn
LFSqrt [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String -> String -> String
flUnOp String
"sqrt" (Reg -> String
creg Reg
x)
doOp String
v PrimFn
LFFloor [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String -> String -> String
flUnOp String
"floor" (Reg -> String
creg Reg
x)
doOp String
v PrimFn
LFCeil [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String -> String -> String
flUnOp String
"ceil" (Reg -> String
creg Reg
x)
doOp String
v PrimFn
LFNegate [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String
"MKFLOAT(vm, -GETFLOAT(" forall a. [a] -> [a] -> [a]
++ (Reg -> String
creg Reg
x) forall a. [a] -> [a] -> [a]
++ String
"))"
doOp String
v PrimFn
LFATan2 [Reg
y, Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String
"MKFLOAT(vm, atan2(GETFLOAT(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
y forall a. [a] -> [a] -> [a]
++ String
"), GETFLOAT(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
")))"

-- String functions which don't need to know we're UTF8
doOp String
v PrimFn
LStrConcat [Reg
l,Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_concat(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v PrimFn
LStrLt [Reg
l,Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_strlt(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v PrimFn
LStrEq [Reg
l,Reg
r] = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_streq(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
l forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
r forall a. [a] -> [a] -> [a]
++ String
")"

doOp String
v PrimFn
LReadStr [Reg
_] = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_readStr(vm, stdin)"
doOp String
v PrimFn
LWriteStr [Reg
_,Reg
s]
             = String
v forall a. [a] -> [a] -> [a]
++ String
"MKINT((i_int)(idris_writeStr(stdout"
                 forall a. [a] -> [a] -> [a]
++ String
",GETSTR("
                 forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
s forall a. [a] -> [a] -> [a]
++ String
"))))"


-- String functions which need to know we're UTF8
doOp String
v PrimFn
LStrHead [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_strHead(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v PrimFn
LStrTail [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_strTail(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v PrimFn
LStrCons [Reg
x, Reg
y] = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_strCons(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
y forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v PrimFn
LStrIndex [Reg
x, Reg
y] = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_strIndex(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
y forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v PrimFn
LStrRev [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_strRev(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v PrimFn
LStrLen [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_strlen(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v PrimFn
LStrSubstr [Reg
x,Reg
y,Reg
z] = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_substr(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
y forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
z forall a. [a] -> [a] -> [a]
++ String
")"

doOp String
v PrimFn
LFork [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String
"MKPTR(vm, vmThread(vm, " forall a. [a] -> [a] -> [a]
++ Name -> String
cname (Int -> String -> Name
sMN Int
0 String
"EVAL") forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
"))"
doOp String
v PrimFn
LPar [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"
doOp String
v (LChInt IntTy
ITNative) [Reg]
args = String
v forall a. [a] -> [a] -> [a]
++ Reg -> String
creg (forall a. [a] -> a
last [Reg]
args)
doOp String
v (LChInt IntTy
ITChar) [Reg]
args = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> PrimFn
LChInt IntTy
ITNative) [Reg]
args
doOp String
v (LIntCh IntTy
ITNative) [Reg]
args = String
v forall a. [a] -> [a] -> [a]
++ Reg -> String
creg (forall a. [a] -> a
last [Reg]
args)
doOp String
v (LIntCh IntTy
ITChar) [Reg]
args = String -> PrimFn -> [Reg] -> String
doOp String
v (IntTy -> PrimFn
LIntCh IntTy
ITNative) [Reg]
args

doOp String
v PrimFn
LSystemInfo [Reg
x] = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_systemInfo(vm, " forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v PrimFn
LCrash [Reg
x] = String
"idris_crash(GETSTR(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
"))"
doOp String
v PrimFn
LNoOp [Reg]
args = String
v forall a. [a] -> [a] -> [a]
++ Reg -> String
creg (forall a. [a] -> a
last [Reg]
args)

-- Pointer primitives (declared as %extern in Builtins.idr)
doOp String
v (LExternal Name
rf) [Reg
_,Reg
x]
   | Name
rf forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"prim__readFile"
       = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_readStr(vm, GETPTR(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
"))"
doOp String
v (LExternal Name
rf) [Reg
_,Reg
len,Reg
x]
   | Name
rf forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"prim__readChars"
       = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_readChars(vm, GETINT(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
len forall a. [a] -> [a] -> [a]
++
                                String
"), GETPTR(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
"))"
doOp String
v (LExternal Name
wf) [Reg
_,Reg
x,Reg
s]
   | Name
wf forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"prim__writeFile"
       = String
v forall a. [a] -> [a] -> [a]
++ String
"MKINT((i_int)(idris_writeStr(GETPTR(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x
                              forall a. [a] -> [a] -> [a]
++ String
"),GETSTR("
                              forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
s forall a. [a] -> [a] -> [a]
++ String
"))))"
doOp String
v (LExternal Name
si) [] | Name
si forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"prim__stdin" = String
v forall a. [a] -> [a] -> [a]
++ String
"MKPTR(vm, stdin)"
doOp String
v (LExternal Name
so) [] | Name
so forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"prim__stdout" = String
v forall a. [a] -> [a] -> [a]
++ String
"MKPTR(vm, stdout)"
doOp String
v (LExternal Name
se) [] | Name
se forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"prim__stderr" = String
v forall a. [a] -> [a] -> [a]
++ String
"MKPTR(vm, stderr)"

doOp String
v (LExternal Name
vm) [Reg
_] | Name
vm forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"prim__vm" = String
v forall a. [a] -> [a] -> [a]
++ String
"MKPTR(vm, vm)"
doOp String
v (LExternal Name
nul) [] | Name
nul forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"prim__null" = String
v forall a. [a] -> [a] -> [a]
++ String
"MKPTR(vm, NULL)"
doOp String
v (LExternal Name
nul) [] | Name
nul forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"prim__managedNull" = String
v forall a. [a] -> [a] -> [a]
++ String
"MKPTR(vm, NULL)"
doOp String
v (LExternal Name
eqp) [Reg
x, Reg
y] | Name
eqp forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"prim__eqPtr"
    = String
v forall a. [a] -> [a] -> [a]
++ String
"MKINT((i_int)(GETPTR(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
") == GETPTR(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
y forall a. [a] -> [a] -> [a]
++ String
")))"
doOp String
v (LExternal Name
eqp) [Reg
x, Reg
y] | Name
eqp forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"prim__eqManagedPtr"
    = String
v forall a. [a] -> [a] -> [a]
++ String
"MKINT((i_int)(GETMPTR(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
") == GETMPTR(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
y forall a. [a] -> [a] -> [a]
++ String
")))"
doOp String
v (LExternal Name
rp) [Reg
p, Reg
i] | Name
rp forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"prim__registerPtr"
    = String
v forall a. [a] -> [a] -> [a]
++ String
"MKMPTR(vm, GETPTR(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p forall a. [a] -> [a] -> [a]
++ String
"), GETINT(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
i forall a. [a] -> [a] -> [a]
++ String
"))"
doOp String
v (LExternal Name
pk) [Reg
_, Reg
p, Reg
o] | Name
pk forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"prim__peek8"
    = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_peekB8(vm," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
o forall a. [a] -> [a] -> [a]
++String
")"
doOp String
v (LExternal Name
pk) [Reg
_, Reg
p, Reg
o, Reg
x] | Name
pk forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"prim__poke8"
    = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_pokeB8(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
o forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LExternal Name
pk) [Reg
_, Reg
p, Reg
o] | Name
pk forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"prim__peek16"
    = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_peekB16(vm," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
o forall a. [a] -> [a] -> [a]
++String
")"
doOp String
v (LExternal Name
pk) [Reg
_, Reg
p, Reg
o, Reg
x] | Name
pk forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"prim__poke16"
    = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_pokeB16(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
o forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LExternal Name
pk) [Reg
_, Reg
p, Reg
o] | Name
pk forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"prim__peek32"
    = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_peekB32(vm," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
o forall a. [a] -> [a] -> [a]
++String
")"
doOp String
v (LExternal Name
pk) [Reg
_, Reg
p, Reg
o, Reg
x] | Name
pk forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"prim__poke32"
    = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_pokeB32(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
o forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LExternal Name
pk) [Reg
_, Reg
p, Reg
o] | Name
pk forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"prim__peek64"
    = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_peekB64(vm," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
o forall a. [a] -> [a] -> [a]
++String
")"
doOp String
v (LExternal Name
pk) [Reg
_, Reg
p, Reg
o, Reg
x] | Name
pk forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"prim__poke64"
    = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_pokeB64(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
o forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LExternal Name
pk) [Reg
_, Reg
p, Reg
o] | Name
pk forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"prim__peekPtr"
    = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_peekPtr(vm," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
o forall a. [a] -> [a] -> [a]
++String
")"
doOp String
v (LExternal Name
pk) [Reg
_, Reg
p, Reg
o, Reg
x] | Name
pk forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"prim__pokePtr"
    = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_pokePtr(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
o forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LExternal Name
pk) [Reg
_, Reg
p, Reg
o, Reg
x] | Name
pk forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"prim__pokeDouble"
    = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_pokeDouble(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
o forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LExternal Name
pk) [Reg
_, Reg
p, Reg
o] | Name
pk forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"prim__peekDouble"
    = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_peekDouble(vm," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
o forall a. [a] -> [a] -> [a]
++String
")"
doOp String
v (LExternal Name
pk) [Reg
_, Reg
p, Reg
o, Reg
x] | Name
pk forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"prim__pokeSingle"
    = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_pokeSingle(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
o forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
x forall a. [a] -> [a] -> [a]
++ String
")"
doOp String
v (LExternal Name
pk) [Reg
_, Reg
p, Reg
o] | Name
pk forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"prim__peekSingle"
    = String
v forall a. [a] -> [a] -> [a]
++ String
"idris_peekSingle(vm," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
o forall a. [a] -> [a] -> [a]
++String
")"
doOp String
v (LExternal Name
pk) [] | Name
pk forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"prim__sizeofPtr"
    = String
v forall a. [a] -> [a] -> [a]
++ String
"MKINT(sizeof(void*))"
doOp String
v (LExternal Name
mpt) [Reg
p] | Name
mpt forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"prim__asPtr"
    = String
v forall a. [a] -> [a] -> [a]
++ String
"MKPTR(vm, GETMPTR("forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p forall a. [a] -> [a] -> [a]
++String
"))"
doOp String
v (LExternal Name
offs) [Reg
p, Reg
n] | Name
offs forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"prim__ptrOffset"
    = String
v forall a. [a] -> [a] -> [a]
++ String
"MKPTR(vm, (void *)((char *)GETPTR(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
p forall a. [a] -> [a] -> [a]
++ String
") + GETINT(" forall a. [a] -> [a] -> [a]
++ Reg -> String
creg Reg
n forall a. [a] -> [a] -> [a]
++ String
")))"
doOp String
_ PrimFn
op [Reg]
args = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"doOp not implemented (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (PrimFn
op, [Reg]
args) forall a. [a] -> [a] -> [a]
++ String
")"


flUnOp :: String -> String -> String
flUnOp :: String -> String -> String
flUnOp String
name String
val = String
"MKFLOAT(vm, " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"(GETFLOAT(" forall a. [a] -> [a] -> [a]
++ String
val forall a. [a] -> [a] -> [a]
++ String
")))"

-------------------- Interface file generation

-- First, the wrappers in the C file

ifaceC :: Export -> String
ifaceC :: Export -> String
ifaceC (ExportData FDesc
n) = String
"typedef VAL " forall a. [a] -> [a] -> [a]
++ FDesc -> String
cdesc FDesc
n forall a. [a] -> [a] -> [a]
++ String
";\n"
ifaceC (ExportFun Name
n FDesc
cn FDesc
ret [FDesc]
args)
   = FDesc -> String
ctype FDesc
ret forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ FDesc -> String
cdesc FDesc
cn forall a. [a] -> [a] -> [a]
++
         String
"(VM* vm" forall a. [a] -> [a] -> [a]
++ [(String, FDesc)] -> String
showArgs (forall a b. [a] -> [b] -> [(a, b)]
zip [String]
argNames [FDesc]
args) forall a. [a] -> [a] -> [a]
++ String
") {\n"
       forall a. [a] -> [a] -> [a]
++ Name -> [(String, FDesc)] -> FDesc -> String
mkBody Name
n (forall a b. [a] -> [b] -> [(a, b)]
zip [String]
argNames [FDesc]
args) FDesc
ret forall a. [a] -> [a] -> [a]
++ String
"}\n\n"
  where showArgs :: [(String, FDesc)] -> String
showArgs [] = String
""
        showArgs ((String
n, FDesc
t) : [(String, FDesc)]
ts) = String
", " forall a. [a] -> [a] -> [a]
++ FDesc -> String
ctype FDesc
t forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
n forall a. [a] -> [a] -> [a]
++
                                 [(String, FDesc)] -> String
showArgs [(String, FDesc)]
ts

        argNames :: [String]
argNames = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. [a] -> [a] -> [a]
(++) (forall a. a -> [a]
repeat String
"arg") (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [Integer
0..])

mkBody :: Name -> [(String, FDesc)] -> FDesc -> String
mkBody Name
n [(String, FDesc)]
as_in FDesc
t
     = Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"INITFRAME;\n" forall a. [a] -> [a] -> [a]
++
       Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"RESERVE(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Ord a => a -> a -> a
max (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, FDesc)]
as) Int
3) forall a. [a] -> [a] -> [a]
++ String
");\n" forall a. [a] -> [a] -> [a]
++
       forall {t}. (Show t, Num t) => t -> [(String, FDesc)] -> String
push Integer
0 [(String, FDesc)]
as forall a. [a] -> [a] -> [a]
++ forall {p}. p -> String
call Name
n forall a. [a] -> [a] -> [a]
++ FDesc -> String
retval FDesc
t
  where
    as :: [(String, FDesc)]
as = case FDesc
t of
              FIO FDesc
t -> [(String, FDesc)]
as_in forall a. [a] -> [a] -> [a]
++ [(String
"NULL", FDesc
FUnknown)] -- add world token
              FDesc
_ -> [(String, FDesc)]
as_in
    push :: t -> [(String, FDesc)] -> String
push t
i [] = String
""
    push t
i ((String
n, FDesc
t) : [(String, FDesc)]
ts) = Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ FType -> String -> String -> String
c_irts (FDesc -> FType
toFType FDesc
t)
                                  (String
"TOP(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
i forall a. [a] -> [a] -> [a]
++ String
") = ") String
n
                               forall a. [a] -> [a] -> [a]
++ String
";\n" forall a. [a] -> [a] -> [a]
++ t -> [(String, FDesc)] -> String
push (t
i forall a. Num a => a -> a -> a
+ t
1) [(String, FDesc)]
ts

    call :: p -> String
call p
_ = Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"STOREOLD;\n" forall a. [a] -> [a] -> [a]
++
             Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"BASETOP(0);\n" forall a. [a] -> [a] -> [a]
++
             Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"ADDTOP(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, FDesc)]
as) forall a. [a] -> [a] -> [a]
++ String
");\n" forall a. [a] -> [a] -> [a]
++
             Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"CALL(" forall a. [a] -> [a] -> [a]
++ Name -> String
cname Name
n forall a. [a] -> [a] -> [a]
++ String
");\n"

    retval :: FDesc -> String
retval (FIO FDesc
t) = FDesc -> String
retval FDesc
t
    retval FDesc
t = Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"return " forall a. [a] -> [a] -> [a]
++ FType -> String -> String
irts_c (FDesc -> FType
toFType FDesc
t) String
"RVAL" forall a. [a] -> [a] -> [a]
++ String
";\n"

ctype :: FDesc -> String
ctype (FCon Name
c)
  | Name
c forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_Str" = String
"char*"
  | Name
c forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_Float" = String
"float"
  | Name
c forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_Ptr" = String
"void*"
  | Name
c forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_MPtr" = String
"void*"
  | Name
c forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_Unit" = String
"void"
ctype (FApp Name
c [FDesc
_,FDesc
ity])
  | Name
c forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_IntT" = FDesc -> String
carith FDesc
ity
ctype (FApp Name
c [FDesc
_])
  | Name
c forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_Any" = String
"VAL"
ctype (FStr String
s) = String
s
ctype FDesc
FUnknown = String
"void*"
ctype (FIO FDesc
t) = FDesc -> String
ctype FDesc
t
ctype FDesc
t = forall a. HasCallStack => String -> a
error String
"Can't happen: Not a valid interface type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FDesc
t

carith :: FDesc -> String
carith (FCon Name
i)
  | Name
i forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_IntChar" = String
"char"
  | Name
i forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_IntNative" = String
"int"
  | Name
i forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_IntBits8" = String
"uint8_t"
  | Name
i forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_IntBits16" = String
"uint16_t"
  | Name
i forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_IntBits32" = String
"uint32_t"
  | Name
i forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_IntBits64" = String
"uint64_t"
carith FDesc
t = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Can't happen: Not an exportable arithmetic type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FDesc
t

cdesc :: FDesc -> String
cdesc (FStr String
s) = String
s
cdesc FDesc
s = forall a. HasCallStack => String -> a
error String
"Can't happen: Not a valid C name"

-- Then, the header files

codegenH :: [ExportIFace] -> IO ()
codegenH :: [ExportIFace] -> IO ()
codegenH [ExportIFace]
es = 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 Name
ffic String
hdr [Export]
exps)
   | Name
ffic forall a. Eq a => a -> a -> Bool
== Name -> [String] -> Name
sNS (String -> Name
sUN String
"FFI_C") [String
"FFI_C"]
       = do let hfile :: String
hfile = String
"#ifndef " forall a. [a] -> [a] -> [a]
++ String -> String
hdr_guard String
hdr forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++
                        String
"#define " forall a. [a] -> [a] -> [a]
++ String -> String
hdr_guard String
hdr forall a. [a] -> [a] -> [a]
++ String
"\n\n" forall a. [a] -> [a] -> [a]
++
                        String
"#include <idris_rts.h>\n\n" forall a. [a] -> [a] -> [a]
++
                        forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Export -> String
hdr_export [Export]
exps forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++
                        String
"#endif\n\n"
            String -> String -> IO ()
writeFile String
hdr String
hfile
   | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()

hdr_guard :: String -> String
hdr_guard String
x = String
"__" forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
hchar String
x
  where hchar :: Char -> Char
hchar Char
x | Char -> Bool
isAlphaNum Char
x = Char -> Char
toUpper Char
x
        hchar Char
_ = Char
'_'

hdr_export :: Export -> String
hdr_export :: Export -> String
hdr_export (ExportData FDesc
n) = String
"typedef VAL " forall a. [a] -> [a] -> [a]
++ FDesc -> String
cdesc FDesc
n forall a. [a] -> [a] -> [a]
++ String
";\n"
hdr_export (ExportFun Name
n FDesc
cn FDesc
ret [FDesc]
args)
   = FDesc -> String
ctype FDesc
ret forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ FDesc -> String
cdesc FDesc
cn forall a. [a] -> [a] -> [a]
++
         String
"(VM* vm" forall a. [a] -> [a] -> [a]
++ [(String, FDesc)] -> String
showArgs (forall a b. [a] -> [b] -> [(a, b)]
zip [String]
argNames [FDesc]
args) forall a. [a] -> [a] -> [a]
++ String
");\n"
  where showArgs :: [(String, FDesc)] -> String
showArgs [] = String
""
        showArgs ((String
n, FDesc
t) : [(String, FDesc)]
ts) = String
", " forall a. [a] -> [a] -> [a]
++ FDesc -> String
ctype FDesc
t forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
n forall a. [a] -> [a] -> [a]
++
                                 [(String, FDesc)] -> String
showArgs [(String, FDesc)]
ts

        argNames :: [String]
argNames = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. [a] -> [a] -> [a]
(++) (forall a. a -> [a]
repeat String
"arg") (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [Integer
0..])

------------------ Callback wrapper generation ----------------
-- Generate callback wrappers and a function to select the
-- correct wrapper function to pass.
-- TODO: This is limited to functions that are specified in
-- the foreign call. Otherwise we would have to generate wrappers for all
-- functions with correct arity or do flow analysis
-- to find all possible inputs to the foreign call.
genWrappers :: [(Name, [BC])] -> String
genWrappers :: [(Name, [BC])] -> String
genWrappers [(Name, [BC])]
bcs = let
                    tags :: [(FDesc, Int)]
tags = forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (\(FDesc, Int)
x (FDesc, Int)
y -> forall a b. (a, b) -> b
snd (FDesc, Int)
x forall a. Eq a => a -> a -> Bool
== forall a b. (a, b) -> b
snd (FDesc, Int)
y)  forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([BC] -> [(FDesc, Int)]
getCallback forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Name, [BC])]
bcs
                  in
                    case [(FDesc, Int)]
tags of
                        [] -> String
""
                        [(FDesc, Int)]
t -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (FDesc, Int) -> String
genWrapper [(FDesc, Int)]
t forall a. [a] -> [a] -> [a]
++ [(FDesc, Int)] -> String
genDispatcher [(FDesc, Int)]
t

genDispatcher :: [(FDesc, Int)] -> String
genDispatcher :: [(FDesc, Int)] -> String
genDispatcher [(FDesc, Int)]
tags = String
"void* _idris_get_wrapper(VAL con)\n" forall a. [a] -> [a] -> [a]
++
                     String
"{\n" forall a. [a] -> [a] -> [a]
++
                     Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"switch(TAG(con)) {\n" forall a. [a] -> [a] -> [a]
++
                     forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a}. (a, Int) -> String
makeSwitch [(FDesc, Int)]
tags forall a. [a] -> [a] -> [a]
++
                     Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"}\n" forall a. [a] -> [a] -> [a]
++
                     Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"fprintf(stderr, \"No wrapper for callback\");\n" forall a. [a] -> [a] -> [a]
++
                     Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"exit(-1);\n" forall a. [a] -> [a] -> [a]
++
                     String
"}\n\n"
                        where
                            makeSwitch :: (a, Int) -> String
makeSwitch (a
_, Int
tag) =
                                    Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"case " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
tag forall a. [a] -> [a] -> [a]
++ String
":\n" forall a. [a] -> [a] -> [a]
++
                                    Int -> String
indent Int
2 forall a. [a] -> [a] -> [a]
++ String
"return (void*) &" forall a. [a] -> [a] -> [a]
++ Int -> String
wrapperName Int
tag forall a. [a] -> [a] -> [a]
++ String
";\n"

genWrapper :: (FDesc, Int) -> String
genWrapper :: (FDesc, Int) -> String
genWrapper (FDesc
desc, Int
tag) | (FDesc -> FType
toFType FDesc
desc) forall a. Eq a => a -> a -> Bool
== FType
FFunctionIO =
    forall a. HasCallStack => String -> a
error String
"Cannot create C callbacks for IO functions, wrap them with unsafePerformIO.\n"
genWrapper (FDesc
desc, Int
tag) =  String
ret forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ Int -> String
wrapperName Int
tag forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++
                          forall {a} {b}. Show a => [((String, b), a)] -> String
renderArgs [((String, FDesc), Integer)]
argList forall a. [a] -> [a] -> [a]
++String
")\n"  forall a. [a] -> [a] -> [a]
++
                          String
"{\n" forall a. [a] -> [a] -> [a]
++
                          (if String
ret forall a. Eq a => a -> a -> Bool
/= String
"void" then Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
ret forall a. [a] -> [a] -> [a]
++ String
" ret;\n" else String
"") forall a. [a] -> [a] -> [a]
++
                          Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"VM* vm = get_vm();\n" forall a. [a] -> [a] -> [a]
++
                          Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"if (vm == NULL) {\n" forall a. [a] -> [a] -> [a]
++
                          Int -> String
indent Int
2 forall a. [a] -> [a] -> [a]
++ String
"vm = idris_vm();\n" forall a. [a] -> [a] -> [a]
++
                          Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"}\n" forall a. [a] -> [a] -> [a]
++
                          Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"INITFRAME;\n" forall a. [a] -> [a] -> [a]
++
                          Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"RESERVE(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Int
len forall a. Num a => a -> a -> a
+ Int
1) forall a. [a] -> [a] -> [a]
++ String
");\n" forall a. [a] -> [a] -> [a]
++
                          Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"allocCon(REG1, vm, " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
tag forall a. [a] -> [a] -> [a]
++ String
",0 , 0);\n" forall a. [a] -> [a] -> [a]
++
                          Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"TOP(0) = REG1;\n" forall a. [a] -> [a] -> [a]
++
                          forall {a} {a}. Show a => [((a, FDesc), a)] -> String
applyArgs [((String, FDesc), Integer)]
argList forall a. [a] -> [a] -> [a]
++
                          if String
ret forall a. Eq a => a -> a -> Bool
/= String
"void"
                            then Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"ret = " forall a. [a] -> [a] -> [a]
++ FType -> String -> String
irts_c (FDesc -> FType
toFType FDesc
ft) String
"RVAL" forall a. [a] -> [a] -> [a]
++ String
";\n"
                                          forall a. [a] -> [a] -> [a]
++ Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"return ret;\n}\n\n"
                            else String
"}\n\n"
                    where
                        (String
ret, FDesc
ft) = FDesc -> (String, FDesc)
rty FDesc
desc
                        argList :: [((String, FDesc), Integer)]
argList = forall a b. [a] -> [b] -> [(a, b)]
zip (FDesc -> [(String, FDesc)]
args FDesc
desc) [Integer
0..]
                        len :: Int
len = forall (t :: * -> *) a. Foldable t => t a -> Int
length [((String, FDesc), Integer)]
argList

                        applyArgs :: [((a, FDesc), a)] -> String
applyArgs (((a, FDesc), a)
x:((a, FDesc), a)
y:[((a, FDesc), a)]
xs) = forall {t} {a} {a}.
(Show t, Show a, Num t) =>
t -> [((a, FDesc), a)] -> String
push Integer
1 [((a, FDesc), a)
x] forall a. [a] -> [a] -> [a]
++
                                            Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"STOREOLD;\n" forall a. [a] -> [a] -> [a]
++
                                            Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"BASETOP(0);\n" forall a. [a] -> [a] -> [a]
++
                                            Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"ADDTOP(2);\n" forall a. [a] -> [a] -> [a]
++
                                            Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"CALL(_idris__123_APPLY_95_0_125_);\n" forall a. [a] -> [a] -> [a]
++
                                            Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"TOP(0)=REG1;\n" forall a. [a] -> [a] -> [a]
++
                                            [((a, FDesc), a)] -> String
applyArgs (((a, FDesc), a)
yforall a. a -> [a] -> [a]
:[((a, FDesc), a)]
xs)
                        applyArgs [((a, FDesc), a)]
x = forall {t} {a} {a}.
(Show t, Show a, Num t) =>
t -> [((a, FDesc), a)] -> String
push Integer
1 [((a, FDesc), a)]
x forall a. [a] -> [a] -> [a]
++
                                      Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"STOREOLD;\n" forall a. [a] -> [a] -> [a]
++
                                      Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"BASETOP(0);\n" forall a. [a] -> [a] -> [a]
++
                                      Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"ADDTOP(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [((a, FDesc), a)]
x forall a. Num a => a -> a -> a
+ Int
1) forall a. [a] -> [a] -> [a]
++ String
");\n" forall a. [a] -> [a] -> [a]
++
                                      Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ String
"CALL(_idris__123_APPLY_95_0_125_);\n"
                        renderArgs :: [((String, b), a)] -> String
renderArgs [] = String
"void"
                        renderArgs [((String
s, b
_), a
n)] = String
s forall a. [a] -> [a] -> [a]
++ String
" a" forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> String
show a
n)
                        renderArgs (((String
s, b
_), a
n):[((String, b), a)]
xs) = String
s forall a. [a] -> [a] -> [a]
++ String
" a" forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> String
show a
n) forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++
                                    [((String, b), a)] -> String
renderArgs [((String, b), a)]
xs
                        rty :: FDesc -> (String, FDesc)
rty (FApp Name
c [FDesc
_,FDesc
ty])
                            | Name
c forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_FnBase" = (FDesc -> String
ctype FDesc
ty, FDesc
ty)
                            | Name
c forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_FnIO" = (FDesc -> String
ctype FDesc
ty, FDesc
ty)
                            | Name
c forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_FnT" = FDesc -> (String, FDesc)
rty FDesc
ty
                        rty (FApp Name
c [FDesc
_,FDesc
_,FDesc
ty,FDesc
fn])
                            | Name
c forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_Fn" = FDesc -> (String, FDesc)
rty FDesc
fn
                        rty FDesc
x = (String
"", FDesc
x)
                        args :: FDesc -> [(String, FDesc)]
args (FApp Name
c [FDesc
_,FDesc
ty])
                            | Name
c forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_FnBase" = []
                            | Name
c forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_FnIO" = []
                            | Name
c forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_FnT" = FDesc -> [(String, FDesc)]
args FDesc
ty
                        args (FApp Name
c [FDesc
_,FDesc
_,FDesc
ty,FDesc
fn])
                            | FDesc -> FType
toFType FDesc
ty forall a. Eq a => a -> a -> Bool
== FType
FUnit = []
                            | Name
c forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"C_Fn" = (FDesc -> String
ctype FDesc
ty, FDesc
ty) forall a. a -> [a] -> [a]
: FDesc -> [(String, FDesc)]
args FDesc
fn
                        args FDesc
_ = []
                        push :: t -> [((a, FDesc), a)] -> String
push t
i [] = String
""
                        push t
i (((a
c, FDesc
t), a
n) : [((a, FDesc), a)]
ts) = Int -> String
indent Int
1 forall a. [a] -> [a] -> [a]
++ FType -> String -> String -> String
c_irts (FDesc -> FType
toFType FDesc
t)
                                      (String
"TOP(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
i forall a. [a] -> [a] -> [a]
++ String
") = ") (String
"a" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
n)
                                   forall a. [a] -> [a] -> [a]
++ String
";\n" forall a. [a] -> [a] -> [a]
++ t -> [((a, FDesc), a)] -> String
push (t
i forall a. Num a => a -> a -> a
+ t
1) [((a, FDesc), a)]
ts

wrapperName :: Int -> String
wrapperName :: Int -> String
wrapperName Int
tag = String
"_idris_wrapper_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
tag

getCallback :: [BC] -> [(FDesc, Int)]
getCallback :: [BC] -> [(FDesc, Int)]
getCallback [BC]
bc = [BC] -> [(FDesc, Int)]
getCallback' (forall a. [a] -> [a]
reverse [BC]
bc)
    where
        getCallback' :: [BC] -> [(FDesc, Int)]
getCallback' (BC
x:[BC]
xs) = case BC -> [(FDesc, Reg)]
hasCallback BC
x of
                                [] -> [BC] -> [(FDesc, Int)]
getCallback' [BC]
xs
                                [(FDesc, Reg)]
cbs -> case forall {a}. [(a, Reg)] -> [BC] -> [(a, Int)]
findCons [(FDesc, Reg)]
cbs [BC]
xs of
                                        [] -> forall a. HasCallStack => String -> a
error String
"Idris function couldn't be wrapped."
                                        [(FDesc, Int)]
x -> [(FDesc, Int)]
x
        getCallback' [] = []
        findCons :: [(a, Reg)] -> [BC] -> [(a, Int)]
findCons ((a, Reg)
c:[(a, Reg)]
cs) [BC]
xs = forall {a}. (a, Reg) -> [BC] -> [(a, Int)]
findCon (a, Reg)
c [BC]
xs forall a. [a] -> [a] -> [a]
++ [(a, Reg)] -> [BC] -> [(a, Int)]
findCons [(a, Reg)]
cs [BC]
xs
        findCons [] [BC]
_ = []
        findCon :: (a, Reg) -> [BC] -> [(a, Int)]
findCon (a, Reg)
c ((MKCON Reg
l Maybe Reg
loc Int
tag [Reg]
args):[BC]
xs) | forall a b. (a, b) -> b
snd (a, Reg)
c forall a. Eq a => a -> a -> Bool
== Reg
l =
            if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Reg]
args
                then [(forall a b. (a, b) -> a
fst (a, Reg)
c, Int
tag)]
                else forall a. HasCallStack => String -> a
error String
"Can't wrap a closure as callback."
        findCon (a, Reg)
c (BC
_:[BC]
xs) = (a, Reg) -> [BC] -> [(a, Int)]
findCon (a, Reg)
c [BC]
xs
        findCon (a, Reg)
c [] = []

hasCallback :: BC -> [(FDesc, Reg)]
hasCallback :: BC -> [(FDesc, Reg)]
hasCallback (FOREIGNCALL Reg
l FDesc
rty (FStr String
fn) [(FDesc, Reg)]
args) = forall a. (a -> Bool) -> [a] -> [a]
filter forall {b}. (FDesc, b) -> Bool
isFn [(FDesc, Reg)]
args
    where
        isFn :: (FDesc, b) -> Bool
isFn (FDesc
desc,b
_) = case FDesc -> FType
toFType FDesc
desc of
                            FType
FFunction -> Bool
True
                            FType
FFunctionIO -> Bool
True
                            FType
_ -> Bool
False
hasCallback BC
_ = []