content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE PatternSynonyms #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE ViewPatterns #-}
  
  module Data.LLVM.BitCode.IR.Constants where
  
  import           Control.Applicative ( (<|>) )
  import qualified Data.LLVM.BitCode.Assert as Assert
  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 qualified Codec.Binary.UTF8.String as UTF8 (decode)
  import           Control.Monad (mplus,mzero,foldM,(<=<), when)
  import           Control.Monad.ST (runST,ST)
  import           Data.Array.ST (newArray,readArray,MArray,STUArray)
  import           Data.Bits (shiftL,shiftR,testBit, Bits)
  import           Data.LLVM.BitCode.BitString ( pattern Bits' )
  import qualified Data.LLVM.BitCode.BitString as BitS
  import qualified Data.Map as Map
  import           Data.Maybe (fromMaybe)
  import           Data.Word (Word16, Word32,Word64)
  
  #if __GLASGOW_HASKELL__ >= 704
  import           Data.Array.Unsafe (castSTUArray)
  #else
  import           Data.Array.ST (castSTUArray)
  #endif
  
  import           Prelude
  
  
  -- Instruction Field Parsing ---------------------------------------------------
  
  -- | Parse a binop from a field, returning its constructor in the AST.
  binopGeneric :: forall a.
                  (ArithOp -> Typed PValue -> PValue -> a)
               -> (BitOp -> Typed PValue -> PValue -> a)
               -> Match Field (Maybe Int -> Typed PValue -> PValue -> a)
  binopGeneric aop bop = choose <=< numeric
    where
  
    constant k kf = return $ \_mb x y ->
      case typedType x of
        PrimType (FloatType _) -> kf x y
        _ -> k x y
  
    nuw x = testBit x 0
    nsw x = testBit x 1
  
    -- operations that accept the nuw and nsw flags
    wrapFlags i k kf = return $ \ mb x y ->
      case typedType x of
        PrimType (FloatType _) -> i kf x y
        _ ->
          case mb of
            Nothing -> i (k  False   False)  x y
            Just w  -> i (k (nuw w) (nsw w)) x y
  
    exact x = testBit x 0
  
    -- operations that accept the exact flag
    exactFlag i k kf = return $ \ mb x y ->
      case typedType x of
        PrimType (FloatType _) -> i kf x y
        _ ->
          case mb of
            Nothing -> i (k  False)    x y
            Just w  -> i (k (exact w)) x y
  
    choose :: Match Int (Maybe Int -> Typed PValue -> PValue -> a)
    choose 0  = wrapFlags aop Add   FAdd
    choose 1  = wrapFlags aop Sub   FSub
    choose 2  = wrapFlags aop Mul   FMul
    choose 3  = exactFlag aop UDiv  FDiv
    choose 4  = exactFlag aop SDiv  FDiv
    choose 5  = constant (aop URem) (aop FRem)
    choose 6  = constant (aop SRem) (aop FRem)
    choose 7  = wrapFlags bop Shl  (error "invalid shl on floating point")
    choose 8  = exactFlag bop Lshr (error "invalid lshr on floating point")
    choose 9  = exactFlag bop Ashr (error "invalid ashr on floating point")
    choose 10 = constant (bop And) (error "invalid and on floating point")
    choose 11 = constant (bop Or)  (error "invalid or on floating point")
    choose 12 = constant (bop Xor) (error "invalid xor on floating point")
    choose _  = mzero
  
  binop :: Match Field (Maybe Int -> Typed PValue -> PValue -> PInstr)
  binop = binopGeneric Arith Bit
  
  binopCE :: Match Field (Maybe Int -> Typed PValue -> PValue -> PValue)
  binopCE = binopGeneric aop bop
    where
    aop op tv v = ValConstExpr (ConstArith op tv v)
    bop op tv v = ValConstExpr (ConstBit op tv v)
  
  fcmpOp :: Match Field FCmpOp
  fcmpOp  = choose <=< numeric
    where
    choose :: Match Int FCmpOp
    choose 0  = return Ffalse
    choose 1  = return Foeq
    choose 2  = return Fogt
    choose 3  = return Foge
    choose 4  = return Folt
    choose 5  = return Fole
    choose 6  = return Fone
    choose 7  = return Ford
    choose 8  = return Funo
    choose 9  = return Fueq
    choose 10 = return Fugt
    choose 11 = return Fuge
    choose 12 = return Fult
    choose 13 = return Fule
    choose 14 = return Fune
    choose 15 = return Ftrue
    choose _  = mzero
  
  icmpOp :: Match Field ICmpOp
  icmpOp  = choose <=< numeric
    where
    choose :: Match Int ICmpOp
    choose 32 = return Ieq
    choose 33 = return Ine
    choose 34 = return Iugt
    choose 35 = return Iuge
    choose 36 = return Iult
    choose 37 = return Iule
    choose 38 = return Isgt
    choose 39 = return Isge
    choose 40 = return Islt
    choose 41 = return Isle
    choose _  = mzero
  
  unopGeneric :: forall a.
                 (UnaryArithOp -> Typed PValue -> a)
              -> Match Field (Typed PValue -> a)
  unopGeneric uaop = choose <=< numeric
    where
    choose :: Match Int (Typed PValue -> a)
    choose 0 = return (uaop FNeg)
    choose _ = mzero
  
  unop :: Match Field (Typed PValue -> PInstr)
  unop = unopGeneric UnaryArith
  
  unopCE :: Match Field (Typed PValue -> PValue)
  unopCE = unopGeneric uaop
    where
    uaop op tv = ValConstExpr (ConstUnaryArith op tv)
  
  castOpGeneric :: forall c. (ConvOp -> Maybe c) -> Match Field c
  castOpGeneric op = choose <=< numeric
    where
    choose :: Match Int c
    choose 0  = op Trunc
    choose 1  = op ZExt
    choose 2  = op SExt
    choose 3  = op FpToUi
    choose 4  = op FpToSi
    choose 5  = op UiToFp
    choose 6  = op SiToFp
    choose 7  = op FpTrunc
    choose 8  = op FpExt
    choose 9  = op PtrToInt
    choose 10 = op IntToPtr
    choose 11 = op BitCast
    choose _  = mzero
  
  castOp :: Match Field (Typed PValue -> Type -> PInstr)
  castOp = castOpGeneric (return . Conv)
  
  castOpCE :: Match Field (Typed PValue -> Type -> PValue)
  castOpCE = castOpGeneric op
    where
    op c = return (\ tv t -> ValConstExpr (ConstConv c tv t))
  
  -- Constants Block -------------------------------------------------------------
  
  type ConstantTable = Map.Map Int (Typed Value)
  
  cstGep :: Match Entry Record
  cstGep  = hasRecordCode 12 <=< fromEntry
  
  cstInboundsGep :: Match Entry Record
  cstInboundsGep  = hasRecordCode 20 <=< fromEntry
  
  setCurType :: Int -> Parse Type
  setCurType  = getType'
  
  
  -- Constants Block Parsing -----------------------------------------------------
  
  -- | Parse the entries of the constants block.
  parseConstantsBlock :: [Entry] -> Parse ()
  parseConstantsBlock es = fixValueTable_ $ \ vs' -> do
    let curTy = fail "no current type id set"
    (_,vs) <- foldM (parseConstantEntry vs') (curTy,[]) es
    return vs
  
  -- | Parse entries of the constant table.
  parseConstantEntry :: ValueTable -> (Parse Type,[Typed PValue]) -> Entry
                     -> Parse (Parse Type, [Typed PValue])
  
  parseConstantEntry t (getTy,cs) (fromEntry -> Just r) =
   let parseCString = parseField r 0 (fieldArray (fieldChar6 ||| char))
                      `mplus` parseFields r 0 (fieldChar6 ||| char)
   in
   label "CONSTANTS_BLOCK" $ case recordCode r of
  
    1 -> label "CST_CODE_SETTYPE" $ do
      let field = parseField r
      i <- field 0 numeric
      return (setCurType i, cs)
  
    2 -> label "CST_CODE_NULL" $ do
      ty  <- getTy
      val <- resolveNull ty
      return (getTy, Typed ty val:cs)
  
    3 -> label "CST_CODE_UNDEF" $ do
      ty <- getTy
      return (getTy, Typed ty ValUndef:cs)
  
    -- [intval]
    4 -> label "CST_CODE_INTEGER" $ do
      let field = parseField r
      ty <- getTy
      n  <- field 0 signedWord64
      let val = fromMaybe (ValInteger (toInteger n)) $ do
                  Integer 0 <- elimPrimType ty
                  return (ValBool (n /= 0))
      return (getTy, Typed ty val:cs)
  
    -- [n x value]
    5 -> label "CST_CODE_WIDE_INTEGER" $ do
      ty <- getTy
      n  <- parseWideInteger r 0
      return (getTy, Typed ty (ValInteger n):cs)
  
    -- [fpval]
    6 -> label "CST_CODE_FLOAT" $ do
      ty <- getTy
      ft <- (elimFloatType =<< elimPrimType ty)
          `mplus` fail "expecting a float type"
      let build :: (Num a, Bits a) => (a -> PValue) -> Parse (Parse Type, [Typed PValue])
          build k = do
            a <-  parseField r 0 (fmap k . numeric)
            return (getTy, (Typed ty $! a):cs)
      case ft of
        Float -> build (ValFloat  . castFloat)
        Double -> build (ValDouble . castDouble)
        X86_fp80 -> fp80build ty r cs getTy
        _ -> error $ "parseConstantEntry: Unsupported type " ++ show ft
  
    -- [n x value number]
    7 -> label "CST_CODE_AGGREGATE" $ do
      ty    <- getTy
      elems <- parseField r 0 (fieldArray numeric)
          `mplus` parseFields r 0 numeric
      cxt <- getContext
      let vals = [forwardRef cxt ix t | ix <- elems ]
      case ty of
  
        Struct _fs ->
          return (getTy, Typed ty (ValStruct vals):cs)
  
        PackedStruct _fs ->
          return (getTy, Typed ty (ValPackedStruct vals):cs)
  
        Array _n fty ->
          return (getTy, Typed ty (ValArray fty (map typedValue vals)):cs)
  
        Vector _n ety -> do
          return (getTy, Typed ty (ValVector ety (map typedValue vals)):cs)
  
        _ -> return (getTy, Typed ty ValUndef:cs)
  
    -- [values]
    8 -> label "CST_CODE_STRING" $ do
      let field = parseField r
      ty     <- getTy
      values <- field 0 (fieldArray char)
                <|>
                -- CST_CODE_STRING changed to be identical to CST_CODE_CSTRING in
                -- llvm commit bb8278a (4 Feb 2012, released in llvmorg-3.1.0-rc1
                -- in 18 Apr 2012) with the exception of adding a trailing null.
                parseCString
      return (getTy, Typed ty (ValString values):cs)
  
    -- [values]
    9 -> label "CST_CODE_CSTRING" $ do
      ty     <- getTy
      values <- parseCString
      return (getTy, Typed ty (ValString (values ++ [0])):cs)
  
    -- [opcode,opval,opval]
    10 -> label "CST_CODE_CE_BINOP" $ do
      let field = parseField r
      ty      <- getTy
      mkInstr <- field 0 binopCE
      lopval  <- field 1 numeric
      ropval  <- field 2 numeric
      cxt     <- getContext
      let lv = forwardRef cxt lopval t
          rv = forwardRef cxt ropval t
      let mbWord = numeric =<< fieldAt 3 r
      return (getTy, Typed ty (mkInstr mbWord lv (typedValue rv)) : cs)
  
    -- [opcode, opty, opval]
    11 -> label "CST_CODE_CE_CAST" $ do
      let field = parseField r
      ty   <- getTy
      -- We're not handling the opcode < 0 case here, in which the cast is
      -- reported as ``unknown.''
      cast'  <- field 0 castOpCE
      opval  <- field 2 numeric
      cxt    <- getContext
      return (getTy,Typed ty (cast' (forwardRef cxt opval t) ty):cs)
  
    -- [n x operands]
    12 -> label "CST_CODE_CE_GEP" $ do
      ty <- getTy
      v <- parseCeGep CeGepCode12 t r
      return (getTy,Typed ty v:cs)
  
    -- [opval,opval,opval]
    13 -> label "CST_CODE_CE_SELECT" $ do
      let field = parseField r
      ty  <- getTy
      ix1 <- field 0 numeric
      ix2 <- field 1 numeric
      ix3 <- field 2 numeric
      cxt <- getContext
      let ref ix = forwardRef cxt ix t
          ce     = ConstSelect (ref ix1) (ref ix2) (ref ix3)
      return (getTy, Typed ty (ValConstExpr ce):cs)
  
    -- [opty,opval,opval]
    14 -> label "CST_CODE_CE_EXTRACTELT" $ do
      notImplemented
  
    15 -> label "CST_CODE_CE_INSERTELT" $ do
      notImplemented
  
    16 -> label "CST_CODE_CE_SHUFFLEVEC" $ do
      notImplemented
  
    -- [opty, opval, opval, pred]
    17 -> label "CST_CODE_CE_CMP" $ do
      let field = parseField r
      opty <- getType =<< field 0 numeric
      ix0  <- field 1 numeric
      ix1  <- field 2 numeric
      cxt  <- getContext
      let op0 = forwardRef cxt ix0 t
      let op1 = forwardRef cxt ix1 t
  
      let isFloat = isPrimTypeOf isFloatingPoint
      cst <- if isFloat opty || isVectorOf isFloat opty
                then do op <- field 3 fcmpOp
                        return (ConstFCmp op op0 op1)
  
                else do op <- field 3 icmpOp
                        return (ConstICmp op op0 op1)
  
      return (getTy, Typed (PrimType (Integer 1)) (ValConstExpr cst):cs)
  
    18 -> label "CST_CODE_INLINEASM_OLD" $ do
      tv <- parseInlineAsm InlineAsmCode18 getTy r
      return (getTy, tv:cs)
  
    19 -> label "CST_CODE_CE_SHUFFLEVEC_EX" $ do
      notImplemented
  
    -- [n x operands]
    20 -> label "CST_CODE_CE_INBOUNDS_GEP" $ do
      ty <- getTy
      v <- parseCeGep CeGepCode20 t r
      return (getTy,Typed ty v:cs)
  
    -- [funty,fnval,bb#]
    21 -> label "CST_CODE_BLOCKADDRESS" $ do
      when (length (recordFields r) < 3) $
        fail "Invalid BLOCKADDRESS record (length < 3)"
      let field = parseField r
      ty  <- getTy
      ctx <- getContext
      valref <- field 1 numeric
      bid <- field 2 numeric
      let ce = ConstBlockAddr (forwardRef ctx valref t) bid
      return (getTy, Typed ty (ValConstExpr ce) : cs)
  
    -- [n x elements]
    22 -> label "CST_CODE_DATA" $ do
      ty     <- getTy
      elemTy <- (elimPrimType =<< elimSequentialType ty)
          `mplus` fail "invalid container type for CST_CODE_DATA"
      let build mk = do
            ns <- parseFields r 0 numeric
            let elems            = map mk ns
                val | isArray ty = ValArray (PrimType elemTy) elems
                    | otherwise  = ValVector (PrimType elemTy) elems
            return (getTy, Typed ty val : cs)
      case elemTy of
        Integer 8          -> build ValInteger
        Integer 16         -> build ValInteger
        Integer 32         -> build ValInteger
        Integer 64         -> build ValInteger
        FloatType Float    -> build (ValFloat . castFloat)
        FloatType Double   -> build (ValDouble . castDouble)
        x                  -> Assert.unknownEntity "element type" x
  
    23 -> label "CST_CODE_INLINEASM_OLD2" $ do
      tv <- parseInlineAsm InlineAsmCode23 getTy r
      return (getTy, tv:cs)
  
    -- [opty, flags, n x operands]
    24 -> label "CST_CODE_CE_GEP_WITH_INRANGE_INDEX" $ do
      ty <- getTy
      v <- parseCeGep CeGepCode24 t r
      return (getTy,Typed ty v:cs)
  
    -- [opcode, opval]
    25 -> label "CST_CODE_CE_UNOP" $ do
      let field = parseField r
      ty      <- getTy
      mkInstr <- field 0 unopCE
      opval   <- field 1 numeric
      cxt     <- getContext
      let v = forwardRef cxt opval t
      return (getTy, Typed ty (mkInstr v) : cs)
  
    26 -> label "CST_CODE_POISON" $ do
      ty <- getTy
      return (getTy, Typed ty ValPoison : cs)
  
    27 -> label "CST_CODE_DSO_LOCAL_EQUIVALENT" $ do
      notImplemented
  
    28 -> label "CST_CODE_INLINEASM_OLD3" $ do
      tv <- parseInlineAsm InlineAsmCode28 getTy r
      return (getTy, tv:cs)
  
    29 -> label "CST_CODE_NO_CFI_VALUE" $ do
      notImplemented
  
    30 -> label "CST_CODE_INLINEASM" $ do
      tv <- parseInlineAsm InlineAsmCode30 getTy r
      return (getTy, tv:cs)
  
    code -> Assert.unknownEntity "constant record code" code
  
  parseConstantEntry _ st (abbrevDef -> Just _) =
    -- ignore abbreviation definitions
    return st
  
  parseConstantEntry _ _ e =
    fail ("constant block: unexpected: " ++ show e)
  
  -- | The different codes for constant @getelementptr@ expressions. Each one has
  -- minor differences in how they are parsed.
  data CeGepCode
    = CeGepCode12
    -- ^ @CST_CODE_CE_GEP = 12@. The original.
    | CeGepCode20
    -- ^ @CST_CODE_CE_INBOUNDS_GEP = 20@. This adds an @inbounds@ field that
    -- indicates that the result value should be poison if it performs an
    -- out-of-bounds index.
    | CeGepCode24
    -- ^ @CST_CODE_CE_GEP_WITH_INRANGE_INDEX = 24@. This adds an @inrange@ field
    -- that indicates that loading or storing to the result pointer will have
    -- undefined behavior if the load or store would access memory outside of the
    -- bounds of the indices marked as @inrange@.
    deriving Eq
  
  -- | Parse a 'ConstGEP' value. There are several variations on this theme that
  -- are captured in the 'CeGepCode' argument.
  parseCeGep :: CeGepCode -> ValueTable -> Record -> Parse PValue
  parseCeGep code t r = do
    let field = parseField r
  
    (mbBaseTy, ix0) <-
      if code == CeGepCode24 || odd (length (recordFields r))
      then do baseTy <- getType =<< field 0 numeric
              pure (Just baseTy, 1)
      else pure (Nothing, 0)
  
    (isInbounds, mInrangeIdx, ix1) <-
      case code of
        CeGepCode12 -> pure (False, Nothing, ix0)
        CeGepCode20 -> pure (True, Nothing, ix0)
        CeGepCode24 -> do
          (flags :: Word64) <- parseField r ix0 numeric
          let inbounds = testBit flags 0
              inrangeIdx = flags `shiftR` 1
          pure (inbounds, Just inrangeIdx, ix0 + 1)
  
    let loop n = do
          ty   <- getType =<< field  n    numeric
          elt  <-             field (n+1) numeric
          rest <- loop (n+2) `mplus` return []
          cxt  <- getContext
          return (Typed ty (typedValue (forwardRef cxt elt t)) : rest)
    args <- loop ix1
    (ptr, args') <-
      case args of
        [] -> fail "Invalid constant GEP with no operands"
        (base:args') -> pure (base, args')
  
    baseTy <-
      case mbBaseTy of
        Just baseTy -> pure baseTy
        Nothing -> Assert.elimPtrTo "constant GEP not headed by pointer" (typedType ptr)
  
    return $! ValConstExpr (ConstGEP isInbounds mInrangeIdx baseTy ptr args')
  
  parseWideInteger :: Record -> Int -> Parse Integer
  parseWideInteger r idx = do
    limbs <- parseSlice r idx (length (recordFields r) - idx) signedWord64
    return (foldr (\l acc -> acc `shiftL` 64 + (toInteger l)) 0 limbs)
  
  resolveNull :: Type -> Parse PValue
  resolveNull ty = case typeNull ty of
    HasNull nv    -> return nv
    ResolveNull i -> resolveNull =<< getType' =<< getTypeId i
  
  -- | The different codes for inline @asm@ constants. Each one has minor
  -- differences in how they are parsed.
  data InlineAsmCode
    = InlineAsmCode18
      -- ^ @CST_CODE_INLINEASM_OLD = 18@. The original.
    | InlineAsmCode23
      -- ^ @CST_CODE_INLINEASM_OLD2 = 23@. This adds an @asmdialect@ field.
    | InlineAsmCode28
      -- ^ @CST_CODE_INLINEASM_OLD3 = 28@. This adds an @unwind@ field (which is
      -- referred to as @canThrow@ in the LLVM source code).
    | InlineAsmCode30
      -- ^ @CST_CODE_INLINEASM = 30@. This adds an explicit function type field.
  
  -- | Parse a 'ValAsm' value. There are several variations on this theme that are
  -- captured in the 'InlineAsmCode' argument.
  parseInlineAsm :: InlineAsmCode -> Parse Type -> Record -> Parse (Typed PValue)
  parseInlineAsm code getTy r = do
    let field = parseField r
  
    -- If using InlineAsmCode30 or later, we parse the type as an explicit
    -- field.
    let parseTy  = do ty <- getType =<< field 0 numeric
                      return (PtrTo ty, 1)
    -- If using an older InlineAsmCode, then we retrieve the type from the
    -- current context.
    let useCurTy = do ty <- getTy
                      return (ty, 0)
    (ty, ix) <- case code of
                  InlineAsmCode18 -> useCurTy
                  InlineAsmCode23 -> useCurTy
                  InlineAsmCode28 -> useCurTy
                  InlineAsmCode30 -> parseTy
  
    mask <- field ix numeric
  
    let test = testBit (mask :: Word32)
        hasSideEffects = test 0
        isAlignStack   = test 1
        -- We don't store these in the llvm-pretty AST at the moment:
        _asmDialect    = test 2 -- Only with InlineAsmCode23 or later
        _canThrow      = test 3 -- Only with InlineAsmCode28 or later
  
    asmStrSize <- field (ix + 1) numeric
    Assert.recordSizeGreater r (ix + 1 + asmStrSize)
  
    constStrSize <- field (ix + 2 + asmStrSize) numeric
    Assert.recordSizeGreater r (ix + 2 + asmStrSize + constStrSize)
  
    asmStr   <- fmap UTF8.decode $ parseSlice r (ix + 2)              asmStrSize   char
    constStr <- fmap UTF8.decode $ parseSlice r (ix + 3 + asmStrSize) constStrSize char
  
    let val = ValAsm hasSideEffects isAlignStack asmStr constStr
  
    return (Typed ty val)
  
  
  -- Float/Double Casting --------------------------------------------------------
  
  castFloat :: Word32 -> Float
  castFloat w = runST (cast w)
  
  castDouble :: Word64 -> Double
  castDouble w = runST (cast w)
  
  cast :: (MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s))
       => a -> ST s b
  cast x = do
    arr <- newArray (0 :: Int, 0) x
    res <- castSTUArray arr
    readArray res 0
  
  -- fp80 is double extended format.  This conforms to IEEE 754, but is
  -- store as two values: the significand and the exponent.  Discussion
  -- here is relative to information from the LLVM source based at
  -- https://github.com/llvm-mirror/llvm/blob/release_60 (hereafter
  -- identified as LGH).
  --
  -- The exponent range is 16383..-16384 (14 bits), and the precision
  -- (significand bits) is 64, including the integer bit (see
  -- LGH/lib/Support/APFloat.cpp:75).
  --
  -- When reading the Record here, there are two fields, one of 65 bits
  -- and the other of up to 20 bits (which clearly adds to more than
  -- 80... extras are ignored).  Bits are not stored in the expected way
  -- and "compensation" is needed. First the two record fields are
  -- combined into an 80-bit integer (see
  -- LGH/lib/Bitcode/Reader/BitcodeReader.cpp:2196-2202), using only 64
  -- bits of the first field and 16 bits of the second field, discarding
  -- the extra bits.  This is the result of this build operation; if
  -- this result is used semantically, it should be analyzed as per
  -- LGH/lib/Support/APFloat.cpp:3076-3108.
  
  fp80build :: Type -> Record -> [Typed PValue] -> Parse Type
            -> Parse (Parse Type, [Typed PValue])
  fp80build ty r cs getTy =
    do v1 <- parseField r 0 fieldLiteral
       v2 <- parseField r 1 fieldLiteral
       let -- Note bs1 <> bs2 results in bs2|bs1 layout, shifting bs2 to higher bits
           v64_0 = BitS.take (Bits' 64)
                   $ BitS.take (Bits' 16) v2 `BitS.joinBitString` v1
           v64_1 = BitS.drop (Bits' 48) v2
           -- result is v64_1|v64_0 being v0|v1
           fullexp :: Word16
           fullexp = BitS.fromBitString $ BitS.take (Bits' 16) v64_1 -- includes sign bit
           significnd :: Word64
           significnd = BitS.fromBitString $ v64_0
           fp80Val = FP80_LongDouble fullexp significnd
       return (getTy, Typed ty (ValFP80 fp80Val):cs)
  