{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

module Data.LLVM.BitCode.IR.Function where

import qualified Data.LLVM.BitCode.Assert as Assert
import           Data.LLVM.BitCode.Bitstream
import           Data.LLVM.BitCode.IR.Blocks
import           Data.LLVM.BitCode.IR.Constants
import           Data.LLVM.BitCode.IR.Metadata
import           Data.LLVM.BitCode.IR.Values
import           Data.LLVM.BitCode.IR.Attrs
import           Data.LLVM.BitCode.Match
import           Data.LLVM.BitCode.Parse
import           Data.LLVM.BitCode.Record

import           Text.LLVM.AST
import           Text.LLVM.Labels
import           Text.LLVM.PP

import           Control.Monad (when,unless,mplus,mzero,foldM,(<=<))
import           Data.Bits (shiftR,bit,shiftL,testBit,(.&.),(.|.),complement,Bits)
import           Data.Int (Int32)
import           Data.Word (Word32)
import qualified Data.Foldable as F
import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
import qualified Data.Sequence as Seq
import qualified Data.Traversable as T


-- | When showing a Symbol to the user, show it in the manner that it would appear
-- in LLVM text format.  This displays the Symbol in the format associated with
-- the latest version of LLVM supported by llvm-pretty and this library; the
-- Symbol syntax has not changed from LLVM 3.5 through LLVM 16, and this library
-- is intended to be able to import *any* version of LLVM, so this is not a
-- significant issue that would drive the code changes necessary to make an
-- actual LLVM version available here.

-- NOTE: this cannot be eta-reduced to point-free format because simplified
-- subsumption rules (introduced in GHC 9) requires eta-expansion of some higher
-- order functions in order to maintain soundness and typecheck.
prettySym :: Symbol -> String
prettySym :: Symbol -> KindMd
prettySym Symbol
s = Doc -> KindMd
forall a. Show a => a -> KindMd
show (Doc -> KindMd) -> Doc -> KindMd
forall a b. (a -> b) -> a -> b
$ Int -> ((?config::Config) => Doc) -> Doc
forall a. Int -> ((?config::Config) => a) -> a
ppLLVM Int
llvmVlatest (((?config::Config) => Doc) -> Doc)
-> ((?config::Config) => Doc) -> Doc
forall a b. (a -> b) -> a -> b
$ Symbol -> Doc
forall a. LLVMPretty a => Fmt a
llvmPP Symbol
s


-- Function Aliases ------------------------------------------------------------

type AliasList = Seq.Seq PartialAlias

data PartialAlias = PartialAlias
  { PartialAlias -> Maybe Linkage
paLinkage    :: Maybe Linkage
  , PartialAlias -> Maybe Visibility
paVisibility :: Maybe Visibility
  , PartialAlias -> Symbol
paName       :: Symbol
  , PartialAlias -> Type' Ident
paType       :: Type
  , PartialAlias -> Word32
paTarget     :: !Word32
  } deriving Int -> PartialAlias -> ShowS
[PartialAlias] -> ShowS
PartialAlias -> KindMd
(Int -> PartialAlias -> ShowS)
-> (PartialAlias -> KindMd)
-> ([PartialAlias] -> ShowS)
-> Show PartialAlias
forall a.
(Int -> a -> ShowS) -> (a -> KindMd) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PartialAlias -> ShowS
showsPrec :: Int -> PartialAlias -> ShowS
$cshow :: PartialAlias -> KindMd
show :: PartialAlias -> KindMd
$cshowList :: [PartialAlias] -> ShowS
showList :: [PartialAlias] -> ShowS
Show

parseAliasOld :: Int -> Record -> Parse PartialAlias
parseAliasOld :: Int -> Record -> Parse PartialAlias
parseAliasOld Int
n Record
r = do
  KindMd
sym <- Int -> Parse KindMd
entryName Int
n
  let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
      name :: Symbol
name = KindMd -> Symbol
Symbol KindMd
sym
  Type' Ident
ty  <- Int -> Parse (Type' Ident)
getType   (Int -> Parse (Type' Ident)) -> Parse Int -> Parse (Type' Ident)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field Int
0 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
  Word32
tgt <-               LookupField Word32
forall {a}. LookupField a
field Int
1 Match Field Word32
forall a. (Num a, Bits a) => Match Field a
numeric
  Linkage
lnk <-               LookupField Linkage
forall {a}. LookupField a
field Int
2 Match Field Linkage
linkage
  Visibility
vis <-               LookupField Visibility
forall {a}. LookupField a
field Int
3 Match Field Visibility
visibility
  Int
_   <- Typed PValue -> Parse Int
pushValue (Type' Ident -> PValue -> Typed PValue
forall a. Type' Ident -> a -> Typed a
Typed Type' Ident
ty (Symbol -> PValue
forall lab. Symbol -> Value' lab
ValSymbol Symbol
name))
  PartialAlias -> Parse PartialAlias
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialAlias
    { paLinkage :: Maybe Linkage
paLinkage    = Linkage -> Maybe Linkage
forall a. a -> Maybe a
Just Linkage
lnk
    , paVisibility :: Maybe Visibility
paVisibility = Visibility -> Maybe Visibility
forall a. a -> Maybe a
Just Visibility
vis
    , paName :: Symbol
paName       = Symbol
name
    , paType :: Type' Ident
paType       = Type' Ident
ty
    , paTarget :: Word32
paTarget     = Word32
tgt
    }

parseAlias :: Record -> Parse PartialAlias
parseAlias :: Record -> Parse PartialAlias
parseAlias Record
r = do
  Int
n <- Parse Int
nextValueId
  (Symbol
name, Int
offset) <- Int -> Record -> Parse (Symbol, Int)
oldOrStrtabName Int
n Record
r
  let field :: Int -> Match Field a -> Parse a
field Int
i = Record -> Int -> Match Field a -> Parse a
forall a. Record -> LookupField a
parseField Record
r (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
offset)
  Type' Ident
ty       <- Int -> Parse (Type' Ident)
getType (Int -> Parse (Type' Ident)) -> Parse Int -> Parse (Type' Ident)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field Int
0 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
  Word32
_addrSp  <-             LookupField Word32
forall {a}. LookupField a
field Int
1 Match Field Word32
unsigned
  Word32
tgt      <-             LookupField Word32
forall {a}. LookupField a
field Int
2 Match Field Word32
forall a. (Num a, Bits a) => Match Field a
numeric
  Linkage
lnk      <-             LookupField Linkage
forall {a}. LookupField a
field Int
3 Match Field Linkage
linkage
  Visibility
vis      <-             LookupField Visibility
forall {a}. LookupField a
field Int
4 Match Field Visibility
visibility


  -- XXX: is it the case that the alias type will always be a pointer to the
  -- aliasee?
  Int
_   <- Typed PValue -> Parse Int
pushValue (Type' Ident -> PValue -> Typed PValue
forall a. Type' Ident -> a -> Typed a
Typed (Type' Ident -> Type' Ident
forall ident. Type' ident -> Type' ident
PtrTo Type' Ident
ty) (Symbol -> PValue
forall lab. Symbol -> Value' lab
ValSymbol Symbol
name))

  PartialAlias -> Parse PartialAlias
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialAlias
    { paLinkage :: Maybe Linkage
paLinkage    = Linkage -> Maybe Linkage
forall a. a -> Maybe a
Just Linkage
lnk
    , paVisibility :: Maybe Visibility
paVisibility = Visibility -> Maybe Visibility
forall a. a -> Maybe a
Just Visibility
vis
    , paName :: Symbol
paName       = Symbol
name
    , paType :: Type' Ident
paType       = Type' Ident
ty
    , paTarget :: Word32
paTarget     = Word32
tgt
    }

finalizePartialAlias :: PartialAlias -> Parse GlobalAlias
finalizePartialAlias :: PartialAlias -> Parse GlobalAlias
finalizePartialAlias PartialAlias
pa = KindMd -> Parse GlobalAlias -> Parse GlobalAlias
forall a. KindMd -> Parse a -> Parse a
label KindMd
"finalizePartialAlias" (Parse GlobalAlias -> Parse GlobalAlias)
-> Parse GlobalAlias -> Parse GlobalAlias
forall a b. (a -> b) -> a -> b
$ do
  -- aliases refer to absolute offsets
  Typed PValue
tv  <- Type' Ident -> Int -> Parse (Typed PValue)
getFnValueById (PartialAlias -> Type' Ident
paType PartialAlias
pa) (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PartialAlias -> Word32
paTarget PartialAlias
pa))
  Value' BlockLabel
tgt <- Finalize (Value' BlockLabel) -> Parse (Value' BlockLabel)
forall a. Finalize a -> Parse a
liftFinalize (Finalize (Value' BlockLabel) -> Parse (Value' BlockLabel))
-> Finalize (Value' BlockLabel) -> Parse (Value' BlockLabel)
forall a b. (a -> b) -> a -> b
$ (Maybe Symbol -> Int -> Finalize BlockLabel)
-> PValue -> Finalize (Value' BlockLabel)
forall (f :: * -> *) (m :: * -> *) a b.
(HasLabel f, Applicative m) =>
(Maybe Symbol -> a -> m b) -> f a -> m (f b)
forall (m :: * -> *) a b.
Applicative m =>
(Maybe Symbol -> a -> m b) -> Value' a -> m (Value' b)
relabel ((Int -> Finalize BlockLabel)
-> Maybe Symbol -> Int -> Finalize BlockLabel
forall a b. a -> b -> a
const Int -> Finalize BlockLabel
requireBbEntryName) (Typed PValue -> PValue
forall a. Typed a -> a
typedValue Typed PValue
tv)
  GlobalAlias -> Parse GlobalAlias
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return GlobalAlias
    { aliasLinkage :: Maybe Linkage
aliasLinkage    = PartialAlias -> Maybe Linkage
paLinkage PartialAlias
pa
    , aliasVisibility :: Maybe Visibility
aliasVisibility = PartialAlias -> Maybe Visibility
paVisibility PartialAlias
pa
    , aliasName :: Symbol
aliasName       = PartialAlias -> Symbol
paName PartialAlias
pa
    , aliasType :: Type' Ident
aliasType       = PartialAlias -> Type' Ident
paType PartialAlias
pa
    , aliasTarget :: Value' BlockLabel
aliasTarget     = Value' BlockLabel
tgt
    }


-- Function Attribute Record ---------------------------------------------------

type DeclareList = Seq.Seq FunProto

-- | Turn a function prototype into a declaration.
finalizeDeclare :: FunProto -> Parse Declare
finalizeDeclare :: FunProto -> Parse Declare
finalizeDeclare FunProto
fp = case FunProto -> Type' Ident
protoType FunProto
fp of
  PtrTo (FunTy Type' Ident
ret [Type' Ident]
args Bool
va) -> Declare -> Parse Declare
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Declare
    { decLinkage :: Maybe Linkage
decLinkage    = FunProto -> Maybe Linkage
protoLinkage FunProto
fp
    , decVisibility :: Maybe Visibility
decVisibility = FunProto -> Maybe Visibility
protoVisibility FunProto
fp
    , decRetType :: Type' Ident
decRetType    = Type' Ident
ret
    , decName :: Symbol
decName       = FunProto -> Symbol
protoSym FunProto
fp
    , decArgs :: [Type' Ident]
decArgs       = [Type' Ident]
args
    , decVarArgs :: Bool
decVarArgs    = Bool
va
    , decAttrs :: [FunAttr]
decAttrs      = []
    , decComdat :: Maybe KindMd
decComdat     = FunProto -> Maybe KindMd
protoComdat FunProto
fp
    }
  Type' Ident
_ -> KindMd -> Parse Declare
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail KindMd
"invalid type on function prototype"


-- Function Body ---------------------------------------------------------------

type DefineList = Seq.Seq PartialDefine

-- | A define with a list of statements for a body, instead of a list of basic
-- bocks.
data PartialDefine = PartialDefine
  { PartialDefine -> Maybe Linkage
partialLinkage    :: Maybe Linkage
  , PartialDefine -> Maybe Visibility
partialVisibility :: Maybe Visibility
  , PartialDefine -> Maybe GC
partialGC         :: Maybe GC
  , PartialDefine -> Maybe KindMd
partialSection    :: Maybe String
  , PartialDefine -> Type' Ident
partialRetType    :: Type
  , PartialDefine -> Symbol
partialName       :: Symbol
  , PartialDefine -> [Typed Ident]
partialArgs       :: [Typed Ident]
  , PartialDefine -> Bool
partialVarArgs    :: Bool
  , PartialDefine -> BlockList
partialBody       :: BlockList
  , PartialDefine -> StmtList
partialBlock      :: StmtList
  , PartialDefine -> Int
partialBlockId    :: !Int
  , PartialDefine -> ValueSymtab
partialSymtab     :: ValueSymtab
  , PartialDefine -> Map Int PValMd
partialMetadata   :: Map.Map PKindMd PValMd
  , PartialDefine -> Seq PartialUnnamedMd
partialGlobalMd   :: !(Seq.Seq PartialUnnamedMd)
  , PartialDefine -> Maybe KindMd
partialComdatName :: Maybe String
  } deriving Int -> PartialDefine -> ShowS
[PartialDefine] -> ShowS
PartialDefine -> KindMd
(Int -> PartialDefine -> ShowS)
-> (PartialDefine -> KindMd)
-> ([PartialDefine] -> ShowS)
-> Show PartialDefine
forall a.
(Int -> a -> ShowS) -> (a -> KindMd) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PartialDefine -> ShowS
showsPrec :: Int -> PartialDefine -> ShowS
$cshow :: PartialDefine -> KindMd
show :: PartialDefine -> KindMd
$cshowList :: [PartialDefine] -> ShowS
showList :: [PartialDefine] -> ShowS
Show

-- | Generate a partial function definition from a function prototype.
emptyPartialDefine :: FunProto -> Parse PartialDefine
emptyPartialDefine :: FunProto -> Parse PartialDefine
emptyPartialDefine FunProto
proto = do
  (Type' Ident
rty,[Type' Ident]
tys,Bool
va) <- Type' Ident -> Parse (Type' Ident, [Type' Ident], Bool)
forall (m :: * -> *).
MonadPlus m =>
Type' Ident -> m (Type' Ident, [Type' Ident], Bool)
elimFunPtr (FunProto -> Type' Ident
protoType FunProto
proto)
      Parse (Type' Ident, [Type' Ident], Bool)
-> Parse (Type' Ident, [Type' Ident], Bool)
-> Parse (Type' Ident, [Type' Ident], Bool)
forall a. Parse a -> Parse a -> Parse a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` KindMd -> Parse (Type' Ident, [Type' Ident], Bool)
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail KindMd
"invalid function type in prototype"
  [Ident]
names <- (Type' Ident -> Parse Ident) -> [Type' Ident] -> Parse [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 Type' Ident -> Parse Ident
nameNextValue [Type' Ident]
tys

  ValueSymtab
symtab <- Parse ValueSymtab
initialPartialSymtab

  PartialDefine -> Parse PartialDefine
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialDefine
    { partialLinkage :: Maybe Linkage
partialLinkage    = FunProto -> Maybe Linkage
protoLinkage FunProto
proto
    , partialVisibility :: Maybe Visibility
partialVisibility = FunProto -> Maybe Visibility
protoVisibility FunProto
proto
    , partialGC :: Maybe GC
partialGC         = FunProto -> Maybe GC
protoGC FunProto
proto
    , partialSection :: Maybe KindMd
partialSection    = FunProto -> Maybe KindMd
protoSect FunProto
proto
    , partialRetType :: Type' Ident
partialRetType    = Type' Ident
rty
    , partialName :: Symbol
partialName       = FunProto -> Symbol
protoSym FunProto
proto
    , partialArgs :: [Typed Ident]
partialArgs       = (Type' Ident -> Ident -> Typed Ident)
-> [Type' Ident] -> [Ident] -> [Typed Ident]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Type' Ident -> Ident -> Typed Ident
forall a. Type' Ident -> a -> Typed a
Typed [Type' Ident]
tys [Ident]
names
    , partialVarArgs :: Bool
partialVarArgs    = Bool
va
    , partialBody :: BlockList
partialBody       = BlockList
forall a. Monoid a => a
mempty
    , partialBlock :: StmtList
partialBlock      = StmtList
forall a. Monoid a => a
mempty
    , partialBlockId :: Int
partialBlockId    = Int
0
    , partialSymtab :: ValueSymtab
partialSymtab     = ValueSymtab
symtab
    , partialMetadata :: Map Int PValMd
partialMetadata   = Map Int PValMd
forall a. Monoid a => a
mempty
    , partialGlobalMd :: Seq PartialUnnamedMd
partialGlobalMd   = Seq PartialUnnamedMd
forall a. Monoid a => a
mempty
    , partialComdatName :: Maybe KindMd
partialComdatName = FunProto -> Maybe KindMd
protoComdat FunProto
proto
    }

-- | Set the statement list in a partial define.
setPartialBlock :: StmtList -> PartialDefine -> PartialDefine
setPartialBlock :: StmtList -> PartialDefine -> PartialDefine
setPartialBlock StmtList
stmts PartialDefine
pd = PartialDefine
pd { partialBlock = stmts }

-- | Set the block list in a partial define.
setPartialBody :: BlockList -> PartialDefine -> PartialDefine
setPartialBody :: BlockList -> PartialDefine -> PartialDefine
setPartialBody BlockList
blocks PartialDefine
pd = PartialDefine
pd { partialBody = blocks }

initialPartialSymtab :: Parse ValueSymtab
initialPartialSymtab :: Parse ValueSymtab
initialPartialSymtab  = do
  Maybe BlockLabel
mb <- Finalize (Maybe BlockLabel) -> Parse (Maybe BlockLabel)
forall a. Finalize a -> Parse a
liftFinalize (Finalize (Maybe BlockLabel) -> Parse (Maybe BlockLabel))
-> Finalize (Maybe BlockLabel) -> Parse (Maybe BlockLabel)
forall a b. (a -> b) -> a -> b
$ Int -> Finalize (Maybe BlockLabel)
bbEntryName Int
0
  case Maybe BlockLabel
mb of
    Just{}  -> ValueSymtab -> Parse ValueSymtab
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return ValueSymtab
emptyValueSymtab
    Maybe BlockLabel
Nothing -> do
      Int
i <- Parse Int
nextResultId
      ValueSymtab -> Parse ValueSymtab
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> ValueSymtab -> ValueSymtab
addBBAnon Int
0 Int
i ValueSymtab
emptyValueSymtab)

updateLastStmt :: (PStmt -> PStmt) -> PartialDefine -> Parse PartialDefine
updateLastStmt :: (Stmt' Int -> Stmt' Int) -> PartialDefine -> Parse PartialDefine
updateLastStmt Stmt' Int -> Stmt' Int
f PartialDefine
pd = case Maybe PartialDefine
updatePartialBlock Maybe PartialDefine -> Maybe PartialDefine -> Maybe PartialDefine
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe PartialDefine
updatePartialBody of
  Just PartialDefine
pd' -> PartialDefine -> Parse PartialDefine
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialDefine
pd'
  Maybe PartialDefine
Nothing  -> KindMd -> Parse PartialDefine
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail KindMd
"No statement to update"
  where
  updatePartialBlock :: Maybe PartialDefine
updatePartialBlock = (PartialDefine -> StmtList)
-> (StmtList -> PartialDefine -> PartialDefine)
-> PartialDefine
-> Maybe PartialDefine
forall {m :: * -> *} {t} {a}.
MonadPlus m =>
(t -> StmtList) -> (StmtList -> t -> a) -> t -> m a
updateStmts PartialDefine -> StmtList
partialBlock StmtList -> PartialDefine -> PartialDefine
setPartialBlock PartialDefine
pd

  updatePartialBody :: Maybe PartialDefine
updatePartialBody = case BlockList -> ViewR PartialBlock
forall a. Seq a -> ViewR a
Seq.viewr (PartialDefine -> BlockList
partialBody PartialDefine
pd) of
    BlockList
blocks Seq.:> PartialBlock
b -> do
      PartialBlock
b' <- (PartialBlock -> StmtList)
-> (StmtList -> PartialBlock -> PartialBlock)
-> PartialBlock
-> Maybe PartialBlock
forall {m :: * -> *} {t} {a}.
MonadPlus m =>
(t -> StmtList) -> (StmtList -> t -> a) -> t -> m a
updateStmts PartialBlock -> StmtList
partialStmts StmtList -> PartialBlock -> PartialBlock
setPartialStmts PartialBlock
b
      PartialDefine -> Maybe PartialDefine
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockList -> PartialDefine -> PartialDefine
setPartialBody (BlockList
blocks BlockList -> PartialBlock -> BlockList
forall a. Seq a -> a -> Seq a
Seq.|> PartialBlock
b') PartialDefine
pd)
    ViewR PartialBlock
Seq.EmptyR          -> Maybe PartialDefine
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

  updateStmts :: (t -> StmtList) -> (StmtList -> t -> a) -> t -> m a
updateStmts t -> StmtList
prj StmtList -> t -> a
upd t
a = case StmtList -> ViewR (Stmt' Int)
forall a. Seq a -> ViewR a
Seq.viewr (t -> StmtList
prj t
a) of
    StmtList
stmts Seq.:> Stmt' Int
stmt -> a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (StmtList -> t -> a
upd (StmtList
stmts StmtList -> Stmt' Int -> StmtList
forall a. Seq a -> a -> Seq a
Seq.|> Stmt' Int -> Stmt' Int
f Stmt' Int
stmt) t
a)
    ViewR (Stmt' Int)
Seq.EmptyR        -> m a
forall a. m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero



type BlockLookup = Symbol -> Int -> Finalize BlockLabel

lookupBlockName :: DefineList -> BlockLookup
lookupBlockName :: DefineList -> BlockLookup
lookupBlockName DefineList
dl = BlockLookup
forall {m :: * -> *}. MonadFail m => Symbol -> Int -> m BlockLabel
lkp
  where
  syms :: Map Symbol ValueSymtab
syms = [(Symbol, ValueSymtab)] -> Map Symbol ValueSymtab
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (PartialDefine -> Symbol
partialName PartialDefine
d, PartialDefine -> ValueSymtab
partialSymtab PartialDefine
d) | PartialDefine
d <- DefineList -> [PartialDefine]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList DefineList
dl ]
  lkp :: Symbol -> Int -> m BlockLabel
lkp Symbol
fn Int
bid = case Symbol -> Map Symbol ValueSymtab -> Maybe ValueSymtab
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Symbol
fn Map Symbol ValueSymtab
syms of
    Maybe ValueSymtab
Nothing -> KindMd -> m BlockLabel
forall a. KindMd -> m a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail (KindMd
"symbol " KindMd -> ShowS
forall a. [a] -> [a] -> [a]
++ Symbol -> KindMd
prettySym Symbol
fn KindMd -> ShowS
forall a. [a] -> [a] -> [a]
++ KindMd
" is not defined")
    Just ValueSymtab
st -> case Int -> IntMap SymName -> Maybe SymName
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
bid (ValueSymtab -> IntMap SymName
bbSymtab ValueSymtab
st) of
      Maybe SymName
Nothing -> KindMd -> m BlockLabel
forall a. KindMd -> m a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail (KindMd
"block id " KindMd -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> KindMd
forall a. Show a => a -> KindMd
show Int
bid KindMd -> ShowS
forall a. [a] -> [a] -> [a]
++ KindMd
" does not exist")
      Just SymName
sn -> BlockLabel -> m BlockLabel
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymName -> BlockLabel
mkBlockLabel SymName
sn)

-- | Finalize a partial definition.
finalizePartialDefine :: BlockLookup -> PartialDefine -> Parse Define
finalizePartialDefine :: BlockLookup -> PartialDefine -> Parse Define
finalizePartialDefine BlockLookup
lkp PartialDefine
pd =
  KindMd -> Parse Define -> Parse Define
forall a. KindMd -> Parse a -> Parse a
label KindMd
"finalizePartialDefine" (Parse Define -> Parse Define) -> Parse Define -> Parse Define
forall a b. (a -> b) -> a -> b
$
  -- augment the symbol table with implicitly named anonymous blocks, and
  -- generate basic blocks.
  ValueSymtab -> Parse Define -> Parse Define
forall a. ValueSymtab -> Parse a -> Parse a
withValueSymtab (PartialDefine -> ValueSymtab
partialSymtab PartialDefine
pd) (Parse Define -> Parse Define) -> Parse Define -> Parse Define
forall a b. (a -> b) -> a -> b
$ do
    [BasicBlock]
body <- Finalize [BasicBlock] -> Parse [BasicBlock]
forall a. Finalize a -> Parse a
liftFinalize (Finalize [BasicBlock] -> Parse [BasicBlock])
-> Finalize [BasicBlock] -> Parse [BasicBlock]
forall a b. (a -> b) -> a -> b
$ BlockLookup -> BlockList -> Finalize [BasicBlock]
finalizeBody BlockLookup
lkp (PartialDefine -> BlockList
partialBody PartialDefine
pd)
    FnMdAttachments
md <- Map Int PValMd -> Parse FnMdAttachments
finalizeMetadata (PartialDefine -> Map Int PValMd
partialMetadata PartialDefine
pd)
    Define -> Parse Define
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Define
      { defLinkage :: Maybe Linkage
defLinkage    = PartialDefine -> Maybe Linkage
partialLinkage PartialDefine
pd
      , defVisibility :: Maybe Visibility
defVisibility = PartialDefine -> Maybe Visibility
partialVisibility PartialDefine
pd
      , defGC :: Maybe GC
defGC         = PartialDefine -> Maybe GC
partialGC PartialDefine
pd
      , defAttrs :: [FunAttr]
defAttrs      = []
      , defRetType :: Type' Ident
defRetType    = PartialDefine -> Type' Ident
partialRetType PartialDefine
pd
      , defName :: Symbol
defName       = PartialDefine -> Symbol
partialName PartialDefine
pd
      , defArgs :: [Typed Ident]
defArgs       = PartialDefine -> [Typed Ident]
partialArgs PartialDefine
pd
      , defVarArgs :: Bool
defVarArgs    = PartialDefine -> Bool
partialVarArgs PartialDefine
pd
      , defBody :: [BasicBlock]
defBody       = [BasicBlock]
body
      , defSection :: Maybe KindMd
defSection    = PartialDefine -> Maybe KindMd
partialSection PartialDefine
pd
      , defMetadata :: FnMdAttachments
defMetadata   = FnMdAttachments
md
      , defComdat :: Maybe KindMd
defComdat     = PartialDefine -> Maybe KindMd
partialComdatName PartialDefine
pd
      }

finalizeMetadata :: PFnMdAttachments -> Parse FnMdAttachments
finalizeMetadata :: Map Int PValMd -> Parse FnMdAttachments
finalizeMetadata Map Int PValMd
patt = [(KindMd, ValMd)] -> FnMdAttachments
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(KindMd, ValMd)] -> FnMdAttachments)
-> Parse [(KindMd, ValMd)] -> Parse FnMdAttachments
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Int, PValMd) -> Parse (KindMd, ValMd))
-> [(Int, PValMd)] -> Parse [(KindMd, ValMd)]
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, PValMd) -> Parse (KindMd, ValMd)
f (Map Int PValMd -> [(Int, PValMd)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Int PValMd
patt)
  where f :: (Int, PValMd) -> Parse (KindMd, ValMd)
f (Int
k,PValMd
md) = (,) (KindMd -> ValMd -> (KindMd, ValMd))
-> Parse KindMd -> Parse (ValMd -> (KindMd, ValMd))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parse KindMd
getKind Int
k Parse (ValMd -> (KindMd, ValMd))
-> Parse ValMd -> Parse (KindMd, ValMd)
forall a b. Parse (a -> b) -> Parse a -> Parse b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Finalize ValMd -> Parse ValMd
forall a. Finalize a -> Parse a
liftFinalize (PValMd -> Finalize ValMd
finalizePValMd PValMd
md)

-- | Individual label resolution step.
resolveBlockLabel :: BlockLookup -> Maybe Symbol -> Int -> Finalize BlockLabel
resolveBlockLabel :: BlockLookup -> Maybe Symbol -> Int -> Finalize BlockLabel
resolveBlockLabel BlockLookup
lkp Maybe Symbol
mbSym = case Maybe Symbol
mbSym of
  Maybe Symbol
Nothing  -> Int -> Finalize BlockLabel
requireBbEntryName
  Just Symbol
sym -> BlockLookup
lkp Symbol
sym

-- | Name the next result with either its symbol, or the next available
-- anonymous result id.
nameNextValue :: Type -> Parse Ident
nameNextValue :: Type' Ident -> Parse Ident
nameNextValue Type' Ident
ty = do
  ValueTable
vs   <- Parse ValueTable
getValueTable
  let nextId :: Int
nextId = ValueTable -> Int
valueNextId ValueTable
vs
  KindMd
name <- Int -> Parse KindMd
entryName Int
nextId Parse KindMd -> Parse KindMd -> Parse KindMd
forall a. Parse a -> Parse a -> Parse a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (Int -> KindMd
forall a. Show a => a -> KindMd
show (Int -> KindMd) -> Parse Int -> Parse KindMd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parse Int
nextResultId)
  let i :: Ident
i   = KindMd -> Ident
Ident KindMd
name
      tv :: Typed (Value' lab)
tv  = Type' Ident -> Value' lab -> Typed (Value' lab)
forall a. Type' Ident -> a -> Typed a
Typed Type' Ident
ty (Ident -> Value' lab
forall lab. Ident -> Value' lab
ValIdent Ident
i)
  ValueTable -> Parse ()
setValueTable (Typed PValue -> ValueTable -> ValueTable
addValue Typed PValue
forall {lab}. Typed (Value' lab)
tv ValueTable
vs)
  Ident -> Parse Ident
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Ident
i

-- | The record that defines the number of blocks in a function.
declareBlocksRecord :: Match Entry UnabbrevRecord
declareBlocksRecord :: Match Entry UnabbrevRecord
declareBlocksRecord  = Int -> Match UnabbrevRecord UnabbrevRecord
hasUnabbrevCode Int
1 Match UnabbrevRecord UnabbrevRecord
-> Match Entry UnabbrevRecord -> Match Entry UnabbrevRecord
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Match Entry UnabbrevRecord
unabbrev

-- | Emit a statement to the current partial definition.
addStmt :: Stmt' Int -> PartialDefine -> Parse PartialDefine
addStmt :: Stmt' Int -> PartialDefine -> Parse PartialDefine
addStmt Stmt' Int
s PartialDefine
d
  | Instr' Int -> Bool
forall lab. Instr' lab -> Bool
isTerminator (Stmt' Int -> Instr' Int
forall lab. Stmt' lab -> Instr' lab
stmtInstr Stmt' Int
s) = PartialDefine -> Parse PartialDefine
terminateBlock PartialDefine
d'
  | Bool
otherwise                  = PartialDefine -> Parse PartialDefine
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialDefine
d'
  where
  d' :: PartialDefine
d' = PartialDefine
d { partialBlock = partialBlock d Seq.|> s }

-- | Terminate the current basic block.  Resolve the name of the next basic
-- block as either its symbol from the symbol table, or the next available
-- anonymous identifier.
terminateBlock :: PartialDefine -> Parse PartialDefine
terminateBlock :: PartialDefine -> Parse PartialDefine
terminateBlock PartialDefine
d = do
  let next :: Int
next = PartialDefine -> Int
partialBlockId PartialDefine
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
  Maybe BlockLabel
mb <- Finalize (Maybe BlockLabel) -> Parse (Maybe BlockLabel)
forall a. Finalize a -> Parse a
liftFinalize (Finalize (Maybe BlockLabel) -> Parse (Maybe BlockLabel))
-> Finalize (Maybe BlockLabel) -> Parse (Maybe BlockLabel)
forall a b. (a -> b) -> a -> b
$ Int -> Finalize (Maybe BlockLabel)
bbEntryName Int
next
  PartialDefine
d' <- case Maybe BlockLabel
mb of
    Just BlockLabel
_  -> PartialDefine -> Parse PartialDefine
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialDefine
d
    Maybe BlockLabel
Nothing -> do
      -- no label, use the next result id
      Int
l <- Parse Int
nextResultId
      PartialDefine -> Parse PartialDefine
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialDefine
d { partialSymtab = addBBAnon next l (partialSymtab d) }

  PartialDefine -> Parse PartialDefine
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialDefine
d'
    { partialBody  = partialBody d Seq.|> PartialBlock
      { partialLabel = partialBlockId d
      , partialStmts = partialBlock   d
      }
    , partialBlockId = next
    , partialBlock   = Seq.empty
    }

type BlockList = Seq.Seq PartialBlock

-- | Process a @BlockList@, turning it into a list of basic blocks.
finalizeBody :: BlockLookup -> BlockList -> Finalize [BasicBlock]
finalizeBody :: BlockLookup -> BlockList -> Finalize [BasicBlock]
finalizeBody BlockLookup
lkp = (Seq BasicBlock -> [BasicBlock])
-> Finalize (Seq BasicBlock) -> Finalize [BasicBlock]
forall a b. (a -> b) -> Finalize a -> Finalize b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Seq BasicBlock -> [BasicBlock]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Finalize (Seq BasicBlock) -> Finalize [BasicBlock])
-> (BlockList -> Finalize (Seq BasicBlock))
-> BlockList
-> Finalize [BasicBlock]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PartialBlock -> Finalize BasicBlock)
-> BlockList -> Finalize (Seq BasicBlock)
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) -> Seq a -> m (Seq b)
T.mapM (BlockLookup -> PartialBlock -> Finalize BasicBlock
finalizePartialBlock BlockLookup
lkp)

data PartialBlock = PartialBlock
  { PartialBlock -> Int
partialLabel :: !Int
  , PartialBlock -> StmtList
partialStmts :: StmtList
  } deriving (Int -> PartialBlock -> ShowS
[PartialBlock] -> ShowS
PartialBlock -> KindMd
(Int -> PartialBlock -> ShowS)
-> (PartialBlock -> KindMd)
-> ([PartialBlock] -> ShowS)
-> Show PartialBlock
forall a.
(Int -> a -> ShowS) -> (a -> KindMd) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PartialBlock -> ShowS
showsPrec :: Int -> PartialBlock -> ShowS
$cshow :: PartialBlock -> KindMd
show :: PartialBlock -> KindMd
$cshowList :: [PartialBlock] -> ShowS
showList :: [PartialBlock] -> ShowS
Show)

setPartialStmts :: StmtList -> PartialBlock -> PartialBlock
setPartialStmts :: StmtList -> PartialBlock -> PartialBlock
setPartialStmts StmtList
stmts PartialBlock
pb = PartialBlock
pb { partialStmts = stmts }

-- | Process a partial basic block into a full basic block.
finalizePartialBlock :: BlockLookup -> PartialBlock -> Finalize BasicBlock
finalizePartialBlock :: BlockLookup -> PartialBlock -> Finalize BasicBlock
finalizePartialBlock BlockLookup
lkp PartialBlock
pb = Maybe BlockLabel -> [Stmt' BlockLabel] -> BasicBlock
forall lab. Maybe lab -> [Stmt' lab] -> BasicBlock' lab
BasicBlock
                          (Maybe BlockLabel -> [Stmt' BlockLabel] -> BasicBlock)
-> Finalize (Maybe BlockLabel)
-> Finalize ([Stmt' BlockLabel] -> BasicBlock)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Finalize (Maybe BlockLabel)
bbEntryName (PartialBlock -> Int
partialLabel PartialBlock
pb)
                          Finalize ([Stmt' BlockLabel] -> BasicBlock)
-> Finalize [Stmt' BlockLabel] -> Finalize BasicBlock
forall a b. Finalize (a -> b) -> Finalize a -> Finalize b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BlockLookup -> StmtList -> Finalize [Stmt' BlockLabel]
finalizeStmts BlockLookup
lkp (PartialBlock -> StmtList
partialStmts PartialBlock
pb)

type PStmt = Stmt' Int

type StmtList = Seq.Seq PStmt

-- | Process a list of statements with explicit block id labels into one with
-- textual labels.
finalizeStmts :: BlockLookup -> StmtList -> Finalize [Stmt]
finalizeStmts :: BlockLookup -> StmtList -> Finalize [Stmt' BlockLabel]
finalizeStmts BlockLookup
lkp = (Stmt' Int -> Finalize (Stmt' BlockLabel))
-> [Stmt' Int] -> Finalize [Stmt' BlockLabel]
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 (BlockLookup -> Stmt' Int -> Finalize (Stmt' BlockLabel)
finalizeStmt BlockLookup
lkp) ([Stmt' Int] -> Finalize [Stmt' BlockLabel])
-> (StmtList -> [Stmt' Int])
-> StmtList
-> Finalize [Stmt' BlockLabel]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StmtList -> [Stmt' Int]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList

finalizeStmt :: BlockLookup -> Stmt' Int -> Finalize Stmt
finalizeStmt :: BlockLookup -> Stmt' Int -> Finalize (Stmt' BlockLabel)
finalizeStmt BlockLookup
lkp = (Maybe Symbol -> Int -> Finalize BlockLabel)
-> Stmt' Int -> Finalize (Stmt' BlockLabel)
forall (f :: * -> *) (m :: * -> *) a b.
(HasLabel f, Applicative m) =>
(Maybe Symbol -> a -> m b) -> f a -> m (f b)
forall (m :: * -> *) a b.
Applicative m =>
(Maybe Symbol -> a -> m b) -> Stmt' a -> m (Stmt' b)
relabel (BlockLookup -> Maybe Symbol -> Int -> Finalize BlockLabel
resolveBlockLabel BlockLookup
lkp)


-- Function Block Parsing ------------------------------------------------------

-- | A bit saying whether a call or callbr instruction has an explicit type, see
-- LLVM's CallMarkersFlags:
-- https://github.com/llvm/llvm-project/blob/c8ed784ee69a7dbdf4b33e85229457ffad309cf2/llvm/include/llvm/Bitcode/LLVMBitCodes.h#L505
callExplicitTypeBit :: Int
callExplicitTypeBit :: Int
callExplicitTypeBit = Int
15

-- | Parse the function block.
parseFunctionBlock ::
  Int {- ^ unnamed globals so far -} ->
  [Entry] -> Parse PartialDefine
parseFunctionBlock :: Int -> [Entry] -> Parse PartialDefine
parseFunctionBlock Int
unnamedGlobals [Entry]
ents =
  KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNCTION_BLOCK" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ Parse PartialDefine -> Parse PartialDefine
forall a. Parse a -> Parse a
enterFunctionDef (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do

  -- parse the value symtab block first, so that names are present during the
  -- rest of the parse
  ValueSymtab
symtab <- KindMd -> Parse ValueSymtab -> Parse ValueSymtab
forall a. KindMd -> Parse a -> Parse a
label KindMd
"VALUE_SYMTAB" (Parse ValueSymtab -> Parse ValueSymtab)
-> Parse ValueSymtab -> Parse ValueSymtab
forall a b. (a -> b) -> a -> b
$ do
    Maybe [Entry]
mb <- Match [Entry] (Maybe [Entry]) -> [Entry] -> Parse (Maybe [Entry])
forall i a. Match i a -> i -> Parse a
match (Match Entry [Entry] -> Match [Entry] (Maybe [Entry])
forall a b. Match a b -> Match [a] (Maybe b)
findMatch Match Entry [Entry]
valueSymtabBlockId) [Entry]
ents
    case Maybe [Entry]
mb of
      Just [Entry]
es -> [Entry] -> Parse ValueSymtab
parseValueSymbolTableBlock [Entry]
es
      Maybe [Entry]
Nothing -> ValueSymtab -> Parse ValueSymtab
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return ValueSymtab
forall a. Monoid a => a
mempty

  -- pop the function prototype off of the internal stack
  FunProto
proto <- Parse FunProto
popFunProto

  KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label (Symbol -> KindMd
prettySym (FunProto -> Symbol
protoSym FunProto
proto)) (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ ValueSymtab -> Parse PartialDefine -> Parse PartialDefine
forall a. ValueSymtab -> Parse a -> Parse a
withValueSymtab ValueSymtab
symtab (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do

    -- generate the initial partial definition
    PartialDefine
pd  <- FunProto -> Parse PartialDefine
emptyPartialDefine FunProto
proto
    rec PartialDefine
pd' <- (PartialDefine -> Entry -> Parse PartialDefine)
-> PartialDefine -> [Entry] -> Parse PartialDefine
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Int -> ValueTable -> PartialDefine -> Entry -> Parse PartialDefine
parseFunctionBlockEntry Int
unnamedGlobals ValueTable
vt) PartialDefine
pd [Entry]
ents
        ValueTable
vt  <- Parse ValueTable
getValueTable

    -- merge the symbol table with the anonymous symbol table
    PartialDefine -> Parse PartialDefine
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialDefine
pd' { partialSymtab = partialSymtab pd' `mappend` symtab }

-- | Parse the members of the function block
parseFunctionBlockEntry ::
  Int {- ^ unnamed globals so far -} ->
  ValueTable -> PartialDefine -> Entry ->
  Parse PartialDefine

parseFunctionBlockEntry :: Int -> ValueTable -> PartialDefine -> Entry -> Parse PartialDefine
parseFunctionBlockEntry Int
_ ValueTable
_ PartialDefine
d (Match Entry [Entry]
constantsBlockId -> Just [Entry]
es) = do
  -- CONSTANTS_BLOCK
  [Entry] -> Parse ()
parseConstantsBlock [Entry]
es
  PartialDefine -> Parse PartialDefine
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialDefine
d

parseFunctionBlockEntry Int
_ ValueTable
t PartialDefine
d (Match Entry Record
fromEntry -> Just Record
r) = case Record -> Int
recordCode Record
r of

  -- [n]
  Int
1 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_DECLARE_BLOCKS"
             (Record -> Int -> Parse ()
forall (m :: * -> *). MonadFail m => Record -> Int -> m ()
Assert.recordSizeGreater Record
r Int
0 Parse () -> Parse PartialDefine -> Parse PartialDefine
forall a b. Parse a -> Parse b -> Parse b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PartialDefine -> Parse PartialDefine
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialDefine
d)

  -- [opval,ty,opval,opcode]
  Int
2 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_BINOP" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    (Typed PValue
lhs,Int
ix) <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
0
    Typed PValue
rhs      <- ValueTable -> Type' Ident -> Int -> Parse (Typed PValue)
getValue ValueTable
t (Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
lhs) (Int -> Parse (Typed PValue)) -> Parse Int -> Parse (Typed PValue)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field Int
ix Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    Maybe Int -> Typed PValue -> PValue -> Instr' Int
mkInstr  <- LookupField (Maybe Int -> Typed PValue -> PValue -> Instr' Int)
forall {a}. LookupField a
field (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Match Field (Maybe Int -> Typed PValue -> PValue -> Instr' Int)
binop
    -- If there's an extra field on the end of the record, it's for one of the
    -- following:
    --
    -- - If the instruction is add, sub, mul, or shl, the extra field
    --   designates the value of the nuw and nsw flags.
    --
    -- - If the instruction is sdiv, udiv, lshr, or ashr, the extra field
    --   designates the value of the exact flag.
    --
    -- - If the instruction is floating-point, the extra field designates the
    --   value of the fast-math flags. We currently ignore these.
    --
    -- The constructor returned from binop will use that value when
    -- constructing the binop.
    let mbWord :: Maybe Int
mbWord = Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric Match Field Int -> Maybe Field -> Maybe Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> Match Record Field
fieldAt (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Record
r
    Type' Ident -> Instr' Int -> PartialDefine -> Parse PartialDefine
result (Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
lhs) (Maybe Int -> Typed PValue -> PValue -> Instr' Int
mkInstr Maybe Int
mbWord Typed PValue
lhs (Typed PValue -> PValue
forall a. Typed a -> a
typedValue Typed PValue
rhs)) PartialDefine
d

  -- [opval,opty,destty,castopc]
  Int
3 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_CAST" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    (Typed PValue
tv,Int
ix) <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
0
    Record -> [Int] -> Parse ()
forall (m :: * -> *). MonadFail m => Record -> [Int] -> m ()
Assert.recordSizeIn Record
r [Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2]
    Type' Ident
resty   <- Int -> Parse (Type' Ident)
getType (Int -> Parse (Type' Ident)) -> Parse Int -> Parse (Type' Ident)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field Int
ix Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    Typed PValue -> Type' Ident -> Instr' Int
cast'   <-             LookupField (Typed PValue -> Type' Ident -> Instr' Int)
forall {a}. LookupField a
field (Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Match Field (Typed PValue -> Type' Ident -> Instr' Int)
castOp
    Type' Ident -> Instr' Int -> PartialDefine -> Parse PartialDefine
result Type' Ident
resty (Typed PValue -> Type' Ident -> Instr' Int
cast' Typed PValue
tv Type' Ident
resty) PartialDefine
d

  Int
4 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_GEP_OLD" (ValueTable
-> Maybe Bool -> Record -> PartialDefine -> Parse PartialDefine
parseGEP ValueTable
t (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False) Record
r PartialDefine
d)

  -- [opval,ty,opval,opval]
  Int
5 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_SELECT" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    (Typed PValue
tval,Int
ix) <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
0
    Typed PValue
fval      <- ValueTable -> Type' Ident -> Int -> Parse (Typed PValue)
getValue ValueTable
t (Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
tval)       (Int -> Parse (Typed PValue)) -> Parse Int -> Parse (Typed PValue)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field  Int
ix    Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    Typed PValue
cond      <- ValueTable -> Type' Ident -> Int -> Parse (Typed PValue)
getValue ValueTable
t (PrimType -> Type' Ident
forall ident. PrimType -> Type' ident
PrimType (Word32 -> PrimType
Integer Word32
1)) (Int -> Parse (Typed PValue)) -> Parse Int -> Parse (Typed PValue)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field (Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    Type' Ident -> Instr' Int -> PartialDefine -> Parse PartialDefine
result (Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
tval) (Typed PValue -> Typed PValue -> PValue -> Instr' Int
forall lab.
Typed (Value' lab)
-> Typed (Value' lab) -> Value' lab -> Instr' lab
Select Typed PValue
cond Typed PValue
tval (Typed PValue -> PValue
forall a. Typed a -> a
typedValue Typed PValue
fval)) PartialDefine
d

  -- [ty,opval,opval]
  Int
6 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_EXTRACTELT" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    (Typed PValue
tv,Int
ix) <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
0
    Typed PValue
idx     <- ValueTable -> Type' Ident -> Int -> Parse (Typed PValue)
getValue ValueTable
t (PrimType -> Type' Ident
forall ident. PrimType -> Type' ident
PrimType (Word32 -> PrimType
Integer Word32
32)) (Int -> Parse (Typed PValue)) -> Parse Int -> Parse (Typed PValue)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Record -> LookupField Int
forall a. Record -> LookupField a
parseField Record
r Int
ix Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    (Word64
_, Type' Ident
ty) <- Type' Ident -> Parse (Word64, Type' Ident)
forall (m :: * -> *).
MonadPlus m =>
Type' Ident -> m (Word64, Type' Ident)
elimVector (Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
tv)
        Parse (Word64, Type' Ident)
-> Parse (Word64, Type' Ident) -> Parse (Word64, Type' Ident)
forall a. Parse a -> Parse a -> Parse a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` KindMd -> Parse (Word64, Type' Ident)
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail KindMd
"invalid EXTRACTELT record"
    Type' Ident -> Instr' Int -> PartialDefine -> Parse PartialDefine
result Type' Ident
ty (Typed PValue -> PValue -> Instr' Int
forall lab. Typed (Value' lab) -> Value' lab -> Instr' lab
ExtractElt Typed PValue
tv (Typed PValue -> PValue
forall a. Typed a -> a
typedValue Typed PValue
idx)) PartialDefine
d

  -- [ty,opval,opval,opval]
  Int
7 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_INSERTELT" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    (Typed PValue
tv,Int
ix) <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
0
    (Word64
_,Type' Ident
pty) <- Type' Ident -> Parse (Word64, Type' Ident)
forall (m :: * -> *).
MonadPlus m =>
Type' Ident -> m (Word64, Type' Ident)
elimVector (Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
tv)
                 Parse (Word64, Type' Ident)
-> Parse (Word64, Type' Ident) -> Parse (Word64, Type' Ident)
forall a. Parse a -> Parse a -> Parse a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` KindMd -> Parse (Word64, Type' Ident)
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail KindMd
"invalid INSERTELT record (not a vector)"
    Typed PValue
elt     <- ValueTable -> Type' Ident -> Int -> Parse (Typed PValue)
getValue ValueTable
t Type' Ident
pty                     (Int -> Parse (Typed PValue)) -> Parse Int -> Parse (Typed PValue)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field  Int
ix    Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    Typed PValue
idx     <- ValueTable -> Type' Ident -> Int -> Parse (Typed PValue)
getValue ValueTable
t (PrimType -> Type' Ident
forall ident. PrimType -> Type' ident
PrimType (Word32 -> PrimType
Integer Word32
32)) (Int -> Parse (Typed PValue)) -> Parse Int -> Parse (Typed PValue)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field (Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    Type' Ident -> Instr' Int -> PartialDefine -> Parse PartialDefine
result (Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
tv) (Typed PValue -> Typed PValue -> PValue -> Instr' Int
forall lab.
Typed (Value' lab)
-> Typed (Value' lab) -> Value' lab -> Instr' lab
InsertElt Typed PValue
tv Typed PValue
elt (Typed PValue -> PValue
forall a. Typed a -> a
typedValue Typed PValue
idx)) PartialDefine
d

  -- [opval,ty,opval,opval]
  Int
8 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_SHUFFLEVEC" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    (Typed PValue
vec1,Int
ix) <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
0
    Typed PValue
vec2      <- ValueTable -> Type' Ident -> Int -> Parse (Typed PValue)
getValue ValueTable
t (Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
vec1) (Int -> Parse (Typed PValue)) -> Parse Int -> Parse (Typed PValue)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field  Int
ix    Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    (Typed PValue
mask,Int
_)  <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r (Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
    Type' Ident
resTy <- case (Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
vec1,Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
mask) of
                (Vector Word64
_ Type' Ident
elemTy, Vector Word64
shuffleLen Type' Ident
_) ->
                        Type' Ident -> Parse (Type' Ident)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> Type' Ident -> Type' Ident
forall ident. Word64 -> Type' ident -> Type' ident
Vector Word64
shuffleLen Type' Ident
elemTy)
                (Type' Ident, Type' Ident)
_ -> KindMd -> Parse (Type' Ident)
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail KindMd
"Invalid arguments to shuffle vector (not vectors)"
    Type' Ident -> Instr' Int -> PartialDefine -> Parse PartialDefine
result Type' Ident
resTy (Typed PValue -> PValue -> Typed PValue -> Instr' Int
forall lab.
Typed (Value' lab)
-> Value' lab -> Typed (Value' lab) -> Instr' lab
ShuffleVector Typed PValue
vec1 (Typed PValue -> PValue
forall a. Typed a -> a
typedValue Typed PValue
vec2) Typed PValue
mask) PartialDefine
d

  -- 9 is handled lower down, as it's processed the same way as 28

  -- [opval,opval<optional>]
  Int
10 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_RET" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ case [Field] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Record -> [Field]
recordFields Record
r) of
    Int
0 -> Instr' Int -> PartialDefine -> Parse PartialDefine
effect Instr' Int
forall lab. Instr' lab
RetVoid PartialDefine
d
    Int
_ -> do
      (Typed PValue
tv, Int
ix) <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
0
      Record -> [Int] -> Parse ()
forall (m :: * -> *). MonadFail m => Record -> [Int] -> m ()
Assert.recordSizeIn Record
r [Int
ix]
      Instr' Int -> PartialDefine -> Parse PartialDefine
effect (Typed PValue -> Instr' Int
forall lab. Typed (Value' lab) -> Instr' lab
Ret Typed PValue
tv) PartialDefine
d

  -- [bb#,bb#,cond] or [bb#]
  Int
11 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_BR" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    Record -> [Int] -> Parse ()
forall (m :: * -> *). MonadFail m => Record -> [Int] -> m ()
Assert.recordSizeIn Record
r [Int
1, Int
3]
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    Int
bb1 <- LookupField Int
forall {a}. LookupField a
field Int
0 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    let jump :: Parse PartialDefine
jump   = Instr' Int -> PartialDefine -> Parse PartialDefine
effect (Int -> Instr' Int
forall lab. lab -> Instr' lab
Jump Int
bb1) PartialDefine
d
        branch :: Parse PartialDefine
branch = do
          Int
bb2  <- LookupField Int
forall {a}. LookupField a
field Int
1 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
          Int
n    <- LookupField Int
forall {a}. LookupField a
field Int
2 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
          Typed PValue
cond <- ValueTable -> Type' Ident -> Int -> Parse (Typed PValue)
getValue ValueTable
t (PrimType -> Type' Ident
forall ident. PrimType -> Type' ident
PrimType (Word32 -> PrimType
Integer Word32
1)) Int
n
          Instr' Int -> PartialDefine -> Parse PartialDefine
effect (Typed PValue -> Int -> Int -> Instr' Int
forall lab. Typed (Value' lab) -> lab -> lab -> Instr' lab
Br Typed PValue
cond Int
bb1 Int
bb2) PartialDefine
d
    Parse PartialDefine
branch Parse PartialDefine -> Parse PartialDefine -> Parse PartialDefine
forall a. Parse a -> Parse a -> Parse a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Parse PartialDefine
jump

  Int
12 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_SWITCH" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r

    -- switch implementation magic, May 2012 => 1205 => 0x4B5
    let switchInstMagic :: Int
        switchInstMagic :: Int
switchInstMagic  = Int
0x4B5

    Int
n <- LookupField Int
forall {a}. LookupField a
field Int
0 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric

    -- parse the new switch format.
    let newSwitch :: Parse PartialDefine
newSwitch = do
          Type' Ident
opty <- Int -> Parse (Type' Ident)
getType (Int -> Parse (Type' Ident)) -> Parse Int -> Parse (Type' Ident)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field Int
1 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric

          Word32
width <- case Type' Ident
opty of
            PrimType (Integer Word32
w) -> Word32 -> Parse Word32
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Word32
w
            Type' Ident
_                    -> KindMd -> Parse Word32
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail KindMd
"invalid switch discriminate"

          Typed PValue
cond     <- ValueTable -> Type' Ident -> Int -> Parse (Typed PValue)
getValue ValueTable
t Type' Ident
opty (Int -> Parse (Typed PValue)) -> Parse Int -> Parse (Typed PValue)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field Int
2 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
          Int
def      <-                      LookupField Int
forall {a}. LookupField a
field Int
3 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric -- Int id of a label
          Int
numCases <-                      LookupField Int
forall {a}. LookupField a
field Int
4 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
          [(Integer, Int)]
ls       <- Word32 -> Record -> Int -> Int -> Parse [(Integer, Int)]
parseNewSwitchLabels Word32
width Record
r Int
numCases Int
5
          Instr' Int -> PartialDefine -> Parse PartialDefine
effect (Typed PValue -> Int -> [(Integer, Int)] -> Instr' Int
forall lab.
Typed (Value' lab) -> lab -> [(Integer, lab)] -> Instr' lab
Switch Typed PValue
cond Int
def [(Integer, Int)]
ls) PartialDefine
d



    -- parse the old switch format
    -- [opty, op0, op1, ...]
    let oldSwitch :: Parse PartialDefine
oldSwitch = do
          Type' Ident
opty <- Int -> Parse (Type' Ident)
getType Int
n
          Typed PValue
cond <- ValueTable -> Type' Ident -> Int -> Parse (Typed PValue)
getValue ValueTable
t Type' Ident
opty (Int -> Parse (Typed PValue)) -> Parse Int -> Parse (Typed PValue)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field Int
1 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
          Int
def  <-                      LookupField Int
forall {a}. LookupField a
field Int
2 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
          [(Integer, Int)]
ls   <- Type' Ident -> Record -> Int -> Parse [(Integer, Int)]
parseSwitchLabels Type' Ident
opty Record
r Int
3
          Instr' Int -> PartialDefine -> Parse PartialDefine
effect (Typed PValue -> Int -> [(Integer, Int)] -> Instr' Int
forall lab.
Typed (Value' lab) -> lab -> [(Integer, lab)] -> Instr' lab
Switch Typed PValue
cond Int
def [(Integer, Int)]
ls) PartialDefine
d

    -- NOTE: there's a message in BitcodeReader.cpp that indicates that the
    -- newSwitch format is not used as of sometime before 3.4.2.  It's still
    -- supported, but 3.4.2 at least doesn't generate it anymore.
    if Int
n Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
16 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
switchInstMagic then Parse PartialDefine
newSwitch else Parse PartialDefine
oldSwitch




  -- [attrs,cc,normBB,unwindBB,fnty,op0,op1..]
  Int
13 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_INVOKE" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    Record -> Int -> Parse ()
forall (m :: * -> *). MonadFail m => Record -> Int -> m ()
Assert.recordSizeGreater Record
r Int
3
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    Word32
ccinfo      <- LookupField Word32
forall {a}. LookupField a
field Int
1 Match Field Word32
unsigned
    Int
normal      <- LookupField Int
forall {a}. LookupField a
field Int
2 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    Int
unwind      <- LookupField Int
forall {a}. LookupField a
field Int
3 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric

    -- explicit function type?
    (Maybe (Type' Ident)
mbFTy,Int
ix)    <-
      if Word32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word32
ccinfo Int
13
         then do Type' Ident
ty <- Int -> Parse (Type' Ident)
getType (Int -> Parse (Type' Ident)) -> Parse Int -> Parse (Type' Ident)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field Int
4 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
                 (Maybe (Type' Ident), Int) -> Parse (Maybe (Type' Ident), Int)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type' Ident -> Maybe (Type' Ident)
forall a. a -> Maybe a
Just Type' Ident
ty, Int
5)
         else (Maybe (Type' Ident), Int) -> Parse (Maybe (Type' Ident), Int)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Type' Ident)
forall a. Maybe a
Nothing, Int
4)

    (Typed PValue
f,Int
ix')      <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
ix

    Type' Ident
fty <- case Maybe (Type' Ident)
mbFTy of
             Just Type' Ident
ty -> Type' Ident -> Parse (Type' Ident)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Type' Ident
ty
             Maybe (Type' Ident)
Nothing -> KindMd -> Type' Ident -> Parse (Type' Ident)
forall (m :: * -> *).
(MonadFail m, MonadPlus m) =>
KindMd -> Type' Ident -> m (Type' Ident)
Assert.elimPtrTo KindMd
"Callee is not a pointer" (Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
f)

    (Type' Ident
ret,[Type' Ident]
as,Bool
va) <- Type' Ident -> Parse (Type' Ident, [Type' Ident], Bool)
forall (m :: * -> *).
MonadPlus m =>
Type' Ident -> m (Type' Ident, [Type' Ident], Bool)
elimFunTy Type' Ident
fty
        Parse (Type' Ident, [Type' Ident], Bool)
-> Parse (Type' Ident, [Type' Ident], Bool)
-> Parse (Type' Ident, [Type' Ident], Bool)
forall a. Parse a -> Parse a -> Parse a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` KindMd -> Parse (Type' Ident, [Type' Ident], Bool)
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail KindMd
"invalid INVOKE record"

    [Typed PValue]
args        <- ValueTable
-> Bool -> Record -> Int -> [Type' Ident] -> Parse [Typed PValue]
parseInvokeArgs ValueTable
t Bool
va Record
r Int
ix' [Type' Ident]
as
    -- Use `fty` instead of `typedType f` as the function type, as `typedType f`
    -- will be a pointer type. See Note [Typing function applications].
    Type' Ident -> Instr' Int -> PartialDefine -> Parse PartialDefine
result Type' Ident
ret (Type' Ident -> PValue -> [Typed PValue] -> Int -> Int -> Instr' Int
forall lab.
Type' Ident
-> Value' lab -> [Typed (Value' lab)] -> lab -> lab -> Instr' lab
Invoke Type' Ident
fty (Typed PValue -> PValue
forall a. Typed a -> a
typedValue Typed PValue
f) [Typed PValue]
args Int
normal Int
unwind) PartialDefine
d

  Int
14 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_UNWIND" (Instr' Int -> PartialDefine -> Parse PartialDefine
effect Instr' Int
forall lab. Instr' lab
Unwind PartialDefine
d)

  Int
15 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_UNREACHABLE" (Instr' Int -> PartialDefine -> Parse PartialDefine
effect Instr' Int
forall lab. Instr' lab
Unreachable PartialDefine
d)

  -- [ty,val0,bb0,...]
  Int
16 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_PHI" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    Type' Ident
ty     <- Int -> Parse (Type' Ident)
getType (Int -> Parse (Type' Ident)) -> Parse Int -> Parse (Type' Ident)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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

    -- NOTE: we use getRelIds here, as that uses a table that's not currently
    -- stuck in the recursive loop.  Attempting to use valueRelIds on t will
    -- cause a loop.
    Bool
useRelIds <- Parse Bool
getRelIds
    [(PValue, Int)]
args      <- Bool -> ValueTable -> Record -> Parse [(PValue, Int)]
parsePhiArgs Bool
useRelIds ValueTable
t Record
r

    Bool -> Parse () -> Parse ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> Bool
forall a. Integral a => a -> Bool
even ([Field] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Record -> [Field]
recordFields Record
r))) (Parse () -> Parse ()) -> Parse () -> Parse ()
forall a b. (a -> b) -> a -> b
$ do
      () -> Parse ()
forall a. a -> Parse a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- TODO: fast math flags

    Type' Ident -> Instr' Int -> PartialDefine -> Parse PartialDefine
result Type' Ident
ty (Type' Ident -> [(PValue, Int)] -> Instr' Int
forall lab. Type' Ident -> [(Value' lab, lab)] -> Instr' lab
Phi Type' Ident
ty [(PValue, Int)]
args) PartialDefine
d

  -- 17 is unused
  -- 18 is unused

  -- [instty,opty,op,align]
  Int
