{-# LANGUAGE ViewPatterns #-}

module Data.LLVM.BitCode.IR.Values (
    getValueTypePair
  , getValue
  , getFnValueById, getFnValueById'
  , parseValueSymbolTableBlock
  ) where

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)


-- Value Table -----------------------------------------------------------------

-- | Get either a value from the value table, with its value, or parse a value
-- and a type.
getValueTypePair :: ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair :: ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
ix = do
  let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
  Int
n  <- 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
ix Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
  Maybe (Typed PValue)
mb <- Int -> Parse (Maybe (Typed PValue))
lookupValueAbs Int
n
  case Maybe (Typed PValue)
mb of

    -- value is already present in the incremental table
    Just Typed PValue
tv -> (Typed PValue, Int) -> Parse (Typed PValue, Int)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Typed PValue
tv, Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)

    -- forward reference to the entry in the final table
    Maybe (Typed PValue)
Nothing -> do
      Type
ty  <- Int -> Parse Type
getType (Int -> Parse Type) -> Parse Int -> Parse Type
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
      [String]
cxt <- Parse [String]
getContext
      let ref :: Typed PValue
ref = HasCallStack => [String] -> Int -> ValueTable -> Typed PValue
[String] -> Int -> ValueTable -> Typed PValue
forwardRef [String]
cxt Int
n ValueTable
t

      -- generate the forward reference to the value only, as we already know
      -- what the type should be.
      (Typed PValue, Int) -> Parse (Typed PValue, Int)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> PValue -> Typed PValue
forall a. Type -> a -> Typed a
Typed Type
ty (Typed PValue -> PValue
forall a. Typed a -> a
typedValue Typed PValue
ref), Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2)

-- | Get a single value from the value table.
--getValueNoFwdRef :: Type -> Int -> Parse (Typed PValue)
--getValueNoFwdRef ty n = label "getValueNoFwdRef" (getFnValueById ty =<< adjustId n)

getFnValueById :: Type -> Int -> Parse (Typed PValue)
getFnValueById :: Type -> Int -> Parse (Typed PValue)
getFnValueById  = Maybe ValueTable -> Type -> Int -> Parse (Typed PValue)
getFnValueById' Maybe ValueTable
forall a. Maybe a
Nothing

getValue :: ValueTable -> Type -> Int -> Parse (Typed PValue)
getValue :: ValueTable -> Type -> Int -> Parse (Typed PValue)
getValue ValueTable
vt Type
ty Int
n = String -> Parse (Typed PValue) -> Parse (Typed PValue)
forall a. String -> Parse a -> Parse a
label String
"getValue" (Maybe ValueTable -> Type -> Int -> Parse (Typed PValue)
getFnValueById' (ValueTable -> Maybe ValueTable
forall a. a -> Maybe a
Just ValueTable
vt) Type
ty (Int -> Parse (Typed PValue)) -> Parse Int -> Parse (Typed PValue)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> Parse Int
adjustId Int
n)

-- | Lookup a value by its absolute id, or perhaps some metadata.
getFnValueById' :: Maybe ValueTable -> Type -> Int -> Parse (Typed PValue)
getFnValueById' :: Maybe ValueTable -> Type -> Int -> Parse (Typed PValue)
getFnValueById' Maybe ValueTable
mbVt Type
ty Int
n = String -> Parse (Typed PValue) -> Parse (Typed PValue)
forall a. String -> Parse a -> Parse a
label String
"getFnValueById'" (Parse (Typed PValue) -> Parse (Typed PValue))
-> Parse (Typed PValue) -> Parse (Typed PValue)
forall a b. (a -> b) -> a -> b
$ case Type
ty of

  PrimType PrimType
Metadata -> do
    [String]
cxt <- Parse [String]
getContext
    ValueTable
md  <- Parse ValueTable
getMdTable
    Typed PValue -> Parse (Typed PValue)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (HasCallStack => [String] -> Int -> ValueTable -> Typed PValue
[String] -> Int -> ValueTable -> Typed PValue
forwardRef [String]
cxt Int
n ValueTable
md)

  Type
_ -> do
    Maybe (Typed PValue)
mb <- Int -> Parse (Maybe (Typed PValue))
lookupValueAbs Int
n
    case Maybe (Typed PValue)
mb of

      Just Typed PValue
tv -> Typed PValue -> Parse (Typed PValue)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Typed PValue
tv

      -- forward reference
      Maybe (Typed PValue)
Nothing -> do
        Maybe String
mbName <- Int -> Parse (Maybe String)
entryNameMb Int
n
        case Maybe String
mbName of
          Just String
name -> Typed PValue -> Parse (Typed PValue)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> PValue -> Typed PValue
forall a. Type -> a -> Typed a
Typed Type
ty (Ident -> PValue
forall lab. Ident -> Value' lab
ValIdent (String -> Ident
Ident String
name)))

          Maybe String
Nothing
            | Just ValueTable
vt <- Maybe ValueTable
mbVt ->
              do [String]
