{-# LANGUAGE
  TemplateHaskell
  #-}
module LLVM.Internal.FFI.Cleanup where

import LLVM.Prelude

import Language.Haskell.TH
import Data.Sequence as Seq

import Foreign.C
import Foreign.Ptr

import LLVM.Internal.FFI.LLVMCTypes
import qualified LLVM.Internal.FFI.PtrHierarchy as FFI

import qualified LLVM.AST.IntegerPredicate as A (IntegerPredicate) 
import qualified LLVM.AST.FloatingPointPredicate as A (FloatingPointPredicate) 
import qualified LLVM.AST.Constant as A.C (Constant)
import qualified LLVM.AST.Operand as A (Operand)
import qualified LLVM.AST.Type as A (Type)
import qualified LLVM.AST.Instruction as A (FastMathFlags)

foreignDecl :: String -> String -> [TypeQ] -> TypeQ -> DecsQ
foreignDecl :: String -> String -> [TypeQ] -> TypeQ -> DecsQ
foreignDecl cName :: String
cName hName :: String
hName argTypeQs :: [TypeQ]
argTypeQs returnTypeQ :: TypeQ
returnTypeQ = do
  let retTyQ :: TypeQ
retTyQ = TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT ''IO) TypeQ
returnTypeQ
      foreignDecl' :: String -> t TypeQ -> DecQ
foreignDecl' hName :: String
hName argTypeQs :: t TypeQ
argTypeQs =
        Callconv -> Safety -> String -> Name -> TypeQ -> DecQ
forImpD Callconv
cCall Safety
unsafe String
cName (String -> Name
mkName String
hName) 
                  ((TypeQ -> TypeQ -> TypeQ) -> TypeQ -> t TypeQ -> TypeQ
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a :: TypeQ
a b :: TypeQ
b -> TypeQ -> TypeQ -> TypeQ
appT (TypeQ -> TypeQ -> TypeQ
appT TypeQ
arrowT TypeQ
a) TypeQ
b) TypeQ
retTyQ t TypeQ
argTypeQs)
      splitTuples :: [Type] -> Q ([Type], [Pat], [Exp])
      splitTuples :: [Type] -> Q ([Type], [Pat], [Exp])
splitTuples ts :: [Type]
ts = do
        let f :: Type -> Q (Seq Type, Pat, Seq Exp)
            f :: Type -> Q (Seq Type, Pat, Seq Exp)
f x :: Type
x@(AppT _ _) = Q (Seq Type, Pat, Seq Exp)
-> (Q (Seq Type, Seq Pat, Seq Exp) -> Q (Seq Type, Pat, Seq Exp))
-> Maybe (Q (Seq Type, Seq Pat, Seq Exp))
-> Q (Seq Type, Pat, Seq Exp)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Type -> Q (Seq Type, Pat, Seq Exp)
d Type
x) (\q :: Q (Seq Type, Seq Pat, Seq Exp)
q -> Q (Seq Type, Seq Pat, Seq Exp)
q Q (Seq Type, Seq Pat, Seq Exp)
-> ((Seq Type, Seq Pat, Seq Exp) -> Q (Seq Type, Pat, Seq Exp))
-> Q (Seq Type, Pat, Seq Exp)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(ts :: Seq Type
ts, ps :: Seq Pat
ps, es :: Seq Exp
es) -> (Seq Type, Pat, Seq Exp) -> Q (Seq Type, Pat, Seq Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Seq Type
ts, [Pat] -> Pat
TupP (Seq Pat -> [Pat]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Pat
ps), Seq Exp
es)) (Int -> Type -> Maybe (Q (Seq Type, Seq Pat, Seq Exp))
g 0 Type
x)
            f x :: Type
x = Type -> Q (Seq Type, Pat, Seq Exp)
d Type
x
            g :: Int -> Type -> Maybe (Q (Seq Type, Seq Pat, Seq Exp))
            g :: Int -> Type -> Maybe (Q (Seq Type, Seq Pat, Seq Exp))
