{-# LANGUAGE ViewPatterns #-}
module Data.LLVM.BitCode.IR.Values (
getValueTypePair
, getConstantFwdRef
, getValue
, getFnValueById
, parseValueSymbolTableBlock
) where
import Data.Word
import Data.LLVM.BitCode.Bitstream
import Data.LLVM.BitCode.Match
import Data.LLVM.BitCode.Parse
import Data.LLVM.BitCode.Record
import Text.LLVM.AST
import Control.Monad ((<=<),foldM)
import qualified Data.Map as Map
getConstantFwdRef :: ValueTable -> Type -> Int -> Parse (Typed PValue)
getConstantFwdRef t ty n = label "getConstantFwdRef" $ do
mb <- lookupValue n
case mb of
Just tv -> return tv
Nothing -> do
cxt <- getContext
let ref = forwardRef cxt n t
return (Typed ty (typedValue ref))
getValueTypePair :: ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair t r ix = do
let field = parseField r
n <- field ix numeric
mb <- lookupValue n
case mb of
Just tv -> return (tv, ix+1)
Nothing -> do
ty <- getType =<< field (ix+1) numeric
n' <- adjustId n
cxt <- getContext
let ref = forwardRef cxt n' t
return (Typed ty (typedValue ref), ix+2)
getValue :: Type -> Int -> Parse (Typed PValue)
getValue ty n = label "getValue" $ do
useRelIds <- getRelIds
cur <- getNextId
let i :: Word32
i | useRelIds = fromIntegral cur - fromIntegral n
| otherwise = fromIntegral n
getFnValueById ty i
getFnValueById :: Type -> Word32 -> Parse (Typed PValue)
getFnValueById ty n = label "getFnValueById" $ case ty of
PrimType Metadata -> do
cxt <- getContext
md <- getMdTable
return (forwardRef cxt (fromIntegral n) md)
_ -> do
mb <- lookupValueAbs (fromIntegral n)
case mb of
Just tv -> return tv
Nothing -> do
name <- entryName (fromIntegral n)
return (Typed ty (ValIdent (Ident name)))
vstCodeEntry :: Match Entry Record
vstCodeEntry = hasRecordCode 1 <=< fromEntry
vstCodeBBEntry :: Match Entry Record
vstCodeBBEntry = hasRecordCode 2 <=< fromEntry
vstCodeFNEntry :: Match Entry Record
vstCodeFNEntry = hasRecordCode 3 <=< fromEntry
parseValueSymbolTableBlock :: [Entry] -> Parse ValueSymtab
parseValueSymbolTableBlock = foldM parseValueSymbolTableBlockEntry Map.empty
parseValueSymbolTableBlockEntry :: ValueSymtab -> Entry -> Parse ValueSymtab
parseValueSymbolTableBlockEntry vs (vstCodeEntry -> Just r) = do
let field = parseField r
valid <- field 0 numeric
name <- field 1 (fieldArray (fieldChar6 ||| char))
return (addEntry valid name vs)
parseValueSymbolTableBlockEntry vs (vstCodeBBEntry -> Just r) = do
let field = parseField r
bbid <- field 0 numeric
name <- field 1 (fieldArray (fieldChar6 ||| char))
return (addBBEntry bbid name vs)
parseValueSymbolTableBlockEntry vs (vstCodeFNEntry -> Just r) = do
let field = parseField r
valid <- field 0 numeric
offset <- field 1 numeric
name <- field 2 (fieldArray (fieldChar6 ||| char))
return (addFNEntry valid offset name vs)
parseValueSymbolTableBlockEntry vs (abbrevDef -> Just _) =
return vs
parseValueSymbolTableBlockEntry vs (block -> Just _) =
return vs
parseValueSymbolTableBlockEntry _ e =
fail ("value symtab: unexpected entry: " ++ show e)