{-# LANGUAGE ViewPatterns #-}
module Data.LLVM.BitCode.IR.Types (
resolveTypeDecls
, parseTypeBlock
) where
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 Control.Monad (when,unless,mplus,(<=<))
import Data.List (sortBy)
import Data.Maybe (catMaybes)
import Data.Monoid (mempty)
import Data.Ord (comparing)
import qualified Data.Map as Map
numEntry :: Match Entry Record
numEntry = hasRecordCode 1 <=< fromUnabbrev <=< unabbrev
resolveTypeDecls :: Parse [TypeDecl]
resolveTypeDecls = do
symtab <- getTypeSymtab
decls <- mapM mkTypeDecl (Map.toList (tsById symtab))
return (sortBy (comparing typeName) decls)
where
mkTypeDecl (ix,alias) = do
ty <- getType' ix
return TypeDecl
{ typeName = alias
, typeValue = ty
}
parseTypeBlock :: [Entry] -> Parse TypeSymtab
parseTypeBlock es = label "TYPE_BLOCK" $ do
(r,ents) <- match (dropUntil numEntry) es
setTypeTableSize =<< label "type-table size" (parseField r 0 numeric)
isEmpty <- isTypeTableEmpty
unless isEmpty (fail "Multiple TYPE_BLOCKs found!")
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
sym = foldl mkSym mempty ixs
mkSym sym' (ix,(_,mb)) = case mb of
Nothing -> sym'
Just alias -> addTypeSymbol ix alias sym'
tt = Map.fromList [ (ix,updateAliases resolve ty) | (ix,(ty,_)) <- ixs ]
resolve ix = case Map.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
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" (addType Opaque)
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
_space <- field 1 keep
return ()
addType (PtrTo ty)
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_X86_FP80" (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))
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` parseFields r 0 char
setTypeName name
noType
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
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"
code -> fail ("unknown type code " ++ show code)
parseTypeBlockEntry (block -> Just _) =
return Nothing
parseTypeBlockEntry (abbrevDef -> Just _) =
return Nothing
parseTypeBlockEntry e =
fail ("type block: unexpected: " ++ show e)
addType :: PType -> ParseType
addType ty = return (Just (ty,Nothing))
addTypeWithAlias :: PType -> Ident -> ParseType
addTypeWithAlias ty i = return (Just (ty,Just i))
noType :: ParseType
noType = return Nothing