{-# LANGUAGE QuasiQuotes, MultiParamTypeClasses #-} module LLVM.Internal.Type where import LLVM.Prelude import Control.Monad.AnyCont import Control.Monad.Catch import Control.Monad.State import qualified Data.Map as Map import qualified Data.Set as Set import Foreign.Ptr import qualified LLVM.Internal.FFI.LLVMCTypes as FFI import LLVM.Internal.FFI.LLVMCTypes (typeKindP) import qualified LLVM.Internal.FFI.Type as FFI import qualified LLVM.Internal.FFI.PtrHierarchy as FFI import qualified LLVM.AST as A import qualified LLVM.AST.AddrSpace as A import LLVM.Exception import LLVM.Internal.Context import LLVM.Internal.Coding import LLVM.Internal.DecodeAST import LLVM.Internal.EncodeAST getStructure :: Ptr FFI.Type -> DecodeAST A.Type getStructure :: Ptr Type -> DecodeAST Type getStructure t :: Ptr Type t = DecodeAST Type -> DecodeAST Type forall (m :: * -> *) a. ScopeAnyCont m => m a -> m a scopeAnyCont (DecodeAST Type -> DecodeAST Type) -> DecodeAST Type -> DecodeAST Type forall a b. (a -> b) -> a -> b $ do (Bool -> [Type] -> Type) -> DecodeAST (Bool -> [Type] -> Type) forall (m :: * -> *) a. Monad m => a -> m a return Bool -> [Type] -> Type A.StructureType DecodeAST (Bool -> [Type] -> Type) -> DecodeAST Bool -> DecodeAST ([Type] -> Type) forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b `ap` (LLVMBool -> DecodeAST Bool forall (d :: * -> *) h c. DecodeM d h c => c -> d h decodeM (LLVMBool -> DecodeAST Bool) -> DecodeAST LLVMBool -> DecodeAST Bool forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< IO LLVMBool -> DecodeAST LLVMBool forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (Ptr Type -> IO LLVMBool FFI.isPackedStruct Ptr Type t)) DecodeAST ([Type] -> Type) -> DecodeAST [Type] -> DecodeAST Type forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b `ap` do CUInt n <- IO CUInt -> DecodeAST CUInt forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (Ptr Type -> IO CUInt FFI.countStructElementTypes Ptr Type t) Ptr (Ptr Type) ts <- CUInt -> DecodeAST (Ptr (Ptr Type)) forall i a (m :: * -> *). (Integral i, Storable a, MonadAnyCont IO m) => i -> m (Ptr a) allocaArray CUInt n IO () -> DecodeAST () forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO () -> DecodeAST ()) -> IO () -> DecodeAST () forall a b. (a -> b) -> a -> b $ Ptr Type -> Ptr (Ptr Type) -> IO () FFI.getStructElementTypes Ptr Type t Ptr (Ptr Type) ts (CUInt, Ptr (Ptr Type)) -> DecodeAST [Type] forall (d :: * -> *) h c. DecodeM d h c => c -> d h decodeM (CUInt n, Ptr (Ptr Type) ts) getStructDefinitions :: DecodeAST [A.Definition] getStructDefinitions :: DecodeAST [Definition] getStructDefinitions = do let getStructDefinition :: Ptr Type -> DecodeAST (Maybe Type) getStructDefinition t :: Ptr Type t = do Bool opaque <- LLVMBool -> DecodeAST Bool forall (d :: * -> *) h c. DecodeM d h c => c -> d h decodeM (LLVMBool -> DecodeAST Bool) -> DecodeAST LLVMBool -> DecodeAST Bool forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< IO LLVMBool -> DecodeAST LLVMBool forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (Ptr Type -> IO LLVMBool FFI.structIsOpaque Ptr Type t) if Bool opaque then Maybe Type -> DecodeAST (Maybe Type) forall (m :: * -> *) a. Monad m => a -> m a return Maybe Type forall a. Maybe a Nothing else Type -> Maybe Type forall a. a -> Maybe a Just (Type -> Maybe Type) -> DecodeAST Type -> DecodeAST (Maybe Type) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Ptr Type -> DecodeAST Type getStructure Ptr Type t (((Set (Ptr Type) -> DecodeAST [Definition]) -> Set (Ptr Type) -> DecodeAST [Definition]) -> Set (Ptr Type) -> DecodeAST [Definition]) -> Set (Ptr Type) -> ((Set (Ptr Type) -> DecodeAST [Definition]) -> Set (Ptr Type) -> DecodeAST [Definition]) -> DecodeAST [Definition] forall a b c. (a -> b -> c) -> b -> a -> c flip ((Set (Ptr Type) -> DecodeAST [Definition]) -> Set (Ptr Type) -> DecodeAST [Definition]) -> Set (Ptr Type) -> DecodeAST [Definition] forall a. (a -> a) -> a fix Set (Ptr Type) forall a. Set a Set.empty (((Set (Ptr Type) -> DecodeAST [Definition]) -> Set (Ptr Type) -> DecodeAST [Definition]) -> DecodeAST [Definition]) -> ((Set (Ptr Type) -> DecodeAST [Definition]) -> Set (Ptr Type) -> DecodeAST [Definition]) -> DecodeAST [Definition] forall a b. (a -> b) -> a -> b $ \continue :: Set (Ptr Type) -> DecodeAST [Definition] continue done :: Set (Ptr Type) done -> do Maybe (Ptr Type) t <- DecodeAST (Maybe (Ptr Type)) takeTypeToDefine ((Ptr Type -> DecodeAST [Definition]) -> Maybe (Ptr Type) -> DecodeAST [Definition]) -> Maybe (Ptr Type) -> (Ptr Type -> DecodeAST [Definition]) -> DecodeAST [Definition] forall a b c. (a -> b -> c) -> b -> a -> c flip (DecodeAST [Definition] -> (Ptr Type -> DecodeAST [Definition]) -> Maybe (Ptr Type) -> DecodeAST [Definition] forall b a. b -> (a -> b) -> Maybe a -> b maybe ([Definition] -> DecodeAST [Definition] forall (m :: * -> *) a. Monad m => a -> m a return [])) Maybe (Ptr Type) t ((Ptr Type -> DecodeAST [Definition]) -> DecodeAST [Definition]) -> (Ptr Type -> DecodeAST [Definition]) -> DecodeAST [Definition] forall a b. (a -> b) -> a -> b $ \t :: Ptr Type t -> do if Ptr Type t Ptr Type -> Set (Ptr Type) -> Bool forall a. Ord a => a -> Set a -> Bool `Set.member` Set (Ptr Type) done then Set (Ptr Type) -> DecodeAST [Definition] continue Set (Ptr Type) done else (Definition -> [Definition] -> [Definition]) -> DecodeAST (Definition -> [Definition] -> [Definition]) forall (m :: * -> *) a. Monad m => a -> m a return (:) DecodeAST (Definition -> [Definition] -> [Definition]) -> DecodeAST Definition -> DecodeAST ([Definition] -> [Definition]) forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b `ap` ((Name -> Maybe Type -> Definition) -> DecodeAST (Name -> Maybe Type -> Definition) forall (m :: * -> *) a. Monad m => a -> m a return Name -> Maybe Type -> Definition A.TypeDefinition DecodeAST (Name -> Maybe Type -> Definition) -> DecodeAST Name -> DecodeAST (Maybe Type -> Definition) forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b `ap` Ptr Type -> DecodeAST Name getTypeName Ptr Type t DecodeAST (Maybe Type -> Definition) -> DecodeAST (Maybe Type) -> DecodeAST Definition forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b `ap` Ptr Type -> DecodeAST (Maybe Type) getStructDefinition Ptr Type t) DecodeAST ([Definition] -> [Definition]) -> DecodeAST [Definition] -> DecodeAST [Definition] forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b `ap` (Set (Ptr Type) -> DecodeAST [Definition] continue (Set (Ptr Type) -> DecodeAST [Definition]) -> Set (Ptr Type) -> DecodeAST [Definition] forall a b. (a -> b) -> a -> b $ Ptr Type -> Set (Ptr Type) -> Set (Ptr Type) forall a. Ord a => a -> Set a -> Set a Set.insert Ptr Type t Set (Ptr Type) done) isArrayType :: Ptr FFI.Type -> IO Bool isArrayType :: Ptr Type -> IO Bool isArrayType t :: Ptr Type t = do TypeKind k <- IO TypeKind -> IO TypeKind forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO TypeKind -> IO TypeKind) -> IO TypeKind -> IO TypeKind forall a b. (a -> b) -> a -> b $ Ptr Type -> IO TypeKind FFI.getTypeKind Ptr Type t Bool -> IO Bool forall (m :: * -> *) a. Monad m => a -> m a return (Bool -> IO Bool) -> Bool -> IO Bool forall a b. (a -> b) -> a -> b $ TypeKind k TypeKind -> TypeKind -> Bool forall a. Eq a => a -> a -> Bool == TypeKind FFI.typeKindArray instance Monad m => EncodeM m A.AddrSpace FFI.AddrSpace where encodeM :: AddrSpace -> m AddrSpace encodeM (A.AddrSpace a :: Word32 a) = (CUInt -> AddrSpace) -> m (CUInt -> AddrSpace) forall (m :: * -> *) a. Monad m => a -> m a return CUInt -> AddrSpace FFI.AddrSpace m (CUInt -> AddrSpace) -> m CUInt -> m AddrSpace forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b `ap` Word32 -> m CUInt forall (e :: * -> *) h c. EncodeM e h c => h -> e c encodeM Word32 a instance Monad m => DecodeM m A.AddrSpace FFI.AddrSpace where decodeM :: AddrSpace -> m AddrSpace decodeM (FFI.AddrSpace a :: CUInt a) = (Word32 -> AddrSpace) -> m (Word32 -> AddrSpace) forall (m :: * -> *) a. Monad m => a -> m a return Word32 -> AddrSpace A.AddrSpace m (Word32 -> AddrSpace) -> m Word32 -> m AddrSpace forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b `ap` CUInt -> m Word32 forall (d :: * -> *) h c. DecodeM d h c => c -> d h decodeM CUInt a instance EncodeM EncodeAST A.Type (Ptr FFI.Type) where encodeM :: Type -> EncodeAST (Ptr Type) encodeM f :: Type f = EncodeAST (Ptr Type) -> EncodeAST (Ptr Type) forall (m :: * -> *) a. ScopeAnyCont m => m a -> m a scopeAnyCont (EncodeAST (Ptr Type) -> EncodeAST (Ptr Type)) -> EncodeAST (Ptr Type) -> EncodeAST (Ptr Type) forall a b. (a -> b) -> a -> b $ do Context context :: Ptr Context context <- (EncodeState -> Context) -> EncodeAST Context forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a gets EncodeState -> Context encodeStateContext case Type f of A.IntegerType bits :: Word32 bits -> do CUInt bits <- Word32 -> EncodeAST CUInt forall (e :: * -> *) h c. EncodeM e h c => h -> e c encodeM Word32 bits IO (Ptr Type) -> EncodeAST (Ptr Type) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type)) -> IO (Ptr Type) -> EncodeAST (Ptr Type) forall a b. (a -> b) -> a -> b $ Ptr Context -> CUInt -> IO (Ptr Type) FFI.intTypeInContext Ptr Context context CUInt bits A.FunctionType returnTypeAST :: Type returnTypeAST argTypeASTs :: [Type] argTypeASTs isVarArg :: Bool isVarArg -> do Ptr Type returnType <- Type -> EncodeAST (Ptr Type) forall (e :: * -> *) h c. EncodeM e h c => h -> e c encodeM Type returnTypeAST (CUInt, Ptr (Ptr Type)) argTypes <- [Type] -> EncodeAST (CUInt, Ptr (Ptr Type)) forall (e :: * -> *) h c. EncodeM e h c => h -> e c encodeM [Type] argTypeASTs LLVMBool isVarArg <- Bool -> EncodeAST LLVMBool forall (e :: * -> *) h c. EncodeM e h c => h -> e c encodeM Bool isVarArg IO (Ptr Type) -> EncodeAST (Ptr Type) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type)) -> IO (Ptr Type) -> EncodeAST (Ptr Type) forall a b. (a -> b) -> a -> b $ Ptr Type -> (CUInt, Ptr (Ptr Type)) -> LLVMBool -> IO (Ptr Type) FFI.functionType Ptr Type returnType (CUInt, Ptr (Ptr Type)) argTypes LLVMBool isVarArg A.PointerType elementType :: Type elementType addressSpace :: AddrSpace addressSpace -> do Ptr Type e <- Type -> EncodeAST (Ptr Type) forall (e :: * -> *) h c. EncodeM e h c => h -> e c encodeM Type elementType AddrSpace a <- AddrSpace -> EncodeAST AddrSpace forall (e :: * -> *) h c. EncodeM e h c => h -> e c encodeM AddrSpace addressSpace IO (Ptr Type) -> EncodeAST (Ptr Type) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type)) -> IO (Ptr Type) -> EncodeAST (Ptr Type) forall a b. (a -> b) -> a -> b $ Ptr Type -> AddrSpace -> IO (Ptr Type) FFI.pointerType Ptr Type e AddrSpace a A.VoidType -> IO (Ptr Type) -> EncodeAST (Ptr Type) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type)) -> IO (Ptr Type) -> EncodeAST (Ptr Type) forall a b. (a -> b) -> a -> b $ Ptr Context -> IO (Ptr Type) FFI.voidTypeInContext Ptr Context context A.FloatingPointType A.HalfFP -> IO (Ptr Type) -> EncodeAST (Ptr Type) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type)) -> IO (Ptr Type) -> EncodeAST (Ptr Type) forall a b. (a -> b) -> a -> b $ Ptr Context -> IO (Ptr Type) FFI.halfTypeInContext Ptr Context context A.FloatingPointType A.FloatFP -> IO (Ptr Type) -> EncodeAST (Ptr Type) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type)) -> IO (Ptr Type) -> EncodeAST (Ptr Type) forall a b. (a -> b) -> a -> b $ Ptr Context -> IO (Ptr Type) FFI.floatTypeInContext Ptr Context context A.FloatingPointType A.DoubleFP -> IO (Ptr Type) -> EncodeAST (Ptr Type) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type)) -> IO (Ptr Type) -> EncodeAST (Ptr Type) forall a b. (a -> b) -> a -> b $ Ptr Context -> IO (Ptr Type) FFI.doubleTypeInContext Ptr Context context A.FloatingPointType A.X86_FP80FP -> IO (Ptr Type) -> EncodeAST (Ptr Type) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type)) -> IO (Ptr Type) -> EncodeAST (Ptr Type) forall a b. (a -> b) -> a -> b $ Ptr Context -> IO (Ptr Type) FFI.x86FP80TypeInContext Ptr Context context A.FloatingPointType A.FP128FP -> IO (Ptr Type) -> EncodeAST (Ptr Type) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type)) -> IO (Ptr Type) -> EncodeAST (Ptr Type) forall a b. (a -> b) -> a -> b $ Ptr Context -> IO (Ptr Type) FFI.fP128TypeInContext Ptr Context context A.FloatingPointType A.PPC_FP128FP -> IO (Ptr Type) -> EncodeAST (Ptr Type) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type)) -> IO (Ptr Type) -> EncodeAST (Ptr Type) forall a b. (a -> b) -> a -> b $ Ptr Context -> IO (Ptr Type) FFI.ppcFP128TypeInContext Ptr Context context A.VectorType sz :: Word32 sz e :: Type e -> do Ptr Type e <- Type -> EncodeAST (Ptr Type) forall (e :: * -> *) h c. EncodeM e h c => h -> e c encodeM Type e CUInt sz <- Word32 -> EncodeAST CUInt forall (e :: * -> *) h c. EncodeM e h c => h -> e c encodeM Word32 sz IO (Ptr Type) -> EncodeAST (Ptr Type) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type)) -> IO (Ptr Type) -> EncodeAST (Ptr Type) forall a b. (a -> b) -> a -> b $ Ptr Type -> CUInt -> IO (Ptr Type) FFI.vectorType Ptr Type e CUInt sz A.ArrayType sz :: Word64 sz e :: Type e -> do Ptr Type e <- Type -> EncodeAST (Ptr Type) forall (e :: * -> *) h c. EncodeM e h c => h -> e c encodeM Type e Word64 sz <- Word64 -> EncodeAST Word64 forall (e :: * -> *) h c. EncodeM e h c => h -> e c encodeM Word64 sz IO (Ptr Type) -> EncodeAST (Ptr Type) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type)) -> IO (Ptr Type) -> EncodeAST (Ptr Type) forall a b. (a -> b) -> a -> b $ Ptr Type -> Word64 -> IO (Ptr Type) FFI.arrayType Ptr Type e Word64 sz A.StructureType packed :: Bool packed ets :: [Type] ets -> do (CUInt, Ptr (Ptr Type)) ets <- [Type] -> EncodeAST (CUInt, Ptr (Ptr Type)) forall (e :: * -> *) h c. EncodeM e h c => h -> e c encodeM [Type] ets LLVMBool packed <- Bool -> EncodeAST LLVMBool forall (e :: * -> *) h c. EncodeM e h c => h -> e c encodeM Bool packed IO (Ptr Type) -> EncodeAST (Ptr Type) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type)) -> IO (Ptr Type) -> EncodeAST (Ptr Type) forall a b. (a -> b) -> a -> b $ Ptr Context -> (CUInt, Ptr (Ptr Type)) -> LLVMBool -> IO (Ptr Type) FFI.structTypeInContext Ptr Context context (CUInt, Ptr (Ptr Type)) ets LLVMBool packed A.NamedTypeReference n :: Name n -> Name -> EncodeAST (Ptr Type) lookupNamedType Name n A.MetadataType -> IO (Ptr Type) -> EncodeAST (Ptr Type) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type)) -> IO (Ptr Type) -> EncodeAST (Ptr Type) forall a b. (a -> b) -> a -> b $ Ptr Context -> IO (Ptr Type) FFI.metadataTypeInContext Ptr Context context A.TokenType -> IO (Ptr Type) -> EncodeAST (Ptr Type) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type)) -> IO (Ptr Type) -> EncodeAST (Ptr Type) forall a b. (a -> b) -> a -> b $ Ptr Context -> IO (Ptr Type) FFI.tokenTypeInContext Ptr Context context A.LabelType -> IO (Ptr Type) -> EncodeAST (Ptr Type) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type)) -> IO (Ptr Type) -> EncodeAST (Ptr Type) forall a b. (a -> b) -> a -> b $ Ptr Context -> IO (Ptr Type) FFI.labelTypeInContext Ptr Context context instance DecodeM DecodeAST A.Type (Ptr FFI.Type) where decodeM :: Ptr Type -> DecodeAST Type decodeM t :: Ptr Type t = DecodeAST Type -> DecodeAST Type forall (m :: * -> *) a. ScopeAnyCont m => m a -> m a scopeAnyCont (DecodeAST Type -> DecodeAST Type) -> DecodeAST Type -> DecodeAST Type forall a b. (a -> b) -> a -> b $ do TypeKind k <- IO TypeKind -> DecodeAST TypeKind forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO TypeKind -> DecodeAST TypeKind) -> IO TypeKind -> DecodeAST TypeKind forall a b. (a -> b) -> a -> b $ Ptr Type -> IO TypeKind FFI.getTypeKind Ptr Type t case TypeKind k of [typeKindP|Void|] -> Type -> DecodeAST Type forall (m :: * -> *) a. Monad m => a -> m a return Type A.VoidType [typeKindP|Integer|] -> Word32 -> Type A.IntegerType (Word32 -> Type) -> DecodeAST Word32 -> DecodeAST Type forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (CUInt -> DecodeAST Word32 forall (d :: * -> *) h c. DecodeM d h c => c -> d h decodeM (CUInt -> DecodeAST Word32) -> DecodeAST CUInt -> DecodeAST Word32 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< IO CUInt -> DecodeAST CUInt forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (Ptr Type -> IO CUInt FFI.getIntTypeWidth Ptr Type t)) [typeKindP|Function|] -> (Type -> [Type] -> Bool -> Type) -> DecodeAST (Type -> [Type] -> Bool -> Type) forall (m :: * -> *) a. Monad m => a -> m a return Type -> [Type] -> Bool -> Type A.FunctionType DecodeAST (Type -> [Type] -> Bool -> Type) -> DecodeAST Type -> DecodeAST ([Type] -> Bool -> Type) forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b `ap` (Ptr Type -> DecodeAST Type forall (d :: * -> *) h c. DecodeM d h c => c -> d h decodeM (Ptr Type -> DecodeAST Type) -> DecodeAST (Ptr Type) -> DecodeAST Type forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< IO (Ptr Type) -> DecodeAST (Ptr Type) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (Ptr Type -> IO (Ptr Type) FFI.getReturnType Ptr Type t)) DecodeAST ([Type] -> Bool -> Type) -> DecodeAST [Type] -> DecodeAST (Bool -> Type) forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b `ap` (do CUInt n <- IO CUInt -> DecodeAST CUInt forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (Ptr Type -> IO CUInt FFI.countParamTypes Ptr Type t) Ptr (Ptr Type) ts <- CUInt -> DecodeAST (Ptr (Ptr Type)) forall i a (m :: * -> *). (Integral i, Storable a, MonadAnyCont IO m) => i -> m (Ptr a) allocaArray CUInt n IO () -> DecodeAST () forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO () -> DecodeAST ()) -> IO () -> DecodeAST () forall a b. (a -> b) -> a -> b $ Ptr Type -> Ptr (Ptr Type) -> IO () FFI.getParamTypes Ptr Type t Ptr (Ptr Type) ts (CUInt, Ptr (Ptr Type)) -> DecodeAST [Type] forall (d :: * -> *) h c. DecodeM d h c => c -> d h decodeM (CUInt n, Ptr (Ptr Type) ts) ) DecodeAST (Bool -> Type) -> DecodeAST Bool -> DecodeAST Type forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b `ap` (LLVMBool -> DecodeAST Bool forall (d :: * -> *) h c. DecodeM d h c => c -> d h decodeM (LLVMBool -> DecodeAST Bool) -> DecodeAST LLVMBool -> DecodeAST Bool forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< IO LLVMBool -> DecodeAST LLVMBool forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (Ptr Type -> IO LLVMBool FFI.isFunctionVarArg Ptr Type t)) [typeKindP|Pointer|] -> (Type -> AddrSpace -> Type) -> DecodeAST (Type -> AddrSpace -> Type) forall (m :: * -> *) a. Monad m => a -> m a return Type -> AddrSpace -> Type A.PointerType DecodeAST (Type -> AddrSpace -> Type) -> DecodeAST Type -> DecodeAST (AddrSpace -> Type) forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b `ap` (Ptr Type -> DecodeAST Type forall (d :: * -> *) h c. DecodeM d h c => c -> d h decodeM (Ptr Type -> DecodeAST Type) -> DecodeAST (Ptr Type) -> DecodeAST Type forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< IO (Ptr Type) -> DecodeAST (Ptr Type) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (Ptr Type -> IO (Ptr Type) FFI.getElementType Ptr Type t)) DecodeAST (AddrSpace -> Type) -> DecodeAST AddrSpace -> DecodeAST Type forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b `ap` (AddrSpace -> DecodeAST AddrSpace forall (d :: * -> *) h c. DecodeM d h c => c -> d h decodeM (AddrSpace -> DecodeAST AddrSpace) -> DecodeAST AddrSpace -> DecodeAST AddrSpace forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< IO AddrSpace -> DecodeAST AddrSpace forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (Ptr Type -> IO AddrSpace FFI.getPointerAddressSpace Ptr Type t)) [typeKindP|Half|] -> Type -> DecodeAST Type forall (m :: * -> *) a. Monad m => a -> m a return (Type -> DecodeAST Type) -> Type -> DecodeAST Type forall a b. (a -> b) -> a -> b $ FloatingPointType -> Type A.FloatingPointType FloatingPointType A.HalfFP [typeKindP|Float|] -> Type -> DecodeAST Type forall (m :: * -> *) a. Monad m => a -> m a return (Type -> DecodeAST Type) -> Type -> DecodeAST Type forall a b. (a -> b) -> a -> b $ FloatingPointType -> Type A.FloatingPointType FloatingPointType A.FloatFP [typeKindP|Double|] -> Type -> DecodeAST Type forall (m :: * -> *) a. Monad m => a -> m a return (Type -> DecodeAST Type) -> Type -> DecodeAST Type forall a b. (a -> b) -> a -> b $ FloatingPointType -> Type A.FloatingPointType FloatingPointType A.DoubleFP [typeKindP|FP128|] -> Type -> DecodeAST Type forall (m :: * -> *) a. Monad m => a -> m a return (Type -> DecodeAST Type) -> Type -> DecodeAST Type forall a b. (a -> b) -> a -> b $ FloatingPointType -> Type A.FloatingPointType FloatingPointType A.FP128FP [typeKindP|X86_FP80|] -> Type -> DecodeAST Type forall (m :: * -> *) a. Monad m => a -> m a return (Type -> DecodeAST Type) -> Type -> DecodeAST Type forall a b. (a -> b) -> a -> b $ FloatingPointType -> Type A.FloatingPointType FloatingPointType A.X86_FP80FP [typeKindP|PPC_FP128|] -> Type -> DecodeAST Type forall (m :: * -> *) a. Monad m => a -> m a return (Type -> DecodeAST Type) -> Type -> DecodeAST Type forall a b. (a -> b) -> a -> b $ FloatingPointType -> Type A.FloatingPointType FloatingPointType A.PPC_FP128FP [typeKindP|Vector|] -> (Word32 -> Type -> Type) -> DecodeAST (Word32 -> Type -> Type) forall (m :: * -> *) a. Monad m => a -> m a return Word32 -> Type -> Type A.VectorType DecodeAST (Word32 -> Type -> Type) -> DecodeAST Word32 -> DecodeAST (Type -> Type) forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b `ap` (CUInt -> DecodeAST Word32 forall (d :: * -> *) h c. DecodeM d h c => c -> d h decodeM (CUInt -> DecodeAST Word32) -> DecodeAST CUInt -> DecodeAST Word32 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< IO CUInt -> DecodeAST CUInt forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (Ptr Type -> IO CUInt FFI.getVectorSize Ptr Type t)) DecodeAST (Type -> Type) -> DecodeAST Type -> DecodeAST Type forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b `ap` (Ptr Type -> DecodeAST Type forall (d :: * -> *) h c. DecodeM d h c => c -> d h decodeM (Ptr Type -> DecodeAST Type) -> DecodeAST (Ptr Type) -> DecodeAST Type forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< IO (Ptr Type) -> DecodeAST (Ptr Type) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (Ptr Type -> IO (Ptr Type) FFI.getElementType Ptr Type t)) [typeKindP|Struct|] -> do let ifM :: m Bool -> m b -> m b -> m b ifM c :: m Bool c a :: m b a b :: m b b = m Bool c m Bool -> (Bool -> m b) -> m b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \x :: Bool x -> if Bool x then m b a else m b b DecodeAST Bool -> DecodeAST Type -> DecodeAST Type -> DecodeAST Type forall (m :: * -> *) b. Monad m => m Bool -> m b -> m b -> m b ifM (LLVMBool -> DecodeAST Bool forall (d :: * -> *) h c. DecodeM d h c => c -> d h decodeM (LLVMBool -> DecodeAST Bool) -> DecodeAST LLVMBool -> DecodeAST Bool forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< IO LLVMBool -> DecodeAST LLVMBool forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (Ptr Type -> IO LLVMBool FFI.structIsLiteral Ptr Type t)) (Ptr Type -> DecodeAST Type getStructure Ptr Type t) (Ptr Type -> DecodeAST () saveNamedType Ptr Type t DecodeAST () -> DecodeAST Type -> DecodeAST Type forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> (Name -> Type) -> DecodeAST (Name -> Type) forall (m :: * -> *) a. Monad m => a -> m a return Name -> Type A.NamedTypeReference DecodeAST (Name -> Type) -> DecodeAST Name -> DecodeAST Type forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b `ap` Ptr Type -> DecodeAST Name getTypeName Ptr Type t) [typeKindP|Metadata|] -> Type -> DecodeAST Type forall (m :: * -> *) a. Monad m => a -> m a return Type A.MetadataType [typeKindP|Array|] -> (Word64 -> Type -> Type) -> DecodeAST (Word64 -> Type -> Type) forall (m :: * -> *) a. Monad m => a -> m a return Word64 -> Type -> Type A.ArrayType DecodeAST (Word64 -> Type -> Type) -> DecodeAST Word64 -> DecodeAST (Type -> Type) forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b `ap` (Word64 -> DecodeAST Word64 forall (d :: * -> *) h c. DecodeM d h c => c -> d h decodeM (Word64 -> DecodeAST Word64) -> DecodeAST Word64 -> DecodeAST Word64 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< IO Word64 -> DecodeAST Word64 forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (Ptr Type -> IO Word64 FFI.getArrayLength Ptr Type t)) DecodeAST (Type -> Type) -> DecodeAST Type -> DecodeAST Type forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b `ap` (Ptr Type -> DecodeAST Type forall (d :: * -> *) h c. DecodeM d h c => c -> d h decodeM (Ptr Type -> DecodeAST Type) -> DecodeAST (Ptr Type) -> DecodeAST Type forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< IO (Ptr Type) -> DecodeAST (Ptr Type) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (Ptr Type -> IO (Ptr Type) FFI.getElementType Ptr Type t)) [typeKindP|Token|] -> Type -> DecodeAST Type forall (m :: * -> *) a. Monad m => a -> m a return Type A.TokenType [typeKindP|Label|] -> Type -> DecodeAST Type forall (m :: * -> *) a. Monad m => a -> m a return Type A.LabelType _ -> [Char] -> DecodeAST Type forall a. HasCallStack => [Char] -> a error ([Char] -> DecodeAST Type) -> [Char] -> DecodeAST Type forall a b. (a -> b) -> a -> b $ "unhandled type kind " [Char] -> [Char] -> [Char] forall a. [a] -> [a] -> [a] ++ TypeKind -> [Char] forall a. Show a => a -> [Char] show TypeKind k createNamedType :: A.Name -> EncodeAST (Ptr FFI.Type, Maybe ShortByteString) createNamedType :: Name -> EncodeAST (Ptr Type, Maybe ShortByteString) createNamedType n :: Name n = do Context c :: Ptr Context c <- (EncodeState -> Context) -> EncodeAST Context forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a gets EncodeState -> Context encodeStateContext Ptr CChar n <- case Name n of { A.Name n :: ShortByteString n -> ShortByteString -> EncodeAST (Ptr CChar) forall (e :: * -> *) h c. EncodeM e h c => h -> e c encodeM ShortByteString n; _ -> Ptr CChar -> EncodeAST (Ptr CChar) forall (m :: * -> *) a. Monad m => a -> m a return Ptr CChar forall a. Ptr a nullPtr } Ptr (OwnerTransfered (Ptr CChar)) renamedName <- EncodeAST (Ptr (OwnerTransfered (Ptr CChar))) forall a (m :: * -> *). (Storable a, MonadAnyCont IO m) => m (Ptr a) alloca Ptr Type t <- IO (Ptr Type) -> EncodeAST (Ptr Type) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type)) -> IO (Ptr Type) -> EncodeAST (Ptr Type) forall a b. (a -> b) -> a -> b $ Ptr Context -> Ptr CChar -> Ptr (OwnerTransfered (Ptr CChar)) -> IO (Ptr Type) FFI.structCreateNamed Ptr Context c Ptr CChar n Ptr (OwnerTransfered (Ptr CChar)) renamedName OwnerTransfered (Ptr CChar) p <- Ptr (OwnerTransfered (Ptr CChar)) -> EncodeAST (OwnerTransfered (Ptr CChar)) forall a (m :: * -> *). (Storable a, MonadIO m) => Ptr a -> m a peek Ptr (OwnerTransfered (Ptr CChar)) renamedName if OwnerTransfered (Ptr CChar) p OwnerTransfered (Ptr CChar) -> OwnerTransfered (Ptr CChar) -> Bool forall a. Eq a => a -> a -> Bool == Ptr CChar -> OwnerTransfered (Ptr CChar) forall a. a -> OwnerTransfered a FFI.OwnerTransfered Ptr CChar forall a. Ptr a nullPtr then (Ptr Type, Maybe ShortByteString) -> EncodeAST (Ptr Type, Maybe ShortByteString) forall (f :: * -> *) a. Applicative f => a -> f a pure (Ptr Type t, Maybe ShortByteString forall a. Maybe a Nothing) else do ShortByteString n' <- OwnerTransfered (Ptr CChar) -> EncodeAST ShortByteString forall (d :: * -> *) h c. DecodeM d h c => c -> d h decodeM OwnerTransfered (Ptr CChar) p (Ptr Type, Maybe ShortByteString) -> EncodeAST (Ptr Type, Maybe ShortByteString) forall (f :: * -> *) a. Applicative f => a -> f a pure (Ptr Type t, ShortByteString -> Maybe ShortByteString forall a. a -> Maybe a Just ShortByteString n') renameType :: A.Type -> EncodeAST A.Type renameType :: Type -> EncodeAST Type renameType A.VoidType = Type -> EncodeAST Type forall (f :: * -> *) a. Applicative f => a -> f a pure Type A.VoidType renameType t :: Type t@(A.IntegerType _) = Type -> EncodeAST Type forall (f :: * -> *) a. Applicative f => a -> f a pure Type t renameType (A.PointerType r :: Type r a :: AddrSpace a) = (Type -> Type) -> EncodeAST Type -> EncodeAST Type forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (\r' :: Type r' -> Type -> AddrSpace -> Type A.PointerType Type r' AddrSpace a) (Type -> EncodeAST Type renameType Type r) renameType t :: Type t@(A.FloatingPointType _) = Type -> EncodeAST Type forall (f :: * -> *) a. Applicative f => a -> f a pure Type t renameType (A.FunctionType r :: Type r as :: [Type] as varArg :: Bool varArg) = (Type -> [Type] -> Type) -> EncodeAST Type -> EncodeAST [Type] -> EncodeAST Type forall (f :: * -> *) a b c. Applicative f => (a -> b -> c) -> f a -> f b -> f c liftA2 (\r' :: Type r' as' :: [Type] as' -> Type -> [Type] -> Bool -> Type A.FunctionType Type r' [Type] as' Bool varArg) (Type -> EncodeAST Type renameType Type r) ((Type -> EncodeAST Type) -> [Type] -> EncodeAST [Type] forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse Type -> EncodeAST Type renameType [Type] as) renameType (A.VectorType n :: Word32 n t :: Type t) = Word32 -> Type -> Type A.VectorType Word32 n (Type -> Type) -> EncodeAST Type -> EncodeAST Type forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Type -> EncodeAST Type renameType Type t renameType (A.StructureType packed :: Bool packed ts :: [Type] ts) = Bool -> [Type] -> Type A.StructureType Bool packed ([Type] -> Type) -> EncodeAST [Type] -> EncodeAST Type forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (Type -> EncodeAST Type) -> [Type] -> EncodeAST [Type] forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse Type -> EncodeAST Type renameType [Type] ts renameType (A.ArrayType n :: Word64 n t :: Type t) = Word64 -> Type -> Type A.ArrayType Word64 n (Type -> Type) -> EncodeAST Type -> EncodeAST Type forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Type -> EncodeAST Type renameType Type t renameType t :: Type t@(A.NamedTypeReference n :: Name n) = do Map Name ShortByteString renamedTypes <- (EncodeState -> Map Name ShortByteString) -> EncodeAST (Map Name ShortByteString) forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a gets EncodeState -> Map Name ShortByteString encodeStateRenamedTypes case Name -> Map Name ShortByteString -> Maybe ShortByteString forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup Name n Map Name ShortByteString renamedTypes of Just n' :: ShortByteString n' -> Type -> EncodeAST Type forall (f :: * -> *) a. Applicative f => a -> f a pure (Name -> Type A.NamedTypeReference (ShortByteString -> Name A.Name ShortByteString n')) Nothing -> Type -> EncodeAST Type forall (f :: * -> *) a. Applicative f => a -> f a pure Type t renameType A.MetadataType = Type -> EncodeAST Type forall (f :: * -> *) a. Applicative f => a -> f a pure Type A.MetadataType renameType A.LabelType = Type -> EncodeAST Type forall (f :: * -> *) a. Applicative f => a -> f a pure Type A.LabelType renameType A.TokenType = Type -> EncodeAST Type forall (f :: * -> *) a. Applicative f => a -> f a pure Type A.TokenType setNamedType :: Ptr FFI.Type -> A.Type -> EncodeAST () setNamedType :: Ptr Type -> Type -> EncodeAST () setNamedType t :: Ptr Type t (A.StructureType packed :: Bool packed ets :: [Type] ets) = do (CUInt, Ptr (Ptr Type)) ets <- [Type] -> EncodeAST (CUInt, Ptr (Ptr Type)) forall (e :: * -> *) h c. EncodeM e h c => h -> e c encodeM [Type] ets LLVMBool packed <- Bool -> EncodeAST LLVMBool forall (e :: * -> *) h c. EncodeM e h c => h -> e c encodeM Bool packed IO () -> EncodeAST () forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO () -> EncodeAST ()) -> IO () -> EncodeAST () forall a b. (a -> b) -> a -> b $ Ptr Type -> (CUInt, Ptr (Ptr Type)) -> LLVMBool -> IO () FFI.structSetBody Ptr Type t (CUInt, Ptr (Ptr Type)) ets LLVMBool packed setNamedType _ ty :: Type ty = EncodeException -> EncodeAST () forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a throwM ([Char] -> EncodeException EncodeException ("A type definition requires a structure type but got: " [Char] -> [Char] -> [Char] forall a. [a] -> [a] -> [a] ++ Type -> [Char] forall a. Show a => a -> [Char] show Type ty))