{-# 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 cName hName argTypeQs returnTypeQ = do let retTyQ = appT (conT ''IO) returnTypeQ foreignDecl' hName argTypeQs = forImpD cCall unsafe cName (mkName hName) (foldr (\a b -> appT (appT arrowT a) b) retTyQ argTypeQs) splitTuples :: [Type] -> Q ([Type], [Pat], [Exp]) splitTuples ts = do let f :: Type -> Q (Seq Type, Pat, Seq Exp) f x@(AppT _ _) = maybe (d x) (\q -> q >>= \(ts, ps, es) -> return (ts, TupP (toList ps), es)) (g 0 x) f x = d x g :: Int -> Type -> Maybe (Q (Seq Type, Seq Pat, Seq Exp)) g n (TupleT m) | m == n = return (return (Seq.empty, Seq.empty, Seq.empty)) g n (AppT a b) = do k <- g (n+1) a return $ do (ts, ps, es) <- k (ts', p', es') <- f b return (ts >< ts', ps |> p', es >< es') g _ _ = Nothing d :: Type -> Q (Seq Type, Pat, Seq Exp) d x = do n <- newName "v" return (Seq.singleton x, VarP n, Seq.singleton (VarE n)) seqsToList :: [Seq a] -> [a] seqsToList = toList . foldr (><) Seq.empty (tss, ps, ess) <- liftM unzip3 . mapM f $ ts return (seqsToList tss, ps, seqsToList ess) argTypes <- sequence argTypeQs (ts, ps, es) <- splitTuples argTypes let phName = hName ++ "'" sequence [ foreignDecl' phName (map return ts), sigD (mkName hName) (foldr (\argT retT -> appT (appT arrowT argT) retT) retTyQ argTypeQs), funD (mkName hName) [ clause (map return ps) (normalB (foldl appE (varE (mkName phName)) (map return 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 = any (== ConT ''Bool) typeMapping :: Type -> TypeQ typeMapping t = case t of ConT h | h == ''Bool -> [t| LLVMBool |] | h == ''Int32 -> [t| CInt |] | h == ''Word32 -> [t| CUInt |] | h == ''String -> [t| CString |] | h == ''A.Operand -> [t| Ptr FFI.Value |] | h == ''A.Type -> [t| Ptr FFI.Type |] | h == ''A.C.Constant -> [t| Ptr FFI.Constant |] | h == ''A.FloatingPointPredicate -> [t| FCmpPredicate |] | h == ''A.IntegerPredicate -> [t| ICmpPredicate |] | h == ''A.FastMathFlags -> [t| FastMathFlags |] AppT ListT x -> foldl1 appT [tupleT 2, [t| CUInt |], appT [t| Ptr |] (typeMapping x)] x -> error $ "type not handled in Cleanup typeMapping: " ++ show x