{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}

module Data.LLVM.BitCode.IR.Constants where

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 :: forall a.
(ArithOp -> Typed PValue -> PValue -> a)
-> (BitOp -> Typed PValue -> PValue -> a)
-> Match Field (Maybe Int -> Typed PValue -> PValue -> a)
binopGeneric ArithOp -> Typed PValue -> PValue -> a
aop BitOp -> Typed PValue -> PValue -> a
bop = Match Int (Maybe Int -> Typed PValue -> PValue -> a)
choose Match Int (Maybe Int -> Typed PValue -> PValue -> a)
-> (Field -> Maybe Int)
-> Field
-> Maybe (Maybe Int -> Typed PValue -> PValue -> a)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Field -> Maybe Int
forall a. (Num a, Bits a) => Match Field a
numeric
  where

  constant :: (Typed a -> t -> t)
-> (Typed a -> t -> t) -> m (p -> Typed a -> t -> t)
constant Typed a -> t -> t
k Typed a -> t -> t
kf = (p -> Typed a -> t -> t) -> m (p -> Typed a -> t -> t)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((p -> Typed a -> t -> t) -> m (p -> Typed a -> t -> t))
-> (p -> Typed a -> t -> t) -> m (p -> Typed a -> t -> t)
forall a b. (a -> b) -> a -> b
$ \p
_mb Typed a
x t
y ->
    case Typed a -> Type
forall a. Typed a -> Type
typedType Typed a
x of
      PrimType (FloatType FloatType
_) -> Typed a -> t -> t
kf Typed a
x t
y
      Type
_ -> Typed a -> t -> t
k Typed a
x t
y

  nuw :: a -> Bool
nuw a
x = a -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit a
x Int
0
  nsw :: a -> Bool
nsw a
x = a -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit a
x Int
1

  -- operations that accept the nuw and nsw flags
  wrapFlags :: (t -> Typed a -> t -> t)
-> (Bool -> Bool -> t) -> t -> m (Maybe a -> Typed a -> t -> t)
wrapFlags t -> Typed a -> t -> t
i Bool -> Bool -> t
k t
kf = (Maybe a -> Typed a -> t -> t) -> m (Maybe a -> Typed a -> t -> t)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe a -> Typed a -> t -> t)
 -> m (Maybe a -> Typed a -> t -> t))
-> (Maybe a -> Typed a -> t -> t)
-> m (Maybe a -> Typed a -> t -> t)
forall a b. (a -> b) -> a -> b
$ \ Maybe a
mb Typed a
x t
y ->
    case Typed a -> Type
forall a. Typed a -> Type
typedType Typed a
x of
      PrimType (FloatType FloatType
_) -> t -> Typed a -> t -> t
i t
kf Typed a
x t
y
      Type
_ ->
        case Maybe a
mb of
          Maybe a
Nothing -> t -> Typed a -> t -> t
i (Bool -> Bool -> t
k  Bool
False   Bool
False)  Typed a
x t
y
          Just a
w  -> t -> Typed a -> t -> t
i (Bool -> Bool -> t
k (a -> Bool
forall {a}. Bits a => a -> Bool
nuw a
w) (a -> Bool
forall {a}. Bits a => a -> Bool
nsw a
w)) Typed a
x t
y

  exact :: a -> Bool
exact a
x = a -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit a
x Int
0

  -- operations that accept the exact flag
  exactFlag :: (t -> Typed a -> t -> t)
-> (Bool -> t) -> t -> m (Maybe a -> Typed a -> t -> t)
exactFlag t -> Typed a -> t -> t
i Bool -> t
k t
kf = (Maybe a -> Typed a -> t -> t) -> m (Maybe a -> Typed a -> t -> t)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe a -> Typed a -> t -> t)
 -> m (Maybe a -> Typed a -> t -> t))
-> (Maybe a -> Typed a -> t -> t)
-> m (Maybe a -> Typed a -> t -> t)
forall a b. (a -> b) -> a -> b
$ \ Maybe a
mb Typed a
x t
y ->
    case Typed a -> Type
forall a. Typed a -> Type
typedType Typed a
x of
      PrimType (FloatType FloatType
_) -> t -> Typed a -> t -> t
i t
kf Typed a
x t
y
      Type
_ ->
        case Maybe a
mb of
          Maybe a
Nothing -> t -> Typed a -> t -> t
i (Bool -> t
k  Bool
False)    Typed a
x t
y
          Just a
w  -> t -> Typed a -> t -> t
i (Bool -> t
k (a -> Bool
forall {a}. Bits a => a -> Bool
exact a
w)) Typed a
x t
y

  choose :: Match Int (Maybe Int -> Typed PValue -> PValue -> a)
  choose :: Match Int (Maybe Int -> Typed PValue -> PValue -> a)
choose Int
0  = (ArithOp -> Typed PValue -> PValue -> a)
-> (Bool -> Bool -> ArithOp)
-> ArithOp
-> Maybe (Maybe Int -> Typed PValue -> PValue -> a)
forall {m :: * -> *} {a} {t} {a} {t} {t}.
(Monad m, Bits a) =>
(t -> Typed a -> t -> t)
-> (Bool -> Bool -> t) -> t -> m (Maybe a -> Typed a -> t -> t)
wrapFlags ArithOp -> Typed PValue -> PValue -> a
aop Bool -> Bool -> ArithOp
Add   ArithOp
FAdd
  choose Int
1  = (ArithOp -> Typed PValue -> PValue -> a)
-> (Bool -> Bool -> ArithOp)
-> ArithOp
-> Maybe (Maybe Int -> Typed PValue -> PValue -> a)
forall {m :: * -> *} {a} {t} {a} {t} {t}.
(Monad m, Bits a) =>
(t -> Typed a -> t -> t)
-> (Bool -> Bool -> t) -> t -> m (Maybe a -> Typed a -> t -> t)
wrapFlags ArithOp -> Typed PValue -> PValue -> a
aop Bool -> Bool -> ArithOp
Sub   ArithOp
FSub
  choose Int
2  = (ArithOp -> Typed PValue -> PValue -> a)
-> (Bool -> Bool -> ArithOp)
-> ArithOp
-> Maybe (Maybe Int -> Typed PValue -> PValue -> a)
forall {m :: * -> *} {a} {t} {a} {t} {t}.
(Monad m, Bits a) =>
(t -> Typed a -> t -> t)
-> (Bool -> Bool -> t) -> t -> m (Maybe a -> Typed a -> t -> t)
wrapFlags ArithOp -> Typed PValue -> PValue -> a
aop Bool -> Bool -> ArithOp
Mul   ArithOp
FMul
  choose Int
3  = (ArithOp -> Typed PValue -> PValue -> a)
-> (Bool -> ArithOp)
-> ArithOp
-> Maybe (Maybe Int -> Typed PValue -> PValue -> a)
forall {m :: * -> *} {a} {t} {a} {t} {t}.
(Monad m, Bits a) =>
(t -> Typed a -> t -> t)
-> (Bool -> t) -> t -> m (Maybe a -> Typed a -> t -> t)
exactFlag ArithOp -> Typed PValue -> PValue -> a
aop Bool -> ArithOp
UDiv  ArithOp
FDiv
  choose Int
4  = (ArithOp -> Typed PValue -> PValue -> a)
-> (Bool -> ArithOp)
-> ArithOp
-> Maybe (Maybe Int -> Typed PValue -> PValue -> a)
forall {m :: * -> *} {a} {t} {a} {t} {t}.
(Monad m, Bits a) =>
(t -> Typed a -> t -> t)
-> (Bool -> t) -> t -> m (Maybe a -> Typed a -> t -> t)
exactFlag ArithOp -> Typed PValue -> PValue -> a
aop Bool -> ArithOp
SDiv  ArithOp
FDiv
  choose Int
5  = (Typed PValue -> PValue -> a)
-> (Typed PValue -> PValue -> a)
-> Maybe (Maybe Int -> Typed PValue -> PValue -> a)
forall {m :: * -> *} {a} {t} {t} {p}.
Monad m =>
(Typed a -> t -> t)
-> (Typed a -> t -> t) -> m (p -> Typed a -> t -> t)
constant (ArithOp -> Typed PValue -> PValue -> a
aop ArithOp
URem) (ArithOp -> Typed PValue -> PValue -> a
aop ArithOp
FRem)
  choose Int
6  = (Typed PValue -> PValue -> a)
-> (Typed PValue -> PValue -> a)
-> Maybe (Maybe Int -> Typed PValue -> PValue -> a)
forall {m :: * -> *} {a} {t} {t} {p}.
Monad m =>
(Typed a -> t -> t)
-> (Typed a -> t -> t) -> m (p -> Typed a -> t -> t)
constant (ArithOp -> Typed PValue -> PValue -> a
aop ArithOp
SRem) (ArithOp -> Typed PValue -> PValue -> a
aop ArithOp
FRem)
  choose Int
7  = (BitOp -> Typed PValue -> PValue -> a)
-> (Bool -> Bool -> BitOp)
-> BitOp
-> Maybe (Maybe Int -> Typed PValue -> PValue -> a)
forall {m :: * -> *} {a} {t} {a} {t} {t}.
(Monad m, Bits a) =>
(t -> Typed a -> t -> t)
-> (Bool -> Bool -> t) -> t -> m (Maybe a -> Typed a -> t -> t)
wrapFlags BitOp -> Typed PValue -> PValue -> a
bop Bool -> Bool -> BitOp
Shl  ([Char] -> BitOp
forall a. HasCallStack => [Char] -> a
error [Char]
"invalid shl on floating point")
  choose Int
