{-# 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 :: Match Entry Record
numEntry  = Int -> Match Record Record
hasRecordCode Int
1 Match Record Record -> Match Entry Record -> Match Entry Record
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Match UnabbrevRecord Record
fromUnabbrev Match UnabbrevRecord Record
-> (Entry -> Maybe UnabbrevRecord) -> Match Entry Record
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Entry -> Maybe UnabbrevRecord
unabbrev

resolveTypeDecls :: Parse [TypeDecl]
resolveTypeDecls :: Parse [TypeDecl]
resolveTypeDecls  = do
  TypeSymtab
symtab <- Parse TypeSymtab
getTypeSymtab
  [TypeDecl]
decls  <- ((Int, Ident) -> Parse TypeDecl)
-> [(Int, Ident)] -> Parse [TypeDecl]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Int, Ident) -> Parse TypeDecl
mkTypeDecl (IntMap Ident -> [(Int, Ident)]
forall a. IntMap a -> [(Int, a)]
IntMap.toList (TypeSymtab -> IntMap Ident
tsById TypeSymtab
symtab))
  [TypeDecl] -> Parse [TypeDecl]
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return ((TypeDecl -> TypeDecl -> Ordering) -> [TypeDecl] -> [TypeDecl]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((TypeDecl -> Ident) -> TypeDecl -> TypeDecl -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing TypeDecl -> Ident
typeName) [TypeDecl]
decls)
  where
  mkTypeDecl :: (Int, Ident) -> Parse TypeDecl
mkTypeDecl (Int
ix,Ident
alias) = do
    Type