19 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_ALLOCA" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    Record -> [Int] -> Parse ()
forall (m :: * -> *). MonadFail m => Record -> [Int] -> m ()
Assert.recordSizeIn Record
r [Int
4]

    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r

    Type' Ident
instty <- Int -> Parse (Type' Ident)
getType           (Int -> Parse (Type' Ident)) -> Parse Int -> Parse (Type' Ident)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field Int
0 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric -- pointer type
    Type' Ident
ty     <- Int -> Parse (Type' Ident)
getType           (Int -> Parse (Type' Ident)) -> Parse Int -> Parse (Type' Ident)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field Int
1 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric -- size type
    Typed PValue
size   <- Type' Ident -> Int -> Parse (Typed PValue)
getFnValueById Type' Ident
ty (Int -> Parse (Typed PValue)) -> Parse Int -> Parse (Typed PValue)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field Int
2 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric -- size value
    Word32
align  <-                       LookupField Word32
forall {a}. LookupField a
field Int
3 Match Field Word32
forall a. (Num a, Bits a) => Match Field a
numeric -- alignment value

    let sval :: Maybe (Typed PValue)
sval = case Typed PValue -> PValue
forall a. Typed a -> a
typedValue Typed PValue
size of
          ValInteger Integer
i | Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1 -> Maybe (Typed PValue)
forall a. Maybe a
Nothing
          PValue
_                     -> Typed PValue -> Maybe (Typed PValue)
forall a. a -> Maybe a
Just Typed PValue
size
        mask :: Word32
        mask :: Word32
mask = (Word32
1 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
5) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. -- inalloca
               (Word32
1 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
6) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. -- explicit type
               (Word32
1 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
7)     -- swift error
        aval :: Int
aval = (Int
1 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
align Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32 -> Word32
forall a. Bits a => a -> a
complement Word32
mask))) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
1
        explicitType :: Bool
explicitType = Word32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word32
align Int
6
        ity :: Type' Ident
ity = if Bool
explicitType then Type' Ident -> Type' Ident
forall ident. Type' ident -> Type' ident
PtrTo Type' Ident
instty else Type' Ident
instty

    Type' Ident
ret <- if Bool
explicitType
           then Type' Ident -> Parse (Type' Ident)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Type' Ident
instty
           else KindMd -> Type' Ident -> Parse (Type' Ident)