8  = (BitOp -> Typed PValue -> PValue -> a)
-> (Bool -> BitOp)
-> BitOp
-> Maybe (Maybe Int -> Typed PValue -> PValue -> a)
forall {m :: * -> *} {a} {t} {a} {t} {t}.
(Monad m, Bits a) =>
(t -> Typed a -> t -> t)
-> (Bool -> t) -> t -> m (Maybe a -> Typed a -> t -> t)
exactFlag BitOp -> Typed PValue -> PValue -> a
bop Bool -> BitOp
Lshr ([Char] -> BitOp
forall a. HasCallStack => [Char] -> a
error [Char]
"invalid lshr on floating point")
  choose Int
9  = (BitOp -> Typed PValue -> PValue -> a)
-> (Bool -> BitOp)
-> BitOp
-> Maybe (Maybe Int -> Typed PValue -> PValue -> a)
forall {m :: * -> *} {a} {t} {a} {t} {t}.
(Monad m, Bits a) =>
(t -> Typed a -> t -> t)
-> (Bool -> t) -> t -> m (Maybe a -> Typed a -> t -> t)
exactFlag BitOp -> Typed PValue -> PValue -> a
bop Bool -> BitOp
Ashr ([Char] -> BitOp
forall a. HasCallStack => [Char] -> a
error [Char]
"invalid ashr on floating point")
  choose Int
10 = (Typed PValue -> PValue -> a)
-> (Typed PValue -> PValue -> a)
-> Maybe (Maybe Int -> Typed PValue -> PValue -> a)
forall {m :: * -> *} {a} {t} {t} {p}.
Monad m =>
(Typed a -> t -> t)
-> (Typed a -> t -> t) -> m (p -> Typed a -> t -> t)
constant (BitOp -> Typed PValue -> PValue -> a
bop BitOp
And) ([Char] -> Typed PValue -> PValue -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"invalid and on floating point")
  choose Int
11 = (Typed PValue -> PValue -> a)
-> (Typed PValue -> PValue -> a)
-> Maybe (Maybe Int -> Typed PValue -> PValue -> a)
forall {m :: * -> *} {a} {t} {t} {p}.
Monad m =>
(Typed a -> t -> t)
-> (Typed a -> t -> t) -> m (p -> Typed a -> t -> t)
constant (BitOp -> Typed PValue -> PValue -> a
bop BitOp
Or)  ([Char] -> Typed PValue -> PValue -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"invalid or on floating point")
  choose Int
12 = (Typed PValue -> PValue -> a)
-> (Typed PValue -> PValue -> a)
-> Maybe (Maybe Int -> Typed PValue -> PValue -> a)
forall {m :: * -> *} {a} {t} {t} {p}.
Monad m =>
(Typed a -> t -> t)
-> (Typed a -> t -> t) -> m (p -> Typed a -> t -> t)
constant (BitOp -> Typed PValue -> PValue -> a
bop BitOp
Xor) ([Char] -> Typed PValue -> PValue -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"invalid xor on floating point")
  choose Int
_  = Maybe (Maybe Int -> Typed PValue -> PValue -> a)
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