cxt <- Parse [String]
getContext
                 Typed PValue -> Parse (Typed PValue)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (HasCallStack => [String] -> Int -> ValueTable -> Typed PValue
[String] -> Int -> ValueTable -> Typed PValue
forwardRef [String]
cxt Int
n ValueTable
vt)

            | Bool
otherwise ->
              String -> Parse (Typed PValue)
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unable to create forward reference"

-- Value Symbol Table Entries --------------------------------------------------

vstCodeEntry :: Match Entry Record
vstCodeEntry :: Match Entry Record
vstCodeEntry  = Int -> Match Record Record
hasRecordCode Int
1 Match Record Record -> Match Entry Record -> Match Entry Record
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Match Entry Record
fromEntry

vstCodeBBEntry :: Match Entry Record
vstCodeBBEntry :: Match Entry Record
vstCodeBBEntry  = Int -> Match Record Record
hasRecordCode Int
2 Match Record Record -> Match Entry Record -> Match Entry Record
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Match Entry Record
fromEntry

vstCodeFNEntry :: Match Entry Record
vstCodeFNEntry :: Match Entry Record
vstCodeFNEntry  = Int -> Match Record Record
hasRecordCode Int
3 Match Record Record -> Match Entry Record -> Match Entry Record
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Match Entry Record
fromEntry

-- Value Symbol Table Parsing --------------------------------------------------

parseValueSymbolTableBlock :: [Entry] -> Parse ValueSymtab
parseValueSymbolTableBlock :: [Entry] -> Parse ValueSymtab
parseValueSymbolTableBlock  = (ValueSymtab -> Entry -> Parse ValueSymtab)
-> ValueSymtab -> [Entry] -> Parse ValueSymtab
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ValueSymtab -> Entry -> Parse ValueSymtab
parseValueSymbolTableBlockEntry ValueSymtab
forall a. Monoid a => a
mempty

parseValueSymbolTableBlockEntry :: ValueSymtab -> Entry -> Parse ValueSymtab

parseValueSymbolTableBlockEntry :: ValueSymtab -> Entry -> Parse ValueSymtab
parseValueSymbolTableBlockEntry ValueSymtab
vs (Match Entry Record
vstCodeEntry -> Just Record
r) = do
  -- VST_ENTRY: [valid, namechar x N]
  -- TODO: fail if version >= 2? These aren't supposed to be around anymore.
  let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
  Int
valid <- LookupField Int
forall {a}. LookupField a
field Int
0 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
  String
name  <- LookupField String
forall {a}. LookupField a
field Int
1 Match Field String
cstring
  ValueSymtab -> Parse ValueSymtab
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> String -> ValueSymtab -> ValueSymtab
addEntry Int
valid String
name ValueSymtab
vs)

parseValueSymbolTableBlockEntry ValueSymtab
vs (Match Entry Record
vstCodeBBEntry -> Just Record
r) = do
  -- VST_BBENTRY: [bbid, namechar x N]
  -- TODO: fail if version >= 2? These aren't supposed to be around anymore.
  let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
  Int
bbid <- LookupField Int
forall {a}. LookupField a
field Int
0 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
  String
name <- LookupField String
forall {a}. LookupField a
field Int
1 Match Field String
cstring
  ValueSymtab -> Parse ValueSymtab
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> String -> ValueSymtab -> ValueSymtab
addBBEntry Int
bbid String
name ValueSymtab
vs)

parseValueSymbolTableBlockEntry ValueSymtab
vs (Match Entry Record
vstCodeFNEntry -> Just Record
r) = do
  -- VST_FNENTRY: [valid, offset, namechar x N]
  let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
  Int
valid  <- LookupField Int
forall {a}. LookupField a
field Int
0 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
  Int
offset <- LookupField Int
forall {a}. LookupField a
field Int
1 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
  case [Field] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Record -> [Field]
recordFields Record
r) of
    Int
2 -> ValueSymtab -> Parse ValueSymtab
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> ValueSymtab -> ValueSymtab
addFwdFNEntry Int
valid Int
offset ValueSymtab
vs)
    Int
3 -> do
      String
name <- LookupField String
forall {a}. LookupField a
field Int
2 Match Field String
cstring
      ValueSymtab -> Parse ValueSymtab
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> String -> ValueSymtab -> ValueSymtab
addFNEntry Int
valid Int
offset String
name ValueSymtab
vs)
    Int
_ -> String -> Parse ValueSymtab
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unexpected number of parameters to FNENTRY"

parseValueSymbolTableBlockEntry ValueSymtab
vs (Match Entry DefineAbbrev
abbrevDef -> Just DefineAbbrev
_) =
  -- skip abbreviation definitions, they're already resolved
  ValueSymtab -> Parse ValueSymtab
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return ValueSymtab
vs

parseValueSymbolTableBlockEntry ValueSymtab
vs (Match Entry Block
block -> Just Block
_) =
  -- skip blocks, there are no known subblocks.
  ValueSymtab -> Parse ValueSymtab
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return ValueSymtab
vs

parseValueSymbolTableBlockEntry ValueSymtab
_ Entry
e =
  String -> Parse ValueSymtab
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"value symtab: unexpected entry: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Entry -> String
forall a. Show a => a -> String
show Entry
e)