g n :: Int
n (TupleT m :: Int
m) | Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n = Q (Seq Type, Seq Pat, Seq Exp)
-> Maybe (Q (Seq Type, Seq Pat, Seq Exp))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Seq Type, Seq Pat, Seq Exp) -> Q (Seq Type, Seq Pat, Seq Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Seq Type
forall a. Seq a
Seq.empty, Seq Pat
forall a. Seq a
Seq.empty, Seq Exp
forall a. Seq a
Seq.empty))
            g n :: Int
n (AppT a :: Type
a b :: Type
b) = do
              Q (Seq Type, Seq Pat, Seq Exp)
k <- Int -> Type -> Maybe (Q (Seq Type, Seq Pat, Seq Exp))
g (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) Type
a
              Q (Seq Type, Seq Pat, Seq Exp)
-> Maybe (Q (Seq Type, Seq Pat, Seq Exp))
forall (m :: * -> *) a. Monad m => a -> m a
return (Q (Seq Type, Seq Pat, Seq Exp)
 -> Maybe (Q (Seq Type, Seq Pat, Seq Exp)))
-> Q (Seq Type, Seq Pat, Seq Exp)
-> Maybe (Q (Seq Type, Seq Pat, Seq Exp))
forall a b. (a -> b) -> a -> b
$ do
                (ts :: Seq Type
ts, ps :: Seq Pat
ps, es :: Seq Exp
es) <- Q (Seq Type, Seq Pat, Seq Exp)
k
                (ts' :: Seq Type
ts', p' :: Pat
p', es' :: Seq Exp
es') <- Type -> Q (Seq Type, Pat, Seq Exp)
f Type
b
                (Seq Type, Seq Pat, Seq Exp) -> Q (Seq Type, Seq Pat, Seq Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Seq Type
ts Seq Type -> Seq Type -> Seq Type
forall a. Seq a -> Seq a -> Seq a
>< Seq Type
ts', Seq Pat
ps Seq Pat -> Pat -> Seq Pat
forall a. Seq a -> a -> Seq a
|> Pat
p', Seq Exp
es Seq Exp -> Seq Exp -> Seq Exp
forall a. Seq a -> Seq a -> Seq a
>< Seq Exp
es')
            g _ _ = Maybe (Q (Seq Type, Seq Pat, Seq Exp))
forall a. Maybe a
Nothing
            d :: Type -> Q (Seq Type, Pat, Seq Exp)
            d :: Type -> Q (Seq Type, Pat, Seq Exp)
d x :: Type
x = do
              Name
n <- String -> Q Name
newName "v"
              (Seq Type, Pat, Seq Exp) -> Q (Seq Type, Pat, Seq Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Seq Type
forall a. a -> Seq a
Seq.singleton Type
x, Name -> Pat
VarP Name
n, Exp -> Seq Exp
forall a. a -> Seq a
Seq.singleton (Name -> Exp
VarE Name
n))
            seqsToList :: [Seq a] -> [a]
            seqsToList :: [Seq a] -> [a]
seqsToList = Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq a -> [a]) -> ([Seq a] -> Seq a) -> [Seq a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Seq a -> Seq a -> Seq a) -> Seq a -> [Seq a] -> Seq a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Seq a -> Seq a -> Seq a
forall a. Seq a -> Seq a -> Seq a
(><) Seq a
forall a. Seq a
Seq.empty
                
        (tss :: [Seq Type]
tss, ps :: [Pat]
ps, ess :: [Seq Exp]
ess) <- ([(Seq Type, Pat, Seq Exp)] -> ([Seq Type], [Pat], [Seq Exp]))
-> Q [(Seq Type, Pat, Seq Exp)] -> Q ([Seq Type], [Pat], [Seq Exp])
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [(Seq Type, Pat, Seq Exp)] -> ([Seq Type], [Pat], [Seq Exp])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 (Q [(Seq Type, Pat, Seq Exp)] -> Q ([Seq Type], [Pat], [Seq Exp]))
-> ([Type] -> Q [(Seq Type, Pat, Seq Exp)])
-> [Type]
-> Q ([Seq Type], [Pat], [Seq Exp])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Q (Seq Type, Pat, Seq Exp))
-> [Type] -> Q [(Seq Type, Pat, Seq Exp)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q (Seq Type, Pat, Seq Exp)
f ([Type] -> Q ([Seq Type], [Pat], [Seq Exp]))
-> [Type] -> Q ([Seq Type], [Pat], [Seq Exp])
forall a b. (a -> b) -> a -> b
$ [Type]
ts
        ([Type], [Pat], [Exp]) -> Q ([Type], [Pat], [Exp])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Seq Type] -> [Type]