ty <- Int -> Parse Type
getType' Int
ix
    TypeDecl -> Parse TypeDecl
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return TypeDecl
      { typeName :: Ident
typeName  = Ident
alias
      , typeValue :: Type
typeValue = Type
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 :: [Entry] -> Parse TypeSymtab
parseTypeBlock [Entry]
es = String -> Parse TypeSymtab -> Parse TypeSymtab
forall a. String -> Parse a -> Parse a
label String
"TYPE_BLOCK" (Parse TypeSymtab -> Parse TypeSymtab)
-> Parse TypeSymtab -> Parse TypeSymtab
forall a b. (a -> b) -> a -> b
$ do

  -- drop everything until we hit TYPE_CODE_NUMENTRY
  (Record
r,[Entry]
ents) <- Match [Entry] (Record, [Entry])
-> [Entry] -> Parse (Record, [Entry])
forall i a. Match i a -> i -> Parse a
match (Match Entry Record -> Match [Entry] (Record, [Entry])
forall a b. Match a b -> Match [a] (b, [a])
dropUntil Match Entry Record
numEntry) [Entry]
es
  Int -> Parse ()
setTypeTableSize (Int -> Parse ()) -> Parse Int -> Parse ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Parse Int -> Parse Int
forall a. String -> Parse a -> Parse a
label String
"type-table size" (Record -> LookupField Int
forall a. Record -> LookupField a
parseField Record
r Int
0 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric)

  -- verify that the type table hasn't been set already
  Bool
isEmpty <- Parse Bool
isTypeTableEmpty
  Bool -> Parse () -> Parse ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isEmpty (String -> Parse ()
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Multiple TYPE_BLOCKs found!")

  -- resolve the type table, and the type symbol table
  [Maybe (PType, Maybe Ident)]
tys <- (Entry -> Parse (Maybe (PType, Maybe Ident)))
-> [Entry] -> Parse [Maybe (PType, Maybe Ident)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Entry -> Parse (Maybe (PType, Maybe Ident))
parseTypeBlockEntry [Entry]
ents
  [String]
cxt <- Parse [String]
getContext
  let (TypeTable
tt,TypeSymtab
sym) = [String] -> [(PType, Maybe Ident)] -> (TypeTable, TypeSymtab)
deriveTypeTables [String]
cxt ([Maybe (PType, Maybe Ident)] -> [(PType, Maybe Ident)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (PType, Maybe Ident)]
tys)
  TypeTable -> Parse ()
setTypeTable TypeTable
tt
  TypeSymtab -> Parse TypeSymtab
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return TypeSymtab
sym

deriveTypeTables :: [String] -> [(PType,Maybe Ident)] -> (TypeTable,TypeSymtab)
deriveTypeTables :: [String] -> [(PType, Maybe Ident)] -> (TypeTable, TypeSymtab)
deriveTypeTables [String]
cxt [(PType, Maybe Ident)]
tys = (TypeTable
tt,TypeSymtab
sym)
  where
  ixs :: [(Int, (PType, Maybe Ident))]
ixs = [Int] -> [(PType, Maybe Ident)] -> [(Int, (PType, Maybe Ident))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [(PType, Maybe Ident)]
tys

  -- symbol table entries aren't very common
  sym :: TypeSymtab
sym = (TypeSymtab -> (Int, (PType, Maybe Ident)) -> TypeSymtab)
-> TypeSymtab -> [(Int, (PType, Maybe Ident))] -> TypeSymtab
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeSymtab -> (Int, (PType, Maybe Ident)) -> TypeSymtab
forall {a}. TypeSymtab -> (Int, (a, Maybe Ident)) -> TypeSymtab
mkSym TypeSymtab
forall a. Monoid a => a
mempty [(Int, (PType, Maybe Ident))]
ixs
  mkSym :: TypeSymtab -> (Int, (a, Maybe Ident)) -> TypeSymtab
mkSym TypeSymtab
sym' (Int
ix,(a
_,Maybe Ident
mb)) = case Maybe Ident
mb of
    Maybe Ident
Nothing    -> TypeSymtab
sym'
    Just Ident
alias -> Int -> Ident -> TypeSymtab -> TypeSymtab
addTypeSymbol Int
ix Ident
alias TypeSymtab
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 :: TypeTable
tt = [(Int, Type)] -> TypeTable
forall a. [(Int, a)] -> IntMap a
IntMap.fromList [ (Int
ix, (Int -> Type) -> PType -> Type
forall a b. (a -> Type' b) -> Type' a -> Type' b
updateAliases Int -> Type
resolve PType
ty) | (Int
ix, (PType
ty, Maybe Ident
_)) <- [(Int, (PType, Maybe Ident))]
ixs ]
  resolve :: Int -> Type
resolve Int
ix = case Int -> IntMap Ident -> Maybe Ident
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
ix (TypeSymtab -> IntMap Ident
tsById TypeSymtab
sym) of
    Maybe Ident
Nothing    -> HasCallStack => [String] -> Int -> TypeTable -> Type
[String] -> Int -> TypeTable -> Type
lookupTypeRef [String]
cxt Int
ix TypeTable
tt
    Just Ident
ident -> Ident -> Type
forall ident. ident -> Type' ident
Alias Ident
ident


type PType = Type' Int

type ParseType = Parse (Maybe (PType,Maybe Ident))

typeRef :: Match Field PType
typeRef :: Match Field PType
typeRef  = PType -> Maybe PType
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (PType -> Maybe PType) -> (Int -> PType) -> Int -> Maybe PType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> PType
forall ident. ident -> Type' ident
Alias (Int -> Maybe PType) -> Match Field Int -> Match Field PType
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric

-- | Parsing the type table will only ever effect internal state.
parseTypeBlockEntry :: Entry -> ParseType

parseTypeBlockEntry :: Entry -> Parse (Maybe (PType, Maybe Ident))
parseTypeBlockEntry (Match Entry Record
fromEntry -> Just Record
r) = case Record -> Int
recordCode Record
r of

  Int
1 -> String
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a. String -> Parse a -> Parse a
label String
"TYPE_CODE_NUMENTRY" Parse (Maybe (PType, Maybe Ident))
noType

  Int
2 -> String
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a. String -> Parse a -> Parse a
label String
"TYPE_CODE_VOID" (PType -> Parse (Maybe (PType, Maybe Ident))
addType (PrimType -> PType
forall ident. PrimType -> Type' ident
PrimType PrimType
Void))

  Int
3 -> String
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a. String -> Parse a -> Parse a
label String
"TYPE_CODE_FLOAT" (PType -> Parse (Maybe (PType, Maybe Ident))
addType (PrimType -> PType
forall ident. PrimType -> Type' ident
PrimType (FloatType -> PrimType
FloatType FloatType
Float)))

  Int
4 -> String
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a. String -> Parse a -> Parse a
label String
"TYPE_CODE_DOUBLE" (PType -> Parse (Maybe (PType, Maybe Ident))
addType (PrimType -> PType
forall ident. PrimType -> Type' ident
PrimType (FloatType -> PrimType
FloatType FloatType
Double)))

  Int
5 -> String
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a. String -> Parse a -> Parse a
label String
"TYPE_CODE_LABEL" (PType -> Parse (Maybe (PType, Maybe Ident))
addType (PrimType -> PType
forall ident. PrimType -> Type' ident
PrimType PrimType
Label))

  Int
6 -> String
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a. String -> Parse a -> Parse a
label String
"TYPE_CODE_OPAQUE" (Parse (Maybe (PType, Maybe Ident))
 -> Parse (Maybe (PType, Maybe Ident)))
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a b. (a -> b) -> a -> b
$ do
    do Ident
ident    <- Parse Ident
getTypeName
       PType -> Ident -> Parse (Maybe (PType, Maybe Ident))
addTypeWithAlias PType
forall ident. Type' ident
Opaque Ident
ident

  Int
7 -> String
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a. String -> Parse a -> Parse a
label String
"TYPE_CODE_INTEGER" (Parse (Maybe (PType, Maybe Ident))
 -> Parse (Maybe (PType, Maybe Ident)))
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a b. (a -> b) -> a -> b
$ do
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    Word32
width <- LookupField Word32
forall {a}. LookupField a
field Int
0 Match Field Word32
forall a. (Num a, Bits a) => Match Field a
numeric
    PType -> Parse (Maybe (PType, Maybe Ident))
addType (PrimType -> PType
forall ident. PrimType -> Type' ident
PrimType (Word32 -> PrimType
Integer Word32
width))

  Int
8 -> String
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a. String -> Parse a -> Parse a
label String
"TYPE_CODE_POINTER" (Parse (Maybe (PType, Maybe Ident))
 -> Parse (Maybe (PType, Maybe Ident)))
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a b. (a -> b) -> a -> b
$ do
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    PType
ty <- LookupField PType
forall {a}. LookupField a
field Int
0 Match Field PType
typeRef
    Bool -> Parse () -> Parse ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Field] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Record -> [Field]
recordFields Record
r) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2) (Parse () -> Parse ()) -> Parse () -> Parse ()
forall a b. (a -> b) -> a -> b
$ do
      -- We do not currently store address spaces in the @llvm-pretty@ AST.
      Field
_space <- LookupField Field
forall {a}. LookupField a
field Int
1 Match Field Field
forall a. a -> Maybe a
keep
      () -> Parse ()
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    PType -> Parse (Maybe (PType, Maybe Ident))
addType (PType -> PType
forall ident. Type' ident -> Type' ident
PtrTo PType
ty)

  -- [vararg, attrid, [retty, paramty x N]]
  Int
9 -> String
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a. String -> Parse a -> Parse a
label String
"TYPE_CODE_FUNCTION_OLD" (Parse (Maybe (PType, Maybe Ident))
 -> Parse (Maybe (PType, Maybe Ident)))
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a b. (a -> b) -> a -> b
$ do
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    Bool
va  <- LookupField Bool
forall {a}. LookupField a
field Int
0 Match Field Bool
boolean
    [PType]
tys <- LookupField [PType]
forall {a}. LookupField a
field Int
2 (Match Field PType -> Match Field [PType]
forall a. Match Field a -> Match Field [a]
fieldArray Match Field PType
typeRef)
    case [PType]
tys of
      PType
rty:[PType]
ptys -> PType -> Parse (Maybe (PType, Maybe Ident))
addType (PType -> [PType] -> Bool -> PType
forall ident. Type' ident -> [Type' ident] -> Bool -> Type' ident
FunTy PType
rty [PType]
ptys Bool
va)
      [PType]