forall (m :: * -> *).
(MonadFail m, MonadPlus m) =>
KindMd -> Type' Ident -> m (Type' Ident)
Assert.elimPtrTo KindMd
"In return type:" Type' Ident
instty

    Type' Ident -> Instr' Int -> PartialDefine -> Parse PartialDefine
result Type' Ident
ity (Type' Ident -> Maybe (Typed PValue) -> Maybe Int -> Instr' Int
forall lab.
Type' Ident
-> Maybe (Typed (Value' lab)) -> Maybe Int -> Instr' lab
Alloca Type' Ident
ret Maybe (Typed PValue)
sval (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
aval)) PartialDefine
d

  -- [opty,op,align,vol]
  Int
20 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_LOAD" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    (Typed PValue
tv,Int
ix) <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
0
    Record -> [Int] -> Parse ()
forall (m :: * -> *). MonadFail m => Record -> [Int] -> m ()
Assert.recordSizeIn Record
r [Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2, Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3]

    (Type' Ident
ret,Int
ix') <-
      if [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
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3
         then do Type' Ident
ty <- Int -> Parse (Type' Ident)
getType (Int -> Parse (Type' Ident)) -> Parse Int -> Parse (Type' Ident)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Record -> LookupField Int
forall a. Record -> LookupField a
parseField Record
r Int
ix Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
                 (Type' Ident, Int) -> Parse (Type' Ident, Int)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type' Ident
ty,Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)

         else do Type' Ident
ty <- KindMd -> Type' Ident -> Parse (Type' Ident)
forall (m :: * -> *).
(MonadFail m, MonadPlus m) =>
KindMd -> Type' Ident -> m (Type' Ident)
Assert.elimPtrTo KindMd
"" (Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
tv)
                 (Type' Ident, Int) -> Parse (Type' Ident, Int)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type' Ident
ty,Int
ix)

    Int
aval    <- Record -> LookupField Int
forall a. Record -> LookupField a
parseField Record
r Int
ix' Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    let align :: Maybe Int
align | Int
aval Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0  = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Int
forall a. Bits a => Int -> a
bit Int
aval Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
1)
              | Bool
