{-# LANGUAGE ViewPatterns #-} module Data.LLVM.BitCode.IR.Types ( resolveTypeDecls , parseTypeBlock ) where import qualified Data.LLVM.BitCode.Assert as Assert import Data.LLVM.BitCode.Bitstream import Data.LLVM.BitCode.Match import Data.LLVM.BitCode.Parse import Data.LLVM.BitCode.Record import Text.LLVM.AST import qualified Codec.Binary.UTF8.String as UTF8 (decode) import Control.Monad (when,unless,mplus,(<=<)) import qualified Data.IntMap as IntMap import Data.List (sortBy) import Data.Maybe (catMaybes) import Data.Ord (comparing) -- Type Block ------------------------------------------------------------------ -- | Pattern match the TYPE_CODE_NUMENTRY unabbreviated record. numEntry :: Match Entry Record numEntry = hasRecordCode 1 <=< fromUnabbrev <=< unabbrev resolveTypeDecls :: Parse [TypeDecl] resolveTypeDecls = do symtab <- getTypeSymtab decls <- mapM mkTypeDecl (IntMap.toList (tsById symtab)) return (sortBy (comparing typeName) decls) where mkTypeDecl (ix,alias) = do ty <- getType' ix return TypeDecl { typeName = alias , typeValue = ty } -- Type Block Parsing ---------------------------------------------------------- -- | Parsing the type block only modifies internal state, introducing a number -- of entries to the type table. parseTypeBlock :: [Entry] -> Parse TypeSymtab parseTypeBlock es = label "TYPE_BLOCK" $ do -- drop everything until we hit TYPE_CODE_NUMENTRY (r,ents) <- match (dropUntil numEntry) es setTypeTableSize =<< label "type-table size" (parseField r 0 numeric) -- verify that the type table hasn't been set already isEmpty <- isTypeTableEmpty unless isEmpty (fail "Multiple TYPE_BLOCKs found!") -- resolve the type table, and the type symbol table tys <- mapM parseTypeBlockEntry ents cxt <- getContext let (tt,sym) = deriveTypeTables cxt (catMaybes tys) setTypeTable tt return sym deriveTypeTables :: [String] -> [(PType,Maybe Ident)] -> (TypeTable,TypeSymtab) deriveTypeTables cxt tys = (tt,sym) where ixs = zip [0 ..] tys -- symbol table entries aren't very common sym = foldl mkSym mempty ixs mkSym sym' (ix,(_,mb)) = case mb of Nothing -> sym' Just alias -> addTypeSymbol ix alias sym' -- recursively resolve the type table, if they don't already exist in the -- symbol table. if the index entry doesn't exist, throw an error, as that -- should be impossible. tt = IntMap.fromList [ (ix, updateAliases resolve ty) | (ix, (ty, _)) <- ixs ] resolve ix = case IntMap.lookup ix (tsById sym) of Nothing -> lookupTypeRef cxt ix tt Just ident -> Alias ident type PType = Type' Int type ParseType = Parse (Maybe (PType,Maybe Ident)) typeRef :: Match Field PType typeRef = return . Alias <=< numeric -- | Parsing the type table will only ever effect internal state. parseTypeBlockEntry :: Entry -> ParseType parseTypeBlockEntry (fromEntry -> Just r) = case recordCode r of 1 -> label "TYPE_CODE_NUMENTRY" noType 2 -> label "TYPE_CODE_VOID" (addType (PrimType Void)) 3 -> label "TYPE_CODE_FLOAT" (addType (PrimType (FloatType Float))) 4 -> label "TYPE_CODE_DOUBLE" (addType (PrimType (FloatType Double))) 5 -> label "TYPE_CODE_LABEL" (addType (PrimType Label)) 6 -> label "TYPE_CODE_OPAQUE" $ do do ident <- getTypeName addTypeWithAlias Opaque ident 7 -> label "TYPE_CODE_INTEGER" $ do let field = parseField r width <- field 0 numeric addType (PrimType (Integer width)) 8 -> label "TYPE_CODE_POINTER" $ do let field = parseField r ty <- field 0 typeRef when (length (recordFields r) == 2) $ do -- We do not currently store address spaces in the @llvm-pretty@ AST. _space <- field 1 keep return () addType (PtrTo ty) -- [vararg, attrid, [retty, paramty x N]] 9 -> label "TYPE_CODE_FUNCTION_OLD" $ do let field = parseField r va <- field 0 boolean tys <- field 2 (fieldArray typeRef) case tys of rty:ptys -> addType (FunTy rty ptys va) _ -> fail "function expects a return type" 10 -> label "TYPE_CODE_FP_HALF" (addType (PrimType (FloatType Half))) 11 -> label "TYPE_CODE_ARRAY" $ do let field = parseField r numelts <- field 0 numeric eltty <- field 1 typeRef addType (Array numelts eltty) 12 -> label "TYPE_CODE_VECTOR" $ do let field = parseField r numelts <- field 0 numeric eltty <- field 1 typeRef addType (Vector numelts eltty) 13 -> label "TYPE_CODE_X86_FP80" (addType (PrimType (FloatType X86_fp80))) 14 -> label "TYPE_CODE_FP128" (addType (PrimType (FloatType Fp128))) 15 -> label "TYPE_CODE_PPC_FP128" (addType (PrimType (FloatType PPC_fp128))) 16 -> label "TYPE_CODE_METADATA" (addType (PrimType Metadata)) 17 -> label "TYPE_CODE_X86_MMX" (addType (PrimType X86mmx)) -- [ispacked, eltty x N] 18 -> label "TYPE_CODE_STRUCT_ANON" $ do let field = parseField r ispacked <- label "is packed" (field 0 boolean) tys <- label "struct fields" (field 1 (fieldArray typeRef)) if ispacked then addType (PackedStruct tys) else addType (Struct tys) 19 -> label "TYPE_CODE_STRUCT_NAME" $ do name <- label "struct name" $ parseField r 0 cstring `mplus` fmap UTF8.decode (parseFields r 0 char) setTypeName name noType -- [ispacked, eltty x N] 20 -> label "TYPE_CODE_STRUCT_NAMED" $ do let field = parseField r ident <- getTypeName ispacked <- label "ispacked" (field 0 boolean) tys <- label "element types" (field 1 (fieldArray typeRef)) if ispacked then addTypeWithAlias (PackedStruct tys) ident else addTypeWithAlias (Struct tys) ident -- [vararg, [retty, paramty x N]] 21 -> label "TYPE_CODE_FUNCTION" $ do let field = parseField r vararg <- label "vararg" (field 0 boolean) tys <- label "parameters" (field 1 (fieldArray typeRef)) case tys of rty:ptys -> addType (FunTy rty ptys vararg) [] -> fail "function expects a return type" 22 -> label "TYPE_CODE_TOKEN" $ do notImplemented 23 -> label "TYPE_CODE_BFLOAT" $ do notImplemented 24 -> label "TYPE_CODE_X86_AMX" $ do notImplemented 25 -> label "TYPE_CODE_OPAQUE_POINTER" $ do let field = parseField r when (length (recordFields r) /= 1) $ fail "Invalid opaque pointer record" -- We do not currently store address spaces in the @llvm-pretty@ AST. _space <- field 0 keep addType PtrOpaque 26 -> label "TYPE_CODE_TARGET_TYPE" $ do notImplemented code -> Assert.unknownEntity "type code " code -- skip blocks parseTypeBlockEntry (block -> Just _) = return Nothing -- skip abbrevs parseTypeBlockEntry (abbrevDef -> Just _) = return Nothing parseTypeBlockEntry e = fail ("type block: unexpected: " ++ show e) -- | Add a type to the type table. addType :: PType -> ParseType addType ty = return (Just (ty,Nothing)) -- | Add a type and an alias to the type table addTypeWithAlias :: PType -> Ident -> ParseType addTypeWithAlias ty i = return (Just (ty,Just i)) -- | Return no type for addition to the type table noType :: ParseType noType = return Nothing