_        -> String -> Parse (Maybe (PType, Maybe Ident))
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"function expects a return type"

  Int
10 -> String
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a. String -> Parse a -> Parse a
label String
"TYPE_CODE_FP_HALF" (PType -> Parse (Maybe (PType, Maybe Ident))
addType (PrimType -> PType
forall ident. PrimType -> Type' ident
PrimType (FloatType -> PrimType
FloatType FloatType
Half)))

  Int
11 -> String
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a. String -> Parse a -> Parse a
label String
"TYPE_CODE_ARRAY" (Parse (Maybe (PType, Maybe Ident))
 -> Parse (Maybe (PType, Maybe Ident)))
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a b. (a -> b) -> a -> b
$ do
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    Word64
numelts <- LookupField Word64
forall {a}. LookupField a
field Int
0 Match Field Word64
forall a. (Num a, Bits a) => Match Field a
numeric
    PType
eltty   <- LookupField PType
forall {a}. LookupField a
field Int
1 Match Field PType
typeRef
    PType -> Parse (Maybe (PType, Maybe Ident))
addType (Word64 -> PType -> PType
forall ident. Word64 -> Type' ident -> Type' ident
Array Word64
numelts PType
eltty)

  Int
12 -> String
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a. String -> Parse a -> Parse a
label String
"TYPE_CODE_VECTOR" (Parse (Maybe (PType, Maybe Ident))
 -> Parse (Maybe (PType, Maybe Ident)))
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a b. (a -> b) -> a -> b
$ do
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    Word64
numelts <- LookupField Word64
forall {a}. LookupField a
field Int
0 Match Field Word64
forall a. (Num a, Bits a) => Match Field a
numeric
    PType