binop :: Match Field (Maybe Int -> Typed PValue -> PValue -> PInstr)
binop :: Match Field (Maybe Int -> Typed PValue -> PValue -> PInstr)
binop = (ArithOp -> Typed PValue -> PValue -> PInstr)
-> (BitOp -> Typed PValue -> PValue -> PInstr)
-> Match Field (Maybe Int -> Typed PValue -> PValue -> PInstr)
forall a.
(ArithOp -> Typed PValue -> PValue -> a)
-> (BitOp -> Typed PValue -> PValue -> a)
-> Match Field (Maybe Int -> Typed PValue -> PValue -> a)
binopGeneric ArithOp -> Typed PValue -> PValue -> PInstr
forall lab.
ArithOp -> Typed (Value' lab) -> Value' lab -> Instr' lab
Arith BitOp -> Typed PValue -> PValue -> PInstr
forall lab. BitOp -> Typed (Value' lab) -> Value' lab -> Instr' lab
Bit

binopCE :: Match Field (Maybe Int -> Typed PValue -> PValue -> PValue)
binopCE :: Match Field (Maybe Int -> Typed PValue -> PValue -> PValue)
binopCE = (ArithOp -> Typed PValue -> PValue -> PValue)
-> (BitOp -> Typed PValue -> PValue -> PValue)
-> Match Field (Maybe Int -> Typed PValue -> PValue -> PValue)
forall a.
(ArithOp -> Typed PValue -> PValue -> a)
-> (BitOp -> Typed PValue -> PValue -> a)
-> Match Field (Maybe Int -> Typed PValue -> PValue -> a)
binopGeneric ArithOp -> Typed PValue -> PValue -> PValue
forall {lab}.
ArithOp -> Typed (Value' lab) -> Value' lab -> Value' lab
aop BitOp -> Typed PValue -> PValue -> PValue
forall {lab}.
BitOp -> Typed (Value' lab) -> Value' lab -> Value' lab
bop
  where
  aop :: ArithOp -> Typed (Value' lab) -> Value' lab -> Value' lab
aop ArithOp
op Typed (Value' lab)
tv Value' lab
v = ConstExpr' lab -> Value' lab
forall lab. ConstExpr' lab -> Value' lab
ValConstExpr (ArithOp -> Typed (Value' lab) -> Value' lab -> ConstExpr' lab
forall lab.
ArithOp -> Typed (Value' lab) -> Value' lab -> ConstExpr' lab
ConstArith ArithOp
op Typed (Value' lab)
tv Value' lab
v)
  bop :: BitOp -> Typed (Value' lab) -> Value' lab -> Value' lab
bop BitOp
op Typed (Value' lab)
tv Value' lab
v = ConstExpr' lab -> Value' lab
forall lab. ConstExpr' lab -> Value' lab
ValConstExpr (BitOp -> Typed (Value' lab) -> Value' lab -> ConstExpr' lab
forall lab.
BitOp -> Typed (Value' lab) -> Value' lab -> ConstExpr' lab
ConstBit BitOp
op Typed (Value' lab)
tv Value' lab
v)

fcmpOp :: Match Field FCmpOp
fcmpOp :: Match Field FCmpOp
fcmpOp  = Match Int FCmpOp
choose Match Int FCmpOp -> (Field -> Maybe Int) -> Match Field FCmpOp
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Field -> Maybe Int
forall a. (Num a, Bits a) => Match Field a
numeric
  where
  choose :: Match Int FCmpOp
  choose :: Match Int FCmpOp
choose Int
0  = FCmpOp -> Maybe FCmpOp
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return FCmpOp
Ffalse
  choose Int
1  = FCmpOp -> Maybe FCmpOp
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return FCmpOp
Foeq
  choose Int
2  = FCmpOp -> Maybe FCmpOp
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return FCmpOp
Fogt
  choose Int
3  = FCmpOp -> Maybe FCmpOp
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return FCmpOp
Foge
  choose Int
4  = FCmpOp -> Maybe FCmpOp
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return FCmpOp
Folt
  choose Int
5  = FCmpOp -> Maybe FCmpOp
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return FCmpOp
Fole
  choose Int
6  = FCmpOp -> Maybe FCmpOp
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return FCmpOp
Fone
  choose Int
7  = FCmpOp -> Maybe FCmpOp
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return FCmpOp
Ford
  choose Int
8  = FCmpOp -> Maybe FCmpOp
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return FCmpOp
Funo
  choose Int
9  = FCmpOp -> Maybe FCmpOp
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return FCmpOp
Fueq
  choose Int
10 = FCmpOp -> Maybe FCmpOp
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return FCmpOp
Fugt
  choose Int
11 = FCmpOp -> Maybe FCmpOp
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return FCmpOp
Fuge
  choose Int
12 = FCmpOp -> Maybe FCmpOp
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return FCmpOp
Fult
  choose Int
13 = FCmpOp -> Maybe FCmpOp
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return FCmpOp
Fule
  choose Int
14 = FCmpOp -> Maybe FCmpOp
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return FCmpOp
Fune
  choose Int
15 = FCmpOp -> Maybe FCmpOp
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return FCmpOp
Ftrue
  choose Int
_  = Maybe FCmpOp
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

icmpOp :: Match Field ICmpOp
icmpOp :: Match Field ICmpOp
icmpOp  = Match Int ICmpOp
choose Match Int ICmpOp -> (Field -> Maybe Int) -> Match Field ICmpOp
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Field -> Maybe Int
forall a. (Num a, Bits a) => Match Field a
numeric
  where
  choose :: Match Int ICmpOp
  choose :: Match Int ICmpOp
choose Int
32 = ICmpOp -> Maybe ICmpOp
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ICmpOp
Ieq
  choose Int
33 = ICmpOp -> Maybe ICmpOp
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ICmpOp
Ine
  choose Int
34 = ICmpOp -> Maybe ICmpOp
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ICmpOp
Iugt
  choose Int
35 = ICmpOp -> Maybe ICmpOp
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ICmpOp
Iuge
  choose Int
36 = ICmpOp -> Maybe ICmpOp
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ICmpOp
Iult
  choose Int
37 = ICmpOp -> Maybe ICmpOp
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ICmpOp
Iule
  choose Int
38 = ICmpOp -> Maybe ICmpOp
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ICmpOp
Isgt
  choose Int
39 = ICmpOp -> Maybe ICmpOp
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ICmpOp
Isge
  choose Int
40 = ICmpOp -> Maybe ICmpOp
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ICmpOp
Islt
  choose Int
41 = ICmpOp -> Maybe ICmpOp
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ICmpOp
Isle
  choose Int
_  = Maybe ICmpOp
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

unopGeneric :: forall a.
               (UnaryArithOp -> Typed PValue -> a)
            -> Match Field (Typed PValue -> a)
unopGeneric :: forall a.
(UnaryArithOp -> Typed PValue -> a)
-> Match Field (Typed PValue -> a)
unopGeneric UnaryArithOp -> Typed PValue -> a
uaop = Match Int (Typed PValue -> a)
choose Match Int (Typed PValue -> a)
-> (Field -> Maybe Int) -> Field -> Maybe (Typed PValue -> a)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Field -> Maybe Int
forall a. (Num a, Bits a) => Match Field a
numeric
  where
  choose :: Match Int (Typed PValue -> a)
  choose :: Match Int (Typed PValue -> a)
choose Int
0 = (Typed PValue -> a) -> Maybe (Typed PValue -> a)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnaryArithOp -> Typed PValue -> a
uaop UnaryArithOp
FNeg)
  choose Int
_ = Maybe (Typed PValue -> a)
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

unop :: Match Field (Typed PValue -> PInstr)
unop :: Match Field (Typed PValue -> PInstr)
unop = (UnaryArithOp -> Typed PValue -> PInstr)
-> Match Field (Typed PValue -> PInstr)
forall a.
(UnaryArithOp -> Typed PValue -> a)
-> Match Field (Typed PValue -> a)
unopGeneric UnaryArithOp -> Typed PValue -> PInstr
forall lab. UnaryArithOp -> Typed (Value' lab) -> Instr' lab
UnaryArith

unopCE :: Match Field (Typed PValue -> PValue)
unopCE :: Match Field (Typed PValue -> PValue)
unopCE = (UnaryArithOp -> Typed PValue -> PValue)
-> Match Field (Typed PValue -> PValue)
forall a.
(UnaryArithOp -> Typed PValue -> a)
-> Match Field (Typed PValue -> a)
unopGeneric UnaryArithOp -> Typed PValue -> PValue
forall {lab}. UnaryArithOp -> Typed (Value' lab) -> Value' lab
uaop
  where
  uaop :: UnaryArithOp -> Typed (Value' lab) -> Value' lab
uaop UnaryArithOp
op Typed (Value' lab)
tv = ConstExpr' lab -> Value' lab
forall lab. ConstExpr' lab -> Value' lab
ValConstExpr (UnaryArithOp -> Typed (Value' lab) -> ConstExpr' lab
forall lab. UnaryArithOp -> Typed (Value' lab) -> ConstExpr' lab
ConstUnaryArith UnaryArithOp
op Typed (Value' lab)
tv)

castOpGeneric :: forall c. (ConvOp -> Maybe c) -> Match Field c
castOpGeneric :: forall c. (ConvOp -> Maybe c) -> Match Field c
castOpGeneric ConvOp -> Maybe c
op = Match Int c
choose Match Int c -> (Field -> Maybe Int) -> Field -> Maybe c
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Field -> Maybe Int
forall a. (Num a, Bits a) => Match Field a
numeric
  where
  choose :: Match Int c
  choose :: Match Int c
choose Int
0  = ConvOp -> Maybe c
op ConvOp
Trunc
  choose Int
1  = ConvOp -> Maybe c
op ConvOp
ZExt
  choose Int
2  = ConvOp -> Maybe c
op ConvOp
SExt
  choose Int
3  = ConvOp -> Maybe c
op ConvOp
FpToUi
  choose Int
4  = ConvOp -> Maybe c
op ConvOp
FpToSi
  choose Int
5  = ConvOp -> Maybe c
op ConvOp
UiToFp
  choose Int
6  = ConvOp -> Maybe c
op ConvOp
SiToFp
  choose Int
7  = ConvOp -> Maybe c
op ConvOp
FpTrunc
  choose Int
8  = ConvOp -> Maybe c
op ConvOp
FpExt
  choose Int
9  = ConvOp -> Maybe c
op ConvOp
PtrToInt
  choose Int
10 = ConvOp -> Maybe c
op ConvOp
IntToPtr
  choose Int
11 = ConvOp -> Maybe c
op ConvOp
BitCast
  choose Int
_  = Maybe c
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

castOp :: Match Field (Typed PValue -> Type -> PInstr)
castOp :: Match Field (Typed PValue -> Type -> PInstr)
castOp = (ConvOp -> Maybe (Typed PValue -> Type -> PInstr))
-> Match Field (Typed PValue -> Type -> PInstr)
forall c. (ConvOp -> Maybe c) -> Match Field c
castOpGeneric ((Typed PValue -> Type -> PInstr)
-> Maybe (Typed PValue -> Type -> PInstr)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Typed PValue -> Type -> PInstr)
 -> Maybe (Typed PValue -> Type -> PInstr))
-> (ConvOp -> Typed PValue -> Type -> PInstr)
-> ConvOp
-> Maybe (Typed PValue -> Type -> PInstr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConvOp -> Typed PValue -> Type -> PInstr
forall lab. ConvOp -> Typed (Value' lab) -> Type -> Instr' lab
Conv)

castOpCE :: Match Field (Typed PValue -> Type -> PValue)
castOpCE :: Match Field (Typed PValue -> Type -> PValue)
castOpCE = (ConvOp -> Maybe (Typed PValue -> Type -> PValue))
-> Match Field (Typed PValue -> Type -> PValue)
forall c. (ConvOp -> Maybe c) -> Match Field c
castOpGeneric ConvOp -> Maybe (Typed PValue -> Type -> PValue)
forall {m :: * -> *} {lab}.
Monad m =>
ConvOp -> m (Typed (Value' lab) -> Type -> Value' lab)
op
  where
  op :: ConvOp -> m (Typed (Value' lab) -> Type -> Value' lab)
op ConvOp
c = (Typed (Value' lab) -> Type -> Value' lab)
-> m (Typed (Value' lab) -> Type -> Value' lab)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (\ Typed (Value' lab)
tv Type
t -> ConstExpr' lab -> Value' lab
forall lab. ConstExpr' lab -> Value' lab
ValConstExpr (ConvOp -> Typed (Value' lab) -> Type -> ConstExpr' lab
forall lab. ConvOp -> Typed (Value' lab) -> Type -> ConstExpr' lab
ConstConv ConvOp
c Typed (Value' lab)
tv Type
t))

-- Constants Block -------------------------------------------------------------

type ConstantTable = Map.Map Int (Typed Value)

cstGep :: Match Entry Record
cstGep :: Match Entry Record
cstGep  = Int -> Match Record Record
hasRecordCode Int
12 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

cstInboundsGep :: Match Entry Record
cstInboundsGep :: Match Entry Record
cstInboundsGep  = Int -> Match Record Record
hasRecordCode Int
20 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

setCurType :: Int -> Parse Type
setCurType :: Int -> Parse Type
setCurType  = Int -> Parse Type
getType'


-- Constants Block Parsing -----------------------------------------------------

-- | Parse the entries of the constants block.
parseConstantsBlock :: [Entry] -> Parse ()
parseConstantsBlock :: [Entry] -> Parse ()
parseConstantsBlock [Entry]
es = (ValueTable -> Parse [Typed PValue]) -> Parse ()
fixValueTable_ ((ValueTable -> Parse [Typed PValue]) -> Parse ())
-> (ValueTable -> Parse [Typed PValue]) -> Parse ()
forall a b. (a -> b) -> a -> b
$ \ ValueTable
vs' -> do
  let curTy :: Parse a
curTy = [Char] -> Parse a
forall a. [Char] -> Parse a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"no current type id set"
  (Parse Type
_,[Typed PValue]
vs) <- ((Parse Type, [Typed PValue])
 -> Entry -> Parse (Parse Type, [Typed PValue]))
-> (Parse Type, [Typed PValue])
-> [Entry]
-> Parse (Parse Type, [Typed PValue])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (ValueTable
-> (Parse Type, [Typed PValue])
-> Entry
-> Parse (Parse Type, [Typed PValue])
parseConstantEntry ValueTable
vs') (Parse Type
forall {a}. Parse a
curTy,[]) [Entry]
es
  [Typed PValue] -> Parse [Typed PValue]
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return [Typed PValue]
vs

-- | Parse entries of the constant table.
parseConstantEntry :: ValueTable -> (Parse Type,[Typed PValue]) -> Entry
                   -> Parse (Parse Type, [Typed PValue])

parseConstantEntry :: ValueTable
-> (Parse Type, [Typed PValue])
-> Entry
-> Parse (Parse Type, [Typed PValue])
parseConstantEntry ValueTable
t (Parse Type
getTy,[Typed PValue]
cs) (Match Entry Record
fromEntry -> Just Record
r) =
 [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CONSTANTS_BLOCK" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ case Record -> Int
recordCode Record
r of

  Int
1 -> [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CST_CODE_SETTYPE" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ do
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    Int
i <- LookupField Int
forall {a}. LookupField a
field Int
0 Field -> Maybe Int
forall a. (Num a, Bits a) => Match Field a
numeric
    (Parse Type, [Typed PValue]) -> Parse (Parse Type, [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Parse Type
setCurType Int
i, [Typed PValue]
cs)

  Int
2 -> [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CST_CODE_NULL" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ do
    Type
ty  <- Parse Type
getTy
    PValue
val <- Type -> Parse PValue
resolveNull Type
ty
    (Parse Type, [Typed PValue]) -> Parse (Parse Type, [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parse Type
getTy, Type -> PValue -> Typed PValue
forall a. Type -> a -> Typed a
Typed Type
ty PValue
valTyped PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
:[Typed PValue]
cs)

  Int
3 -> [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CST_CODE_UNDEF" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ do
    Type
ty <- Parse Type
getTy
    (Parse Type, [Typed PValue]) -> Parse (Parse Type, [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parse Type
getTy, Type -> PValue -> Typed PValue
forall a. Type -> a -> Typed a
Typed Type
ty PValue
forall lab. Value' lab
ValUndefTyped PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
:[Typed PValue]
cs)

  -- [intval]
  Int
4 -> [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CST_CODE_INTEGER" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ do
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    Type
ty <- Parse Type
getTy
    Word64
n  <- LookupField Word64
forall {a}. LookupField a
field Int
0 Match Field Word64
signedWord64
    let val :: Value' lab
val = Value' lab -> Maybe (Value' lab) -> Value' lab
forall a. a -> Maybe a -> a
fromMaybe (Integer -> Value' lab
forall lab. Integer -> Value' lab
ValInteger (Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
n)) (Maybe (Value' lab) -> Value' lab)
-> Maybe (Value' lab) -> Value' lab
forall a b. (a -> b) -> a -> b
$ do
                Integer Word32
0 <- Type -> Maybe PrimType
forall (m :: * -> *). MonadPlus m => Type -> m PrimType
elimPrimType Type
ty
                Value' lab -> Maybe (Value' lab)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Value' lab
forall lab. Bool -> Value' lab
ValBool (Word64
n Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
0))
    (Parse Type, [Typed PValue]) -> Parse (Parse Type, [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parse Type
getTy, Type -> PValue -> Typed PValue
forall a. Type -> a -> Typed a
Typed Type
ty PValue
forall lab. Value' lab
valTyped PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
:[Typed PValue]
cs)

  -- [n x value]
  Int
5 -> [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CST_CODE_WIDE_INTEGER" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ do
    Type
ty <- Parse Type
getTy
    Integer
n  <- Record -> Int -> Parse Integer
parseWideInteger Record
r Int
0
    (Parse Type, [Typed PValue]) -> Parse (Parse Type, [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parse Type
getTy, Type -> PValue -> Typed PValue
forall a. Type -> a -> Typed a
Typed Type
ty (Integer -> PValue
forall lab. Integer -> Value' lab
ValInteger Integer
n)Typed PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
:[Typed PValue]
cs)

  -- [fpval]
  Int
6 -> [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CST_CODE_FLOAT" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ do
    Type
ty <- Parse Type
getTy
    FloatType
ft <- (PrimType -> Parse FloatType
forall (m :: * -> *). MonadPlus m => PrimType -> m FloatType
elimFloatType (PrimType -> Parse FloatType) -> Parse PrimType -> Parse FloatType
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> Parse PrimType
forall (m :: * -> *). MonadPlus m => Type -> m PrimType
elimPrimType Type
ty)
        Parse FloatType -> Parse FloatType -> Parse FloatType
forall a. Parse a -> Parse a -> Parse a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` [Char] -> Parse FloatType
forall a. [Char] -> Parse a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"expecting a float type"
    let build :: (Num a, Bits a) => (a -> PValue) -> Parse (Parse Type, [Typed PValue])
        build :: forall a.
(Num a, Bits a) =>
(a -> PValue) -> Parse (Parse Type, [Typed PValue])
build a -> PValue
k = do
          PValue
a <-  Record -> LookupField PValue
forall a. Record -> LookupField a
parseField Record
r Int
0 ((a -> PValue) -> Maybe a -> Maybe PValue
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> PValue
k (Maybe a -> Maybe PValue)
-> (Field -> Maybe a) -> Field -> Maybe PValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> Maybe a
forall a. (Num a, Bits a) => Match Field a
numeric)
          (Parse Type, [Typed PValue]) -> Parse (Parse Type, [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parse Type
getTy, (Type -> PValue -> Typed PValue
forall a. Type -> a -> Typed a
Typed Type
ty (PValue -> Typed PValue) -> PValue -> Typed PValue
forall a b. (a -> b) -> a -> b
$! PValue
a)Typed PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
:[Typed PValue]
cs)
    case FloatType
ft of
      FloatType
Float -> (Word32 -> PValue) -> Parse (Parse Type, [Typed PValue])
forall a.
(Num a, Bits a) =>
(a -> PValue) -> Parse (Parse Type, [Typed PValue])
build (Float -> PValue
forall lab. Float -> Value' lab
ValFloat  (Float -> PValue) -> (Word32 -> Float) -> Word32 -> PValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Float
castFloat)
      FloatType
Double -> (Word64 -> PValue) -> Parse (Parse Type, [Typed PValue])
forall a.
(Num a, Bits a) =>
(a -> PValue) -> Parse (Parse Type, [Typed PValue])
build (Double -> PValue
forall lab. Double -> Value' lab
ValDouble (Double -> PValue) -> (Word64 -> Double) -> Word64 -> PValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Double
castDouble)
      FloatType
X86_fp80 -> Type
-> Record
-> [Typed PValue]
-> Parse Type
-> Parse (Parse Type, [Typed PValue])
fp80build Type
ty Record
r [Typed PValue]
cs Parse Type
getTy
      FloatType
_ -> [Char] -> Parse (Parse Type, [Typed PValue])
forall a. HasCallStack => [Char] -> a
error ([Char] -> Parse (Parse Type, [Typed PValue]))
-> [Char] -> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ [Char]
"parseConstantEntry: Unsupported type " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ FloatType -> [Char]
forall a. Show a => a -> [Char]
show FloatType
ft

  -- [n x value number]
  Int
7 -> [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CST_CODE_AGGREGATE" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ do
    Type
ty    <- Parse Type
getTy
    [Int]
elems <- Record -> LookupField [Int]
forall a. Record -> LookupField a
parseField Record
r Int
0 ((Field -> Maybe Int) -> Match Field [Int]
forall a. Match Field a -> Match Field [a]
fieldArray Field -> Maybe Int
forall a. (Num a, Bits a) => Match Field a
numeric)
        Parse [Int] -> Parse [Int] -> Parse [Int]
forall a. Parse a -> Parse a -> Parse a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Record -> Int -> (Field -> Maybe Int) -> Parse [Int]
forall a. Record -> Int -> Match Field a -> Parse [a]
parseFields Record
r Int
0 Field -> Maybe Int
forall a. (Num a, Bits a) => Match Field a
numeric
    [[Char]]
cxt <- Parse [[Char]]
getContext
    let vals :: [Typed PValue]
vals = [HasCallStack => [[Char]] -> Int -> ValueTable -> Typed PValue
[[Char]] -> Int -> ValueTable -> Typed PValue
forwardRef [[Char]]
cxt Int
ix ValueTable
t | Int
ix <- [Int]
elems ]
    case Type
ty of

      Struct [Type]
_fs ->
        (Parse Type, [Typed PValue]) -> Parse (Parse Type, [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parse Type
getTy, Type -> PValue -> Typed PValue
forall a. Type -> a -> Typed a
Typed Type
ty ([Typed PValue] -> PValue
forall lab. [Typed (Value' lab)] -> Value' lab
ValStruct [Typed PValue]
vals)Typed PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
:[Typed PValue]
cs)

      PackedStruct [Type]
_fs ->
        (Parse Type, [Typed PValue]) -> Parse (Parse Type, [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parse Type
getTy, Type -> PValue -> Typed PValue
forall a. Type -> a -> Typed a
Typed Type
ty ([Typed PValue] -> PValue
forall lab. [Typed (Value' lab)] -> Value' lab
ValPackedStruct [Typed PValue]
vals)Typed PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
:[Typed PValue]
cs)

      Array Word64
_n Type
fty ->
        (Parse Type, [Typed PValue]) -> Parse (Parse Type, [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parse Type
getTy, Type -> PValue -> Typed PValue
forall a. Type -> a -> Typed a
Typed Type
ty (Type -> [PValue] -> PValue
forall lab. Type -> [Value' lab] -> Value' lab
ValArray Type
fty ((Typed PValue -> PValue) -> [Typed PValue] -> [PValue]
forall a b. (a -> b) -> [a] -> [b]
map Typed PValue -> PValue
forall a. Typed a -> a
typedValue [Typed PValue]
vals))Typed PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
:[Typed PValue]
cs)

      Vector Word64
_n Type
ety -> do
        (Parse Type, [Typed PValue]) -> Parse (Parse Type, [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parse Type
getTy, Type -> PValue -> Typed PValue
forall a. Type -> a -> Typed a
Typed Type
ty (Type -> [PValue] -> PValue
forall lab. Type -> [Value' lab] -> Value' lab
ValVector Type
ety ((Typed PValue -> PValue) -> [Typed PValue] -> [PValue]
forall a b. (a -> b) -> [a] -> [b]
map Typed PValue -> PValue
forall a. Typed a -> a
typedValue [Typed PValue]
vals))Typed PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
:[Typed PValue]
cs)

      Type
_ -> (Parse Type, [Typed PValue]) -> Parse (Parse Type, [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parse Type
getTy, Type -> PValue -> Typed PValue
forall a. Type -> a -> Typed a
Typed Type
ty PValue
forall lab. Value' lab
ValUndefTyped PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
:[Typed PValue]
cs)

  -- [values]
  Int
8 -> [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CST_CODE_STRING" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ do
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    Type
ty     <- Parse Type
getTy
    [Word8]
values <- LookupField [Word8]
forall {a}. LookupField a
field Int
0 (Match Field Word8 -> Match Field [Word8]
forall a. Match Field a -> Match Field [a]
fieldArray Match Field Word8
char)
    (Parse Type, [Typed PValue]) -> Parse (Parse Type, [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parse Type
getTy, Type -> PValue -> Typed PValue
forall a. Type -> a -> Typed a
Typed Type
ty ([Word8] -> PValue
forall lab. [Word8] -> Value' lab
ValString [Word8]
values)Typed PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
:[Typed PValue]
cs)

  -- [values]
  Int
9 -> [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CST_CODE_CSTRING" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ do
    Type
ty     <- Parse Type
getTy
    [Word8]
values <- Record -> LookupField [Word8]
forall a. Record -> LookupField a
parseField Record
r Int
0 (Match Field Word8 -> Match Field [Word8]
forall a. Match Field a -> Match Field [a]
fieldArray (Match Field Word8
fieldChar6 Match Field Word8 -> Match Field Word8 -> Match Field Word8
forall a b. Match a b -> Match a b -> Match a b
||| Match Field Word8
char))
        Parse [Word8] -> Parse [Word8] -> Parse [Word8]
forall a. Parse a -> Parse a -> Parse a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Record -> Int -> Match Field Word8 -> Parse [Word8]
forall a. Record -> Int -> Match Field a -> Parse [a]
parseFields Record
r Int
0 (Match Field Word8
fieldChar6 Match Field Word8 -> Match Field Word8 -> Match Field Word8
forall a b. Match a b -> Match a b -> Match a b
||| Match Field Word8
char)
    (Parse Type, [Typed PValue]) -> Parse (Parse Type, [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parse Type
getTy, Type -> PValue -> Typed PValue
forall a. Type -> a -> Typed a
Typed Type
ty ([Word8] -> PValue
forall lab. [Word8] -> Value' lab
ValString ([Word8]
values [Word8] -> [Word8] -> [Word8]
forall a. [a] -> [a] -> [a]
++ [Word8
0]))Typed PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
:[Typed PValue]
cs)

  -- [opcode,opval,opval]
  Int
10 -> [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CST_CODE_CE_BINOP" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ do
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    Type
ty      <- Parse Type
getTy
    Maybe Int -> Typed PValue -> PValue -> PValue
mkInstr <- LookupField (Maybe Int -> Typed PValue -> PValue -> PValue)
forall {a}. LookupField a
field Int
0 Match Field (Maybe Int -> Typed PValue -> PValue -> PValue)
binopCE
    Int
lopval  <- LookupField Int
forall {a}. LookupField a
field Int
1 Field -> Maybe Int
forall a. (Num a, Bits a) => Match Field a
numeric
    Int
ropval  <- LookupField Int
forall {a}. LookupField a
field Int
2 Field -> Maybe Int
forall a. (Num a, Bits a) => Match Field a
numeric
    [[Char]]
cxt     <- Parse [[Char]]
getContext
    let lv :: Typed PValue
lv = HasCallStack => [[Char]] -> Int -> ValueTable -> Typed PValue
[[Char]] -> Int -> ValueTable -> Typed PValue
forwardRef [[Char]]
cxt Int
lopval ValueTable
t
        rv :: Typed PValue
rv = HasCallStack => [[Char]] -> Int -> ValueTable -> Typed PValue
[[Char]] -> Int -> ValueTable -> Typed PValue
forwardRef [[Char]]
cxt Int
ropval ValueTable
t
    let mbWord :: Maybe Int
mbWord = Field -> Maybe Int
forall a. (Num a, Bits a) => Match Field a
numeric (Field -> Maybe Int) -> Maybe Field -> Maybe Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> Match Record Field
fieldAt Int
3 Record
r
    (Parse Type, [Typed PValue]) -> Parse (Parse Type, [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parse Type
getTy, Type -> PValue -> Typed PValue
forall a. Type -> a -> Typed a
Typed Type
ty (Maybe Int -> Typed PValue -> PValue -> PValue
mkInstr Maybe Int
mbWord Typed PValue
lv (Typed PValue -> PValue
forall a. Typed a -> a
typedValue Typed PValue
rv)) Typed PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
: [Typed PValue]
cs)

  -- [opcode, opty, opval]
  Int
11 -> [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CST_CODE_CE_CAST" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ do
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    Type
ty   <- Parse Type
getTy
    -- We're not handling the opcode < 0 case here, in which the cast is
    -- reported as ``unknown.''
    Typed PValue -> Type -> PValue
cast'  <- LookupField (Typed PValue -> Type -> PValue)
forall {a}. LookupField a
field Int
0 Match Field (Typed PValue -> Type -> PValue)
castOpCE
    Int
opval  <- LookupField Int
forall {a}. LookupField a
field Int
2 Field -> Maybe Int
forall a. (Num a, Bits a) => Match Field a
numeric
    [[Char]]
cxt    <- Parse [[Char]]
getContext
    (Parse Type, [Typed PValue]) -> Parse (Parse Type, [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parse Type
getTy,Type -> PValue -> Typed PValue
forall a. Type -> a -> Typed a
Typed Type
ty (Typed PValue -> Type -> PValue
cast' (HasCallStack => [[Char]] -> Int -> ValueTable -> Typed PValue
[[Char]] -> Int -> ValueTable -> Typed PValue
forwardRef [[Char]]
cxt Int
opval ValueTable
t) Type
ty)Typed PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
:[Typed PValue]
cs)

  -- [n x operands]
  Int
12 -> [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CST_CODE_CE_GEP" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ do
    Type
ty <- Parse Type
getTy
    PValue
v <- CeGepCode -> ValueTable -> Record -> Parse PValue
parseCeGep CeGepCode
CeGepCode12 ValueTable
t Record
r
    (Parse Type, [Typed PValue]) -> Parse (Parse Type, [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parse Type
getTy,Type -> PValue -> Typed PValue
forall a. Type -> a -> Typed a
Typed Type
ty PValue
vTyped PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
:[Typed PValue]
cs)

  -- [opval,opval,opval]
  Int
13 -> [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CST_CODE_CE_SELECT" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ do
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    Type
ty  <- Parse Type
getTy
    Int
ix1 <- LookupField Int
forall {a}. LookupField a
field Int
0 Field -> Maybe Int
forall a. (Num a, Bits a) => Match Field a
numeric
    Int
ix2 <- LookupField Int
forall {a}. LookupField a
field Int
1 Field -> Maybe Int
forall a. (Num a, Bits a) => Match Field a
numeric
    Int
ix3 <- LookupField Int
forall {a}. LookupField a
field Int
2 Field -> Maybe Int
forall a. (Num a, Bits a) => Match Field a
numeric
    [[Char]]
cxt <- Parse [[Char]]
getContext
    let ref :: Int -> Typed PValue
ref Int
ix = HasCallStack => [[Char]] -> Int -> ValueTable -> Typed PValue
[[Char]] -> Int -> ValueTable -> Typed PValue
forwardRef [[Char]]
cxt Int
ix ValueTable
t
        ce :: ConstExpr' Int
ce     = Typed PValue -> Typed PValue -> Typed PValue -> ConstExpr' Int
forall lab.
Typed (Value' lab)
-> Typed (Value' lab) -> Typed (Value' lab) -> ConstExpr' lab
ConstSelect (Int -> Typed PValue
ref Int
ix1) (Int -> Typed PValue
ref Int
ix2) (Int -> Typed PValue
ref Int
ix3)
    (Parse Type, [Typed PValue]) -> Parse (Parse Type, [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parse Type
getTy, Type -> PValue -> Typed PValue
forall a. Type -> a -> Typed a
Typed Type
ty (ConstExpr' Int -> PValue
forall lab. ConstExpr' lab -> Value' lab
ValConstExpr ConstExpr' Int
ce)Typed PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
:[Typed PValue]
cs)

  -- [opty,opval,opval]
  Int
14 -> [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CST_CODE_CE_EXTRACTELT" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ do
    Parse (Parse Type, [Typed PValue])
forall {a}. Parse a
notImplemented

  Int
15 -> [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CST_CODE_CE_INSERTELT" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ do
    Parse (Parse Type, [Typed PValue])
forall {a}. Parse a
notImplemented

  Int
16 -> [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CST_CODE_CE_SHUFFLEVEC" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ do
    Parse (Parse Type, [Typed PValue])
forall {a}. Parse a
notImplemented

  -- [opty, opval, opval, pred]
  Int
17 -> [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CST_CODE_CE_CMP" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ do
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    Type
opty <- 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
0 Field -> Maybe Int
forall a. (Num a, Bits a) => Match Field a
numeric
    Int
ix0  <- LookupField Int
forall {a}. LookupField a
field Int
1 Field -> Maybe Int
forall a. (Num a, Bits a) => Match Field a
numeric
    Int
ix1  <- LookupField Int
forall {a}. LookupField a
field Int
2 Field -> Maybe Int
forall a. (Num a, Bits a) => Match Field a
numeric
    [[Char]]
cxt  <- Parse [[Char]]
getContext
    let op0 :: Typed PValue
op0 = HasCallStack => [[Char]] -> Int -> ValueTable -> Typed PValue
[[Char]] -> Int -> ValueTable -> Typed PValue
forwardRef [[Char]]
cxt Int
ix0 ValueTable
t
    let op1 :: Typed PValue
op1 = HasCallStack => [[Char]] -> Int -> ValueTable -> Typed PValue
[[Char]] -> Int -> ValueTable -> Typed PValue
forwardRef [[Char]]
cxt Int
ix1 ValueTable
t

    let isFloat :: Type -> Bool
isFloat = (PrimType -> Bool) -> Type -> Bool
isPrimTypeOf PrimType -> Bool
isFloatingPoint
    ConstExpr' Int
cst <- if Type -> Bool
isFloat Type
opty Bool -> Bool -> Bool
|| (Type -> Bool) -> Type -> Bool
isVectorOf Type -> Bool
isFloat Type
opty
              then do FCmpOp
op <- LookupField FCmpOp
forall {a}. LookupField a
field Int
3 Match Field FCmpOp
fcmpOp
                      ConstExpr' Int -> Parse (ConstExpr' Int)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (FCmpOp -> Typed PValue -> Typed PValue -> ConstExpr' Int
forall lab.
FCmpOp
-> Typed (Value' lab) -> Typed (Value' lab) -> ConstExpr' lab
ConstFCmp FCmpOp
op Typed PValue
op0 Typed PValue
op1)

              else do ICmpOp
op <- LookupField ICmpOp
forall {a}. LookupField a
field Int
3 Match Field ICmpOp
icmpOp
                      ConstExpr' Int -> Parse (ConstExpr' Int)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (ICmpOp -> Typed PValue -> Typed PValue -> ConstExpr' Int
forall lab.
ICmpOp
-> Typed (Value' lab) -> Typed (Value' lab) -> ConstExpr' lab
ConstICmp ICmpOp
op Typed PValue
op0 Typed PValue
op1)

    (Parse Type, [Typed PValue]) -> Parse (Parse Type, [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parse Type
getTy, Type -> PValue -> Typed PValue
forall a. Type -> a -> Typed a
Typed (PrimType -> Type
forall ident. PrimType -> Type' ident
PrimType (Word32 -> PrimType
Integer Word32
1)) (ConstExpr' Int -> PValue
forall lab. ConstExpr' lab -> Value' lab
ValConstExpr ConstExpr' Int
cst)Typed PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
:[Typed PValue]
cs)

  Int
18 -> [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CST_CODE_INLINEASM_OLD" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ do
    Typed PValue
tv <- InlineAsmCode -> Parse Type -> Record -> Parse (Typed PValue)
parseInlineAsm InlineAsmCode
InlineAsmCode18 Parse Type
getTy Record
r
    (Parse Type, [Typed PValue]) -> Parse (Parse Type, [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parse Type
getTy, Typed PValue
tvTyped PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
:[Typed PValue]
cs)

  Int
19 -> [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CST_CODE_CE_SHUFFLEVEC_EX" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ do
    Parse (Parse Type, [Typed PValue])
forall {a}. Parse a
notImplemented

  -- [n x operands]
  Int
20 -> [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CST_CODE_CE_INBOUNDS_GEP" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ do
    Type
ty <- Parse Type
getTy
    PValue
v <- CeGepCode -> ValueTable -> Record -> Parse PValue
parseCeGep CeGepCode
CeGepCode20 ValueTable
t Record
r
    (Parse Type, [Typed PValue]) -> Parse (Parse Type, [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parse Type
getTy,Type -> PValue -> Typed PValue
forall a. Type -> a -> Typed a
Typed Type
ty PValue
vTyped PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
:[Typed PValue]
cs)

  -- [funty,fnval,bb#]
  Int
21 -> [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CST_CODE_BLOCKADDRESS" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ do
    Bool -> Parse () -> Parse ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Field] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Record -> [Field]
recordFields Record
r) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
3) (Parse () -> Parse ()) -> Parse () -> Parse ()
forall a b. (a -> b) -> a -> b
$
      [Char] -> Parse ()
forall a. [Char] -> Parse a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Invalid BLOCKADDRESS record (length < 3)"
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    Type
ty  <- Parse Type
getTy
    [[Char]]
ctx <- Parse [[Char]]
getContext
    Int
valref <- LookupField Int
forall {a}. LookupField a
field Int
1 Field -> Maybe Int
forall a. (Num a, Bits a) => Match Field a
numeric
    Int
bid <- LookupField Int
forall {a}. LookupField a
field Int
2 Field -> Maybe Int
forall a. (Num a, Bits a) => Match Field a
numeric
    let ce :: ConstExpr' Int
ce = Typed PValue -> Int -> ConstExpr' Int
forall lab. Typed (Value' lab) -> lab -> ConstExpr' lab
ConstBlockAddr (HasCallStack => [[Char]] -> Int -> ValueTable -> Typed PValue
[[Char]] -> Int -> ValueTable -> Typed PValue
forwardRef [[Char]]
ctx Int
valref ValueTable
t) Int
bid
    (Parse Type, [Typed PValue]) -> Parse (Parse Type, [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parse Type
getTy, Type -> PValue -> Typed PValue
forall a. Type -> a -> Typed a
Typed Type
ty (ConstExpr' Int -> PValue
forall lab. ConstExpr' lab -> Value' lab
ValConstExpr ConstExpr' Int
ce) Typed PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
: [Typed PValue]
cs)

  -- [n x elements]
  Int
22 -> [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CST_CODE_DATA" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ do
    Type
ty     <- Parse Type
getTy
    PrimType
elemTy <- (Type -> Parse PrimType
forall (m :: * -> *). MonadPlus m => Type -> m PrimType
elimPrimType (Type -> Parse PrimType) -> Parse Type -> Parse PrimType
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> Parse Type
forall (m :: * -> *). MonadPlus m => Type -> m Type
elimSequentialType Type
ty)
        Parse PrimType -> Parse PrimType -> Parse PrimType
forall a. Parse a -> Parse a -> Parse a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` [Char] -> Parse PrimType
forall a. [Char] -> Parse a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"invalid container type for CST_CODE_DATA"
    let build :: (a -> PValue) -> Parse (Parse Type, [Typed PValue])
build a -> PValue
mk = do
          [a]
ns <- Record -> Int -> Match Field a -> Parse [a]
forall a. Record -> Int -> Match Field a -> Parse [a]
parseFields Record
r Int
0 Match Field a
forall a. (Num a, Bits a) => Match Field a
numeric
          let elems :: [PValue]
elems            = (a -> PValue) -> [a] -> [PValue]
forall a b. (a -> b) -> [a] -> [b]
map a -> PValue
mk [a]
ns
              val :: PValue
val | Type -> Bool
isArray Type
ty = Type -> [PValue] -> PValue
forall lab. Type -> [Value' lab] -> Value' lab
ValArray (PrimType -> Type
forall ident. PrimType -> Type' ident
PrimType PrimType
elemTy) [PValue]
elems
                  | Bool
otherwise  = Type -> [PValue] -> PValue
forall lab. Type -> [Value' lab] -> Value' lab
ValVector (PrimType -> Type
forall ident. PrimType -> Type' ident
PrimType PrimType
elemTy) [PValue]
elems
          (Parse Type, [Typed PValue]) -> Parse (Parse Type, [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parse Type
getTy, Type -> PValue -> Typed PValue
forall a. Type -> a -> Typed a
Typed Type
ty PValue
val Typed PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
: [Typed PValue]
cs)
    case PrimType
elemTy of
      Integer Word32
8          -> (Integer -> PValue) -> Parse (Parse Type, [Typed PValue])
forall a.
(Num a, Bits a) =>
(a -> PValue) -> Parse (Parse Type, [Typed PValue])
build Integer -> PValue
forall lab. Integer -> Value' lab
ValInteger
      Integer Word32
16         -> (Integer -> PValue) -> Parse (Parse Type, [Typed PValue])
forall a.
(Num a, Bits a) =>
(a -> PValue) -> Parse (Parse Type, [Typed PValue])
build Integer -> PValue
forall lab. Integer -> Value' lab
ValInteger
      Integer Word32
32         -> (Integer -> PValue) -> Parse (Parse Type, [Typed PValue])
forall a.
(Num a, Bits a) =>
(a -> PValue) -> Parse (Parse Type, [Typed PValue])
build Integer -> PValue
forall lab. Integer -> Value' lab
ValInteger
      Integer Word32
64         -> (Integer -> PValue) -> Parse (Parse Type, [Typed PValue])
forall a.
(Num a, Bits a) =>
(a -> PValue) -> Parse (Parse Type, [Typed PValue])
build Integer -> PValue
forall lab. Integer -> Value' lab
ValInteger
      FloatType FloatType
Float    -> (Word32 -> PValue) -> Parse (Parse Type, [Typed PValue])
forall a.
(Num a, Bits a) =>
(a -> PValue) -> Parse (Parse Type, [Typed PValue])
build (Float -> PValue
forall lab. Float -> Value' lab
ValFloat (Float -> PValue) -> (Word32 -> Float) -> Word32 -> PValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Float
castFloat)
      FloatType FloatType
Double   -> (Word64 -> PValue) -> Parse (Parse Type, [Typed PValue])
forall a.
(Num a, Bits a) =>
(a -> PValue) -> Parse (Parse Type, [Typed PValue])
build (Double -> PValue
forall lab. Double -> Value' lab
ValDouble (Double -> PValue) -> (Word64 -> Double) -> Word64 -> PValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Double
castDouble)
      PrimType
x                  -> [Char] -> PrimType -> Parse (Parse Type, [Typed PValue])
forall (m :: * -> *) a b.
(MonadFail m, Show a) =>
[Char] -> a -> m b
Assert.unknownEntity [Char]
"element type" PrimType
x

  Int
23 -> [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CST_CODE_INLINEASM_OLD2" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ do
    Typed PValue
tv <- InlineAsmCode -> Parse Type -> Record -> Parse (Typed PValue)
parseInlineAsm InlineAsmCode
InlineAsmCode23 Parse Type
getTy Record
r
    (Parse Type, [Typed PValue]) -> Parse (Parse Type, [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parse Type
getTy, Typed PValue
tvTyped PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
:[Typed PValue]
cs)

  -- [opty, flags, n x operands]
  Int
24 -> [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CST_CODE_CE_GEP_WITH_INRANGE_INDEX" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ do
    Type
ty <- Parse Type
getTy
    PValue
v <- CeGepCode -> ValueTable -> Record -> Parse PValue
parseCeGep CeGepCode
CeGepCode24 ValueTable
t Record
r
    (Parse Type, [Typed PValue]) -> Parse (Parse Type, [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parse Type
getTy,Type -> PValue -> Typed PValue
forall a. Type -> a -> Typed a
Typed Type
ty PValue
vTyped PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
:[Typed PValue]
cs)

  -- [opcode, opval]
  Int
25 -> [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CST_CODE_CE_UNOP" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ do
    let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
    Type
ty      <- Parse Type
getTy
    Typed PValue -> PValue
mkInstr <- LookupField (Typed PValue -> PValue)
forall {a}. LookupField a
field Int
0 Match Field (Typed PValue -> PValue)
unopCE
    Int
opval   <- LookupField Int
forall {a}. LookupField a
field Int
1 Field -> Maybe Int
forall a. (Num a, Bits a) => Match Field a
numeric
    [[Char]]
cxt     <- Parse [[Char]]
getContext
    let v :: Typed PValue
v = HasCallStack => [[Char]] -> Int -> ValueTable -> Typed PValue
[[Char]] -> Int -> ValueTable -> Typed PValue
forwardRef [[Char]]
cxt Int
opval ValueTable
t
    (Parse Type, [Typed PValue]) -> Parse (Parse Type, [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parse Type
getTy, Type -> PValue -> Typed PValue
forall a. Type -> a -> Typed a
Typed Type
ty (Typed PValue -> PValue
mkInstr Typed PValue
v) Typed PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
: [Typed PValue]
cs)

  Int
26 -> [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CST_CODE_POISON" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ do
    Type
ty <- Parse Type
getTy
    (Parse Type, [Typed PValue]) -> Parse (Parse Type, [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parse Type
getTy, Type -> PValue -> Typed PValue
forall a. Type -> a -> Typed a
Typed Type
ty PValue
forall lab. Value' lab
ValPoison Typed PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
: [Typed PValue]
cs)

  Int
27 -> [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CST_CODE_DSO_LOCAL_EQUIVALENT" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ do
    Parse (Parse Type, [Typed PValue])
forall {a}. Parse a
notImplemented

  Int
28 -> [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CST_CODE_INLINEASM_OLD3" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ do
    Typed PValue
tv <- InlineAsmCode -> Parse Type -> Record -> Parse (Typed PValue)
parseInlineAsm InlineAsmCode
InlineAsmCode28 Parse Type
getTy Record
r
    (Parse Type, [Typed PValue]) -> Parse (Parse Type, [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parse Type
getTy, Typed PValue
tvTyped PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
:[Typed PValue]
cs)

  Int
29 -> [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CST_CODE_NO_CFI_VALUE" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ do
    Parse (Parse Type, [Typed PValue])
forall {a}. Parse a
notImplemented

  Int
30 -> [Char]
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a -> Parse a
label [Char]
"CST_CODE_INLINEASM" (Parse (Parse Type, [Typed PValue])
 -> Parse (Parse Type, [Typed PValue]))
-> Parse (Parse Type, [Typed PValue])
-> Parse (Parse Type, [Typed PValue])
forall a b. (a -> b) -> a -> b
$ do
    Typed PValue
tv <- InlineAsmCode -> Parse Type -> Record -> Parse (Typed PValue)
parseInlineAsm InlineAsmCode
InlineAsmCode30 Parse Type
getTy Record
r
    (Parse Type, [Typed PValue]) -> Parse (Parse Type, [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parse Type
getTy, Typed PValue
tvTyped PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
:[Typed PValue]
cs)

  Int
code -> [Char] -> Int -> Parse (Parse Type, [Typed PValue])
forall (m :: * -> *) a b.
(MonadFail m, Show a) =>
[Char] -> a -> m b
Assert.unknownEntity [Char]
"constant record code" Int
code

parseConstantEntry ValueTable
_ (Parse Type, [Typed PValue])
st (Match Entry DefineAbbrev
abbrevDef -> Just DefineAbbrev
_) =
  -- ignore abbreviation definitions
  (Parse Type, [Typed PValue]) -> Parse (Parse Type, [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parse Type, [Typed PValue])
st

parseConstantEntry ValueTable
_ (Parse Type, [Typed PValue])
_ Entry
e =
  [Char] -> Parse (Parse Type, [Typed PValue])
forall a. [Char] -> Parse a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"constant block: unexpected: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Entry -> [Char]
forall a. Show a => a -> [Char]
show Entry
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 CeGepCode -> CeGepCode -> Bool
(CeGepCode -> CeGepCode -> Bool)
-> (CeGepCode -> CeGepCode -> Bool) -> Eq CeGepCode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CeGepCode -> CeGepCode -> Bool
== :: CeGepCode -> CeGepCode -> Bool
$c/= :: CeGepCode -> CeGepCode -> Bool
/= :: CeGepCode -> CeGepCode -> Bool
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 :: CeGepCode -> ValueTable -> Record -> Parse PValue
parseCeGep CeGepCode
code ValueTable
t Record
r = do
  let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r

  (Maybe Type
mbBaseTy, Int
ix0) <-
    if CeGepCode
code CeGepCode -> CeGepCode -> Bool
forall a. Eq a => a -> a -> Bool
== CeGepCode
CeGepCode24 Bool -> Bool -> Bool
|| Int -> Bool
forall a. Integral a => a -> Bool
odd ([Field] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Record -> [Field]
recordFields Record
r))
    then do Type
baseTy <- 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
0 Field -> Maybe Int
forall a. (Num a, Bits a) => Match Field a
numeric
            (Maybe Type, Int) -> Parse (Maybe Type, Int)
forall a. a -> Parse a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Maybe Type
forall a. a -> Maybe a
Just Type
baseTy, Int
1)
    else (Maybe Type, Int) -> Parse (Maybe Type, Int)
forall a. a -> Parse a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Type
forall a. Maybe a
Nothing, Int
0)

  (Bool
isInbounds, Maybe Word64
mInrangeIdx, Int
ix1) <-
    case CeGepCode
code of
      CeGepCode
CeGepCode12 -> (Bool, Maybe Word64, Int) -> Parse (Bool, Maybe Word64, Int)
forall a. a -> Parse a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, Maybe Word64
forall a. Maybe a
Nothing, Int
ix0)
      CeGepCode
CeGepCode20 -> (Bool, Maybe Word64, Int) -> Parse (Bool, Maybe Word64, Int)
forall a. a -> Parse a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
True, Maybe Word64
forall a. Maybe a
Nothing, Int
ix0)
      CeGepCode
CeGepCode24 -> do
        (Word64
flags :: Word64) <- Record -> LookupField Word64
forall a. Record -> LookupField a
parseField Record
r Int
ix0 Match Field Word64
forall a. (Num a, Bits a) => Match Field a
numeric
        let inbounds :: Bool
inbounds = Word64 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word64
flags Int
0
            inrangeIdx :: Word64
inrangeIdx = Word64
flags Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
1
        (Bool, Maybe Word64, Int) -> Parse (Bool, Maybe Word64, Int)
forall a. a -> Parse a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
inbounds, Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
inrangeIdx, Int
ix0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

  let loop :: Int -> Parse [Typed PValue]
loop Int
n = 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
n    Field -> Maybe Int
forall a. (Num a, Bits a) => Match Field a
numeric
        Int
elt  <-             LookupField Int
forall {a}. LookupField a
field (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Field -> Maybe Int
forall a. (Num a, Bits a) => Match Field a
numeric
        [Typed PValue]
rest <- Int -> Parse [Typed PValue]
loop (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2) Parse [Typed PValue]
-> Parse [Typed PValue] -> Parse [Typed PValue]
forall a. Parse a -> Parse a -> Parse a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` [Typed PValue] -> Parse [Typed PValue]
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return []
        [[Char]]
cxt  <- Parse [[Char]]
getContext
        [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 (Typed PValue -> PValue
forall a. Typed a -> a
typedValue (HasCallStack => [[Char]] -> Int -> ValueTable -> Typed PValue
[[Char]] -> Int -> ValueTable -> Typed PValue
forwardRef [[Char]]
cxt Int
elt ValueTable
t)) Typed PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
: [Typed PValue]
rest)
  [Typed PValue]
args <- Int -> Parse [Typed PValue]
loop Int
ix1
  (Typed PValue
ptr, [Typed PValue]
args') <-
    case [Typed PValue]
args of
      [] -> [Char] -> Parse (Typed PValue, [Typed PValue])
forall a. [Char] -> Parse a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Invalid constant GEP with no operands"
      (Typed PValue
base:[Typed PValue]
args') -> (Typed PValue, [Typed PValue])
-> Parse (Typed PValue, [Typed PValue])
forall a. a -> Parse a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Typed PValue
base, [Typed PValue]
args')

  Type
baseTy <-
    case Maybe Type
mbBaseTy of
      Just Type
baseTy -> Type -> Parse Type
forall a. a -> Parse a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
baseTy
      Maybe Type
Nothing -> [Char] -> Type -> Parse Type
forall (m :: * -> *).
(MonadFail m, MonadPlus m) =>
[Char] -> Type -> m Type
Assert.elimPtrTo [Char]
"constant GEP not headed by pointer" (Typed PValue -> Type
forall a. Typed a -> Type
typedType Typed PValue
ptr)

  PValue -> Parse PValue
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (PValue -> Parse PValue) -> PValue -> Parse PValue
forall a b. (a -> b) -> a -> b
$! ConstExpr' Int -> PValue
forall lab. ConstExpr' lab -> Value' lab
ValConstExpr (Bool
-> Maybe Word64
-> Type
-> Typed PValue
-> [Typed PValue]
-> ConstExpr' Int
forall lab.
Bool
-> Maybe Word64
-> Type
-> Typed (Value' lab)
-> [Typed (Value' lab)]
-> ConstExpr' lab
ConstGEP Bool
isInbounds Maybe Word64
mInrangeIdx Type
baseTy Typed PValue
ptr [Typed PValue]
args')

parseWideInteger :: Record -> Int -> Parse Integer
parseWideInteger :: Record -> Int -> Parse Integer
parseWideInteger Record
r Int
idx = do
  [Word64]
limbs <- Record -> Int -> Int -> Match Field Word64 -> Parse [Word64]
forall a. Record -> Int -> Int -> Match Field a -> Parse [a]
parseSlice Record
r Int
idx ([Field] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Record -> [Field]
recordFields Record
r) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
idx) Match Field Word64
signedWord64
  Integer -> Parse Integer
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Word64 -> Integer -> Integer) -> Integer -> [Word64] -> Integer
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Word64
l Integer
acc -> Integer
acc Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
64 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ (Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
l)) Integer
0 [Word64]
limbs)

resolveNull :: Type -> Parse PValue
resolveNull :: Type -> Parse PValue
resolveNull Type
ty = case Type -> NullResult Int
forall lab. Type -> NullResult lab
typeNull Type
ty of
  HasNull PValue
nv    -> PValue -> Parse PValue
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PValue
nv
  ResolveNull Ident
i -> Type -> Parse PValue
resolveNull (Type -> Parse PValue) -> Parse Type -> Parse PValue
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> Parse Type
getType' (Int -> Parse Type) -> Parse Int -> Parse Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ident -> Parse Int
getTypeId Ident
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 :: InlineAsmCode -> Parse Type -> Record -> Parse (Typed PValue)
parseInlineAsm InlineAsmCode
code Parse Type
getTy Record
r = do
  let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r

  -- If using InlineAsmCode30 or later, we parse the type as an explicit
  -- field.
  let parseTy :: Parse (Type, Int)
parseTy  = 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
0 Field -> Maybe Int
forall a. (Num a, Bits a) => Match Field a
numeric
                    (Type, Int) -> Parse (Type, Int)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Type
forall ident. Type' ident -> Type' ident
PtrTo Type
ty, Int
1)
  -- If using an older InlineAsmCode, then we retrieve the type from the
  -- current context.
  let useCurTy :: Parse (Type, Int)
useCurTy = do Type
ty <- Parse Type
getTy
                    (Type, Int) -> Parse (Type, Int)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
ty, Int
0)
  (Type
ty, Int
ix) <- case InlineAsmCode
code of
                InlineAsmCode
InlineAsmCode18 -> Parse (Type, Int)
useCurTy
                InlineAsmCode
InlineAsmCode23 -> Parse (Type, Int)
useCurTy
                InlineAsmCode
InlineAsmCode28 -> Parse (Type, Int)
useCurTy
                InlineAsmCode
InlineAsmCode30 -> Parse (Type, Int)
parseTy

  Word32
mask <- LookupField Word32
forall {a}. LookupField a
field Int
ix Match Field Word32
forall a. (Num a, Bits a) => Match Field a
numeric

  let test :: Int -> Bool
test = Word32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit (Word32
mask :: Word32)
      hasSideEffects :: Bool
hasSideEffects = Int -> Bool
test Int
0
      isAlignStack :: Bool
isAlignStack   = Int -> Bool
test Int
1
      -- We don't store these in the llvm-pretty AST at the moment:
      _asmDialect :: Bool
_asmDialect    = Int -> Bool
test Int
2 -- Only with InlineAsmCode23 or later
      _canThrow :: Bool
_canThrow      = Int -> Bool
test Int
3 -- Only with InlineAsmCode28 or later

  Int
asmStrSize <- LookupField Int
forall {a}. LookupField a
field (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Field -> Maybe Int
forall a. (Num a, Bits a) => Match Field a
numeric
  Record -> Int -> Parse ()
forall (m :: * -> *). MonadFail m => Record -> Int -> m ()
Assert.recordSizeGreater Record
r (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
asmStrSize)

  Int
constStrSize <- LookupField Int
forall {a}. LookupField a
field (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
asmStrSize) Field -> Maybe Int
forall a. (Num a, Bits a) => Match Field a
numeric
  Record -> Int -> Parse ()
forall (m :: * -> *). MonadFail m => Record -> Int -> m ()
Assert.recordSizeGreater Record
r (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
asmStrSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
constStrSize)

  [Char]
asmStr   <- ([Word8] -> [Char]) -> Parse [Word8] -> Parse [Char]
forall a b. (a -> b) -> Parse a -> Parse b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Word8] -> [Char]
UTF8.decode (Parse [Word8] -> Parse [Char]) -> Parse [Word8] -> Parse [Char]
forall a b. (a -> b) -> a -> b
$ Record -> Int -> Int -> Match Field Word8 -> Parse [Word8]
forall a. Record -> Int -> Int -> Match Field a -> Parse [a]
parseSlice Record
r (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)              Int
asmStrSize   Match Field Word8
char
  [Char]
constStr <- ([Word8] -> [Char]) -> Parse [Word8] -> Parse [Char]
forall a b. (a -> b) -> Parse a -> Parse b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Word8] -> [Char]
UTF8.decode (Parse [Word8] -> Parse [Char]) -> Parse [Word8] -> Parse [Char]
forall a b. (a -> b) -> a -> b
$ Record -> Int -> Int -> Match Field Word8 -> Parse [Word8]
forall a. Record -> Int -> Int -> Match Field a -> Parse [a]
parseSlice Record
r (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
asmStrSize) Int
constStrSize Match Field Word8
char

  let val :: Value' lab
val = Bool -> Bool -> [Char] -> [Char] -> Value' lab
forall lab. Bool -> Bool -> [Char] -> [Char] -> Value' lab
ValAsm Bool
hasSideEffects Bool
isAlignStack [Char]
asmStr [Char]
constStr

  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 PValue
forall lab. Value' lab
val)


-- Float/Double Casting --------------------------------------------------------

castFloat :: Word32 -> Float
castFloat :: Word32 -> Float
castFloat Word32
w = (forall s. ST s Float) -> Float
forall a. (forall s. ST s a) -> a
runST (Word32 -> ST s Float
forall s a b.
(MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s)) =>
a -> ST s b
cast Word32
w)

castDouble :: Word64 -> Double
castDouble :: Word64 -> Double
castDouble Word64
w = (forall s. ST s Double) -> Double
forall a. (forall s. ST s a) -> a
runST (Word64 -> ST s Double
forall s a b.
(MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s)) =>
a -> ST s b
cast Word64
w)

cast :: (MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s))
     => a -> ST s b
cast :: forall s a b.
(MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s)) =>
a -> ST s b
cast a
x = do
  STUArray s Int a
arr <- (Int, Int) -> a -> ST s (STUArray s Int a)
forall i. Ix i => (i, i) -> a -> ST s (STUArray s i a)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int
0 :: Int, Int
0) a
x
  STUArray s Int b
res <- STUArray s Int a -> ST s (STUArray s Int b)
forall s ix a b. STUArray s ix a -> ST s (STUArray s ix b)
castSTUArray STUArray s Int a
arr
  STUArray s Int b -> Int -> ST s b
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int b
res Int
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 :: Type
-> Record
-> [Typed PValue]
-> Parse Type
-> Parse (Parse Type, [Typed PValue])
fp80build Type
ty Record
r [Typed PValue]
cs Parse Type
getTy =
  do BitString
v1 <- Record -> LookupField BitString
forall a. Record -> LookupField a
parseField Record
r Int
0 Match Field BitString
fieldLiteral
     BitString
v2 <- Record -> LookupField BitString
forall a. Record -> LookupField a
parseField Record
r Int
1 Match Field BitString
fieldLiteral
     let -- Note bs1 <> bs2 results in bs2|bs1 layout, shifting bs2 to higher bits
         v64_0 :: BitString
v64_0 = NumBits -> BitString -> BitString
BitS.take (Int -> NumBits
Bits' Int
64)
                 (BitString -> BitString) -> BitString -> BitString
forall a b. (a -> b) -> a -> b
$ NumBits -> BitString -> BitString
BitS.take (Int -> NumBits
Bits' Int
16) BitString
v2 BitString -> BitString -> BitString
`BitS.joinBitString` BitString
v1
         v64_1 :: BitString
v64_1 = NumBits -> BitString -> BitString
BitS.drop (Int -> NumBits
Bits' Int
48) BitString
v2
         -- result is v64_1|v64_0 being v0|v1
         fullexp :: Word16
         fullexp :: Word16
fullexp = BitString -> Word16
forall a. (Num a, Bits a) => BitString -> a
BitS.fromBitString (BitString -> Word16) -> BitString -> Word16
forall a b. (a -> b) -> a -> b
$ NumBits -> BitString -> BitString
BitS.take (Int -> NumBits
Bits' Int
16) BitString
v64_1 -- includes sign bit
         significnd :: Word64
         significnd :: Word64
significnd = BitString -> Word64
forall a. (Num a, Bits a) => BitString -> a
BitS.fromBitString (BitString -> Word64) -> BitString -> Word64
forall a b. (a -> b) -> a -> b
$ BitString
v64_0
         fp80Val :: FP80Value
fp80Val = Word16 -> Word64 -> FP80Value
FP80_LongDouble Word16
fullexp Word64
significnd
     (Parse Type, [Typed PValue]) -> Parse (Parse Type, [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Parse Type
getTy, Type -> PValue -> Typed PValue
forall a. Type -> a -> Typed a
Typed Type
ty (FP80Value -> PValue
forall lab. FP80Value -> Value' lab
ValFP80 FP80Value
fp80Val)Typed PValue -> [Typed PValue] -> [Typed PValue]
forall a. a -> [a] -> [a]
:[Typed PValue]
cs)