otherwise = Maybe Int
forall a. Maybe a
Nothing
    Type' Ident -> Instr' Int -> PartialDefine -> Parse PartialDefine
result Type' Ident
ret (Type' Ident
-> Typed PValue -> Maybe AtomicOrdering -> Maybe Int -> Instr' Int
forall lab.
Type' Ident
-> Typed (Value' lab)
-> Maybe AtomicOrdering
-> Maybe Int
-> Instr' lab
Load Type' Ident
ret Typed PValue
tv Maybe AtomicOrdering
forall a. Maybe a
Nothing Maybe Int
align) PartialDefine
d

  -- 21 is unused
  -- 22 is unused

  Int
23 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_VAARG" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    Record -> Int -> Parse ()
forall (m :: * -> *). MonadFail m => Record -> Int -> m ()
Assert.recordSizeGreater Record
r Int
2
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    Type' Ident
ty    <- Int -> Parse (Type' Ident)
getType     (Int -> Parse (Type' Ident)) -> Parse Int -> Parse (Type' Ident)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field Int
0 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    Typed PValue
op    <- ValueTable -> Type' Ident -> Int -> Parse (Typed PValue)
getValue ValueTable
t Type' Ident
ty (Int -> Parse (Typed PValue)) -> Parse Int -> Parse (Typed PValue)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field Int
1 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    Type' Ident
resTy <- Int -> Parse (Type' Ident)
getType     (Int -> Parse (Type' Ident)) -> Parse Int -> Parse (Type' Ident)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field Int
2 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    Type' Ident -> Instr' Int -> PartialDefine -> Parse PartialDefine
result Type' Ident
resTy (Typed PValue -> Type' Ident -> Instr' Int
forall lab. Typed (Value' lab) -> Type' Ident -> Instr' lab
VaArg Typed PValue
op Type' Ident
resTy) PartialDefine
d

  -- [ptrty,ptr,val,align,vol]
  Int
24 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_STORE_OLD" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    (Typed PValue
ptr,Int
ix) <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
0
    Type' Ident
ty       <- KindMd -> Type' Ident -> Parse (Type' Ident)
forall (m :: * -> *).
(MonadFail m, MonadPlus m) =>
KindMd -> Type' Ident -> m (Type' Ident)
Assert.elimPtrTo KindMd
"" (Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
ptr)
    Typed PValue
val      <- ValueTable -> Type' Ident -> Int -> Parse (Typed PValue)
getValue ValueTable
t Type' Ident
ty (Int -> Parse (Typed PValue)) -> Parse Int -> Parse (Typed PValue)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field Int
ix Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    Int
aval     <- LookupField Int
forall {a}. LookupField a
field (Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    let align :: Maybe Int
align | Int
aval Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0  = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Int
forall a. Bits a => Int -> a
bit Int
aval Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
1)
              | Bool
otherwise = Maybe Int
forall a. Maybe a
Nothing
    Instr' Int -> PartialDefine -> Parse PartialDefine
effect (Typed PValue
-> Typed PValue -> Maybe AtomicOrdering -> Maybe Int -> Instr' Int
forall lab.
Typed (Value' lab)
-> Typed (Value' lab)
-> Maybe AtomicOrdering
-> Maybe Int
-> Instr' lab
Store Typed PValue
val Typed PValue
ptr Maybe AtomicOrdering
forall a. Maybe a
Nothing Maybe Int
align) PartialDefine
d

  -- 25 is unused

  -- LLVM 6: [opty, opval, n x indices]
  Int
26 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_EXTRACTVAL" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    (Typed PValue
tv, Int
ix) <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
0

    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
ix) (Parse () -> Parse ()) -> Parse () -> Parse ()
forall a b. (a -> b) -> a -> b
$
      KindMd -> Parse ()
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail KindMd
"`extractval` instruction had zero indices"

    [Int32]
ixs <- Record -> Int -> Parse [Int32]
forall a. (Num a, Bits a) => Record -> Int -> Parse [a]
parseIndexes Record
r Int
ix
    let instr :: Instr' Int
instr = Typed PValue -> [Int32] -> Instr' Int
forall lab. Typed (Value' lab) -> [Int32] -> Instr' lab
ExtractValue Typed PValue
tv [Int32]
ixs

    -- The return type of this instruction depends on the given indices into the
    -- type.
    Type' Ident
ret      <- Type' Ident -> [Int32] -> Parse (Type' Ident)
interpValueIndex (Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
tv) [Int32]
ixs
    Type' Ident -> Instr' Int -> PartialDefine -> Parse PartialDefine
result Type' Ident
ret Instr' Int
instr PartialDefine
d

  Int
27 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_INSERTVAL" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    (Typed PValue
tv,Int
ix)   <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
0

    -- See comment in FUNC_CODE_INST_EXTRACTVAL
    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
ix) (Parse () -> Parse ()) -> Parse () -> Parse ()
forall a b. (a -> b) -> a -> b
$
      KindMd -> Parse ()
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail KindMd
"Invalid instruction with zero indices"

    (Typed PValue
elt,Int
ix') <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
ix
    [Int32]
ixs       <- Record -> Int -> Parse [Int32]
forall a. (Num a, Bits a) => Record -> Int -> Parse [a]
parseIndexes Record
r Int
ix'
    Type' Ident -> Instr' Int -> PartialDefine -> Parse PartialDefine
result (Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
tv) (Typed PValue -> Typed PValue -> [Int32] -> Instr' Int
forall lab.
Typed (Value' lab) -> Typed (Value' lab) -> [Int32] -> Instr' lab
InsertValue Typed PValue
tv Typed PValue
elt [Int32]
ixs) PartialDefine
d

  -- 28 is handled lower down, as it's processed the same way as 9

  Int
29 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_VSELECT" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    (Typed PValue
tv,Int
ix) <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
0
    Typed PValue
fv      <- ValueTable -> Type' Ident -> Int -> Parse (Typed PValue)
getValue ValueTable
t (Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
tv) (Int -> Parse (Typed PValue)) -> Parse Int -> Parse (Typed PValue)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field Int
ix Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    (Typed PValue
c,Int
_)   <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r (Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
    -- XXX: we're ignoring the fast-math flags
    Type' Ident -> Instr' Int -> PartialDefine -> Parse PartialDefine
result (Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
tv) (Typed PValue -> Typed PValue -> PValue -> Instr' Int
forall lab.
Typed (Value' lab)
-> Typed (Value' lab) -> Value' lab -> Instr' lab
Select Typed PValue
c Typed PValue
tv (Typed PValue -> PValue
forall a. Typed a -> a
typedValue Typed PValue
fv)) PartialDefine
d

  Int
30 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_INBOUNDS_GEP_OLD" (ValueTable
-> Maybe Bool -> Record -> PartialDefine -> Parse PartialDefine
parseGEP ValueTable
t (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) Record
r PartialDefine
d)

  Int
31 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_INDIRECTBR" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    Type' Ident
ty   <- Int -> Parse (Type' Ident)
getType     (Int -> Parse (Type' Ident)) -> Parse Int -> Parse (Type' Ident)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field Int
0 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    Typed PValue
addr <- ValueTable -> Type' Ident -> Int -> Parse (Typed PValue)
getValue ValueTable
t Type' Ident
ty (Int -> Parse (Typed PValue)) -> Parse Int -> Parse (Typed PValue)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field Int
1 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    [Int]
ls   <- Record -> Int -> Parse [Int]
forall a. (Num a, Bits a) => Record -> Int -> Parse [a]
parseIndexes Record
r Int
2
    Instr' Int -> PartialDefine -> Parse PartialDefine
effect (Typed PValue -> [Int] -> Instr' Int
forall lab. Typed (Value' lab) -> [lab] -> Instr' lab
IndirectBr Typed PValue
addr [Int]
ls) PartialDefine
d

  -- 32 is unused

  Int
33 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_DEBUG_LOC_AGAIN" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    PDebugLoc
loc <- Parse PDebugLoc
getLastLoc
    (Stmt' Int -> Stmt' Int) -> PartialDefine -> Parse PartialDefine
updateLastStmt ((KindMd, PValMd) -> Stmt' Int -> Stmt' Int
forall lab. (KindMd, ValMd' lab) -> Stmt' lab -> Stmt' lab
extendMetadata (KindMd
"dbg", PDebugLoc -> PValMd
forall lab. DebugLoc' lab -> ValMd' lab
ValMdLoc PDebugLoc
loc)) PartialDefine
d

  -- [paramattrs, cc, mb fmf, mb fnty, fnid, arg0 .. arg n, varargs]
  Int
34 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_CALL" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    Record -> Int -> Parse ()
forall (m :: * -> *). MonadFail m => Record -> Int -> m ()
Assert.recordSizeGreater Record
r Int
2
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r

    -- pal <- field 0 numeric -- N.B. skipping param attributes
    Word32
ccinfo <- LookupField Word32
forall {a}. LookupField a
field Int
1 Match Field Word32
forall a. (Num a, Bits a) => Match Field a
numeric
    let ix0 :: Int
ix0 = if Word32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word32
ccinfo Int
17 then Int
3 else Int
2 -- N.B. skipping fast-math flags
    (Maybe (Type' Ident)
mbFnTy, Int
ix1) <- if Word32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit (Word32
ccinfo :: Word32) Int
callExplicitTypeBit
                       then do Type' Ident
fnTy <- Int -> Parse (Type' Ident)
getType (Int -> Parse (Type' Ident)) -> Parse Int -> Parse (Type' Ident)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field Int
ix0 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
                               (Maybe (Type' Ident), Int) -> Parse (Maybe (Type' Ident), Int)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type' Ident -> Maybe (Type' Ident)
forall a. a -> Maybe a
Just Type' Ident
fnTy, Int
ix0Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
                       else    (Maybe (Type' Ident), Int) -> Parse (Maybe (Type' Ident), Int)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Type' Ident)
forall a. Maybe a
Nothing,   Int
ix0)

    (Typed Type' Ident
opTy PValue
fn, Int
ix2) <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
ix1
                                Parse (Typed PValue, Int)
-> Parse (Typed PValue, Int) -> Parse (Typed PValue, Int)
forall a. Parse a -> Parse a -> Parse a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` KindMd -> Parse (Typed PValue, Int)
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail KindMd
"Invalid record"

    Type' Ident
fnty <- case Maybe (Type' Ident)
mbFnTy of
             Just Type' Ident
ty -> Type' Ident -> Parse (Type' Ident)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Type' Ident
ty
             Maybe (Type' Ident)
Nothing -> do
               Type' Ident
op <- KindMd -> Type' Ident -> Parse (Type' Ident)
forall (m :: * -> *).
(MonadFail m, MonadPlus m) =>
KindMd -> Type' Ident -> m (Type' Ident)
Assert.elimPtrTo KindMd
"Callee is not a pointer type" Type' Ident
opTy
               case Type' Ident
op of
                 FunTy{} -> Type' Ident -> Parse (Type' Ident)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Type' Ident
op
                 Type' Ident
_       -> KindMd -> Parse (Type' Ident)
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail KindMd
"Callee is not of pointer to function type"


    KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label (PValue -> KindMd
forall a. Show a => a -> KindMd
show PValue
fn) (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
      (Type' Ident
ret,[Type' Ident]
as,Bool
va) <- Type' Ident -> Parse (Type' Ident, [Type' Ident], Bool)
forall (m :: * -> *).
MonadPlus m =>
Type' Ident -> m (Type' Ident, [Type' Ident], Bool)
elimFunTy Type' Ident
fnty Parse (Type' Ident, [Type' Ident], Bool)
-> Parse (Type' Ident, [Type' Ident], Bool)
-> Parse (Type' Ident, [Type' Ident], Bool)
forall a. Parse a -> Parse a -> Parse a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` KindMd -> Parse (Type' Ident, [Type' Ident], Bool)
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail KindMd
"invalid CALL record"
      [Typed PValue]
args <- ValueTable
-> Bool -> Record -> Int -> [Type' Ident] -> Parse [Typed PValue]
parseCallArgs ValueTable
t Bool
va Record
r Int
ix2 [Type' Ident]
as
      -- Use `fnty` instead of `opTy` as the function type, as `opTy` will be
      -- a pointer type. See Note [Typing function applications].
      Type' Ident -> Instr' Int -> PartialDefine -> Parse PartialDefine
result Type' Ident
ret (Bool -> Type' Ident -> PValue -> [Typed PValue] -> Instr' Int
forall lab.
Bool
-> Type' Ident -> Value' lab -> [Typed (Value' lab)] -> Instr' lab
Call Bool
False Type' Ident
fnty PValue
fn [Typed PValue]
args) PartialDefine
d

  -- [Line,Col,ScopeVal, IAVal]
  Int
35 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_DEBUG_LOC" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    Record -> Int -> Parse ()
forall (m :: * -> *). MonadFail m => Record -> Int -> m ()
Assert.recordSizeGreater Record
r Int
3

    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    Word32
line    <- LookupField Word32
forall {a}. LookupField a
field Int
0 Match Field Word32
forall a. (Num a, Bits a) => Match Field a
numeric
    Word32
col     <- LookupField Word32
forall {a}. LookupField a
field Int
1 Match Field Word32
forall a. (Num a, Bits a) => Match Field a
numeric
    Int
scopeId <- LookupField Int
forall {a}. LookupField a
field Int
2 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    Int
iaId    <- LookupField Int
forall {a}. LookupField a
field Int
3 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric

    Typed PValMd
scope <- if Int
scopeId Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
                then Int -> Parse (Typed PValMd)
getMetadata (Int
scopeId Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                else KindMd -> Parse (Typed PValMd)
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail KindMd
"No scope provided"

    Maybe (Typed PValMd)
ia <- if Int
iaId Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
             then Typed PValMd -> Maybe (Typed PValMd)
forall a. a -> Maybe a
Just (Typed PValMd -> Maybe (Typed PValMd))
-> Parse (Typed PValMd) -> Parse (Maybe (Typed PValMd))
forall a b. (a -> b) -> Parse a -> Parse b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> Parse (Typed PValMd)
getMetadata (Int
iaId Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
             else Maybe (Typed PValMd) -> Parse (Maybe (Typed PValMd))
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Typed PValMd)
forall a. Maybe a
Nothing

    let loc :: PDebugLoc
loc = DebugLoc
          { dlLine :: Word32
dlLine  = Word32
line
          , dlCol :: Word32
dlCol   = Word32
col
          , dlScope :: PValMd
dlScope = Typed PValMd -> PValMd
forall a. Typed a -> a
typedValue Typed PValMd
scope
          , dlIA :: Maybe PValMd
dlIA    = Typed PValMd -> PValMd
forall a. Typed a -> a
typedValue (Typed PValMd -> PValMd) -> Maybe (Typed PValMd) -> Maybe PValMd
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Maybe (Typed PValMd)
ia
          , dlImplicit :: Bool
dlImplicit = Bool
False
          }
    PDebugLoc -> Parse ()
setLastLoc PDebugLoc
loc
    (Stmt' Int -> Stmt' Int) -> PartialDefine -> Parse PartialDefine
updateLastStmt ((KindMd, PValMd) -> Stmt' Int -> Stmt' Int
forall lab. (KindMd, ValMd' lab) -> Stmt' lab -> Stmt' lab
extendMetadata (KindMd
"dbg", PDebugLoc -> PValMd
forall lab. DebugLoc' lab -> ValMd' lab
ValMdLoc PDebugLoc
loc)) PartialDefine
d

  -- [ordering, synchscope]
  Int
36 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_FENCE" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    Record -> [Int] -> Parse ()
forall (m :: * -> *). MonadFail m => Record -> [Int] -> m ()
Assert.recordSizeIn Record
r [Int
2]
    Maybe AtomicOrdering
mordval <- Word32 -> Parse (Maybe AtomicOrdering)
getDecodedOrdering (Word32 -> Parse (Maybe AtomicOrdering))
-> Parse Word32 -> Parse (Maybe AtomicOrdering)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Record -> LookupField Word32
forall a. Record -> LookupField a
parseField Record
r Int
0 Match Field Word32
unsigned
    -- TODO: parse scope
    case Maybe AtomicOrdering
mordval of
      Just AtomicOrdering
ordval -> Instr' Int -> PartialDefine -> Parse PartialDefine
effect (Maybe KindMd -> AtomicOrdering -> Instr' Int
forall lab. Maybe KindMd -> AtomicOrdering -> Instr' lab
Fence Maybe KindMd
forall a. Maybe a
Nothing AtomicOrdering
ordval) PartialDefine
d
      Maybe AtomicOrdering
Nothing -> KindMd -> Parse PartialDefine
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail KindMd
"`fence` instruction requires ordering"

  -- [ptrty,ptr,cmp,new, align, vol,
  --  ordering, synchscope]
  Int
37 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_CMPXCHG_OLD" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    Parse PartialDefine
forall a. Parse a
notImplemented

  -- LLVM 6.0: [ptrty, ptr, val, operation, vol, ordering, ssid]
  Int
38 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_ATOMICRMW_OLD" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$
    Bool
-> ValueTable -> Record -> PartialDefine -> Parse PartialDefine
parseAtomicRMW Bool
True ValueTable
t Record
r PartialDefine
d


  -- [opval]
  Int
39 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_RESUME" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    (Typed PValue
tv,Int
_) <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
0
    Instr' Int -> PartialDefine -> Parse PartialDefine
effect (Typed PValue -> Instr' Int
forall lab. Typed (Value' lab) -> Instr' lab
Resume Typed PValue
tv) PartialDefine
d

  -- [ty,val,val,num,id0,val0...]
  Int
40 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_LANDINGPAD_OLD" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    Record -> Int -> Parse ()
forall (m :: * -> *). MonadFail m => Record -> Int -> m ()
Assert.recordSizeGreater Record
r Int
3
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    Type' Ident
ty          <- Int -> Parse (Type' Ident)
getType (Int -> Parse (Type' Ident)) -> Parse Int -> Parse (Type' Ident)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field Int
0 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    (Typed PValue
persFn,Int
ix) <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
1
    Int
val         <- LookupField Int
forall {a}. LookupField a
field Int
ix Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    let isCleanup :: Bool
isCleanup = Int
val Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= (Int
0 :: Int)
    Int
len         <- LookupField Int
forall {a}. LookupField a
field (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    [PClause]
clauses     <- ValueTable -> Record -> Int -> Int -> Parse [PClause]
parseClauses ValueTable
t Record
r Int
len (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
    Type' Ident -> Instr' Int -> PartialDefine -> Parse PartialDefine
result Type' Ident
ty (Type' Ident
-> Maybe (Typed PValue) -> Bool -> [PClause] -> Instr' Int
forall lab.
Type' Ident
-> Maybe (Typed (Value' lab))
-> Bool
-> [Clause' lab]
-> Instr' lab
LandingPad Type' Ident
ty (Typed PValue -> Maybe (Typed PValue)
forall a. a -> Maybe a
Just Typed PValue
persFn) Bool
isCleanup [PClause]
clauses) PartialDefine
d

  -- [opty, op, align, vol, ordering, synchscope]
  Int
41 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_LOADATOMIC" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    (Typed PValue
tv,Int
ix) <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
0

    Record -> [Int] -> Parse ()
forall (m :: * -> *). MonadFail m => Record -> [Int] -> m ()
Assert.recordSizeIn Record
r [Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4, Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
5]

    (Type' Ident
ret,Int
ix') <-
      if [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
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
5
         then do Type' Ident
ty <- Int -> Parse (Type' Ident)
getType (Int -> Parse (Type' Ident)) -> Parse Int -> Parse (Type' Ident)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Record -> LookupField Int
forall a. Record -> LookupField a
parseField Record
r Int
ix Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
                 (Type' Ident, Int) -> Parse (Type' Ident, Int)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type' Ident
ty, Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

         else do Type' Ident
ty <- KindMd -> Type' Ident -> Parse (Type' Ident)
forall (m :: * -> *).
(MonadFail m, MonadPlus m) =>
KindMd -> Type' Ident -> m (Type' Ident)
Assert.elimPtrTo KindMd
"" (Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
tv)
                 (Type' Ident, Int) -> Parse (Type' Ident, Int)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type' Ident
ty, Int
ix)

    Maybe AtomicOrdering
ordval <- Word32 -> Parse (Maybe AtomicOrdering)
getDecodedOrdering (Word32 -> Parse (Maybe AtomicOrdering))
-> Parse Word32 -> Parse (Maybe AtomicOrdering)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Record -> LookupField Word32
forall a. Record -> LookupField a
parseField Record
r (Int
ix' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Match Field Word32
unsigned
    Bool -> Parse () -> Parse ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe AtomicOrdering
ordval Maybe AtomicOrdering -> [Maybe AtomicOrdering] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Maybe AtomicOrdering
forall a. Maybe a
NothingMaybe AtomicOrdering
-> [Maybe AtomicOrdering] -> [Maybe AtomicOrdering]
forall a. a -> [a] -> [a]
:(AtomicOrdering -> Maybe AtomicOrdering)
-> [AtomicOrdering] -> [Maybe AtomicOrdering]
forall a b. (a -> b) -> [a] -> [b]
map AtomicOrdering -> Maybe AtomicOrdering
forall a. a -> Maybe a
Just [AtomicOrdering
Release, AtomicOrdering
AcqRel]) (Parse () -> Parse ()) -> Parse () -> Parse ()
forall a b. (a -> b) -> a -> b
$
      KindMd -> Parse ()
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail (KindMd -> Parse ()) -> KindMd -> Parse ()
forall a b. (a -> b) -> a -> b
$ KindMd
"Invalid atomic ordering: " KindMd -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe AtomicOrdering -> KindMd
forall a. Show a => a -> KindMd
show Maybe AtomicOrdering
ordval

    Int
aval    <- Record -> LookupField Int
forall a. Record -> LookupField a
parseField Record
r Int
ix' Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    let align :: Maybe Int
align | Int
aval Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0  = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Int
forall a. Bits a => Int -> a
bit Int
aval Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
1)
              | Bool
otherwise = Maybe Int
forall a. Maybe a
Nothing

    Bool -> Parse () -> Parse ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe AtomicOrdering
ordval Maybe AtomicOrdering -> Maybe AtomicOrdering -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe AtomicOrdering
forall a. Maybe a
Nothing Bool -> Bool -> Bool
&& Maybe Int
align Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Int
forall a. Maybe a
Nothing)
         (KindMd -> Parse ()
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail KindMd
"Invalid record")

    Type' Ident -> Instr' Int -> PartialDefine -> Parse PartialDefine
result Type' Ident
ret (Type' Ident
-> Typed PValue -> Maybe AtomicOrdering -> Maybe Int -> Instr' Int
forall lab.
Type' Ident
-> Typed (Value' lab)
-> Maybe AtomicOrdering
-> Maybe Int
-> Instr' lab
Load Type' Ident
ret Typed PValue
tv Maybe AtomicOrdering
ordval Maybe Int
align) PartialDefine
d


  -- [ptrty, ptr, val, align, vol, ordering, synchscope]
  Int
42 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_STOREATOMIC_OLD" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    Parse PartialDefine
forall a. Parse a
notImplemented

  Int
43 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_GEP" (ValueTable
-> Maybe Bool -> Record -> PartialDefine -> Parse PartialDefine
parseGEP ValueTable
t Maybe Bool
forall a. Maybe a
Nothing Record
r PartialDefine
d)

  Int
44 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_STORE" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    (Typed PValue
ptr,Int
ix)  <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
0
    (Typed PValue
val,Int
ix') <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
ix

    Record -> [Int] -> Parse ()
forall (m :: * -> *). MonadFail m => Record -> [Int] -> m ()
Assert.recordSizeIn Record
r [Int
ix' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2]

    Int
aval      <- LookupField Int
forall {a}. LookupField a
field Int
ix' Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    let align :: Maybe Int
align | Int
aval Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0  = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Int
forall a. Bits a => Int -> a
bit Int
aval Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
1)
              | Bool
otherwise = Maybe Int
forall a. Maybe a
Nothing
    Instr' Int -> PartialDefine -> Parse PartialDefine
effect (Typed PValue
-> Typed PValue -> Maybe AtomicOrdering -> Maybe Int -> Instr' Int
forall lab.
Typed (Value' lab)
-> Typed (Value' lab)
-> Maybe AtomicOrdering
-> Maybe Int
-> Instr' lab
Store Typed PValue
val Typed PValue
ptr Maybe AtomicOrdering
forall a. Maybe a
Nothing Maybe Int
align) PartialDefine
d

  -- LLVM 6: [ptrty, ptr, val, align, vol, ordering, ssid]
  Int
45 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_STOREATOMIC" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    (Typed PValue
ptr, Int
ix)  <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
0
    (Typed PValue
val, Int
ix') <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
ix

    Record -> [Int] -> Parse ()
forall (m :: * -> *). MonadFail m => Record -> [Int] -> m ()
Assert.recordSizeIn Record
r [Int
ix' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4]

    -- TODO: There's no spot in the AST for this ordering. Should there be?
    Maybe AtomicOrdering
ordering <- Word32 -> Parse (Maybe AtomicOrdering)
getDecodedOrdering (Word32 -> Parse (Maybe AtomicOrdering))
-> Parse Word32 -> Parse (Maybe AtomicOrdering)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Record -> LookupField Word32
forall a. Record -> LookupField a
parseField Record
r (Int
ix' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Match Field Word32
unsigned
    Bool -> Parse () -> Parse ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe AtomicOrdering
ordering Maybe AtomicOrdering -> [Maybe AtomicOrdering] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Maybe AtomicOrdering
forall a. Maybe a
NothingMaybe AtomicOrdering
-> [Maybe AtomicOrdering] -> [Maybe AtomicOrdering]
forall a. a -> [a] -> [a]
:(AtomicOrdering -> Maybe AtomicOrdering)
-> [AtomicOrdering] -> [Maybe AtomicOrdering]
forall a b. (a -> b) -> [a] -> [b]
map AtomicOrdering -> Maybe AtomicOrdering
forall a. a -> Maybe a
Just [AtomicOrdering
Acquire, AtomicOrdering
AcqRel]) (Parse () -> Parse ()) -> Parse () -> Parse ()
forall a b. (a -> b) -> a -> b
$
      KindMd -> Parse ()
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail (KindMd -> Parse ()) -> KindMd -> Parse ()
forall a b. (a -> b) -> a -> b
$ KindMd
"Invalid atomic ordering: " KindMd -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe AtomicOrdering -> KindMd
forall a. Show a => a -> KindMd
show Maybe AtomicOrdering
ordering

    -- TODO: parse sync scope (ssid)

    -- copy-pasted from LOADATOMIC
    Int
aval    <- Record -> LookupField Int
forall a. Record -> LookupField a
parseField Record
r Int
ix' Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    let align :: Maybe Int
align | Int
aval Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0  = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Int
forall a. Bits a => Int -> a
bit Int
aval Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
1)
              | Bool
otherwise = Maybe Int
forall a. Maybe a
Nothing

    Instr' Int -> PartialDefine -> Parse PartialDefine
effect (Typed PValue
-> Typed PValue -> Maybe AtomicOrdering -> Maybe Int -> Instr' Int
forall lab.
Typed (Value' lab)
-> Typed (Value' lab)
-> Maybe AtomicOrdering
-> Maybe Int
-> Instr' lab
Store Typed PValue
val Typed PValue
ptr Maybe AtomicOrdering
ordering Maybe Int
align) PartialDefine
d

  -- LLVM 6: [ptrty, ptr, cmp, new, vol, successordering, ssid,
  --          failureordering?, isweak?]
  Int
46 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_CMPXCHG" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    (Typed PValue
ptr, Int
ix)  <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
0
    (Typed PValue
val, Int
ix') <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
ix
    Typed PValue
new        <- ValueTable -> Type' Ident -> Int -> Parse (Typed PValue)
getValue ValueTable
t (Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
val) (Int -> Parse (Typed PValue)) -> Parse Int -> Parse (Typed PValue)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Record -> LookupField Int
forall a. Record -> LookupField a
parseField Record
r Int
ix' Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    let ix'' :: Int
ix''   = Int
ix' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 -- TODO: is this right?

    -- TODO: record size assertion
    -- Assert.recordSizeGreater r (ix'' + 5)

    Bool -> Parse () -> Parse ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
val Type' Ident -> Type' Ident -> Bool
forall ident. Eq ident => Type' ident -> Type' ident -> Bool
`eqTypeModuloOpaquePtrs` Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
new)
      -- This test is generally validating the behavior of this library: the LLVM
      -- bitcode was likely generated by LLVM and is therefore "correct".
      (Parse () -> Parse ()) -> Parse () -> Parse ()
forall a b. (a -> b) -> a -> b
$ KindMd -> Parse ()
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail (KindMd -> Parse ()) -> KindMd -> Parse ()
forall a b. (a -> b) -> a -> b
$ [KindMd] -> KindMd
unlines ([KindMd] -> KindMd) -> [KindMd] -> KindMd
forall a b. (a -> b) -> a -> b
$
      [ KindMd
"Mismatched value types:"
      , KindMd
"cmp value: " KindMd -> ShowS
forall a. [a] -> [a] -> [a]
++ PValue -> KindMd
forall a. Show a => a -> KindMd
show (Typed PValue -> PValue
forall a. Typed a -> a
typedValue Typed PValue
val)
      , KindMd
"new value: " KindMd -> ShowS
forall a. [a] -> [a] -> [a]
++ PValue -> KindMd
forall a. Show a => a -> KindMd
show (Typed PValue -> PValue
forall a. Typed a -> a
typedValue Typed PValue
new)
      , KindMd
"cmp type:  " KindMd -> ShowS
forall a. [a] -> [a] -> [a]
++ Type' Ident -> KindMd
forall a. Show a => a -> KindMd
show (Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
val)
      , KindMd
"new type:  " KindMd -> ShowS
forall a. [a] -> [a] -> [a]
++ Type' Ident -> KindMd
forall a. Show a => a -> KindMd
show (Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
new)
      ]

    Bool
volatile <- Record -> LookupField Bool
forall a. Record -> LookupField a
parseField Record
r Int
ix'' Match Field Bool
boolean

    Maybe AtomicOrdering
successOrdering_ <- Word32 -> Parse (Maybe AtomicOrdering)
getDecodedOrdering (Word32 -> Parse (Maybe AtomicOrdering))
-> Parse Word32 -> Parse (Maybe AtomicOrdering)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Record -> LookupField Word32
forall a. Record -> LookupField a
parseField Record
r (Int
ix'' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Match Field Word32
unsigned
    let successOrderMsg :: a -> KindMd
successOrderMsg a
ord = KindMd
"Invalid success ordering: " KindMd -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> KindMd
forall a. Show a => a -> KindMd
show a
ord
    AtomicOrdering
successOrdering  <-
      case Maybe AtomicOrdering
successOrdering_ of
        Maybe AtomicOrdering
Nothing        -> KindMd -> Parse AtomicOrdering
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail (Maybe AtomicOrdering -> KindMd
forall a. Show a => a -> KindMd
successOrderMsg Maybe AtomicOrdering
successOrdering_)
        Just AtomicOrdering
Unordered -> KindMd -> Parse AtomicOrdering
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail (Maybe AtomicOrdering -> KindMd
forall a. Show a => a -> KindMd
successOrderMsg Maybe AtomicOrdering
successOrdering_)
        Just AtomicOrdering
ordering  -> AtomicOrdering -> Parse AtomicOrdering
forall a. a -> Parse a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AtomicOrdering
ordering

    -- TODO: parse sync scope (ssid)
    -- ssid <- parseField r (ix'' + 2) ssid

    let len :: Int
len = [Field] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Record -> [Field]
recordFields Record
r)
    Maybe AtomicOrdering
failureOrdering_ <-
      if Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
7
      -- Implementation of getStrongestFailureOrdering in llvm/IR/Instructions.h:
      then case AtomicOrdering
successOrdering of
             AtomicOrdering
Release   -> Maybe AtomicOrdering -> Parse (Maybe AtomicOrdering)
forall a. a -> Parse a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AtomicOrdering -> Maybe AtomicOrdering
forall a. a -> Maybe a
Just AtomicOrdering
Monotonic)
             AtomicOrdering
Monotonic -> Maybe AtomicOrdering -> Parse (Maybe AtomicOrdering)
forall a. a -> Parse a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AtomicOrdering -> Maybe AtomicOrdering
forall a. a -> Maybe a
Just AtomicOrdering
Monotonic)
             AtomicOrdering
Acquire   -> Maybe AtomicOrdering -> Parse (Maybe AtomicOrdering)
forall a. a -> Parse a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AtomicOrdering -> Maybe AtomicOrdering
forall a. a -> Maybe a
Just AtomicOrdering
Acquire)   -- TODO: AcquireRelease?
             AtomicOrdering
SeqCst    -> Maybe AtomicOrdering -> Parse (Maybe AtomicOrdering)
forall a. a -> Parse a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AtomicOrdering -> Maybe AtomicOrdering
forall a. a -> Maybe a
Just AtomicOrdering
SeqCst)
             AtomicOrdering
_         -> KindMd -> Parse (Maybe AtomicOrdering)
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail (AtomicOrdering -> KindMd
forall a. Show a => a -> KindMd
successOrderMsg AtomicOrdering
successOrdering)
      else Word32 -> Parse (Maybe AtomicOrdering)
getDecodedOrdering (Word32 -> Parse (Maybe AtomicOrdering))
-> Parse Word32 -> Parse (Maybe AtomicOrdering)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Record -> LookupField Word32
forall a. Record -> LookupField a
parseField Record
r (Int
ix'' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3) Match Field Word32
unsigned
    AtomicOrdering
failureOrdering  <-
      case Maybe AtomicOrdering
failureOrdering_ of
        Maybe AtomicOrdering
Nothing  -> KindMd -> Parse AtomicOrdering
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail KindMd
"Invalid failure ordering (Nothing)"
        Just AtomicOrdering
ord -> AtomicOrdering -> Parse AtomicOrdering
forall a. a -> Parse a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AtomicOrdering
ord

    Bool
weak <-
      if Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
8
      then KindMd -> Parse Bool
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail KindMd
"Not yet implemented: old-style cmpxchg instruction (weak)"
      else Record -> LookupField Bool
forall a. Record -> LookupField a
parseField Record
r (Int
ix'' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4) Match Field Bool
boolean

    -- The return type of cmpxchg is: the value that was present in the memory
    -- location and a boolean indicating whether it was overwritten.
    let ty :: Type' Ident
ty = [Type' Ident] -> Type' Ident
forall ident. [Type' ident] -> Type' ident
Struct [Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
val, PrimType -> Type' Ident
forall ident. PrimType -> Type' ident
PrimType (Word32 -> PrimType
Integer Word32
1)]
    Type' Ident -> Instr' Int -> PartialDefine -> Parse PartialDefine
result Type' Ident
ty (Bool
-> Bool
-> Typed PValue
-> Typed PValue
-> Typed PValue
-> Maybe KindMd
-> AtomicOrdering
-> AtomicOrdering
-> Instr' Int
forall lab.
Bool
-> Bool
-> Typed (Value' lab)
-> Typed (Value' lab)
-> Typed (Value' lab)
-> Maybe KindMd
-> AtomicOrdering
-> AtomicOrdering
-> Instr' lab
CmpXchg Bool
weak Bool
volatile Typed PValue
ptr Typed PValue
val Typed PValue
new Maybe KindMd
forall a. Maybe a
Nothing AtomicOrdering
successOrdering AtomicOrdering
failureOrdering) PartialDefine
d

  Int
47 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_LANDINGPAD" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    Record -> Int -> Parse ()
forall (m :: * -> *). MonadFail m => Record -> Int -> m ()
Assert.recordSizeGreater Record
r Int
2
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    Type' Ident
ty         <- Int -> Parse (Type' Ident)
getType (Int -> Parse (Type' Ident)) -> Parse Int -> Parse (Type' Ident)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field Int
0 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    Bool
isCleanup  <- (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/=(Int
0::Int)) (Int -> Bool) -> Parse Int -> Parse Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LookupField Int
forall {a}. LookupField a
field Int
1 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    Int
len        <- LookupField Int
forall {a}. LookupField a
field Int
2 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    [PClause]
clauses    <- ValueTable -> Record -> Int -> Int -> Parse [PClause]
parseClauses ValueTable
t Record
r Int
len Int
3
    Type' Ident -> Instr' Int -> PartialDefine -> Parse PartialDefine
result Type' Ident
ty (Type' Ident
-> Maybe (Typed PValue) -> Bool -> [PClause] -> Instr' Int
forall lab.
Type' Ident
-> Maybe (Typed (Value' lab))
-> Bool
-> [Clause' lab]
-> Instr' lab
LandingPad Type' Ident
ty Maybe (Typed PValue)
forall a. Maybe a
Nothing Bool
isCleanup [PClause]
clauses) PartialDefine
d

  Int
48 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_CLEANUPRET" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    -- Assert.recordSizeIn r [1, 2]
    Parse PartialDefine
forall a. Parse a
notImplemented

  Int
49 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_CATCHRET" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    -- Assert.recordSizeIn r [2]
    Parse PartialDefine
forall a. Parse a
notImplemented

  Int
50 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_CATCHPAD" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    Parse PartialDefine
forall a. Parse a
notImplemented

  Int
51 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_CLEANUPPAD" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    -- Assert.recordSizeGreater r [1]
    Parse PartialDefine
forall a. Parse a
notImplemented

  Int
52 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_CATCHSWITCH" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    -- Assert.recordSizeGreater r [1]
    Parse PartialDefine
forall a. Parse a
notImplemented

  -- 53 is unused
  -- 54 is unused

  Int
55 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_OPERAND_BUNDLE" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    Parse PartialDefine
forall a. Parse a
notImplemented

  -- [opval,ty,opcode]
  Int
56 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_UNOP" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    (Typed PValue
v,Int
ix)  <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
0
    Typed PValue -> Instr' Int
mkInstr <- LookupField (Typed PValue -> Instr' Int)
forall {a}. LookupField a
field Int
ix Match Field (Typed PValue -> Instr' Int)
unop
    -- XXX: we're ignoring the fast-math flags
    Type' Ident -> Instr' Int -> PartialDefine -> Parse PartialDefine
result (Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
v) (Typed PValue -> Instr' Int
mkInstr Typed PValue
v) PartialDefine
d

  -- LLVM 9: [attr, cc, norm, transfs, fnty, fnid, args...]
  Int
57 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_CALLBR" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    -- This implementation shares a lot with the parser for `call`, but they
    -- have different fields and so different handling of indices. In
    -- particular, the handling of basic block destinations is unique to
    -- `callbr`, and `callbr` doesn't support fast math flags.

    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    -- pal <- field 0 numeric -- N.B. skipping param attributes
    Word32
ccinfo <- LookupField Word32
forall {a}. LookupField a
field Int
1 Match Field Word32
unsigned
    Int
normal <- LookupField Int
forall {a}. LookupField a
field Int
2 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    Int
numIndirect <- LookupField Int
forall {a}. LookupField a
field Int
3 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    [Int]
indirectDests <- (Int -> Parse Int) -> [Int] -> Parse [Int]
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
idx -> LookupField Int
forall {a}. LookupField a
field (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
idx) Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric) [Int
0..Int
numIndirect Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
    let ix0 :: Int
ix0 = Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
numIndirect
    (Maybe (Type' Ident)
mbFnTy, Int
ix1) <- if Word32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit (Word32
ccinfo :: Word32) Int
callExplicitTypeBit
                       then do Type' Ident
fnTy <- Int -> Parse (Type' Ident)
getType (Int -> Parse (Type' Ident)) -> Parse Int -> Parse (Type' Ident)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field Int
ix0 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
                               (Maybe (Type' Ident), Int) -> Parse (Maybe (Type' Ident), Int)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type' Ident -> Maybe (Type' Ident)
forall a. a -> Maybe a
Just Type' Ident
fnTy, Int
ix0Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
                       else    (Maybe (Type' Ident), Int) -> Parse (Maybe (Type' Ident), Int)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Type' Ident)
forall a. Maybe a
Nothing,   Int
ix0)

    (Typed Type' Ident
opTy PValue
fn, Int
ix2) <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
ix1
                                Parse (Typed PValue, Int)
-> Parse (Typed PValue, Int) -> Parse (Typed PValue, Int)
forall a. Parse a -> Parse a -> Parse a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` KindMd -> Parse (Typed PValue, Int)
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail KindMd
"Invalid callbr record"

    Type' Ident
fnty <- case Maybe (Type' Ident)
mbFnTy of
             Just Type' Ident
ty -> Type' Ident -> Parse (Type' Ident)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Type' Ident
ty
             Maybe (Type' Ident)
Nothing -> do
               Type' Ident
op <- KindMd -> Type' Ident -> Parse (Type' Ident)
forall (m :: * -> *).
(MonadFail m, MonadPlus m) =>
KindMd -> Type' Ident -> m (Type' Ident)
Assert.elimPtrTo KindMd
"callbr callee is not a pointer type" Type' Ident
opTy
               case Type' Ident
op of
                 FunTy{} -> Type' Ident -> Parse (Type' Ident)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Type' Ident
op
                 Type' Ident
_       -> KindMd -> Parse (Type' Ident)
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail KindMd
"Callee is not of pointer to function type"

    KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label (PValue -> KindMd
forall a. Show a => a -> KindMd
show PValue
fn) (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
      (Type' Ident
ret,[Type' Ident]
as,Bool
va) <- Type' Ident -> Parse (Type' Ident, [Type' Ident], Bool)
forall (m :: * -> *).
MonadPlus m =>
Type' Ident -> m (Type' Ident, [Type' Ident], Bool)
elimFunTy Type' Ident
fnty Parse (Type' Ident, [Type' Ident], Bool)
-> Parse (Type' Ident, [Type' Ident], Bool)
-> Parse (Type' Ident, [Type' Ident], Bool)
forall a. Parse a -> Parse a -> Parse a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` KindMd -> Parse (Type' Ident, [Type' Ident], Bool)
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail KindMd
"invalid CALLBR record"
      [Typed PValue]
args <- ValueTable
-> Bool -> Record -> Int -> [Type' Ident] -> Parse [Typed PValue]
parseCallArgs ValueTable
t Bool
va Record
r Int
ix2 [Type' Ident]
as
      -- Use `fnty` instead of `opTy` as the function type, as `opTy` will be
      -- a pointer type. See Note [Typing function applications].
      Type' Ident -> Instr' Int -> PartialDefine -> Parse PartialDefine
result Type' Ident
ret (Type' Ident
-> PValue -> [Typed PValue] -> Int -> [Int] -> Instr' Int
forall lab.
Type' Ident
-> Value' lab -> [Typed (Value' lab)] -> lab -> [lab] -> Instr' lab
CallBr Type' Ident
fnty PValue
fn [Typed PValue]
args Int
normal [Int]
indirectDests) PartialDefine
d

  -- [opty, opval]
  Int
58 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_FREEZE" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    (Typed PValue
v,Int
_) <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
0
    Type' Ident -> Instr' Int -> PartialDefine -> Parse PartialDefine
result (Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
v) (Typed PValue -> Instr' Int
forall lab. Typed (Value' lab) -> Instr' lab
Freeze Typed PValue
v) PartialDefine
d

  -- LLVM 13: [ptrty, ptr, valty, val, operation, vol, ordering, ssid]
  Int
59 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_ATOMICRMW" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$
    Bool
-> ValueTable -> Record -> PartialDefine -> Parse PartialDefine
parseAtomicRMW Bool
False ValueTable
t Record
r PartialDefine
d


  -- [opty,opval,opval,pred]
  Int
code
   |  Int
code Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
9
   Bool -> Bool -> Bool
|| Int
code Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
28 -> KindMd -> Parse PartialDefine -> Parse PartialDefine
forall a. KindMd -> Parse a -> Parse a
label KindMd
"FUNC_CODE_INST_CMP2" (Parse PartialDefine -> Parse PartialDefine)
-> Parse PartialDefine -> Parse PartialDefine
forall a b. (a -> b) -> a -> b
$ do
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    (Typed PValue
lhs,Int
ix) <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
0
               Parse (Typed PValue, Int)
-> Parse (Typed PValue, Int) -> Parse (Typed PValue, Int)
forall a. Parse a -> Parse a -> Parse a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (do Int
i   <- Int -> Parse Int
adjustId (Int -> Parse Int) -> Parse Int -> Parse Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field Int
0 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
                           [KindMd]
cxt <- Parse [KindMd]
getContext
                           (Typed PValue, Int) -> Parse (Typed PValue, Int)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (HasCallStack => [KindMd] -> Int -> ValueTable -> Typed PValue
[KindMd] -> Int -> ValueTable -> Typed PValue
forwardRef [KindMd]
cxt Int
i ValueTable
t, Int
1))
    Typed PValue
rhs <- ValueTable -> Type' Ident -> Int -> Parse (Typed PValue)
getValue ValueTable
t (Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
lhs) (Int -> Parse (Typed PValue)) -> Parse Int -> Parse (Typed PValue)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field Int
ix Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric

    let ty :: Type' Ident
ty = Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
lhs
        parseOp :: Field -> Maybe (Typed (Value' lab) -> Value' lab -> Instr' lab)
parseOp | (PrimType -> Bool) -> Type' Ident -> Bool
isPrimTypeOf PrimType -> Bool
isFloatingPoint Type' Ident
ty Bool -> Bool -> Bool
||
                  (Type' Ident -> Bool) -> Type' Ident -> Bool
isVectorOf ((PrimType -> Bool) -> Type' Ident -> Bool
isPrimTypeOf PrimType -> Bool
isFloatingPoint) Type' Ident
ty =
                  (Typed (Value' lab) -> Value' lab -> Instr' lab)
-> Maybe (Typed (Value' lab) -> Value' lab -> Instr' lab)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Typed (Value' lab) -> Value' lab -> Instr' lab)
 -> Maybe (Typed (Value' lab) -> Value' lab -> Instr' lab))
-> (FCmpOp -> Typed (Value' lab) -> Value' lab -> Instr' lab)
-> FCmpOp
-> Maybe (Typed (Value' lab) -> Value' lab -> Instr' lab)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FCmpOp -> Typed (Value' lab) -> Value' lab -> Instr' lab
forall lab.
FCmpOp -> Typed (Value' lab) -> Value' lab -> Instr' lab
FCmp (FCmpOp -> Maybe (Typed (Value' lab) -> Value' lab -> Instr' lab))
-> (Field -> Maybe FCmpOp)
-> Field
-> Maybe (Typed (Value' lab) -> Value' lab -> Instr' lab)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Field -> Maybe FCmpOp
fcmpOp

                | Bool
otherwise =
                  (Typed (Value' lab) -> Value' lab -> Instr' lab)
-> Maybe (Typed (Value' lab) -> Value' lab -> Instr' lab)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Typed (Value' lab) -> Value' lab -> Instr' lab)
 -> Maybe (Typed (Value' lab) -> Value' lab -> Instr' lab))
-> (ICmpOp -> Typed (Value' lab) -> Value' lab -> Instr' lab)
-> ICmpOp
-> Maybe (Typed (Value' lab) -> Value' lab -> Instr' lab)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ICmpOp -> Typed (Value' lab) -> Value' lab -> Instr' lab
forall lab.
ICmpOp -> Typed (Value' lab) -> Value' lab -> Instr' lab
ICmp (ICmpOp -> Maybe (Typed (Value' lab) -> Value' lab -> Instr' lab))
-> (Field -> Maybe ICmpOp)
-> Field
-> Maybe (Typed (Value' lab) -> Value' lab -> Instr' lab)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Field -> Maybe ICmpOp
icmpOp

    Typed PValue -> PValue -> Instr' Int
op <- LookupField (Typed PValue -> PValue -> Instr' Int)
forall {a}. LookupField a
field (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Field -> Maybe (Typed PValue -> PValue -> Instr' Int)
forall {lab}.
Field -> Maybe (Typed (Value' lab) -> Value' lab -> Instr' lab)
parseOp
    -- XXX: we're ignoring the fast-math flags

    let boolTy :: PrimType
boolTy = Word32 -> PrimType
Integer Word32
1
    let rty :: Type' ident
rty = case Type' Ident
ty of
          Vector Word64
n Type' Ident
_ -> Word64 -> Type' ident -> Type' ident
forall ident. Word64 -> Type' ident -> Type' ident
Vector Word64
n (PrimType -> Type' ident
forall ident. PrimType -> Type' ident
PrimType PrimType
boolTy)
          Type' Ident
_          -> PrimType -> Type' ident
forall ident. PrimType -> Type' ident
PrimType PrimType
boolTy
    Type' Ident -> Instr' Int -> PartialDefine -> Parse PartialDefine
result Type' Ident
forall {ident}. Type' ident
rty (Typed PValue -> PValue -> Instr' Int
op Typed PValue
lhs (Typed PValue -> PValue
forall a. Typed a -> a
typedValue Typed PValue
rhs)) PartialDefine
d

  -- unknown
   | Bool
otherwise -> KindMd -> Parse PartialDefine
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail (KindMd
"instruction code " KindMd -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> KindMd
forall a. Show a => a -> KindMd
show Int
code KindMd -> ShowS
forall a. [a] -> [a] -> [a]
++ KindMd
" is unknown")

parseFunctionBlockEntry Int
_ ValueTable
_ PartialDefine
d (Match Entry [Entry]
valueSymtabBlockId -> Just [Entry]
_) = do
  -- this is parsed before any of the function block
  PartialDefine -> Parse PartialDefine
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialDefine
d

parseFunctionBlockEntry Int
globals ValueTable
t PartialDefine
d (Match Entry [Entry]
metadataBlockId -> Just [Entry]
es) = do
  (Seq NamedMd
_, (Seq PartialUnnamedMd
globalUnnamedMds, Seq PartialUnnamedMd
localUnnamedMds), InstrMdAttachments
_, Map Int PValMd
_, PGlobalAttachments
_) <- Int
-> ValueTable
-> [Entry]
-> Parse
     (Seq NamedMd, (Seq PartialUnnamedMd, Seq PartialUnnamedMd),
      InstrMdAttachments, Map Int PValMd, PGlobalAttachments)
parseMetadataBlock Int
globals ValueTable
t [Entry]
es
  if (Seq PartialUnnamedMd -> Bool
forall a. Seq a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq PartialUnnamedMd
localUnnamedMds)
    then PartialDefine -> Parse PartialDefine
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialDefine
d { partialGlobalMd = globalUnnamedMds <> partialGlobalMd d }
    else PartialDefine -> Parse PartialDefine
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialDefine
d -- silently drop unexpected local unnamed metadata

parseFunctionBlockEntry Int
globals ValueTable
t PartialDefine
d (Match Entry [Entry]
metadataAttachmentBlockId -> Just [Entry]
es) = do
  (Seq NamedMd
_,(Seq PartialUnnamedMd
globalUnnamedMds, Seq PartialUnnamedMd
localUnnamedMds),InstrMdAttachments
instrAtt,Map Int PValMd
fnAtt,PGlobalAttachments
_)
     <- Int
-> ValueTable
-> [Entry]
-> Parse
     (Seq NamedMd, (Seq PartialUnnamedMd, Seq PartialUnnamedMd),
      InstrMdAttachments, Map Int PValMd, PGlobalAttachments)
parseMetadataBlock Int
globals ValueTable
t [Entry]
es
  Bool -> Parse () -> Parse ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Seq PartialUnnamedMd -> Bool
forall a. Seq a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq PartialUnnamedMd
localUnnamedMds)
     (KindMd -> Parse ()
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail KindMd
"parseFunctionBlockEntry PANIC: unexpected local unnamed metadata")
  Bool -> Parse () -> Parse ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Seq PartialUnnamedMd -> Bool
forall a. Seq a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq PartialUnnamedMd
globalUnnamedMds)
     (KindMd -> Parse ()
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail KindMd
"parseFunctionBlockEntry PANIC: unexpected global unnamed metadata")
  PartialDefine -> Parse PartialDefine
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialDefine
d { partialBody     = addInstrAttachments instrAtt (partialBody d)
           , partialMetadata = Map.union fnAtt (partialMetadata d)
           }

parseFunctionBlockEntry Int
_ ValueTable
_ PartialDefine
d (Match Entry DefineAbbrev
abbrevDef -> Just DefineAbbrev
_) =
  -- ignore any abbreviation definitions
  PartialDefine -> Parse PartialDefine
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialDefine
d

parseFunctionBlockEntry Int
_ ValueTable
_ PartialDefine
d (Match Entry [Entry]
uselistBlockId -> Just [Entry]
_) = do
  -- ignore the uselist block
  PartialDefine -> Parse PartialDefine
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialDefine
d

parseFunctionBlockEntry Int
_ ValueTable
_ PartialDefine
_ Entry
e = do
  KindMd -> Parse PartialDefine
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail (KindMd
"function block: unexpected: " KindMd -> ShowS
forall a. [a] -> [a] -> [a]
++ Entry -> KindMd
forall a. Show a => a -> KindMd
show Entry
e)

addInstrAttachments :: InstrMdAttachments -> BlockList -> BlockList
addInstrAttachments :: InstrMdAttachments -> BlockList -> BlockList
addInstrAttachments InstrMdAttachments
atts BlockList
blocks = Int
-> [(Int, [(KindMd, PValMd)])] -> ViewL PartialBlock -> BlockList
go Int
0 (InstrMdAttachments -> [(Int, [(KindMd, PValMd)])]
forall k a. Map k a -> [(k, a)]
Map.toList InstrMdAttachments
atts) (BlockList -> ViewL PartialBlock
forall a. Seq a -> ViewL a
Seq.viewl BlockList
blocks)
  where
  go :: Int
-> [(Int, [(KindMd, PValMd)])] -> ViewL PartialBlock -> BlockList
go Int
_   []  (PartialBlock
b Seq.:< BlockList
bs) = PartialBlock
b PartialBlock -> BlockList -> BlockList
forall a. a -> Seq a -> Seq a
Seq.<| BlockList
bs
  go Int
off [(Int, [(KindMd, PValMd)])]
mds (PartialBlock
b Seq.:< BlockList
bs) =
    PartialBlock
b' PartialBlock -> BlockList -> BlockList
forall a. a -> Seq a -> Seq a
Seq.<| Int
-> [(Int, [(KindMd, PValMd)])] -> ViewL PartialBlock -> BlockList
go (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
numStmts) [(Int, [(KindMd, PValMd)])]
delay (BlockList -> ViewL PartialBlock
forall a. Seq a -> ViewL a
Seq.viewl BlockList
bs)
    where
    numStmts :: Int
numStmts = StmtList -> Int
forall a. Seq a -> Int
Seq.length (PartialBlock -> StmtList
partialStmts PartialBlock
b)

    -- partition the attachments into those that apply to this block, and those
    -- that don't
    ([(Int, [(KindMd, PValMd)])]
use,[(Int, [(KindMd, PValMd)])]
delay)   = ((Int, [(KindMd, PValMd)]) -> Bool)
-> [(Int, [(KindMd, PValMd)])]
-> ([(Int, [(KindMd, PValMd)])], [(Int, [(KindMd, PValMd)])])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Int, [(KindMd, PValMd)]) -> Bool
forall {b}. (Int, b) -> Bool
applies [(Int, [(KindMd, PValMd)])]
mds
    applies :: (Int, b) -> Bool
applies (Int
i,b
_) = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
off Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
numStmts

    b' :: PartialBlock
b' | [(Int, [(KindMd, PValMd)])] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, [(KindMd, PValMd)])]
use  = PartialBlock
b
       | Bool
otherwise = PartialBlock
b { partialStmts = foldl addMd (partialStmts b) use }

    addMd :: Seq (Stmt' lab) -> (Int, [(KindMd, ValMd' lab)]) -> Seq (Stmt' lab)
addMd Seq (Stmt' lab)
stmts (Int
i,[(KindMd, ValMd' lab)]
md') = (Stmt' lab -> Stmt' lab)
-> Int -> Seq (Stmt' lab) -> Seq (Stmt' lab)
forall a. (a -> a) -> Int -> Seq a -> Seq a
Seq.adjust Stmt' lab -> Stmt' lab
update (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
off) Seq (Stmt' lab)
stmts
      where
      update :: Stmt' lab -> Stmt' lab
update (Result Ident
n Instr' lab
s [(KindMd, ValMd' lab)]
md) = Ident -> Instr' lab -> [(KindMd, ValMd' lab)] -> Stmt' lab
forall lab.
Ident -> Instr' lab -> [(KindMd, ValMd' lab)] -> Stmt' lab
Result Ident
n Instr' lab
s ([(KindMd, ValMd' lab)]
md [(KindMd, ValMd' lab)]
-> [(KindMd, ValMd' lab)] -> [(KindMd, ValMd' lab)]
forall a. [a] -> [a] -> [a]
++ [(KindMd, ValMd' lab)]
md')
      update (Effect   Instr' lab
s [(KindMd, ValMd' lab)]
md) = Instr' lab -> [(KindMd, ValMd' lab)] -> Stmt' lab
forall lab. Instr' lab -> [(KindMd, ValMd' lab)] -> Stmt' lab
Effect   Instr' lab
s ([(KindMd, ValMd' lab)]
md [(KindMd, ValMd' lab)]
-> [(KindMd, ValMd' lab)] -> [(KindMd, ValMd' lab)]
forall a. [a] -> [a] -> [a]
++ [(KindMd, ValMd' lab)]
md')

  go Int
_ [(Int, [(KindMd, PValMd)])]
_ ViewL PartialBlock
Seq.EmptyL = BlockList
forall a. Seq a
Seq.empty

-- [n x operands]
parseGEP :: ValueTable -> Maybe Bool -> Record -> PartialDefine -> Parse PartialDefine
parseGEP :: ValueTable
-> Maybe Bool -> Record -> PartialDefine -> Parse PartialDefine
parseGEP ValueTable
t Maybe Bool
mbInBound Record
r PartialDefine
d = do
  (Bool
ib, Type' Ident
ty, Typed PValue
tv, Record
r', Int
ix) <-
      case Maybe Bool
mbInBound of

        -- FUNC_CODE_INST_GEP_OLD
        -- FUNC_CODE_INST_INBOUNDS_GEP_OLD
        Just Bool
ib -> do
          (Typed PValue
tv,Int
ix') <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
0
          Type' Ident
ty <- KindMd -> Type' Ident -> Parse (Type' Ident)
forall (m :: * -> *).
(MonadFail m, MonadPlus m) =>
KindMd -> Type' Ident -> m (Type' Ident)
Assert.elimPtrTo KindMd
"GEP not headed by pointer" (Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
tv)
          (Bool, Type' Ident, Typed PValue, Record, Int)
-> Parse (Bool, Type' Ident, Typed PValue, Record, Int)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
ib, Type' Ident
ty, Typed PValue
tv, Record
r, Int
ix')

        -- FUNC_CODE_INST_GEP
        Maybe Bool
Nothing -> do
          let r' :: Record
r' = Record -> Record
flattenRecord Record
r
          let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r'
          Bool
ib <- LookupField Bool
forall {a}. LookupField a
field Int
0 Match Field Bool
boolean
          Type' Ident
ty <- Int -> Parse (Type' Ident)
getType (Int -> Parse (Type' Ident)) -> Parse Int -> Parse (Type' Ident)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field Int
1 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
          (Typed PValue
tv,Int
ix') <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r' Int
2
          (Bool, Type' Ident, Typed PValue, Record, Int)
-> Parse (Bool, Type' Ident, Typed PValue, Record, Int)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
ib, Type' Ident
ty, Typed PValue
tv, Record
r', Int
ix')

  [Typed PValue]
args    <- KindMd -> Parse [Typed PValue] -> Parse [Typed PValue]
forall a. KindMd -> Parse a -> Parse a
label KindMd
"parseGepArgs" (ValueTable -> Record -> Int -> Parse [Typed PValue]
parseGepArgs ValueTable
t Record
r' Int
ix)
  Type' Ident
rty     <- KindMd -> Parse (Type' Ident) -> Parse (Type' Ident)
forall a. KindMd -> Parse a -> Parse a
label KindMd
"interpGep"    (Type' Ident
-> Typed PValue -> [Typed PValue] -> Parse (Type' Ident)
interpGep Type' Ident
ty Typed PValue
tv [Typed PValue]
args)
  Type' Ident -> Instr' Int -> PartialDefine -> Parse PartialDefine
result Type' Ident
rty (Bool -> Type' Ident -> Typed PValue -> [Typed PValue] -> Instr' Int
forall lab.
Bool
-> Type' Ident
-> Typed (Value' lab)
-> [Typed (Value' lab)]
-> Instr' lab
GEP Bool
ib Type' Ident
ty Typed PValue
tv [Typed PValue]
args) PartialDefine
d

-- Parse an @atomicrmw@ instruction, which can be represented by one of the
-- following function codes:
--
-- * FUNC_CODE_INST_ATOMICRMW_OLD, which was introduced in LLVM 6.0.
--   [ptrty, ptr,        val, operation, vol, ordering, ssid]
--
-- * FUNC_CODE_INST_ATOMICRMW, which was introduced in LLVM 13.
--   [ptrty, ptr, valty, val, operation, vol, ordering, ssid]
--
-- The only difference between the two is that FUNC_CODE_INST_ATOMICRMW has a
-- @valty@ field, whereas FUNC_CODE_INST_ATOMICRMW_OLD does not (it reuses the
-- type that @ptrty@ points to as the @valty@).
--
-- The parsing code was inspired by the upstream code at
-- https://github.com/llvm/llvm-project/blob/2362c4ecdc88123e5d54c7ebe30889fbfa760a88/llvm/lib/Bitcode/Reader/BitcodeReader.cpp#L5658-L5720.
parseAtomicRMW :: Bool -> ValueTable -> Record -> PartialDefine -> Parse PartialDefine
parseAtomicRMW :: Bool
-> ValueTable -> Record -> PartialDefine -> Parse PartialDefine
parseAtomicRMW Bool
old ValueTable
t Record
r PartialDefine
d = do
  -- TODO: parse sync scope (ssid)
  (Typed PValue
ptr, Int
ix0) <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
0

  (Typed PValue
val, Int
ix1) <-
    if Bool
old
      then -- FUNC_CODE_INST_ATOMICRMW_OLD
           do Type' Ident
ty <- KindMd -> Type' Ident -> Parse (Type' Ident)
forall (m :: * -> *).
(MonadFail m, MonadPlus m) =>
KindMd -> Type' Ident -> m (Type' Ident)
Assert.elimPtrTo KindMd
"atomicrmw instruction not headed by pointer" (Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
ptr)
              Typed PValue
typed <- ValueTable -> Type' Ident -> Int -> Parse (Typed PValue)
getValue ValueTable
t Type' Ident
ty (Int -> Parse (Typed PValue)) -> Parse Int -> Parse (Typed PValue)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Record -> LookupField Int
forall a. Record -> LookupField a
parseField Record
r Int
ix0 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
              if Type' Ident
ty Type' Ident -> Type' Ident -> Bool
forall a. Eq a => a -> a -> Bool
/= (Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
typed)
              then KindMd -> Parse (Typed PValue, Int)
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail (KindMd -> Parse (Typed PValue, Int))
-> KindMd -> Parse (Typed PValue, Int)
forall a b. (a -> b) -> a -> b
$ [KindMd] -> KindMd
unlines ([KindMd] -> KindMd) -> [KindMd] -> KindMd
forall a b. (a -> b) -> a -> b
$ [ KindMd
"Wrong type of value retrieved from value table"
                                    , KindMd
"Expected: " KindMd -> ShowS
forall a. [a] -> [a] -> [a]
++ Type' Ident -> KindMd
forall a. Show a => a -> KindMd
show (Type' Ident
ty)
                                    , KindMd
"Got: " KindMd -> ShowS
forall a. [a] -> [a] -> [a]
++ Type' Ident -> KindMd
forall a. Show a => a -> KindMd
show (Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
typed)
                                    ]
              else (Typed PValue, Int) -> Parse (Typed PValue, Int)
forall a. a -> Parse a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Typed PValue
typed, Int
ix0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      else -- FUNC_CODE_INST_ATOMICRMW
           ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
ix0

  -- Catch incorrect operand types
  let valTy :: Type' Ident
valTy = Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
val
  Bool -> Parse () -> Parse ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (case Type' Ident
valTy of
            PrimType (Integer   Word32
_) -> Bool
True
            PrimType (FloatType FloatType
_) -> Bool
True
            Type' Ident
_                      -> Bool
False) (Parse () -> Parse ()) -> Parse () -> Parse ()
forall a b. (a -> b) -> a -> b
$
    KindMd -> Parse ()
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail (KindMd -> Parse ()) -> KindMd -> Parse ()
forall a b. (a -> b) -> a -> b
$ KindMd
"Expected integer or float operand, found " KindMd -> ShowS
forall a. [a] -> [a] -> [a]
++ Type' Ident -> KindMd
forall a. Show a => a -> KindMd
show Type' Ident
valTy

  -- TODO: enable this assertion. Is getTypeValuePair returning the wrong value?
  -- when (length (recordFields r) /= ix1 + 4) $ do
  --   fail $ "Invalid record size: " ++ show (length (recordFields r))

  AtomicRWOp
operation <- Integer -> Parse AtomicRWOp
getDecodedAtomicRWOp (Integer -> Parse AtomicRWOp) -> Parse Integer -> Parse AtomicRWOp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Record -> LookupField Integer
forall a. Record -> LookupField a
parseField Record
r Int
ix1 Match Field Integer
forall a. (Num a, Bits a) => Match Field a
numeric
  Bool
volatile  <- Record -> LookupField Bool
forall a. Record -> LookupField a
parseField Record
r (Int
ix1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Match Field Bool
nonzero
  AtomicOrdering
ordering  <- Record -> LookupField Word32
forall a. Record -> LookupField a
parseField Record
r (Int
ix1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Match Field Word32
unsigned Parse Word32
-> (Word32 -> Parse (Maybe AtomicOrdering))
-> Parse (Maybe AtomicOrdering)
forall a b. Parse a -> (a -> Parse b) -> Parse b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word32 -> Parse (Maybe AtomicOrdering)
getDecodedOrdering Parse (Maybe AtomicOrdering)
-> (Maybe AtomicOrdering -> Parse AtomicOrdering)
-> Parse AtomicOrdering
forall a b. Parse a -> (a -> Parse b) -> Parse b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    \case
      Just AtomicOrdering
ordering -> AtomicOrdering -> Parse AtomicOrdering
forall a. a -> Parse a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AtomicOrdering
ordering
      Maybe AtomicOrdering
Nothing       -> KindMd -> Parse AtomicOrdering
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail (KindMd -> Parse AtomicOrdering) -> KindMd -> Parse AtomicOrdering
forall a b. (a -> b) -> a -> b
$ KindMd
"`atomicrmw` requires ordering: ix == " KindMd -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> KindMd
forall a. Show a => a -> KindMd
show Int
ix1

  Type' Ident -> Instr' Int -> PartialDefine -> Parse PartialDefine
result (Typed PValue -> Type' Ident
forall a. Typed a -> Type' Ident
typedType Typed PValue
val) (Bool
-> AtomicRWOp
-> Typed PValue
-> Typed PValue
-> Maybe KindMd
-> AtomicOrdering
-> Instr' Int
forall lab.
Bool
-> AtomicRWOp
-> Typed (Value' lab)
-> Typed (Value' lab)
-> Maybe KindMd
-> AtomicOrdering
-> Instr' lab
AtomicRW Bool
volatile AtomicRWOp
operation Typed PValue
ptr Typed PValue
val Maybe KindMd
forall a. Maybe a
Nothing AtomicOrdering
ordering) PartialDefine
d

-- | Generate a statement that doesn't produce a result.
effect :: Instr' Int -> PartialDefine -> Parse PartialDefine
effect :: Instr' Int -> PartialDefine -> Parse PartialDefine
effect Instr' Int
i PartialDefine
d = Stmt' Int -> PartialDefine -> Parse PartialDefine
addStmt (Instr' Int -> [(KindMd, PValMd)] -> Stmt' Int
forall lab. Instr' lab -> [(KindMd, ValMd' lab)] -> Stmt' lab
Effect Instr' Int
i []) PartialDefine
d

-- | Try to name results, fall back on leaving them as effects.
result :: Type -> Instr' Int -> PartialDefine -> Parse PartialDefine
result :: Type' Ident -> Instr' Int -> PartialDefine -> Parse PartialDefine
result (PrimType PrimType
Void) Instr' Int
i PartialDefine
d = Instr' Int -> PartialDefine -> Parse PartialDefine
effect Instr' Int
i PartialDefine
d
result Type' Ident
ty              Instr' Int
i PartialDefine
d = do
  Ident
res <- Type' Ident -> Parse Ident
nameNextValue Type' Ident
ty
  Stmt' Int -> PartialDefine -> Parse PartialDefine
addStmt (Ident -> Instr' Int -> [(KindMd, PValMd)] -> Stmt' Int
forall lab.
Ident -> Instr' lab -> [(KindMd, ValMd' lab)] -> Stmt' lab
Result Ident
res Instr' Int
i []) PartialDefine
d

-- | Loop, parsing arguments out of a record in pairs, as the arguments to a phi
-- instruction.
parsePhiArgs :: Bool -> ValueTable -> Record -> Parse [(PValue,Int)]
parsePhiArgs :: Bool -> ValueTable -> Record -> Parse [(PValue, Int)]
parsePhiArgs Bool
relIds ValueTable
t Record
r = Int -> Parse [(PValue, Int)]
forall {b}. (Num b, Bits b) => Int -> Parse [(PValue, b)]
loop Int
1
  where
  field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
  len :: Int
len   = [Field] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Record -> [Field]
recordFields Record
r)

  getId :: Int -> Parse Int
getId Int
n
    | Bool
relIds    = do
      Word64
i   <- LookupField Word64
forall {a}. LookupField a
field Int
n Match Field Word64
signedWord64
      Int
pos <- Parse Int
getNextId
      Int -> Parse Int
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
- Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i)
    | Bool
otherwise =
      LookupField Int
forall {a}. LookupField a
field Int
n Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric

  parse :: Int -> Parse (PValue, b)
parse Int
n = do
    Int
i   <- Int -> Parse Int
getId Int
n
    [KindMd]
cxt <- Parse [KindMd]
getContext
    let val :: Typed PValue
val = HasCallStack => [KindMd] -> Int -> ValueTable -> Typed PValue
[KindMd] -> Int -> ValueTable -> Typed PValue
forwardRef [KindMd]
cxt Int
i ValueTable
t
    b
bid <- LookupField b
forall {a}. LookupField a
field (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Match Field b
forall a. (Num a, Bits a) => Match Field a
numeric
    (PValue, b) -> Parse (PValue, b)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Typed PValue -> PValue
forall a. Typed a -> a
typedValue Typed PValue
val,b
bid)

  loop :: Int -> Parse [(PValue, b)]
loop Int
n
    -- We must stop when @n@ is either equal to @len@, or to @len - 1@ in the
    -- presence of fast math flags.
    | Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 = [(PValue, b)] -> Parse [(PValue, b)]
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    | Bool
otherwise   = (:) ((PValue, b) -> [(PValue, b)] -> [(PValue, b)])
-> Parse (PValue, b) -> Parse ([(PValue, b)] -> [(PValue, b)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parse (PValue, b)
forall {b}. (Num b, Bits b) => Int -> Parse (PValue, b)
parse Int
n Parse ([(PValue, b)] -> [(PValue, b)])
-> Parse [(PValue, b)] -> Parse [(PValue, b)]
forall a b. Parse (a -> b) -> Parse a -> Parse b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Parse [(PValue, b)]
loop (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)

-- | Parse the arguments for a call record.
parseCallArgs :: ValueTable -> Bool -> Record -> Int -> [Type] -> Parse [Typed PValue]
parseCallArgs :: ValueTable
-> Bool -> Record -> Int -> [Type' Ident] -> Parse [Typed PValue]
parseCallArgs ValueTable
t Bool
b Record
r = ValueTable
-> (Type' Ident -> Int -> Parse (Typed PValue))
-> Bool
-> Record
-> Int
-> [Type' Ident]
-> Parse [Typed PValue]
parseArgs ValueTable
t Type' Ident -> Int -> Parse (Typed PValue)
op Bool
b Record
r
 where
 op :: Type' Ident -> Int -> Parse (Typed PValue)
op Type' Ident
ty Int
i =
  case Type' Ident
ty of
    PrimType PrimType
Label -> Typed PValue -> Parse (Typed PValue)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type' Ident -> PValue -> Typed PValue
forall a. Type' Ident -> a -> Typed a
Typed Type' Ident
ty (Int -> PValue
forall lab. lab -> Value' lab
ValLabel Int
i))
    Type' Ident
_              -> ValueTable -> Type' Ident -> Int -> Parse (Typed PValue)
getValue ValueTable
t Type' Ident
ty Int
i

-- | Parse the arguments for an invoke record.
parseInvokeArgs :: ValueTable -> Bool -> Record -> Int -> [Type] -> Parse [Typed PValue]
parseInvokeArgs :: ValueTable
-> Bool -> Record -> Int -> [Type' Ident] -> Parse [Typed PValue]
parseInvokeArgs ValueTable
t = ValueTable
-> (Type' Ident -> Int -> Parse (Typed PValue))
-> Bool
-> Record
-> Int
-> [Type' Ident]
-> Parse [Typed PValue]
parseArgs ValueTable
t (ValueTable -> Type' Ident -> Int -> Parse (Typed PValue)
getValue ValueTable
t)

-- | Parse arguments for the invoke and call instructions.
parseArgs :: ValueTable -> (Type -> Int -> Parse (Typed PValue))
          -> Bool -> Record -> Int -> [Type] -> Parse [Typed PValue]
parseArgs :: ValueTable
-> (Type' Ident -> Int -> Parse (Typed PValue))
-> Bool
-> Record
-> Int
-> [Type' Ident]
-> Parse [Typed PValue]
parseArgs ValueTable
t Type' Ident -> Int -> Parse (Typed PValue)
parse Bool
va Record
r = Int -> [Type' Ident] -> Parse [Typed PValue]
loop
  where
  field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r

  len :: Int
len = [Field] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Record -> [Field]
recordFields Record
r)

  loop :: Int -> [Type' Ident] -> Parse [Typed PValue]
loop Int
ix (Type' Ident
ty:[Type' Ident]
tys) = do
    Typed PValue
tv   <- Type' Ident -> Int -> Parse (Typed PValue)
parse Type' Ident
ty (Int -> Parse (Typed PValue)) -> Parse Int -> Parse (Typed PValue)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field Int
ix Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
    [Typed PValue]
rest <- Int -> [Type' Ident] -> Parse [Typed PValue]
loop (Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [Type' Ident]
tys
    [Typed PValue] -> Parse [Typed PValue]
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Typed PValue
tvTyped PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
:[Typed PValue]
rest)
  loop Int
ix []
    | Bool
va        = Int -> Parse [Typed PValue]
varArgs Int
ix
    | Bool
otherwise = [Typed PValue] -> Parse [Typed PValue]
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return []

  varArgs :: Int -> Parse [Typed PValue]
varArgs Int
ix
    | Int
ix Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len  = do
      (Typed PValue
tv,Int
ix') <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
ix
      [Typed PValue]
rest     <- Int -> Parse [Typed PValue]
varArgs Int
ix'
      [Typed PValue] -> Parse [Typed PValue]
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Typed PValue
tvTyped PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
:[Typed PValue]
rest)
    | Bool
otherwise = [Typed PValue] -> Parse [Typed PValue]
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return []


parseGepArgs :: ValueTable -> Record -> Int -> Parse [Typed PValue]
parseGepArgs :: ValueTable -> Record -> Int -> Parse [Typed PValue]
parseGepArgs ValueTable
t Record
r = Int -> Parse [Typed PValue]
loop
  where
  loop :: Int -> Parse [Typed PValue]
loop Int
n = Parse [Typed PValue]
parse Parse [Typed PValue]
-> Parse [Typed PValue] -> Parse [Typed PValue]
forall a. Parse a -> Parse a -> Parse a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` [Typed PValue] -> Parse [Typed PValue]
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    where
    parse :: Parse [Typed PValue]
parse = do
      (Typed PValue
tv,Int
ix') <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
n
      [Typed PValue]
rest     <- Int -> Parse [Typed PValue]
loop Int
ix'
      [Typed PValue] -> Parse [Typed PValue]
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Typed PValue
tvTyped PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
:[Typed PValue]
rest)

-- | Interpret a getelementptr instruction to determine its result type.
interpGep :: Type -> Typed PValue -> [Typed PValue] -> Parse Type
interpGep :: Type' Ident
-> Typed PValue -> [Typed PValue] -> Parse (Type' Ident)
interpGep Type' Ident
baseTy Typed PValue
ptr [Typed PValue]
vs = IndexResult -> Parse (Type' Ident)
check (Type' Ident -> Typed PValue -> [Typed PValue] -> IndexResult
forall lab.
Type' Ident
-> Typed (Value' lab) -> [Typed (Value' lab)] -> IndexResult
resolveGep Type' Ident
baseTy Typed PValue
ptr [Typed PValue]
vs)
  where
  check :: IndexResult -> Parse (Type' Ident)
check IndexResult
res = case IndexResult
res of
    HasType Type' Ident
rty -> Type' Ident -> Parse (Type' Ident)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type' Ident -> Type' Ident
forall ident. Type' ident -> Type' ident
PtrTo Type' Ident
rty)
    IndexResult
Invalid -> KindMd -> Parse (Type' Ident)
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail (KindMd -> Parse (Type' Ident)) -> KindMd -> Parse (Type' Ident)
forall a b. (a -> b) -> a -> b
$ [KindMd] -> KindMd
unlines ([KindMd] -> KindMd) -> [KindMd] -> KindMd
forall a b. (a -> b) -> a -> b
$
      [ KindMd
"Unable to determine the type of getelementptr"
      , KindMd
"Base type: " KindMd -> ShowS
forall a. [a] -> [a] -> [a]
++ Type' Ident -> KindMd
forall a. Show a => a -> KindMd
show Type' Ident
baseTy
      , KindMd
"Pointer value: " KindMd -> ShowS
forall a. [a] -> [a] -> [a]
++ Typed PValue -> KindMd
forall a. Show a => a -> KindMd
show Typed PValue
ptr
      ]
    Resolve Ident
i Type' Ident -> IndexResult
k -> do
      Type' Ident
ty' <- Int -> Parse (Type' Ident)
getType' (Int -> Parse (Type' Ident)) -> Parse Int -> Parse (Type' Ident)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ident -> Parse Int
getTypeId Ident
i
      IndexResult -> Parse (Type' Ident)
check (Type' Ident -> IndexResult
k Type' Ident
ty')

parseIndexes :: (Num a, Bits a) => Record -> Int -> Parse [a]
parseIndexes :: forall a. (Num a, Bits a) => Record -> Int -> Parse [a]
parseIndexes Record
r = Int -> Parse [a]
forall {a}. (Num a, Bits a) => Int -> Parse [a]
loop
  where
  field :: LookupField a
field  = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
  loop :: Int -> Parse [a]
loop Int
n = do
    a
ix   <- LookupField a
forall {a}. LookupField a
field Int
n Match Field a
forall a. (Num a, Bits a) => Match Field a
numeric
    [a]
rest <- Int -> Parse [a]
loop (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Parse [a] -> Parse [a] -> Parse [a]
forall a. Parse a -> Parse a -> Parse a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` [a] -> Parse [a]
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    [a] -> Parse [a]
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
ixa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
rest)

interpValueIndex :: Type    -- ^ Aggregate (struct/array) type to index into
                 -> [Int32] -- ^ Indices
                 -> Parse Type
interpValueIndex :: Type' Ident -> [Int32] -> Parse (Type' Ident)
interpValueIndex Type' Ident
ty [Int32]
is = IndexResult -> Parse (Type' Ident)
check (Type' Ident -> [Int32] -> IndexResult
resolveValueIndex Type' Ident
ty [Int32]
is)
  where
  check :: IndexResult -> Parse (Type' Ident)
check IndexResult
res = case IndexResult
res of
    IndexResult
Invalid ->
      KindMd -> Parse (Type' Ident)
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail (KindMd -> Parse (Type' Ident)) -> KindMd -> Parse (Type' Ident)
forall a b. (a -> b) -> a -> b
$ [KindMd] -> KindMd
unlines ([KindMd] -> KindMd) -> [KindMd] -> KindMd
forall a b. (a -> b) -> a -> b
$
        [ KindMd
"Unable to determine the return type of `extractvalue`"
        , KindMd
"Hint: The input type should be an aggregate type (struct or array)"
        , KindMd
"Input type: " KindMd -> ShowS
forall a. [a] -> [a] -> [a]
++ Type' Ident -> KindMd
forall a. Show a => a -> KindMd
show Type' Ident
ty
        , KindMd
"Indices: " KindMd -> ShowS
forall a. [a] -> [a] -> [a]
++ [Int32] -> KindMd
forall a. Show a => a -> KindMd
show [Int32]
is
        ]
    HasType Type' Ident
rty -> Type' Ident -> Parse (Type' Ident)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Type' Ident
rty
    Resolve Ident
i Type' Ident -> IndexResult
k -> do
      Type' Ident
ty' <- Int -> Parse (Type' Ident)
getType' (Int -> Parse (Type' Ident)) -> Parse Int -> Parse (Type' Ident)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ident -> Parse Int
getTypeId Ident
i
      IndexResult -> Parse (Type' Ident)
check (Type' Ident -> IndexResult
k Type' Ident
ty')

-- | Parse out the integer values, and jump targets (as Int labels) for a switch
-- instruction.  For example, parsing the following switch instruction
--
-- >  switch i32 %Val, label %truedest [i32 0, label %falsedest]
--
-- yields the list [0,Ident "falsedest"], if labels are just 'Ident's.
parseSwitchLabels :: Type -> Record -> Int -> Parse [(Integer,Int)]
parseSwitchLabels :: Type' Ident -> Record -> Int -> Parse [(Integer, Int)]
parseSwitchLabels Type' Ident
ty Record
r = Int -> Parse [(Integer, Int)]
forall {b}. (Num b, Bits b) => Int -> Parse [(Integer, b)]
loop
  where
  field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
  len :: Int
len   = [Field] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Record -> [Field]
recordFields Record
r)

  loop :: Int -> Parse [(Integer, b)]
loop Int
n
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len  = [(Integer, b)] -> Parse [(Integer, b)]
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    | Bool
otherwise = do
      Typed PValue
tv <- Type' Ident -> Int -> Parse (Typed PValue)
getFnValueById Type' Ident
ty (Int -> Parse (Typed PValue)) -> Parse Int -> Parse (Typed PValue)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field Int
n Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
      Integer
i <- case Typed PValue -> PValue
forall a. Typed a -> a
typedValue Typed PValue
tv of
             ValInteger Integer
i -> Integer -> Parse Integer
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
i
             ValBool Bool
b -> Integer -> Parse Integer
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Integer
forall a. Enum a => Int -> a
toEnum (Bool -> Int
forall a. Enum a => a -> Int
fromEnum Bool
b))
             PValue
v -> KindMd -> Parse Integer
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail (KindMd -> Parse Integer) -> KindMd -> Parse Integer
forall a b. (a -> b) -> a -> b
$ [KindMd] -> KindMd
unwords [ KindMd
"Invalid value in SWITCH record. Found"
                                 , PValue -> KindMd
forall a. Show a => a -> KindMd
show PValue
v
                                 , KindMd
"at position"
                                 , Int -> KindMd
forall a. Show a => a -> KindMd
show Int
n
                                 ]
      b
l    <- LookupField b
forall {a}. LookupField a
field (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Match Field b
forall a. (Num a, Bits a) => Match Field a
numeric
      [(Integer, b)]
rest <- Int -> Parse [(Integer, b)]
loop (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2)
      [(Integer, b)] -> Parse [(Integer, b)]
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Integer
i,b
l)(Integer, b) -> [(Integer, b)] -> [(Integer, b)]
forall a. a -> [a] -> [a]
:[(Integer, b)]
rest)

-- | See the comment for 'parseSwitchLabels' for information about what this
-- does.
parseNewSwitchLabels :: Word32 -> Record -> Int -> Int -> Parse [(Integer,Int)]
parseNewSwitchLabels :: Word32 -> Record -> Int -> Int -> Parse [(Integer, Int)]
parseNewSwitchLabels Word32
width Record
r = Int -> Int -> Parse [(Integer, Int)]
forall {t} {b}.
(Ord t, Num t, Num b, Bits b) =>
t -> Int -> Parse [(Integer, b)]
loop
  where
  field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
  len :: Int
len   = [Field] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Record -> [Field]
recordFields Record
r)

  -- parse each group of cases as one or more numbers, and a basic block.
  loop :: t -> Int -> Parse [(Integer, b)]
loop t
numCases Int
n
    | t
numCases t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0 = [(Integer, b)] -> Parse [(Integer, b)]
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len      = KindMd -> Parse [(Integer, b)]
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail KindMd
"invalid SWITCH record"
    | Bool
otherwise     = do
      Int
numItems <- LookupField Int
forall {a}. LookupField a
field Int
n  Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
      ([Integer]
ls,Int
n')  <- Int -> Int -> Parse ([Integer], Int)
parseItems Int
numItems (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      b
lab      <- LookupField b
forall {a}. LookupField a
field Int
n' Match Field b
forall a. (Num a, Bits a) => Match Field a
numeric
      [(Integer, b)]
rest     <- t -> Int -> Parse [(Integer, b)]
loop (t
numCases t -> t -> t
forall a. Num a => a -> a -> a
- t
1) (Int
n' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      [(Integer, b)] -> Parse [(Integer, b)]
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return ([ (Integer
l,b
lab) | Integer
l <- [Integer]
ls ] [(Integer, b)] -> [(Integer, b)] -> [(Integer, b)]
forall a. [a] -> [a] -> [a]
++ [(Integer, b)]
rest)

  -- different numbers that all target the same basic block
  parseItems :: Int -> Int -> Parse ([Integer],Int)
  parseItems :: Int -> Int -> Parse ([Integer], Int)
parseItems Int
numItems Int
n
    | Int
numItems Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = ([Integer], Int) -> Parse ([Integer], Int)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],Int
n)
    | Bool
otherwise     = do
      Bool
isSingleNumber <- LookupField Bool
forall {a}. LookupField a
field Int
n Match Field Bool
boolean

      -- The number of words used to represent a case is only specified when the
      -- value comes from a large type.
      (Int
activeWords,Int
lowStart) <-
        if Word32
width Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
64
           then do Int
aw <- LookupField Int
forall {a}. LookupField a
field (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
                   (Int, Int) -> Parse (Int, Int)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
aw, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
           else (Int, Int) -> Parse (Int, Int)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
1,Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)

      -- read the chunks of the number in.  each chunk represents one 64-bit
      -- limb of a big num.
      [Word64]
chunks <- Record -> Int -> Int -> Match Field Word64 -> Parse [Word64]
forall a. Record -> Int -> Int -> Match Field a -> Parse [a]
parseSlice Record
r Int
lowStart Int
activeWords Match Field Word64
signedWord64

      -- decode limbs in big-endian order
      let low :: Integer
low = (Word64 -> Integer -> Integer) -> Integer -> [Word64] -> Integer
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Word64
l Integer
acc -> Integer
acc Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
64 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
l) Integer
0 [Word64]
chunks

      (Integer
num,Int
n') <-
        if Bool
isSingleNumber
           then (Integer, Int) -> Parse (Integer, Int)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
low, Int
lowStart Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
activeWords)
           else KindMd -> Parse (Integer, Int)
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail KindMd
"Unhandled case in switch: Please send in this test case!"

      ([Integer]
rest,Int
nFinal) <- Int -> Int -> Parse ([Integer], Int)
parseItems (Int
numItems Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
n'

      ([Integer], Int) -> Parse ([Integer], Int)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
numInteger -> [Integer] -> [Integer]
forall a. a -> [a] -> [a]
:[Integer]
rest,Int
nFinal)




type PClause = Clause' Int

parseClauses :: ValueTable -> Record -> Int -> Int -> Parse [PClause]
parseClauses :: ValueTable -> Record -> Int -> Int -> Parse [PClause]
parseClauses ValueTable
t Record
r = Int -> Int -> Parse [PClause]
forall {t}. (Ord t, Num t) => t -> Int -> Parse [PClause]
loop
  where
  loop :: t -> Int -> Parse [PClause]
loop t
n Int
ix
    | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0    = [PClause] -> Parse [PClause]
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    | Bool
otherwise = do
      Int
cty       <- Record -> LookupField Int
forall a. Record -> LookupField a
parseField Record
r Int
ix Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
      (Typed PValue
val,Int
ix') <- ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      [PClause]
cs        <- t -> Int -> Parse [PClause]
loop (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) Int
ix'
      case Int
cty :: Int of
        Int
0 -> [PClause] -> Parse [PClause]
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Typed PValue -> PClause
forall lab. Typed (Value' lab) -> Clause' lab
Catch  Typed PValue
val PClause -> [PClause] -> [PClause]
forall a. a -> [a] -> [a]
: [PClause]
cs)
        Int
1 -> [PClause] -> Parse [PClause]
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Typed PValue -> PClause
forall lab. Typed (Value' lab) -> Clause' lab
Filter Typed PValue
val PClause -> [PClause] -> [PClause]
forall a. a -> [a] -> [a]
: [PClause]
cs)
        Int
_ -> KindMd -> Parse [PClause]
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail (KindMd
"Invalid clause type: " KindMd -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> KindMd
forall a. Show a => a -> KindMd
show Int
cty)


-- | 'Nothing' corresponds to @NotAtomic@ in the LLVM source
getDecodedOrdering :: Word32 -> Parse (Maybe AtomicOrdering)
getDecodedOrdering :: Word32 -> Parse (Maybe AtomicOrdering)
getDecodedOrdering Word32
0 = Maybe AtomicOrdering -> Parse (Maybe AtomicOrdering)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AtomicOrdering
forall a. Maybe a
Nothing
getDecodedOrdering Word32
1 = Maybe AtomicOrdering -> Parse (Maybe AtomicOrdering)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (AtomicOrdering -> Maybe AtomicOrdering
forall a. a -> Maybe a
Just AtomicOrdering
Unordered)
getDecodedOrdering Word32
2 = Maybe AtomicOrdering -> Parse (Maybe AtomicOrdering)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (AtomicOrdering -> Maybe AtomicOrdering
forall a. a -> Maybe a
Just AtomicOrdering
Monotonic)
getDecodedOrdering Word32
3 = Maybe AtomicOrdering -> Parse (Maybe AtomicOrdering)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (AtomicOrdering -> Maybe AtomicOrdering
forall a. a -> Maybe a
Just AtomicOrdering
Acquire)
getDecodedOrdering Word32
4 = Maybe AtomicOrdering -> Parse (Maybe AtomicOrdering)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (AtomicOrdering -> Maybe AtomicOrdering
forall a. a -> Maybe a
Just AtomicOrdering
Release)
getDecodedOrdering Word32
5 = Maybe AtomicOrdering -> Parse (Maybe AtomicOrdering)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (AtomicOrdering -> Maybe AtomicOrdering
forall a. a -> Maybe a
Just AtomicOrdering
AcqRel)
getDecodedOrdering Word32
6 = Maybe AtomicOrdering -> Parse (Maybe AtomicOrdering)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (AtomicOrdering -> Maybe AtomicOrdering
forall a. a -> Maybe a
Just AtomicOrdering
SeqCst)
getDecodedOrdering Word32
i = KindMd -> Word32 -> Parse (Maybe AtomicOrdering)
forall (m :: * -> *) a b.
(MonadFail m, Show a) =>
KindMd -> a -> m b
Assert.unknownEntity KindMd
"atomic ordering" Word32
i


-- https://github.com/llvm-mirror/llvm/blob/release_60/include/llvm/Bitcode/LLVMBitCodes.h#L377
getDecodedAtomicRWOp :: Integer -> Parse AtomicRWOp
getDecodedAtomicRWOp :: Integer -> Parse AtomicRWOp
getDecodedAtomicRWOp Integer
0  = AtomicRWOp -> Parse AtomicRWOp
forall a. a -> Parse a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AtomicRWOp
AtomicXchg
getDecodedAtomicRWOp Integer
1  = AtomicRWOp -> Parse AtomicRWOp
forall a. a -> Parse a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AtomicRWOp
AtomicAdd
getDecodedAtomicRWOp Integer
2  = AtomicRWOp -> Parse AtomicRWOp
forall a. a -> Parse a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AtomicRWOp
AtomicSub
getDecodedAtomicRWOp Integer
3  = AtomicRWOp -> Parse AtomicRWOp
forall a. a -> Parse a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AtomicRWOp
AtomicAnd
getDecodedAtomicRWOp Integer
4  = AtomicRWOp -> Parse AtomicRWOp
forall a. a -> Parse a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AtomicRWOp
AtomicNand
getDecodedAtomicRWOp Integer
5  = AtomicRWOp -> Parse AtomicRWOp
forall a. a -> Parse a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AtomicRWOp
AtomicOr
getDecodedAtomicRWOp Integer
6  = AtomicRWOp -> Parse AtomicRWOp
forall a. a -> Parse a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AtomicRWOp
AtomicXor
getDecodedAtomicRWOp Integer
7  = AtomicRWOp -> Parse AtomicRWOp
forall a. a -> Parse a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AtomicRWOp
AtomicMax
getDecodedAtomicRWOp Integer
8  = AtomicRWOp -> Parse AtomicRWOp
forall a. a -> Parse a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AtomicRWOp
AtomicMin
getDecodedAtomicRWOp Integer
9  = AtomicRWOp -> Parse AtomicRWOp
forall a. a -> Parse a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AtomicRWOp
AtomicUMax
getDecodedAtomicRWOp Integer
10 = AtomicRWOp -> Parse AtomicRWOp
forall a. a -> Parse a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AtomicRWOp
AtomicUMin
getDecodedAtomicRWOp Integer
v  = KindMd -> Integer -> Parse AtomicRWOp
forall (m :: * -> *) a b.
(MonadFail m, Show a) =>
KindMd -> a -> m b
Assert.unknownEntity KindMd
"atomic RWOp" Integer
v

{-
Note [Typing function applications]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The LLVM Language Reference Manual says the following about the `call`
instruction:

    <result> = [tail | musttail | notail ] call [fast-math flags] [cconv] [ret attrs] [addrspace(<num>)]
               <ty>|<fnty> <fnptrval>(<function args>) [fn attrs] [ operand bundles ]

    ...

    * ‘fnty’: shall be the signature of the function being called. [...]
    * ‘fnptrval’: An LLVM value containing a pointer to a function to be called. [...]

One slightly surprising aspect of this instruction (at least, this was not
obvious to me when I first read it) is that `fnptrval` does _not_ have the type
`fnty`. Rather, `fnptrval` has a pointer type, and the underlying memory being
pointed to is treated as having type `fnty`.

A consequence of this property is that `fnty` is /never/ a pointer type. It is
easy to accidentally give the `fnty` of a `call` instruction a pointer type if
you simply compute the type of `fnptrval`, but this is incorrect. This is
especially incorrect in a world where pointers are opaque (see
https://llvm.org/docs/OpaquePointers.html), as you cannot know know what a
pointer's pointee type is by looking at the type alone. Instead, you must look
at the surrounding instruction to know what the pointee type is. In the case of
the `call` instruction, the pointee type for `fnptrval` is precisely `fnty`.

Similar reasoning applies to the `callbr` and `invoke` instructions, which also
invoke a pointer whose underlying memory has a function type.
-}