eltty   <- LookupField PType
forall {a}. LookupField a
field Int
1 Match Field PType
typeRef
    PType -> Parse (Maybe (PType, Maybe Ident))
addType (Word64 -> PType -> PType
forall ident. Word64 -> Type' ident -> Type' ident
Vector Word64
numelts PType
eltty)

  Int
13 -> String
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a. String -> Parse a -> Parse a
label String
"TYPE_CODE_X86_FP80" (PType -> Parse (Maybe (PType, Maybe Ident))
addType (PrimType -> PType
forall ident. PrimType -> Type' ident
PrimType (FloatType -> PrimType
FloatType FloatType
X86_fp80)))

  Int
14 -> String
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a. String -> Parse a -> Parse a
label String
"TYPE_CODE_FP128" (PType -> Parse (Maybe (PType, Maybe Ident))
addType (PrimType -> PType
forall ident. PrimType -> Type' ident
PrimType (FloatType -> PrimType
FloatType FloatType
Fp128)))

  Int
15 -> String
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a. String -> Parse a -> Parse a
label String
"TYPE_CODE_PPC_FP128" (PType -> Parse (Maybe (PType, Maybe Ident))
addType (PrimType -> PType
forall ident. PrimType -> Type' ident
PrimType (FloatType -> PrimType
FloatType FloatType
PPC_fp128)))

  Int
16 -> String
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a. String -> Parse a -> Parse a
label String
"TYPE_CODE_METADATA" (PType -> Parse (Maybe (PType, Maybe Ident))
addType (PrimType -> PType
forall ident. PrimType -> Type' ident
PrimType PrimType
Metadata))

  Int
17 -> String
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a. String -> Parse a -> Parse a
label String
"TYPE_CODE_X86_MMX" (PType -> Parse (Maybe (PType, Maybe Ident))
addType (PrimType -> PType
forall ident. PrimType -> Type' ident
PrimType PrimType
X86mmx))

  -- [ispacked, eltty x N]
  Int
18 -> String
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a. String -> Parse a -> Parse a
label String
"TYPE_CODE_STRUCT_ANON" (Parse (Maybe (PType, Maybe Ident))
 -> Parse (Maybe (PType, Maybe Ident)))
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a b. (a -> b) -> a -> b
$ do
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    Bool
ispacked <- String -> Parse Bool -> Parse Bool
forall a. String -> Parse a -> Parse a
label String
"is packed"     (LookupField Bool
forall {a}. LookupField a
field Int
0 Match Field Bool
boolean)
    [PType]
tys      <- String -> Parse [PType] -> Parse [PType]
forall a. String -> Parse a -> Parse a
label String
"struct fields" (LookupField [PType]
forall {a}. LookupField a
field Int
1 (Match Field PType -> Match Field [PType]
forall a. Match Field a -> Match Field [a]
fieldArray Match Field PType
typeRef))
    if Bool
ispacked
       then PType -> Parse (Maybe (PType, Maybe Ident))
