content: {-# 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 t r ix = do
    let field = parseField r
    n  <- adjustId =<< field ix numeric
    mb <- lookupValueAbs n
    case mb of
  
      -- value is already present in the incremental table
      Just tv -> return (tv, ix+1)
  
      -- forward reference to the entry in the final table
      Nothing -> do
        ty  <- getType =<< field (ix+1) numeric
        cxt <- getContext
        let ref = forwardRef cxt n t
  
        -- generate the forward reference to the value only, as we already know
        -- what the type should be.
        return (Typed ty (typedValue ref), ix+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 :: (HasMdTable m, HasParseEnv m, HasValueTable m, MonadFail m)
                 => Type -> Int -> m (Typed PValue)
  getFnValueById  = getFnValueById' Nothing
  
  getValue :: ValueTable -> Type -> Int -> Parse (Typed PValue)
  getValue vt ty n = label "getValue" (getFnValueById' (Just vt) ty =<< adjustId n)
  
  -- | Lookup a value by its absolute id, or perhaps some metadata.
  getFnValueById' :: (HasMdTable m, HasParseEnv m, HasValueTable m, MonadFail m)
                  => Maybe ValueTable -> Type -> Int -> m (Typed PValue)
  getFnValueById' mbVt ty n = case ty of
  
    PrimType Metadata -> do
      cxt <- getContext
      md  <- getMdTable
      return (forwardRef cxt n md)
  
    _ -> do
      mb <- lookupValueAbs n
      case mb of
  
        Just tv -> return tv
  
        -- forward reference
        Nothing -> do
          mbName <- entryNameMb n
          case mbName of
            Just name -> return (Typed ty (ValIdent (Ident name)))
  
            Nothing
              | Just vt <- mbVt ->
                do cxt <- getContext
                   return (forwardRef cxt n vt)
  
              | otherwise ->
                fail "Unable to create forward reference"
  
  -- Value Symbol Table Entries --------------------------------------------------
  
  vstCodeEntry :: Match Entry Record
  vstCodeEntry  = hasRecordCode 1 <=< fromEntry
  
  vstCodeBBEntry :: Match Entry Record
  vstCodeBBEntry  = hasRecordCode 2 <=< fromEntry
  
  vstCodeFNEntry :: Match Entry Record
  vstCodeFNEntry  = hasRecordCode 3 <=< fromEntry
  
  -- Value Symbol Table Parsing --------------------------------------------------
  
  parseValueSymbolTableBlock :: [Entry] -> Parse ValueSymtab
  parseValueSymbolTableBlock  = foldM parseValueSymbolTableBlockEntry mempty
  
  parseValueSymbolTableBlockEntry :: ValueSymtab -> Entry -> Parse ValueSymtab
  
  parseValueSymbolTableBlockEntry vs (vstCodeEntry -> Just r) = do
    -- VST_ENTRY: [valid, namechar x N]
    -- TODO: fail if version >= 2? These aren't supposed to be around anymore.
    let field = parseField r
    valid <- field 0 numeric
    name  <- field 1 cstring
    return (addEntry valid name vs)
  
  parseValueSymbolTableBlockEntry vs (vstCodeBBEntry -> Just r) = do
    -- VST_BBENTRY: [bbid, namechar x N]
    -- TODO: fail if version >= 2? These aren't supposed to be around anymore.
    let field = parseField r
    bbid <- field 0 numeric
    name <- field 1 cstring
    return (addBBEntry bbid name vs)
  
  parseValueSymbolTableBlockEntry vs (vstCodeFNEntry -> Just r) = do
    -- VST_FNENTRY: [valid, offset, namechar x N]
    let field = parseField r
    valid  <- field 0 numeric
    offset <- field 1 numeric
    case length (recordFields r) of
      2 -> return (addFwdFNEntry valid offset vs)
      3 -> do
        name <- field 2 cstring
        return (addFNEntry valid offset name vs)
      _ -> fail "unexpected number of parameters to FNENTRY"
  
  parseValueSymbolTableBlockEntry vs (abbrevDef -> Just _) =
    -- skip abbreviation definitions, they're already resolved
    return vs
  
  parseValueSymbolTableBlockEntry vs (block -> Just _) =
    -- skip blocks, there are no known subblocks.
    return vs
  
  parseValueSymbolTableBlockEntry _ e =
    fail ("value symtab: unexpected entry: " ++ show e)
  