llvm-pretty-bc-parser-0.5.0.0: src/Data/LLVM/BitCode/IR/Function.hs
{-# 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.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 s = show $ ppLLVM llvmVlatest $ llvmPP s
-- Function Aliases ------------------------------------------------------------
type AliasList = Seq.Seq PartialAlias
data PartialAlias = PartialAlias
{ paLinkage :: Maybe Linkage
, paVisibility :: Maybe Visibility
, paName :: Symbol
, paType :: Type
, paTarget :: !Word32
} deriving Show
parseAliasOld :: Int -> Record -> Parse PartialAlias
parseAliasOld n r = do
sym <- entryName n
let field = parseField r
name = Symbol sym
ty <- getType =<< field 0 numeric
tgt <- field 1 numeric
lnk <- field 2 linkage
vis <- field 3 visibility
_ <- pushValue (Typed ty (ValSymbol name))
return PartialAlias
{ paLinkage = Just lnk
, paVisibility = Just vis
, paName = name
, paType = ty
, paTarget = tgt
}
parseAlias :: Record -> Parse PartialAlias
parseAlias r = do
n <- nextValueId
(name, offset) <- oldOrStrtabName n r
let field i = parseField r (i + offset)
ty <- getType =<< field 0 numeric
_addrSp <- field 1 unsigned
tgt <- field 2 numeric
lnk <- field 3 linkage
vis <- field 4 visibility
-- XXX: is it the case that the alias type will always be a pointer to the
-- aliasee?
_ <- pushValue (Typed (PtrTo ty) (ValSymbol name))
return PartialAlias
{ paLinkage = Just lnk
, paVisibility = Just vis
, paName = name
, paType = ty
, paTarget = tgt
}
finalizePartialAlias :: PartialAlias -> Finalize GlobalAlias
finalizePartialAlias pa = do
-- aliases refer to absolute offsets
tv <- getFnValueById (paType pa) (fromIntegral (paTarget pa))
tgt <- relabel requireBbEntryName (typedValue tv)
return GlobalAlias
{ aliasLinkage = paLinkage pa
, aliasVisibility = paVisibility pa
, aliasName = paName pa
, aliasType = paType pa
, aliasTarget = tgt
}
-- Function Attribute Record ---------------------------------------------------
type DeclareList = Seq.Seq FunProto
-- | Turn a function prototype into a declaration.
finalizeDeclare :: FunProto -> Finalize Declare
finalizeDeclare fp = case protoType fp of
PtrTo (FunTy ret args va) -> return Declare
{ decLinkage = protoLinkage fp
, decVisibility = protoVisibility fp
, decRetType = ret
, decName = protoSym fp
, decArgs = args
, decVarArgs = va
, decAttrs = []
, decComdat = protoComdat fp
}
_ -> fail "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
{ partialLinkage :: Maybe Linkage
, partialVisibility :: Maybe Visibility
, partialGC :: Maybe GC
, partialSection :: Maybe String
, partialRetType :: Type
, partialName :: Symbol
, partialArgs :: [Typed Ident]
, partialVarArgs :: Bool
, partialBody :: BlockList
, partialBlock :: StmtList
, partialBlockId :: !Int
, partialSymtab :: ValueSymtab
, partialMetadata :: Map.Map PKindMd PValMd
, partialGlobalMd :: !(Seq.Seq PartialUnnamedMd)
, partialComdatName :: Maybe String
} deriving Show
-- | Generate a partial function definition from a function prototype.
emptyPartialDefine :: FunProto -> Parse PartialDefine
emptyPartialDefine proto = do
(rty,tys,va) <- elimFunPtr (protoType proto)
`mplus` fail "invalid function type in prototype"
names <- mapM nameNextValue tys
symtab <- initialPartialSymtab
return PartialDefine
{ partialLinkage = protoLinkage proto
, partialVisibility = protoVisibility proto
, partialGC = protoGC proto
, partialSection = protoSect proto
, partialRetType = rty
, partialName = protoSym proto
, partialArgs = zipWith Typed tys names
, partialVarArgs = va
, partialBody = mempty
, partialBlock = mempty
, partialBlockId = 0
, partialSymtab = symtab
, partialMetadata = mempty
, partialGlobalMd = mempty
, partialComdatName = protoComdat proto
}
-- | Set the statement list in a partial define.
setPartialBlock :: StmtList -> PartialDefine -> PartialDefine
setPartialBlock stmts pd = pd { partialBlock = stmts }
-- | Set the block list in a partial define.
setPartialBody :: BlockList -> PartialDefine -> PartialDefine
setPartialBody blocks pd = pd { partialBody = blocks }
initialPartialSymtab :: Parse ValueSymtab
initialPartialSymtab = do
mb <- liftFinalize mempty $ bbEntryName Nothing 0
case mb of
Just{} -> return emptyValueSymtab
Nothing -> do
i <- nextResultId
return (addBBAnon 0 i emptyValueSymtab)
updateLastStmt :: (PStmt -> PStmt) -> PartialDefine -> Parse PartialDefine
updateLastStmt f pd = case updatePartialBlock `mplus` updatePartialBody of
Just pd' -> return pd'
Nothing -> fail "No statement to update"
where
updatePartialBlock = updateStmts partialBlock setPartialBlock pd
updatePartialBody = case Seq.viewr (partialBody pd) of
blocks Seq.:> b -> do
b' <- updateStmts partialStmts setPartialStmts b
return (setPartialBody (blocks Seq.|> b') pd)
Seq.EmptyR -> mzero
updateStmts prj upd a = case Seq.viewr (prj a) of
stmts Seq.:> stmt -> return (upd (stmts Seq.|> f stmt) a)
Seq.EmptyR -> mzero
-- | Finalize a partial definition.
finalizePartialDefine :: FuncSymTabs -> PartialDefine -> Parse Define
finalizePartialDefine defs pd =
label "finalizePartialDefine" $
-- augment the symbol table with implicitly named anonymous blocks, and
-- generate basic blocks.
withValueSymtab (partialSymtab pd) $ do
body <- liftFinalize defs $ finalizeBody (partialBody pd)
md <- finalizeMetadata defs (partialMetadata pd)
return Define
{ defLinkage = partialLinkage pd
, defVisibility = partialVisibility pd
, defGC = partialGC pd
, defAttrs = []
, defRetType = partialRetType pd
, defName = partialName pd
, defArgs = partialArgs pd
, defVarArgs = partialVarArgs pd
, defBody = body
, defSection = partialSection pd
, defMetadata = md
, defComdat = partialComdatName pd
}
finalizeMetadata :: FuncSymTabs -> PFnMdAttachments -> Parse FnMdAttachments
finalizeMetadata defs patt = Map.fromList <$> mapM f (Map.toList patt)
where f (k,md) = (,) <$> getKind k <*> (liftFinalize defs $ finalizePValMd md)
-- | Name the next result with either its symbol, or the next available
-- anonymous result id.
nameNextValue :: Type -> Parse Ident
nameNextValue ty = do
vs <- getValueTable
let nextId = valueNextId vs
name <- entryName nextId `mplus` (show <$> nextResultId)
let i = Ident name
tv = Typed ty (ValIdent i)
setValueTable (addValue tv vs)
return i
-- | The record that defines the number of blocks in a function.
declareBlocksRecord :: Match Entry UnabbrevRecord
declareBlocksRecord = hasUnabbrevCode 1 <=< unabbrev
-- | Emit a statement to the current partial definition.
addStmt :: Stmt' Int -> PartialDefine -> Parse PartialDefine
addStmt s d
| isTerminator (stmtInstr s) = terminateBlock d'
| otherwise = return d'
where
d' = 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 d = do
let next = partialBlockId d + 1
mb <- liftFinalize mempty $ bbEntryName Nothing next
d' <- case mb of
Just _ -> return d
Nothing -> do
-- no label, use the next result id
l <- nextResultId
return d { partialSymtab = addBBAnon next l (partialSymtab d) }
return 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 :: BlockList -> Finalize [BasicBlock]
finalizeBody = fmap F.toList . T.mapM finalizePartialBlock
data PartialBlock = PartialBlock
{ partialLabel :: !Int
, partialStmts :: StmtList
} deriving (Show)
setPartialStmts :: StmtList -> PartialBlock -> PartialBlock
setPartialStmts stmts pb = pb { partialStmts = stmts }
-- | Process a partial basic block into a full basic block.
finalizePartialBlock :: PartialBlock -> Finalize BasicBlock
finalizePartialBlock pb = BasicBlock
<$> bbEntryName Nothing (partialLabel pb)
<*> finalizeStmts (partialStmts 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 :: StmtList -> Finalize [Stmt]
finalizeStmts = mapM finalizeStmt . F.toList
finalizeStmt :: Stmt' Int -> Finalize Stmt
finalizeStmt = relabel requireBbEntryName
-- 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 = 15
-- | Parse the function block.
parseFunctionBlock ::
Int {- ^ unnamed globals so far -} ->
[Entry] -> Parse PartialDefine
parseFunctionBlock unnamedGlobals ents =
label "FUNCTION_BLOCK" $ enterFunctionDef $ do
-- parse the value symtab block first, so that names are present during the
-- rest of the parse
symtab <- label "VALUE_SYMTAB" $ do
mb <- match (findMatch valueSymtabBlockId) ents
case mb of
Just es -> parseValueSymbolTableBlock es
Nothing -> return mempty
-- pop the function prototype off of the internal stack
proto <- popFunProto
label (prettySym (protoSym proto)) $ withValueSymtab symtab $ do
-- generate the initial partial definition
pd <- emptyPartialDefine proto
rec pd' <- foldM (parseFunctionBlockEntry unnamedGlobals vt) pd ents
vt <- getValueTable
-- merge the symbol table with the anonymous symbol table
return 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 _ _ d (constantsBlockId -> Just es) = do
-- CONSTANTS_BLOCK
parseConstantsBlock es
return d
parseFunctionBlockEntry _ t d (fromEntry -> Just r) = case recordCode r of
-- [n]
1 -> label "FUNC_CODE_DECLARE_BLOCKS"
(Assert.recordSizeGreater r 0 >> return d)
-- [opval,ty,opval,opcode]
2 -> label "FUNC_CODE_INST_BINOP" $ do
let field = parseField r
(lhs,ix) <- getValueTypePair t r 0
rhs <- getValue t (typedType lhs) =<< field ix numeric
mkInstr <- field (ix + 1) 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 = numeric =<< fieldAt (ix + 2) r
result (typedType lhs) (mkInstr mbWord lhs (typedValue rhs)) d
-- [opval,opty,destty,castopc]
3 -> label "FUNC_CODE_INST_CAST" $ do
let field = parseField r
(tv,ix) <- getValueTypePair t r 0
Assert.recordSizeIn r [ix + 2]
resty <- getType =<< field ix numeric
cast' <- field (ix+1) castOp
result resty (cast' tv resty) d
4 -> label "FUNC_CODE_INST_GEP_OLD" (parseGEP t (Just False) r d)
-- [opval,ty,opval,opval]
5 -> label "FUNC_CODE_INST_SELECT" $ do
let field = parseField r
(tval,ix) <- getValueTypePair t r 0
fval <- getValue t (typedType tval) =<< field ix numeric
cond <- getValue t (PrimType (Integer 1)) =<< field (ix+1) numeric
result (typedType tval) (Select cond tval (typedValue fval)) d
-- [ty,opval,opval]
6 -> label "FUNC_CODE_INST_EXTRACTELT" $ do
(tv,ix) <- getValueTypePair t r 0
idx <- getValue t (PrimType (Integer 32)) =<< parseField r ix numeric
(_, ty) <- elimVector (typedType tv)
`mplus` fail "invalid EXTRACTELT record"
result ty (ExtractElt tv (typedValue idx)) d
-- [ty,opval,opval,opval]
7 -> label "FUNC_CODE_INST_INSERTELT" $ do
let field = parseField r
(tv,ix) <- getValueTypePair t r 0
(_,pty) <- elimVector (typedType tv)
`mplus` fail "invalid INSERTELT record (not a vector)"
elt <- getValue t pty =<< field ix numeric
idx <- getValue t (PrimType (Integer 32)) =<< field (ix+1) numeric
result (typedType tv) (InsertElt tv elt (typedValue idx)) d
-- [opval,ty,opval,opval]
8 -> label "FUNC_CODE_INST_SHUFFLEVEC" $ do
let field = parseField r
(vec1,ix) <- getValueTypePair t r 0
vec2 <- getValue t (typedType vec1) =<< field ix numeric
(mask,_) <- getValueTypePair t r (ix+1)
resTy <- case (typedType vec1,typedType mask) of
(Vector _ elemTy, Vector shuffleLen _) ->
return (Vector shuffleLen elemTy)
_ -> fail "Invalid arguments to shuffle vector (not vectors)"
result resTy (ShuffleVector vec1 (typedValue vec2) mask) d
-- 9 is handled lower down, as it's processed the same way as 28
-- [opval,opval<optional>]
10 -> label "FUNC_CODE_INST_RET" $ case length (recordFields r) of
0 -> effect RetVoid d
_ -> do
(tv, ix) <- getValueTypePair t r 0
Assert.recordSizeIn r [ix]
effect (Ret tv) d
-- [bb#,bb#,cond] or [bb#]
11 -> label "FUNC_CODE_INST_BR" $ do
Assert.recordSizeIn r [1, 3]
let field = parseField r
bb1 <- field 0 numeric
let jump = effect (Jump bb1) d
branch = do
bb2 <- field 1 numeric
n <- field 2 numeric
cond <- getValue t (PrimType (Integer 1)) n
effect (Br cond bb1 bb2) d
branch `mplus` jump
12 -> label "FUNC_CODE_INST_SWITCH" $ do
let field = parseField r
-- switch implementation magic, May 2012 => 1205 => 0x4B5
let switchInstMagic :: Int
switchInstMagic = 0x4B5
n <- field 0 numeric
-- parse the new switch format.
let newSwitch = do
opty <- getType =<< field 1 numeric
width <- case opty of
PrimType (Integer w) -> return w
_ -> fail "invalid switch discriminate"
cond <- getValue t opty =<< field 2 numeric
def <- field 3 numeric -- Int id of a label
numCases <- field 4 numeric
ls <- parseNewSwitchLabels width r numCases 5
effect (Switch cond def ls) d
-- parse the old switch format
-- [opty, op0, op1, ...]
let oldSwitch = do
opty <- getType n
cond <- getValue t opty =<< field 1 numeric
def <- field 2 numeric
ls <- parseSwitchLabels opty r 3
effect (Switch cond def ls) 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 n `shiftR` 16 == switchInstMagic then newSwitch else oldSwitch
-- [attrs,cc,normBB,unwindBB,fnty,op0,op1..]
13 -> label "FUNC_CODE_INST_INVOKE" $ do
Assert.recordSizeGreater r 3
let field = parseField r
ccinfo <- field 1 unsigned
normal <- field 2 numeric
unwind <- field 3 numeric
-- explicit function type?
(mbFTy,ix) <-
if testBit ccinfo 13
then do ty <- getType =<< field 4 numeric
return (Just ty, 5)
else return (Nothing, 4)
(f,ix') <- getValueTypePair t r ix
fty <- case mbFTy of
Just ty -> return ty
Nothing -> Assert.elimPtrTo "Callee is not a pointer" (typedType f)
(ret,as,va) <- elimFunTy fty
`mplus` fail "invalid INVOKE record"
args <- parseInvokeArgs t va r ix' as
-- Use `fty` instead of `typedType f` as the function type, as `typedType f`
-- will be a pointer type. See Note [Typing function applications].
result ret (Invoke fty (typedValue f) args normal unwind) d
14 -> label "FUNC_CODE_INST_UNWIND" (effect Unwind d)
15 -> label "FUNC_CODE_INST_UNREACHABLE" (effect Unreachable d)
-- [ty,val0,bb0,...]
16 -> label "FUNC_CODE_INST_PHI" $ do
ty <- getType =<< parseField r 0 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.
useRelIds <- getRelIds
args <- parsePhiArgs useRelIds t r
when (even (length (recordFields r))) $ do
pure () -- TODO: fast math flags
result ty (Phi ty args) d
-- 17 is unused
-- 18 is unused
-- [instty,opty,op,align]
19 -> label "FUNC_CODE_INST_ALLOCA" $ do
Assert.recordSizeIn r [4]
let field = parseField r
instty <- getType =<< field 0 numeric -- pointer type
ty <- getType =<< field 1 numeric -- size type
size <- getFnValueById ty =<< field 2 numeric -- size value
align <- field 3 numeric -- alignment value
let sval = case typedValue size of
ValInteger i | i == 1 -> Nothing
_ -> Just size
mask :: Word32
mask = (1 `shiftL` 5) .|. -- inalloca
(1 `shiftL` 6) .|. -- explicit type
(1 `shiftL` 7) -- swift error
aval = (1 `shiftL` (fromIntegral (align .&. complement mask))) `shiftR` 1
explicitType = testBit align 6
ity = if explicitType then PtrTo instty else instty
ret <- if explicitType
then return instty
else Assert.elimPtrTo "In return type:" instty
result ity (Alloca ret sval (Just aval)) d
-- [opty,op,align,vol]
20 -> label "FUNC_CODE_INST_LOAD" $ do
(tv,ix) <- getValueTypePair t r 0
Assert.recordSizeIn r [ix + 2, ix + 3]
(ret,ix') <-
if length (recordFields r) == ix + 3
then do ty <- getType =<< parseField r ix numeric
return (ty,ix+1)
else do ty <- Assert.elimPtrTo "" (typedType tv)
return (ty,ix)
aval <- parseField r ix' numeric
let align | aval > 0 = Just (bit aval `shiftR` 1)
| otherwise = Nothing
result ret (Load ret tv Nothing align) d
-- 21 is unused
-- 22 is unused
23 -> label "FUNC_CODE_INST_VAARG" $ do
Assert.recordSizeGreater r 2
let field = parseField r
ty <- getType =<< field 0 numeric
op <- getValue t ty =<< field 1 numeric
resTy <- getType =<< field 2 numeric
result resTy (VaArg op resTy) d
-- [ptrty,ptr,val,align,vol]
24 -> label "FUNC_CODE_INST_STORE_OLD" $ do
let field = parseField r
(ptr,ix) <- getValueTypePair t r 0
ty <- Assert.elimPtrTo "" (typedType ptr)
val <- getValue t ty =<< field ix numeric
aval <- field (ix+1) numeric
let align | aval > 0 = Just (bit aval `shiftR` 1)
| otherwise = Nothing
effect (Store val ptr Nothing align) d
-- 25 is unused
-- LLVM 6: [opty, opval, n x indices]
26 -> label "FUNC_CODE_INST_EXTRACTVAL" $ do
(tv, ix) <- getValueTypePair t r 0
when (length (recordFields r) == ix) $
fail "`extractval` instruction had zero indices"
ixs <- parseIndexes r ix
let instr = ExtractValue tv ixs
-- The return type of this instruction depends on the given indices into the
-- type.
ret <- interpValueIndex (typedType tv) ixs
result ret instr d
27 -> label "FUNC_CODE_INST_INSERTVAL" $ do
(tv,ix) <- getValueTypePair t r 0
-- See comment in FUNC_CODE_INST_EXTRACTVAL
when (length (recordFields r) == ix) $
fail "Invalid instruction with zero indices"
(elt,ix') <- getValueTypePair t r ix
ixs <- parseIndexes r ix'
result (typedType tv) (InsertValue tv elt ixs) d
-- 28 is handled lower down, as it's processed the same way as 9
29 -> label "FUNC_CODE_INST_VSELECT" $ do
let field = parseField r
(tv,ix) <- getValueTypePair t r 0
fv <- getValue t (typedType tv) =<< field ix numeric
(c,_) <- getValueTypePair t r (ix+1)
-- XXX: we're ignoring the fast-math flags
result (typedType tv) (Select c tv (typedValue fv)) d
30 -> label "FUNC_CODE_INST_INBOUNDS_GEP_OLD" (parseGEP t (Just True) r d)
31 -> label "FUNC_CODE_INST_INDIRECTBR" $ do
let field = parseField r
ty <- getType =<< field 0 numeric
addr <- getValue t ty =<< field 1 numeric
ls <- parseIndexes r 2
effect (IndirectBr addr ls) d
-- 32 is unused
33 -> label "FUNC_CODE_DEBUG_LOC_AGAIN" $ do
loc <- getLastLoc
updateLastStmt (extendMetadata ("dbg", ValMdLoc loc)) d
-- [paramattrs, cc, mb fmf, mb fnty, fnid, arg0 .. arg n, varargs]
34 -> label "FUNC_CODE_INST_CALL" $ do
Assert.recordSizeGreater r 2
let field = parseField r
-- pal <- field 0 numeric -- N.B. skipping param attributes
ccinfo <- field 1 numeric
let ix0 = if testBit ccinfo 17 then 3 else 2 -- N.B. skipping fast-math flags
(mbFnTy, ix1) <- if testBit (ccinfo :: Word32) callExplicitTypeBit
then do fnTy <- getType =<< field ix0 numeric
return (Just fnTy, ix0+1)
else return (Nothing, ix0)
(Typed opTy fn, ix2) <- getValueTypePair t r ix1
`mplus` fail "Invalid record"
fnty <- case mbFnTy of
Just ty -> return ty
Nothing -> do
op <- Assert.elimPtrTo "Callee is not a pointer type" opTy
case op of
FunTy{} -> return op
_ -> fail "Callee is not of pointer to function type"
label (show fn) $ do
(ret,as,va) <- elimFunTy fnty `mplus` fail "invalid CALL record"
args <- parseCallArgs t va r ix2 as
-- Use `fnty` instead of `opTy` as the function type, as `opTy` will be
-- a pointer type. See Note [Typing function applications].
result ret (Call False fnty fn args) d
-- [Line,Col,ScopeVal, IAVal]
35 -> label "FUNC_CODE_DEBUG_LOC" $ do
Assert.recordSizeGreater r 3
let field = parseField r
line <- field 0 numeric
col <- field 1 numeric
scopeId <- field 2 numeric
iaId <- field 3 numeric
scope <- if scopeId > 0
then getMetadata (scopeId - 1)
else fail "No scope provided"
ia <- if iaId > 0
then Just `fmap` getMetadata (iaId - 1)
else return Nothing
let loc = DebugLoc
{ dlLine = line
, dlCol = col
, dlScope = typedValue scope
, dlIA = typedValue `fmap` ia
, dlImplicit = False
}
setLastLoc loc
updateLastStmt (extendMetadata ("dbg", ValMdLoc loc)) d
-- [ordering, synchscope]
36 -> label "FUNC_CODE_INST_FENCE" $ do
Assert.recordSizeIn r [2]
mordval <- getDecodedOrdering =<< parseField r 0 unsigned
-- TODO: parse scope
case mordval of
Just ordval -> effect (Fence Nothing ordval) d
Nothing -> fail "`fence` instruction requires ordering"
-- [ptrty,ptr,cmp,new, align, vol,
-- ordering, synchscope]
37 -> label "FUNC_CODE_INST_CMPXCHG_OLD" $ do
notImplemented
-- LLVM 6.0: [ptrty, ptr, val, operation, vol, ordering, ssid]
38 -> label "FUNC_CODE_INST_ATOMICRMW_OLD" $
parseAtomicRMW True t r d
-- [opval]
39 -> label "FUNC_CODE_RESUME" $ do
(tv,_) <- getValueTypePair t r 0
effect (Resume tv) d
-- [ty,val,val,num,id0,val0...]
40 -> label "FUNC_CODE_LANDINGPAD_OLD" $ do
Assert.recordSizeGreater r 3
let field = parseField r
ty <- getType =<< field 0 numeric
(persFn,ix) <- getValueTypePair t r 1
val <- field ix numeric
let isCleanup = val /= (0 :: Int)
len <- field (ix + 1) numeric
clauses <- parseClauses t r len (ix + 2)
result ty (LandingPad ty (Just persFn) isCleanup clauses) d
-- [opty, op, align, vol, ordering, synchscope]
41 -> label "FUNC_CODE_LOADATOMIC" $ do
(tv,ix) <- getValueTypePair t r 0
Assert.recordSizeIn r [ix + 4, ix+ 5]
(ret,ix') <-
if length (recordFields r) == ix + 5
then do ty <- getType =<< parseField r ix numeric
return (ty, ix + 1)
else do ty <- Assert.elimPtrTo "" (typedType tv)
return (ty, ix)
ordval <- getDecodedOrdering =<< parseField r (ix' + 2) unsigned
when (ordval `elem` Nothing:map Just [Release, AcqRel]) $
fail $ "Invalid atomic ordering: " ++ show ordval
aval <- parseField r ix' numeric
let align | aval > 0 = Just (bit aval `shiftR` 1)
| otherwise = Nothing
when (ordval /= Nothing && align == Nothing)
(fail "Invalid record")
result ret (Load ret tv ordval align) d
-- [ptrty, ptr, val, align, vol, ordering, synchscope]
42 -> label "FUNC_CODE_INST_STOREATOMIC_OLD" $ do
notImplemented
43 -> label "FUNC_CODE_INST_GEP" (parseGEP t Nothing r d)
44 -> label "FUNC_CODE_INST_STORE" $ do
let field = parseField r
(ptr,ix) <- getValueTypePair t r 0
(val,ix') <- getValueTypePair t r ix
Assert.recordSizeIn r [ix' + 2]
aval <- field ix' numeric
let align | aval > 0 = Just (bit aval `shiftR` 1)
| otherwise = Nothing
effect (Store val ptr Nothing align) d
-- LLVM 6: [ptrty, ptr, val, align, vol, ordering, ssid]
45 -> label "FUNC_CODE_INST_STOREATOMIC" $ do
(ptr, ix) <- getValueTypePair t r 0
(val, ix') <- getValueTypePair t r ix
Assert.recordSizeIn r [ix' + 4]
-- TODO: There's no spot in the AST for this ordering. Should there be?
ordering <- getDecodedOrdering =<< parseField r (ix' + 2) unsigned
when (ordering `elem` Nothing:map Just [Acquire, AcqRel]) $
fail $ "Invalid atomic ordering: " ++ show ordering
-- TODO: parse sync scope (ssid)
-- copy-pasted from LOADATOMIC
aval <- parseField r ix' numeric
let align | aval > 0 = Just (bit aval `shiftR` 1)
| otherwise = Nothing
effect (Store val ptr ordering align) d
-- LLVM 6: [ptrty, ptr, cmp, new, vol, successordering, ssid,
-- failureordering?, isweak?]
46 -> label "FUNC_CODE_INST_CMPXCHG" $ do
(ptr, ix) <- getValueTypePair t r 0
(val, ix') <- getValueTypePair t r ix
new <- getValue t (typedType val) =<< parseField r ix' numeric
let ix'' = ix' + 1 -- TODO: is this right?
-- TODO: record size assertion
-- Assert.recordSizeGreater r (ix'' + 5)
unless (typedType val `eqTypeModuloOpaquePtrs` typedType new)
-- This test is generally validating the behavior of this library: the LLVM
-- bitcode was likely generated by LLVM and is therefore "correct".
$ fail $ unlines $
[ "Mismatched value types:"
, "cmp value: " ++ show (typedValue val)
, "new value: " ++ show (typedValue new)
, "cmp type: " ++ show (typedType val)
, "new type: " ++ show (typedType new)
]
volatile <- parseField r ix'' boolean
successOrdering_ <- getDecodedOrdering =<< parseField r (ix'' + 1) unsigned
let successOrderMsg ord = "Invalid success ordering: " ++ show ord
successOrdering <-
case successOrdering_ of
Nothing -> fail (successOrderMsg successOrdering_)
Just Unordered -> fail (successOrderMsg successOrdering_)
Just ordering -> pure ordering
-- TODO: parse sync scope (ssid)
-- ssid <- parseField r (ix'' + 2) ssid
let len = length (recordFields r)
failureOrdering_ <-
if len < 7
-- Implementation of getStrongestFailureOrdering in llvm/IR/Instructions.h:
then case successOrdering of
Release -> pure (Just Monotonic)
Monotonic -> pure (Just Monotonic)
Acquire -> pure (Just Acquire) -- TODO: AcquireRelease?
SeqCst -> pure (Just SeqCst)
_ -> fail (successOrderMsg successOrdering)
else getDecodedOrdering =<< parseField r (ix'' + 3) unsigned
failureOrdering <-
case failureOrdering_ of
Nothing -> fail "Invalid failure ordering (Nothing)"
Just ord -> pure ord
weak <-
if len < 8
then fail "Not yet implemented: old-style cmpxchg instruction (weak)"
else parseField r (ix'' + 4) 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 = Struct [typedType val, PrimType (Integer 1)]
result ty (CmpXchg weak volatile ptr val new Nothing successOrdering failureOrdering) d
47 -> label "FUNC_CODE_LANDINGPAD" $ do
Assert.recordSizeGreater r 2
let field = parseField r
ty <- getType =<< field 0 numeric
isCleanup <- (/=(0::Int)) <$> field 1 numeric
len <- field 2 numeric
clauses <- parseClauses t r len 3
result ty (LandingPad ty Nothing isCleanup clauses) d
48 -> label "FUNC_CODE_CLEANUPRET" $ do
-- Assert.recordSizeIn r [1, 2]
notImplemented
49 -> label "FUNC_CODE_CATCHRET" $ do
-- Assert.recordSizeIn r [2]
notImplemented
50 -> label "FUNC_CODE_CATCHPAD" $ do
notImplemented
51 -> label "FUNC_CODE_CLEANUPPAD" $ do
-- Assert.recordSizeGreater r [1]
notImplemented
52 -> label "FUNC_CODE_CATCHSWITCH" $ do
-- Assert.recordSizeGreater r [1]
notImplemented
-- 53 is unused
-- 54 is unused
55 -> label "FUNC_CODE_OPERAND_BUNDLE" $ do
notImplemented
-- [opval,ty,opcode]
56 -> label "FUNC_CODE_INST_UNOP" $ do
let field = parseField r
(v,ix) <- getValueTypePair t r 0
mkInstr <- field ix unop
-- XXX: we're ignoring the fast-math flags
result (typedType v) (mkInstr v) d
-- LLVM 9: [attr, cc, norm, transfs, fnty, fnid, args...]
57 -> label "FUNC_CODE_INST_CALLBR" $ 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 = parseField r
-- pal <- field 0 numeric -- N.B. skipping param attributes
ccinfo <- field 1 unsigned
normal <- field 2 numeric
numIndirect <- field 3 numeric
indirectDests <- mapM (\idx -> field (4 + idx) numeric) [0..numIndirect - 1]
let ix0 = 4 + numIndirect
(mbFnTy, ix1) <- if testBit (ccinfo :: Word32) callExplicitTypeBit
then do fnTy <- getType =<< field ix0 numeric
return (Just fnTy, ix0+1)
else return (Nothing, ix0)
(Typed opTy fn, ix2) <- getValueTypePair t r ix1
`mplus` fail "Invalid callbr record"
fnty <- case mbFnTy of
Just ty -> return ty
Nothing -> do
op <- Assert.elimPtrTo "callbr callee is not a pointer type" opTy
case op of
FunTy{} -> return op
_ -> fail "Callee is not of pointer to function type"
label (show fn) $ do
(ret,as,va) <- elimFunTy fnty `mplus` fail "invalid CALLBR record"
args <- parseCallArgs t va r ix2 as
-- Use `fnty` instead of `opTy` as the function type, as `opTy` will be
-- a pointer type. See Note [Typing function applications].
result ret (CallBr fnty fn args normal indirectDests) d
-- [opty, opval]
58 -> label "FUNC_CODE_INST_FREEZE" $ do
(v,_) <- getValueTypePair t r 0
result (typedType v) (Freeze v) d
-- LLVM 13: [ptrty, ptr, valty, val, operation, vol, ordering, ssid]
59 -> label "FUNC_CODE_INST_ATOMICRMW" $
parseAtomicRMW False t r d
-- [opty,opval,opval,pred]
code
| code == 9
|| code == 28 -> label "FUNC_CODE_INST_CMP2" $ do
let field = parseField r
(lhs,ix) <- getValueTypePair t r 0
`mplus` (do i <- adjustId =<< field 0 numeric
cxt <- getContext
return (forwardRef cxt i t, 1))
rhs <- getValue t (typedType lhs) =<< field ix numeric
let ty = typedType lhs
parseOp | isPrimTypeOf isFloatingPoint ty ||
isVectorOf (isPrimTypeOf isFloatingPoint) ty =
return . FCmp <=< fcmpOp
| otherwise =
return . ICmp <=< icmpOp
op <- field (ix + 1) parseOp
-- XXX: we're ignoring the fast-math flags
let boolTy = Integer 1
let rty = case ty of
Vector n _ -> Vector n (PrimType boolTy)
_ -> PrimType boolTy
result rty (op lhs (typedValue rhs)) d
-- unknown
| otherwise -> fail ("instruction code " ++ show code ++ " is unknown")
parseFunctionBlockEntry _ _ d (valueSymtabBlockId -> Just _) = do
-- this is parsed before any of the function block
return d
parseFunctionBlockEntry globals t d (metadataBlockId -> Just es) = do
(_, (globalUnnamedMds, localUnnamedMds), _, _, _) <- parseMetadataBlock globals t es
if (null localUnnamedMds)
then return d { partialGlobalMd = globalUnnamedMds <> partialGlobalMd d }
else return d -- silently drop unexpected local unnamed metadata
parseFunctionBlockEntry globals t d (metadataAttachmentBlockId -> Just es) = do
(_,(globalUnnamedMds, localUnnamedMds),instrAtt,fnAtt,_)
<- parseMetadataBlock globals t es
unless (null localUnnamedMds)
(fail "parseFunctionBlockEntry PANIC: unexpected local unnamed metadata")
unless (null globalUnnamedMds)
(fail "parseFunctionBlockEntry PANIC: unexpected global unnamed metadata")
return d { partialBody = addInstrAttachments instrAtt (partialBody d)
, partialMetadata = Map.union fnAtt (partialMetadata d)
}
parseFunctionBlockEntry _ _ d (abbrevDef -> Just _) =
-- ignore any abbreviation definitions
return d
parseFunctionBlockEntry _ _ d (uselistBlockId -> Just _) = do
-- ignore the uselist block
return d
parseFunctionBlockEntry _ _ _ e = do
fail ("function block: unexpected: " ++ show e)
addInstrAttachments :: InstrMdAttachments -> BlockList -> BlockList
addInstrAttachments atts blocks = go 0 (Map.toList atts) (Seq.viewl blocks)
where
go _ [] (b Seq.:< bs) = b Seq.<| bs
go off mds (b Seq.:< bs) =
b' Seq.<| go (off + numStmts) delay (Seq.viewl bs)
where
numStmts = Seq.length (partialStmts b)
-- partition the attachments into those that apply to this block, and those
-- that don't
(use,delay) = span applies mds
applies (i,_) = i - off < numStmts
b' | null use = b
| otherwise = b { partialStmts = foldl addMd (partialStmts b) use }
addMd stmts (i,md') = Seq.adjust update (i-off) stmts
where
update (Result n s md) = Result n s (md ++ md')
update (Effect s md) = Effect s (md ++ md')
go _ _ Seq.EmptyL = Seq.empty
-- [n x operands]
parseGEP :: ValueTable -> Maybe Bool -> Record -> PartialDefine -> Parse PartialDefine
parseGEP t mbInBound r d = do
(ib, ty, tv, r', ix) <-
case mbInBound of
-- FUNC_CODE_INST_GEP_OLD
-- FUNC_CODE_INST_INBOUNDS_GEP_OLD
Just ib -> do
(tv,ix') <- getValueTypePair t r 0
ty <- Assert.elimPtrTo "GEP not headed by pointer" (typedType tv)
return (ib, ty, tv, r, ix')
-- FUNC_CODE_INST_GEP
Nothing -> do
let r' = flattenRecord r
let field = parseField r'
ib <- field 0 boolean
ty <- getType =<< field 1 numeric
(tv,ix') <- getValueTypePair t r' 2
return (ib, ty, tv, r', ix')
args <- label "parseGepArgs" (parseGepArgs t r' ix)
rty <- label "interpGep" (interpGep ty tv args)
result rty (GEP ib ty tv args) 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 old t r d = do
-- TODO: parse sync scope (ssid)
(ptr, ix0) <- getValueTypePair t r 0
(val, ix1) <-
if old
then -- FUNC_CODE_INST_ATOMICRMW_OLD
do ty <- Assert.elimPtrTo "atomicrmw instruction not headed by pointer" (typedType ptr)
typed <- getValue t ty =<< parseField r ix0 numeric
if ty /= (typedType typed)
then fail $ unlines $ [ "Wrong type of value retrieved from value table"
, "Expected: " ++ show (ty)
, "Got: " ++ show (typedType typed)
]
else pure (typed, ix0 + 1)
else -- FUNC_CODE_INST_ATOMICRMW
getValueTypePair t r ix0
-- Catch incorrect operand types
let valTy = typedType val
unless (case valTy of
PrimType (Integer _) -> True
PrimType (FloatType _) -> True
_ -> False) $
fail $ "Expected integer or float operand, found " ++ show 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))
operation <- getDecodedAtomicRWOp =<< parseField r ix1 numeric
volatile <- parseField r (ix1 + 1) nonzero
ordering <- parseField r (ix1 + 2) unsigned >>= getDecodedOrdering >>=
\case
Just ordering -> pure ordering
Nothing -> fail $ "`atomicrmw` requires ordering: ix == " ++ show ix1
result (typedType val) (AtomicRW volatile operation ptr val Nothing ordering) d
-- | Generate a statement that doesn't produce a result.
effect :: Instr' Int -> PartialDefine -> Parse PartialDefine
effect i d = addStmt (Effect i []) d
-- | Try to name results, fall back on leaving them as effects.
result :: Type -> Instr' Int -> PartialDefine -> Parse PartialDefine
result (PrimType Void) i d = effect i d
result ty i d = do
res <- nameNextValue ty
addStmt (Result res i []) 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 relIds t r = loop 1
where
field = parseField r
len = length (recordFields r)
getId n
| relIds = do
i <- field n signedWord64
pos <- getNextId
return (pos - fromIntegral i)
| otherwise =
field n numeric
parse n = do
i <- getId n
cxt <- getContext
let val = forwardRef cxt i t
bid <- field (n+1) numeric
return (typedValue val,bid)
loop n
-- We must stop when @n@ is either equal to @len@, or to @len - 1@ in the
-- presence of fast math flags.
| len - n < 2 = return []
| otherwise = (:) <$> parse n <*> loop (n + 2)
-- | Parse the arguments for a call record.
parseCallArgs :: ValueTable -> Bool -> Record -> Int -> [Type] -> Parse [Typed PValue]
parseCallArgs t b r = parseArgs t op b r
where
op ty i =
case ty of
PrimType Label -> return (Typed ty (ValLabel i))
_ -> getValue t ty i
-- | Parse the arguments for an invoke record.
parseInvokeArgs :: ValueTable -> Bool -> Record -> Int -> [Type] -> Parse [Typed PValue]
parseInvokeArgs t = parseArgs t (getValue t)
-- | Parse arguments for the invoke and call instructions.
parseArgs :: ValueTable -> (Type -> Int -> Parse (Typed PValue))
-> Bool -> Record -> Int -> [Type] -> Parse [Typed PValue]
parseArgs t parse va r = loop
where
field = parseField r
len = length (recordFields r)
loop ix (ty:tys) = do
tv <- parse ty =<< field ix numeric
rest <- loop (ix+1) tys
return (tv:rest)
loop ix []
| va = varArgs ix
| otherwise = return []
varArgs ix
| ix < len = do
(tv,ix') <- getValueTypePair t r ix
rest <- varArgs ix'
return (tv:rest)
| otherwise = return []
parseGepArgs :: ValueTable -> Record -> Int -> Parse [Typed PValue]
parseGepArgs t r = loop
where
loop n = parse `mplus` return []
where
parse = do
(tv,ix') <- getValueTypePair t r n
rest <- loop ix'
return (tv:rest)
-- | Interpret a getelementptr instruction to determine its result type.
interpGep :: Type -> Typed PValue -> [Typed PValue] -> Parse Type
interpGep baseTy ptr vs = check (resolveGep baseTy ptr vs)
where
check res = case res of
HasType rty -> return (PtrTo rty)
Invalid -> fail $ unlines $
[ "Unable to determine the type of getelementptr"
, "Base type: " ++ show baseTy
, "Pointer value: " ++ show ptr
]
Resolve i k -> do
ty' <- getType' =<< getTypeId i
check (k ty')
parseIndexes :: (Num a, Bits a) => Record -> Int -> Parse [a]
parseIndexes r = loop
where
field = parseField r
loop n = do
ix <- field n numeric
rest <- loop (n+1) `mplus` return []
return (ix:rest)
interpValueIndex :: Type -- ^ Aggregate (struct/array) type to index into
-> [Int32] -- ^ Indices
-> Parse Type
interpValueIndex ty is = check (resolveValueIndex ty is)
where
check res = case res of
Invalid ->
fail $ unlines $
[ "Unable to determine the return type of `extractvalue`"
, "Hint: The input type should be an aggregate type (struct or array)"
, "Input type: " ++ show ty
, "Indices: " ++ show is
]
HasType rty -> return rty
Resolve i k -> do
ty' <- getType' =<< getTypeId i
check (k 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 ty r = loop
where
field = parseField r
len = length (recordFields r)
loop n
| n >= len = return []
| otherwise = do
tv <- getFnValueById ty =<< field n numeric
i <- case typedValue tv of
ValInteger i -> return i
ValBool b -> return (toEnum (fromEnum b))
v -> fail $ unwords [ "Invalid value in SWITCH record. Found"
, show v
, "at position"
, show n
]
l <- field (n+1) numeric
rest <- loop (n+2)
return ((i,l):rest)
-- | See the comment for 'parseSwitchLabels' for information about what this
-- does.
parseNewSwitchLabels :: Word32 -> Record -> Int -> Int -> Parse [(Integer,Int)]
parseNewSwitchLabels width r = loop
where
field = parseField r
len = length (recordFields r)
-- parse each group of cases as one or more numbers, and a basic block.
loop numCases n
| numCases <= 0 = return []
| n >= len = fail "invalid SWITCH record"
| otherwise = do
numItems <- field n numeric
(ls,n') <- parseItems numItems (n + 1)
lab <- field n' numeric
rest <- loop (numCases - 1) (n' + 1)
return ([ (l,lab) | l <- ls ] ++ rest)
-- different numbers that all target the same basic block
parseItems :: Int -> Int -> Parse ([Integer],Int)
parseItems numItems n
| numItems <= 0 = return ([],n)
| otherwise = do
isSingleNumber <- field n boolean
-- The number of words used to represent a case is only specified when the
-- value comes from a large type.
(activeWords,lowStart) <-
if width > 64
then do aw <- field (n + 1) numeric
return (aw, n + 2)
else return (1,n+1)
-- read the chunks of the number in. each chunk represents one 64-bit
-- limb of a big num.
chunks <- parseSlice r lowStart activeWords signedWord64
-- decode limbs in big-endian order
let low = foldr (\l acc -> acc `shiftL` 64 + toInteger l) 0 chunks
(num,n') <-
if isSingleNumber
then return (low, lowStart + activeWords)
else fail "Unhandled case in switch: Please send in this test case!"
(rest,nFinal) <- parseItems (numItems - 1) n'
return (num:rest,nFinal)
type PClause = Clause' Int
parseClauses :: ValueTable -> Record -> Int -> Int -> Parse [PClause]
parseClauses t r = loop
where
loop n ix
| n <= 0 = return []
| otherwise = do
cty <- parseField r ix numeric
(val,ix') <- getValueTypePair t r (ix + 1)
cs <- loop (n-1) ix'
case cty :: Int of
0 -> return (Catch val : cs)
1 -> return (Filter val : cs)
_ -> fail ("Invalid clause type: " ++ show cty)
-- | 'Nothing' corresponds to @NotAtomic@ in the LLVM source
getDecodedOrdering :: Word32 -> Parse (Maybe AtomicOrdering)
getDecodedOrdering 0 = return Nothing
getDecodedOrdering 1 = return (Just Unordered)
getDecodedOrdering 2 = return (Just Monotonic)
getDecodedOrdering 3 = return (Just Acquire)
getDecodedOrdering 4 = return (Just Release)
getDecodedOrdering 5 = return (Just AcqRel)
getDecodedOrdering 6 = return (Just SeqCst)
getDecodedOrdering i = Assert.unknownEntity "atomic ordering" i
-- https://github.com/llvm/llvm-project/blob/e24dc34aa085b9e8d3ea58cc5f59f80bc4c7cdb4/llvm/include/llvm/Bitcode/LLVMBitCodes.h#L468-L489
getDecodedAtomicRWOp :: Integer -> Parse AtomicRWOp
getDecodedAtomicRWOp 0 = pure AtomicXchg
getDecodedAtomicRWOp 1 = pure AtomicAdd
getDecodedAtomicRWOp 2 = pure AtomicSub
getDecodedAtomicRWOp 3 = pure AtomicAnd
getDecodedAtomicRWOp 4 = pure AtomicNand
getDecodedAtomicRWOp 5 = pure AtomicOr
getDecodedAtomicRWOp 6 = pure AtomicXor
getDecodedAtomicRWOp 7 = pure AtomicMax
getDecodedAtomicRWOp 8 = pure AtomicMin
getDecodedAtomicRWOp 9 = pure AtomicUMax
getDecodedAtomicRWOp 10 = pure AtomicUMin
getDecodedAtomicRWOp 11 = pure AtomicFAdd
getDecodedAtomicRWOp 12 = pure AtomicFSub
getDecodedAtomicRWOp 13 = pure AtomicFMax
getDecodedAtomicRWOp 14 = pure AtomicFMin
getDecodedAtomicRWOp 15 = pure AtomicUIncWrap
getDecodedAtomicRWOp 16 = pure AtomicUDecWrap
getDecodedAtomicRWOp v = Assert.unknownEntity "atomic RWOp" 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.
-}