llvm-pretty-bc-parser-0.1.3.0: src/Data/LLVM/BitCode/IR/Function.hs
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ViewPatterns #-}
module Data.LLVM.BitCode.IR.Function where
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.Match
import Data.LLVM.BitCode.Parse
import Data.LLVM.BitCode.Record
import Text.LLVM.AST
import Text.LLVM.Labels
import Control.Applicative ((<$>),(<*>))
import Control.Monad (unless,mplus,mzero,foldM,(<=<))
import Data.Bits (shiftR,bit,shiftL)
import Data.Int (Int32)
import qualified Data.Foldable as F
import qualified Data.Map as Map
import qualified Data.Sequence as Seq
import qualified Data.Traversable as T
-- Function Aliases ------------------------------------------------------------
type AliasList = Seq.Seq PartialAlias
data PartialAlias = PartialAlias
{ paName :: Symbol
, paType :: Type
, paTarget :: !Int
} deriving Show
parseAlias :: Int -> Record -> Parse PartialAlias
parseAlias n r = do
let field = parseField r
ty <- getType =<< field 0 numeric
tgt <- field 1 numeric
sym <- entryName n
let name = Symbol sym
_ <- pushValue (Typed ty (ValSymbol name))
return PartialAlias
{ paName = name
, paType = ty
, paTarget = tgt
}
finalizePartialAlias :: PartialAlias -> Parse GlobalAlias
finalizePartialAlias pa = do
tv <- getValue (paType pa) (paTarget pa)
tgt <- relabel (const requireBbEntryName) (typedValue tv)
return GlobalAlias
{ 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 -> Parse Declare
finalizeDeclare fp = case protoType fp of
PtrTo (FunTy ret args va) -> return Declare
{ decRetType = ret
, decName = Symbol (protoName fp)
, decArgs = args
, decVarArgs = va
}
_ -> 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
{ partialAttrs :: FunAttrs
, partialSection :: Maybe String
, partialRetType :: Type
, partialName :: Symbol
, partialArgs :: [Typed Ident]
, partialVarArgs :: Bool
, partialBody :: BlockList
, partialBlock :: StmtList
, partialBlockId :: !Int
, partialSymtab :: ValueSymtab
} 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
{ partialAttrs = protoAttrs proto
, partialSection = protoSect proto
, partialRetType = rty
, partialName = Symbol (protoName proto)
, partialArgs = zipWith Typed tys names
, partialVarArgs = va
, partialBody = Seq.empty
, partialBlock = Seq.empty
, partialBlockId = 0
, partialSymtab = symtab
}
-- | 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 <- bbEntryName 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
type BlockLookup = Symbol -> Int -> Parse BlockLabel
lookupBlockName :: DefineList -> BlockLookup
lookupBlockName dl = lkp
where
syms = Map.fromList [ (partialName d, partialSymtab d) | d <- F.toList dl ]
lkp fn bid = case Map.lookup fn syms of
Nothing -> fail ("symbol " ++ show (ppSymbol fn) ++ " is not defined")
Just st -> case Map.lookup (SymTabBBEntry bid) st of
Nothing -> fail ("block id " ++ show bid ++ " does not exist")
Just sn -> return (mkBlockLabel sn)
-- | Finalize a partial definition.
finalizePartialDefine :: BlockLookup -> PartialDefine -> Parse Define
finalizePartialDefine lkp pd =
-- augment the symbol table with implicitly named anonymous blocks, and
-- generate basic blocks.
withValueSymtab (partialSymtab pd) $ do
body <- finalizeBody lkp (partialBody pd)
return Define
{ defAttrs = partialAttrs pd
, defRetType = partialRetType pd
, defName = partialName pd
, defArgs = partialArgs pd
, defVarArgs = partialVarArgs pd
, defBody = body
, defSection = partialSection pd
}
-- | Individual label resolution step.
resolveBlockLabel :: BlockLookup -> Maybe Symbol -> Int -> Parse BlockLabel
resolveBlockLabel lkp mbSym = case mbSym of
Nothing -> requireBbEntryName
Just sym -> lkp sym
-- | 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 <- bbEntryName 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 :: BlockLookup -> BlockList -> Parse [BasicBlock]
finalizeBody lkp = fmap F.toList . T.mapM (finalizePartialBlock lkp)
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 :: BlockLookup -> PartialBlock -> Parse BasicBlock
finalizePartialBlock lkp pb = BasicBlock
<$> bbEntryName (partialLabel pb)
<*> finalizeStmts lkp (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 :: BlockLookup -> StmtList -> Parse [Stmt]
finalizeStmts lkp = mapM (finalizeStmt lkp) . F.toList
finalizeStmt :: BlockLookup -> Stmt' Int -> Parse Stmt
finalizeStmt lkp = relabel (resolveBlockLabel lkp)
-- Function Block Parsing ------------------------------------------------------
-- | Parse the function block.
parseFunctionBlock :: [Entry] -> Parse PartialDefine
parseFunctionBlock 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 Map.empty
-- pop the function prototype off of the internal stack
proto <- popFunProto
label (protoName proto) $ withValueSymtab symtab $ do
-- generate the initial partial definition
pd <- emptyPartialDefine proto
rec pd' <- foldM (parseFunctionBlockEntry vt) pd ents
vt <- getValueTable
-- merge the symbol table with the anonymous symbol table
return pd' { partialSymtab = partialSymtab pd' `Map.union` symtab }
-- | Parse the members of the function block
parseFunctionBlockEntry :: 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" (return d)
-- [opval,ty,opval,opcode]
2 -> label "FUNC_CODE_INST_BINOP" $ do
let field = parseField r
(lhs,ix) <- getValueTypePair r 0
rhs <- getValue (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 designating
-- the value of the nuw and nsw flags. 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 r 0
resty <- getType =<< field ix numeric
cast' <- field (ix+1) castOp
result resty (cast' tv resty) d
4 -> label "FUNC_CODE_INST_GEP" (parseGEP False r d)
-- [opval,ty,opval,opval]
5 -> label "FUNC_CODE_INST_SELECT" $ do
let field = parseField r
(tval,ix) <- getValueTypePair r 0
fval <- getValue (typedType tval) =<< field ix numeric
cond <- getValue (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 r 0
idx <- getValue (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 r 0
(_,pty) <- elimVector (typedType tv)
`mplus` fail "invalid INSERTELT record (not a vector)"
elt <- getValue pty =<< field ix numeric
idx <- getValue (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 r 0
vec2 <- getValue (typedType vec1) =<< field ix numeric
(mask,_) <- getValueTypePair r (ix+1)
result (typedType vec1) (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,_) <- getValueTypePair r 0
effect (Ret tv) d
-- [bb#,bb#,cond] or [bb#]
11 -> label "FUNC_CODE_INST_BR" $ do
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 (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 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 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
let field = parseField r
normal <- field 2 numeric
unwind <- field 3 numeric
(f,ix) <- getValueTypePair r 4
(ret,as,va) <- elimFunPtr (typedType f)
`mplus` fail "invalid INVOKE record"
args <- parseInvokeArgs va r ix as
result ret (Invoke (typedType f) (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
result ty (Phi ty args) d
-- 17 is unused
-- 18 is unused
-- [instty,opty,op,align]
19 -> label "FUNC_CODE_INST_ALLOCA" $ do
unless (length (recordFields r) == 4)
(fail "Invalid ALLOCA record")
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
aval = bit align `shiftR` 1
ret <- elimPtrTo instty
`mplus` fail "invalid return type in INST_ALLOCA"
result instty (Alloca ret sval (Just aval)) d
-- [opty,op,align,vol]
20 -> label "FUNC_CODE_INST_LOAD" $ do
(tv,ix) <- getValueTypePair r 0
aval <- parseField r ix numeric
ret <- elimPtrTo (typedType tv)
`mplus` fail "invalid type to INST_LOAD"
let align | aval > 0 = Just (bit aval `shiftR` 1)
| otherwise = Nothing
result ret (Load tv align) d
-- 21 is unused
-- 22 is unused
23 -> label "FUNC_CODE_INST_VAARG" $ do
let field = parseField r
ty <- getType =<< field 0 numeric
op <- getValue 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" $ do
let field = parseField r
(ptr,ix) <- getValueTypePair r 0
ty <- elimPtrTo (typedType ptr)
`mplus` fail "invalid type to INST_STORE"
val <- getValue ty =<< field ix numeric
aval <- field (ix+1) numeric
let align | aval > 0 = Just (bit aval `shiftR` 1)
| otherwise = Nothing
effect (Store val ptr align) d
-- 25 is unused
-- [opty, opval, n x indices]
26 -> label "FUNC_CODE_INST_EXTRACTVAL" $ do
(tv,ix) <- getValueTypePair r 0
ixs <- parseIndexes r ix
ret <- interpValueIndex (typedType tv) ixs
result ret (ExtractValue tv ixs) d
27 -> label "FUNC_CODE_INST_INSERTVAL" $ do
(tv,ix) <- getValueTypePair r 0
(elt,ix') <- getValueTypePair 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 r 0
fv <- getValue (typedType tv) =<< field ix numeric
(c,_) <- getValueTypePair r (ix+1)
result (typedType tv) (Select c tv (typedValue fv)) d
-- 30 is handled lower down, as it's processed the same way as 4
30 -> label "FUNC_CODE_INST_INBOUNDS_GEP" (parseGEP True r d)
31 -> label "FUNC_CODE_INST_INDIRECTBR" $ do
let field = parseField r
ty <- getType =<< field 0 numeric
addr <- getValue ty =<< field 1 numeric
ls <- parseIndexes r 2
effect (IndirectBr addr ls) d
-- 32 is unused
33 -> label "FUNC_CODE_INST_LOC_AGAIN" $ do
loc <- getLastLoc
updateLastStmt (extendMetadata ("dbg", ValMdLoc loc)) d
-- [paramattrs, cc, fnty, fnid, arg0 .. arg n]
34 -> label "FUNC_CODE_INST_CALL" $ do
(Typed fnty fn,ix) <- getValueTypePair r 2
label (show fn) $ do
(ret,as,va) <- elimFunPtr fnty `mplus` fail "invalid CALL record"
args <- parseCallArgs va r ix as
result ret (Call False fnty fn args) d
-- [Line,Col,ScopeVal, IAVal]
35 -> label "FUNC_CODE_DEBUG_LOC" $ do
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
}
setLastLoc loc
updateLastStmt (extendMetadata ("dbg", ValMdLoc loc)) d
-- [ordering, synchscope]
36 -> label "FUNC_CODE_INST_FENCE" $ do
notImplemented
-- [ptrty,ptr,cmp,new, align, vol,
-- ordering, synchscope]
37 -> label "FUNC_CODE_INST_CMPXCHG" $ do
notImplemented
-- [ptrty,ptr,val, operation,
-- align, vol,
-- ordering,synchscope]
38 -> label "FUNC_CODE_INST_ATOMICRMW" $ do
notImplemented
-- [opval]
39 -> label "FUNC_CODE_RESUME" $ do
(tv,_) <- getValueTypePair r 0
effect (Resume tv) d
-- [ty,val,val,num,id0,val0...]
40 -> label "FUNC_CODE_LANDINGPAD" $ do
let field = parseField r
ty <- getType =<< field 0 numeric
(persFn,ix) <- getValueTypePair r 1
val <- field ix numeric
let isCleanup = val /= (0 :: Int)
len <- field (ix + 1) numeric
clauses <- parseClauses r len (ix + 2)
result ty (LandingPad ty persFn isCleanup clauses) d
-- [opty, op, align, vol,
-- ordering, synchscope]
41 -> label "FUNC_CODE_LOADATOMIC" $ do
notImplemented
-- [ptrty,ptr,val, align, vol
-- ordering, synchscope]
42 -> label "FUNC_CODE_STOREATOMIC" $ do
notImplemented
-- [opty,opval,opval,pred]
code
| code == 9
|| code == 28 -> label "FUNC_CODE_INST_CMP2" $ do
let field = parseField r
(lhs,ix) <- getValueTypePair r 0
rhs <- getValue (typedType lhs) =<< field ix numeric
let ty = typedType lhs
parseOp | isPrimTypeOf isFloatingPoint ty ||
isVectorOf (isPrimTypeOf isFloatingPoint) ty = fcmpOp
| otherwise = icmpOp
op <- field (ix+1) parseOp
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 t d (metadataBlockId -> Just es) = do
_ <- parseMetadataBlock t es
return d
parseFunctionBlockEntry _ d (metadataAttachmentBlockId -> Just _) = do
-- skip the metadata attachment block
return d
parseFunctionBlockEntry _ d (abbrevDef -> Just _) =
-- ignore any abbreviation definitions
return d
parseFunctionBlockEntry _ _ e = do
fail ("function block: unexpected: " ++ show e)
-- [n x operands]
parseGEP :: Bool -> Record -> PartialDefine -> Parse PartialDefine
parseGEP ib r d = do
(tv,ix) <- getValueTypePair r 0
args <- label "parseGepArgs" (parseGepArgs r ix)
rty <- label "interpGep" (interpGep (typedType tv) args)
result rty (GEP ib tv args) 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 signed
pos <- getNextId
return (pos - 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
| n >= len = return []
| otherwise = do
entry <- parse n
rest <- loop (n+2)
return (entry:rest)
-- | Parse the arguments for a call record.
parseCallArgs :: Bool -> Record -> Int -> [Type] -> Parse [Typed PValue]
parseCallArgs = parseArgs $ \ ty i ->
case ty of
PrimType Label -> return (Typed ty (ValLabel i))
_ -> getValue ty i
-- | Parse the arguments for an invoke record.
parseInvokeArgs :: Bool -> Record -> Int -> [Type] -> Parse [Typed PValue]
parseInvokeArgs = parseArgs getValue
-- | Parse arguments for the invoke and call instructions.
parseArgs :: (Type -> Int -> Parse (Typed PValue))
-> Bool -> Record -> Int -> [Type] -> Parse [Typed PValue]
parseArgs 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 r ix
rest <- varArgs ix'
return (tv:rest)
| otherwise = return []
parseGepArgs :: Record -> Int -> Parse [Typed PValue]
parseGepArgs r = loop
where
loop n = parse `mplus` return []
where
parse = do
(tv,ix') <- getValueTypePair r n
rest <- loop ix'
return (tv:rest)
-- | Interpret the getelementptr arguments, to determine the final type of the
-- instruction.
interpGep :: Type -> [Typed PValue] -> Parse Type
interpGep ty vs = check (resolveGep ty vs)
where
check res = case res of
HasType rty -> return (PtrTo rty)
Invalid -> fail "unable to determine the type of getelementptr"
Resolve i k -> do
ty' <- getType' =<< getTypeId i
check (k ty')
parseIndexes :: Num 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 -> [Int32] -> Parse Type
interpValueIndex ty is = check (resolveValueIndex ty is)
where
check res = case res of
Invalid -> fail "unable to determine the type of (extract/insert)value"
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
case typedValue tv of
ValInteger i -> do
l <- field (n+1) numeric
rest <- loop (n+2)
return ((i,l):rest)
_ -> fail "Invalid SWITCH record"
-- | See the comment for 'parseSwitchLabels' for information about what this
-- does.
parseNewSwitchLabels :: Int32 -> 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 signed
-- decode limbs in big-endian order
let low = foldr (\l acc -> acc `shiftL` 64 + 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 :: Record -> Int -> Int -> Parse [PClause]
parseClauses r = loop
where
loop n ix
| n <= 0 = return []
| otherwise = do
cty <- parseField r ix numeric
(val,ix') <- getValueTypePair 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)