addType ([PType] -> PType
forall ident. [Type' ident] -> Type' ident
PackedStruct [PType]
tys)
       else PType -> Parse (Maybe (PType, Maybe Ident))
addType ([PType] -> PType
forall ident. [Type' ident] -> Type' ident
Struct [PType]
tys)

  Int
19 -> String
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a. String -> Parse a -> Parse a
label String
"TYPE_CODE_STRUCT_NAME" (Parse (Maybe (PType, Maybe Ident))
 -> Parse (Maybe (PType, Maybe Ident)))
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a b. (a -> b) -> a -> b
$ do
    String
name <- String -> Parse String -> Parse String
forall a. String -> Parse a -> Parse a
label String
"struct name" (Parse String -> Parse String) -> Parse String -> Parse String
forall a b. (a -> b) -> a -> b
$ Record -> LookupField String
forall a. Record -> LookupField a
parseField Record
r Int
0 Match Field String
cstring
        Parse String -> Parse String -> Parse String
forall a. Parse a -> Parse a -> Parse a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` ([Word8] -> String) -> Parse [Word8] -> Parse String
forall a b. (a -> b) -> Parse a -> Parse b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Word8] -> String
UTF8.decode (Record -> Int -> Match Field Word8 -> Parse [Word8]
forall a. Record -> Int -> Match Field a -> Parse [a]
parseFields Record
r Int
0 Match Field Word8
char)
    String -> Parse ()
setTypeName String
name
    Parse (Maybe (PType, Maybe Ident))
noType

  -- [ispacked, eltty x N]
  Int
20 -> String
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a. String -> Parse a -> Parse a
label String
"TYPE_CODE_STRUCT_NAMED" (Parse (Maybe (PType, Maybe Ident))
 -> Parse (Maybe (PType, Maybe Ident)))
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a b. (a -> b) -> a -> b
$ do
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r

    Ident
ident    <- Parse Ident
getTypeName
    Bool
ispacked <- String -> Parse Bool -> Parse Bool
forall a. String -> Parse a -> Parse a
label String
"ispacked"      (LookupField Bool
forall {a}. LookupField a
field Int
0 Match Field Bool
boolean)
    [PType]
tys      <- String -> Parse [PType] -> Parse [PType]
forall a. String -> Parse a -> Parse a
label String
"element types" (LookupField [PType]
forall {a}. LookupField a
field Int
1 (Match Field PType -> Match Field [PType]
forall a. Match Field a -> Match Field [a]
fieldArray Match Field PType
typeRef))
    if Bool
ispacked
       then PType -> Ident -> Parse (Maybe (PType, Maybe Ident))
addTypeWithAlias ([PType] -> PType
forall ident. [Type' ident] -> Type' ident
PackedStruct [PType]
tys) Ident
ident
       else PType -> Ident -> Parse (Maybe (PType, Maybe Ident))
addTypeWithAlias ([PType] -> PType
forall ident. [Type' ident] -> Type' ident
Struct [PType]
tys) Ident
ident

  -- [vararg, [retty, paramty x N]]
  Int
21 -> String
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a. String -> Parse a -> Parse a
label String
"TYPE_CODE_FUNCTION" (Parse (Maybe (PType, Maybe Ident))
 -> Parse (Maybe (PType, Maybe Ident)))
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a b. (a -> b) -> a -> b
$ do
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    Bool
vararg <- String -> Parse Bool -> Parse Bool
forall a. String -> Parse a -> Parse a
label String
"vararg"     (LookupField Bool
forall {a}. LookupField a
field Int
0 Match Field Bool
boolean)
    [PType]
tys    <- String -> Parse [PType] -> Parse [PType]
forall a. String -> Parse a -> Parse a
label String
"parameters" (LookupField [PType]
forall {a}. LookupField a
field Int
1 (Match Field PType -> Match Field [PType]
forall a. Match Field a -> Match Field [a]
fieldArray Match Field PType
typeRef))
    case [PType]
tys of
      PType
rty:[PType]
ptys -> PType -> Parse (Maybe (PType, Maybe Ident))
addType (PType -> [PType] -> Bool -> PType
forall ident. Type' ident -> [Type' ident] -> Bool -> Type' ident
FunTy PType
rty [PType]
ptys Bool
vararg)
      []       -> String -> Parse (Maybe (PType, Maybe Ident))
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"function expects a return type"

  Int
22 -> String
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a. String -> Parse a -> Parse a
label String
"TYPE_CODE_TOKEN" (Parse (Maybe (PType, Maybe Ident))
 -> Parse (Maybe (PType, Maybe Ident)))
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a b. (a -> b) -> a -> b
$ do
    Parse (Maybe (PType, Maybe Ident))
forall a. Parse a
notImplemented

  Int
23 -> String
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a. String -> Parse a -> Parse a
label String
"TYPE_CODE_BFLOAT" (Parse (Maybe (PType, Maybe Ident))
 -> Parse (Maybe (PType, Maybe Ident)))
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a b. (a -> b) -> a -> b
$ do
    Parse (Maybe (PType, Maybe Ident))
forall a. Parse a
notImplemented

  Int
24 -> String
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a. String -> Parse a -> Parse a
label String
"TYPE_CODE_X86_AMX" (Parse (Maybe (PType, Maybe Ident))
 -> Parse (Maybe (PType, Maybe Ident)))
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a b. (a -> b) -> a -> b
$ do
    Parse (Maybe (PType, Maybe Ident))
forall a. Parse a
notImplemented

  Int
25 -> String
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a. String -> Parse a -> Parse a
label String
"TYPE_CODE_OPAQUE_POINTER" (Parse (Maybe (PType, Maybe Ident))
 -> Parse (Maybe (PType, Maybe Ident)))
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a b. (a -> b) -> a -> b
$ do
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    Bool -> Parse () -> Parse ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Field] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Record -> [Field]
recordFields Record
r) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1) (Parse () -> Parse ()) -> Parse () -> Parse ()
forall a b. (a -> b) -> a -> b
$
      String -> Parse ()
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid opaque pointer record"
    -- We do not currently store address spaces in the @llvm-pretty@ AST.
    Field
_space <- LookupField Field
forall {a}. LookupField a
field Int
0 Match Field Field
forall a. a -> Maybe a
keep
    PType -> Parse (Maybe (PType, Maybe Ident))
addType PType
forall ident. Type' ident
PtrOpaque

  Int
26 -> String
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a. String -> Parse a -> Parse a
label String
"TYPE_CODE_TARGET_TYPE" (Parse (Maybe (PType, Maybe Ident))
 -> Parse (Maybe (PType, Maybe Ident)))
-> Parse (Maybe (PType, Maybe Ident))
-> Parse (Maybe (PType, Maybe Ident))
forall a b. (a -> b) -> a -> b
$ do
    Parse (Maybe (PType, Maybe Ident))
forall a. Parse a
notImplemented

  Int
code -> String -> Int -> Parse (Maybe (PType, Maybe Ident))
forall (m :: * -> *) a b.
(MonadFail m, Show a) =>
String -> a -> m b
Assert.unknownEntity String
"type code " Int
code

-- skip blocks
parseTypeBlockEntry (Match Entry Block
block -> Just Block
_) =
  Maybe (PType, Maybe Ident) -> Parse (Maybe (PType, Maybe Ident))
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (PType, Maybe Ident)
forall a. Maybe a
Nothing

-- skip abbrevs
parseTypeBlockEntry (Match Entry DefineAbbrev
abbrevDef -> Just DefineAbbrev
_) =
  Maybe (PType, Maybe Ident) -> Parse (Maybe (PType, Maybe Ident))
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (PType, Maybe Ident)
forall a. Maybe a
Nothing

parseTypeBlockEntry Entry
e =
  String -> Parse (Maybe (PType, Maybe Ident))
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"type block: unexpected: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Entry -> String
forall a. Show a => a -> String
show Entry
e)



-- | Add a type to the type table.
addType :: PType -> ParseType
addType :: PType -> Parse (Maybe (PType, Maybe Ident))
addType PType
ty = Maybe (PType, Maybe Ident) -> Parse (Maybe (PType, Maybe Ident))
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return ((PType, Maybe Ident) -> Maybe (PType, Maybe Ident)
forall a. a -> Maybe a
Just (PType
ty,Maybe Ident
forall a. Maybe a
Nothing))

-- | Add a type and an alias to the type table
addTypeWithAlias :: PType -> Ident -> ParseType
addTypeWithAlias :: PType -> Ident -> Parse (Maybe (PType, Maybe Ident))
addTypeWithAlias PType
ty Ident
i = Maybe (PType, Maybe Ident) -> Parse (Maybe (PType, Maybe Ident))
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return ((PType, Maybe Ident) -> Maybe (PType, Maybe Ident)
forall a. a -> Maybe a
Just (PType
ty,Ident -> Maybe Ident
forall a. a -> Maybe a
Just Ident
i))

-- | Return no type for addition to the type table
noType :: ParseType
noType :: Parse (Maybe (PType, Maybe Ident))
noType  = Maybe (PType, Maybe Ident) -> Parse (Maybe (PType, Maybe Ident))
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (PType, Maybe Ident)
forall a. Maybe a
Nothing