forall a. [Seq a] -> [a]
seqsToList [Seq Type]
tss, [Pat]
ps, [Seq Exp] -> [Exp]
forall a. [Seq a] -> [a]
seqsToList [Seq Exp]
ess)

                                
  [Type]
argTypes <- [TypeQ] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [TypeQ]
argTypeQs
  (ts :: [Type]
ts, ps :: [Pat]
ps, es :: [Exp]
es) <- [Type] -> Q ([Type], [Pat], [Exp])
splitTuples [Type]
argTypes
  let phName :: String
phName = String
hName String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'"
  [DecQ] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [
    String -> [TypeQ] -> DecQ
forall (t :: * -> *). Foldable t => String -> t TypeQ -> DecQ
foreignDecl' String
phName ((Type -> TypeQ) -> [Type] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return [Type]
ts),
    Name -> TypeQ -> DecQ
sigD (String -> Name
mkName String
hName) ((TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\argT :: TypeQ
argT retT :: TypeQ
retT -> TypeQ -> TypeQ -> TypeQ
appT (TypeQ -> TypeQ -> TypeQ
appT TypeQ
arrowT TypeQ
argT) TypeQ
retT) TypeQ
retTyQ [TypeQ]
argTypeQs),
    Name -> [ClauseQ] -> DecQ
funD (String -> Name
mkName String
hName) [
     [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause ((Pat -> PatQ) -> [Pat] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Pat -> PatQ
forall (m :: * -> *) a. Monad m => a -> m a
return [Pat]
ps) (ExpQ -> BodyQ
normalB ((ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (String -> Name
mkName String
phName)) ((Exp -> ExpQ) -> [Exp] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return [Exp]
es))) []
    ]
   ]

-- | The LLVM C-API for instructions with boolean flags (e.g. nsw) and is weak, so they get
-- separated out for different handling. This check is an accurate but crude test for whether
-- an instruction needs such handling.
hasFlags :: [Type] -> Bool
hasFlags :: [Type] -> Bool
hasFlags = (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
ConT ''Bool)

typeMapping :: Type -> TypeQ
typeMapping :: Type -> TypeQ
typeMapping t :: Type
t = case Type
t of
  ConT h :: Name
h | Name
h Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Bool -> [t| LLVMBool |]
         | Name
h Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Int32 -> [t| CInt |]
         | Name
h Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Word32 -> [t| CUInt |]
         | Name
h Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''String -> [t| CString |]
         | Name
h Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''A.Operand -> [t| Ptr FFI.Value |]
         | Name
h Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''A.Type -> [t| Ptr FFI.Type |]
         | Name
h Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''A.C.Constant -> [t| Ptr FFI.Constant |]
         | Name
h Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''A.FloatingPointPredicate -> [t| FCmpPredicate |]
         | Name
h Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''A.IntegerPredicate -> [t| ICmpPredicate |]
         | Name
h Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''A.FastMathFlags -> [t| FastMathFlags |]
  AppT ListT x :: Type
x -> (TypeQ -> TypeQ -> TypeQ) -> [TypeQ] -> TypeQ
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 TypeQ -> TypeQ -> TypeQ
appT [Int -> TypeQ
tupleT 2, [t| CUInt |], TypeQ -> TypeQ -> TypeQ
appT [t| Ptr |] (Type -> TypeQ
typeMapping Type
x)]
  x :: Type
x -> String -> TypeQ
forall a. HasCallStack => String -> a
error (String -> TypeQ) -> String -> TypeQ
forall a b. (a -> b) -> a -> b
$ "type not handled in Cleanup typeMapping: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
x