-- | A primitive expression is an expression where the non-leaves are
-- primitive operators.  Our representation does not guarantee that
-- the expression is type-correct.
module Futhark.Analysis.PrimExp
  ( PrimExp (..)
  , evalPrimExp
  , primExpType
  , primExpSizeAtLeast
  , coerceIntPrimExp
  , leafExpTypes
  , true
  , false
  , constFoldPrimExp

  , module Futhark.IR.Primitive
  , sExt, zExt
  , (.&&.), (.||.), (.<.), (.<=.), (.>.), (.>=.), (.==.), (.&.), (.|.), (.^.)
  ) where

import           Control.Monad
import           Data.Traversable
import qualified Data.Map as M
import qualified Data.Set as S

import           Futhark.IR.Prop.Names
import           Futhark.IR.Primitive
import           Futhark.Util.IntegralExp
import           Futhark.Util.Pretty

-- | A primitive expression parametrised over the representation of
-- free variables.  Note that the 'Functor', 'Traversable', and 'Num'
-- instances perform automatic (but simple) constant folding.
--
-- Note also that the 'Num' instance assumes 'OverflowUndef'
-- semantics!
data PrimExp v = LeafExp v PrimType
               | ValueExp PrimValue
               | BinOpExp BinOp (PrimExp v) (PrimExp v)
               | CmpOpExp CmpOp (PrimExp v) (PrimExp v)
               | UnOpExp UnOp (PrimExp v)
               | ConvOpExp ConvOp (PrimExp v)
               | FunExp String [PrimExp v] PrimType
               deriving (Eq (PrimExp v)
Eq (PrimExp v)
-> (PrimExp v -> PrimExp v -> Ordering)
-> (PrimExp v -> PrimExp v -> Bool)
-> (PrimExp v -> PrimExp v -> Bool)
-> (PrimExp v -> PrimExp v -> Bool)
-> (PrimExp v -> PrimExp v -> Bool)
-> (PrimExp v -> PrimExp v -> PrimExp v)
-> (PrimExp v -> PrimExp v -> PrimExp v)
-> Ord (PrimExp v)
PrimExp v -> PrimExp v -> Bool
PrimExp v -> PrimExp v -> Ordering
PrimExp v -> PrimExp v -> PrimExp v
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall v. Ord v => Eq (PrimExp v)
forall v. Ord v => PrimExp v -> PrimExp v -> Bool
forall v. Ord v => PrimExp v -> PrimExp v -> Ordering
forall v. Ord v => PrimExp v -> PrimExp v -> PrimExp v
min :: PrimExp v -> PrimExp v -> PrimExp v
$cmin :: forall v. Ord v => PrimExp v -> PrimExp v -> PrimExp v
max :: PrimExp v -> PrimExp v -> PrimExp v
$cmax :: forall v. Ord v => PrimExp v -> PrimExp v -> PrimExp v
>= :: PrimExp v -> PrimExp v -> Bool
$c>= :: forall v. Ord v => PrimExp v -> PrimExp v -> Bool
> :: PrimExp v -> PrimExp v -> Bool
$c> :: forall v. Ord v => PrimExp v -> PrimExp v -> Bool
<= :: PrimExp v -> PrimExp v -> Bool
$c<= :: forall v. Ord v => PrimExp v -> PrimExp v -> Bool
< :: PrimExp v -> PrimExp v -> Bool
$c< :: forall v. Ord v => PrimExp v -> PrimExp v -> Bool
compare :: PrimExp v -> PrimExp v -> Ordering
$ccompare :: forall v. Ord v => PrimExp v -> PrimExp v -> Ordering
$cp1Ord :: forall v. Ord v => Eq (PrimExp v)
Ord, Int -> PrimExp v -> ShowS
[PrimExp v] -> ShowS
PrimExp v -> String
(Int -> PrimExp v -> ShowS)
-> (PrimExp v -> String)
-> ([PrimExp v] -> ShowS)
-> Show (PrimExp v)
forall v. Show v => Int -> PrimExp v -> ShowS
forall v. Show v => [PrimExp v] -> ShowS
forall v. Show v => PrimExp v -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PrimExp v] -> ShowS
$cshowList :: forall v. Show v => [PrimExp v] -> ShowS
show :: PrimExp v -> String
$cshow :: forall v. Show v => PrimExp v -> String
showsPrec :: Int -> PrimExp v -> ShowS
$cshowsPrec :: forall v. Show v => Int -> PrimExp v -> ShowS
Show)

-- The Eq instance upcoerces all integer constants to their largest
-- type before comparing for equality.  This is technically not a good
-- idea, but solves annoying problems related to the Num instance
-- always producing Int64s.
instance Eq v => Eq (PrimExp v) where
  LeafExp v
x PrimType
xt == :: PrimExp v -> PrimExp v -> Bool
== LeafExp v
y PrimType
yt = v
x v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
y Bool -> Bool -> Bool
&& PrimType
xt PrimType -> PrimType -> Bool
forall a. Eq a => a -> a -> Bool
== PrimType
yt
  ValueExp (IntValue IntValue
x) == ValueExp (IntValue IntValue
y) =
    IntValue -> Int64
intToInt64 IntValue
x Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== IntValue -> Int64
intToInt64 IntValue
y
  ValueExp PrimValue
x == ValueExp PrimValue
y =
    PrimValue
x PrimValue -> PrimValue -> Bool
forall a. Eq a => a -> a -> Bool
== PrimValue
y
  BinOpExp BinOp
xop PrimExp v
x1 PrimExp v
x2 == BinOpExp BinOp
yop PrimExp v
y1 PrimExp v
y2 =
    BinOp
xop BinOp -> BinOp -> Bool
forall a. Eq a => a -> a -> Bool
== BinOp
yop Bool -> Bool -> Bool
&& PrimExp v
x1 PrimExp v -> PrimExp v -> Bool
forall a. Eq a => a -> a -> Bool
== PrimExp v
y1 Bool -> Bool -> Bool
&& PrimExp v
x2 PrimExp v -> PrimExp v -> Bool
forall a. Eq a => a -> a -> Bool
== PrimExp v
y2
  CmpOpExp CmpOp
xop PrimExp v
x1 PrimExp v
x2 == CmpOpExp CmpOp
yop PrimExp v
y1 PrimExp v
y2 =
    CmpOp
xop CmpOp -> CmpOp -> Bool
forall a. Eq a => a -> a -> Bool
== CmpOp
yop Bool -> Bool -> Bool
&& PrimExp v
x1 PrimExp v -> PrimExp v -> Bool
forall a. Eq a => a -> a -> Bool
== PrimExp v
y1 Bool -> Bool -> Bool
&& PrimExp v
x2 PrimExp v -> PrimExp v -> Bool
forall a. Eq a => a -> a -> Bool
== PrimExp v
y2
  UnOpExp UnOp
xop PrimExp v
x == UnOpExp UnOp
yop PrimExp v
y =
    UnOp
xop UnOp -> UnOp -> Bool
forall a. Eq a => a -> a -> Bool
== UnOp
yop Bool -> Bool -> Bool
&& PrimExp v
x PrimExp v -> PrimExp v -> Bool
forall a. Eq a => a -> a -> Bool
== PrimExp v
y
  ConvOpExp ConvOp
xop PrimExp v
x == ConvOpExp ConvOp
yop PrimExp v
y =
    ConvOp
xop ConvOp -> ConvOp -> Bool
forall a. Eq a => a -> a -> Bool
== ConvOp
yop Bool -> Bool -> Bool
&& PrimExp v
x PrimExp v -> PrimExp v -> Bool
forall a. Eq a => a -> a -> Bool
== PrimExp v
y
  FunExp String
xf [PrimExp v]
xargs PrimType
_ == FunExp String
yf [PrimExp v]
yargs PrimType
_ =
    String
xf String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
yf Bool -> Bool -> Bool
&& [PrimExp v]
xargs [PrimExp v] -> [PrimExp v] -> Bool
forall a. Eq a => a -> a -> Bool
== [PrimExp v]
yargs
  PrimExp v
_ == PrimExp v
_ = Bool
False

instance Functor PrimExp where
  fmap :: (a -> b) -> PrimExp a -> PrimExp b
fmap = (a -> b) -> PrimExp a -> PrimExp b
forall (t :: * -> *) a b. Traversable t => (a -> b) -> t a -> t b
fmapDefault

instance Foldable PrimExp where
  foldMap :: (a -> m) -> PrimExp a -> m
foldMap = (a -> m) -> PrimExp a -> m
forall (t :: * -> *) m a.
(Traversable t, Monoid m) =>
(a -> m) -> t a -> m
foldMapDefault

instance Traversable PrimExp where
  traverse :: (a -> f b) -> PrimExp a -> f (PrimExp b)
traverse a -> f b
f (LeafExp a
v PrimType
t) =
    b -> PrimType -> PrimExp b
forall v. v -> PrimType -> PrimExp v
LeafExp (b -> PrimType -> PrimExp b) -> f b -> f (PrimType -> PrimExp b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
v f (PrimType -> PrimExp b) -> f PrimType -> f (PrimExp b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PrimType -> f PrimType
forall (f :: * -> *) a. Applicative f => a -> f a
pure PrimType
t
  traverse a -> f b
_ (ValueExp PrimValue
v) =
    PrimExp b -> f (PrimExp b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrimExp b -> f (PrimExp b)) -> PrimExp b -> f (PrimExp b)
forall a b. (a -> b) -> a -> b
$ PrimValue -> PrimExp b
forall v. PrimValue -> PrimExp v
ValueExp PrimValue
v
  traverse a -> f b
f (BinOpExp BinOp
op PrimExp a
x PrimExp a
y) =
    PrimExp b -> PrimExp b
forall v. PrimExp v -> PrimExp v
constFoldPrimExp (PrimExp b -> PrimExp b) -> f (PrimExp b) -> f (PrimExp b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (BinOp -> PrimExp b -> PrimExp b -> PrimExp b
forall v. BinOp -> PrimExp v -> PrimExp v -> PrimExp v
BinOpExp BinOp
op (PrimExp b -> PrimExp b -> PrimExp b)
-> f (PrimExp b) -> f (PrimExp b -> PrimExp b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> PrimExp a -> f (PrimExp b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f PrimExp a
x f (PrimExp b -> PrimExp b) -> f (PrimExp b) -> f (PrimExp b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (a -> f b) -> PrimExp a -> f (PrimExp b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f PrimExp a
y)
  traverse a -> f b
f (CmpOpExp CmpOp
op PrimExp a
x PrimExp a
y) =
    CmpOp -> PrimExp b -> PrimExp b -> PrimExp b
forall v. CmpOp -> PrimExp v -> PrimExp v -> PrimExp v
CmpOpExp CmpOp
op (PrimExp b -> PrimExp b -> PrimExp b)
-> f (PrimExp b) -> f (PrimExp b -> PrimExp b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> PrimExp a -> f (PrimExp b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f PrimExp a
x f (PrimExp b -> PrimExp b) -> f (PrimExp b) -> f (PrimExp b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (a -> f b) -> PrimExp a -> f (PrimExp b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f PrimExp a
y
  traverse a -> f b
f (ConvOpExp ConvOp
op PrimExp a
x) =
    ConvOp -> PrimExp b -> PrimExp b
forall v. ConvOp -> PrimExp v -> PrimExp v
ConvOpExp ConvOp
op (PrimExp b -> PrimExp b) -> f (PrimExp b) -> f (PrimExp b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> PrimExp a -> f (PrimExp b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f PrimExp a
x
  traverse a -> f b
f (UnOpExp UnOp
op PrimExp a
x) =
    UnOp -> PrimExp b -> PrimExp b
forall v. UnOp -> PrimExp v -> PrimExp v
UnOpExp UnOp
op (PrimExp b -> PrimExp b) -> f (PrimExp b) -> f (PrimExp b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> PrimExp a -> f (PrimExp b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f PrimExp a
x
  traverse a -> f b
f (FunExp String
h [PrimExp a]
args PrimType
t) =
    String -> [PrimExp b] -> PrimType -> PrimExp b
forall v. String -> [PrimExp v] -> PrimType -> PrimExp v
FunExp String
h ([PrimExp b] -> PrimType -> PrimExp b)
-> f [PrimExp b] -> f (PrimType -> PrimExp b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PrimExp a -> f (PrimExp b)) -> [PrimExp a] -> f [PrimExp b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((a -> f b) -> PrimExp a -> f (PrimExp b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f) [PrimExp a]
args f (PrimType -> PrimExp b) -> f PrimType -> f (PrimExp b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PrimType -> f PrimType
forall (f :: * -> *) a. Applicative f => a -> f a
pure PrimType
t

instance FreeIn v => FreeIn (PrimExp v) where
  freeIn' :: PrimExp v -> FV
freeIn' = (v -> FV) -> PrimExp v -> FV
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap v -> FV
forall a. FreeIn a => a -> FV
freeIn'

-- | True if the 'PrimExp' has at least this many nodes.  This can be
-- much more efficient than comparing with 'length' for large
-- 'PrimExp's, as this function is lazy.
primExpSizeAtLeast :: Int -> PrimExp v -> Bool
primExpSizeAtLeast :: Int -> PrimExp v -> Bool
primExpSizeAtLeast Int
k = Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>=Int
k) (Maybe Int -> Bool)
-> (PrimExp v -> Maybe Int) -> PrimExp v -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> PrimExp v -> Maybe Int
forall v. Int -> PrimExp v -> Maybe Int
descend Int
0
  where descend :: Int -> PrimExp v -> Maybe Int
descend Int
i PrimExp v
_
          | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
k = Maybe Int
forall a. Maybe a
Nothing
        descend Int
i LeafExp{} = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
        descend Int
i ValueExp{} = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
        descend Int
i (BinOpExp BinOp
_ PrimExp v
x PrimExp v
y) = do Int
x' <- Int -> PrimExp v -> Maybe Int
descend (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) PrimExp v
x
                                        Int -> PrimExp v -> Maybe Int
descend Int
x' PrimExp v
y
        descend Int
i (CmpOpExp CmpOp
_ PrimExp v
x PrimExp v
y) = do Int
x' <- Int -> PrimExp v -> Maybe Int
descend (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) PrimExp v
x
                                        Int -> PrimExp v -> Maybe Int
descend Int
x' PrimExp v
y
        descend Int
i (ConvOpExp ConvOp
_ PrimExp v
x) = Int -> PrimExp v -> Maybe Int
descend (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) PrimExp v
x
        descend Int
i (UnOpExp UnOp
_ PrimExp v
x) = Int -> PrimExp v -> Maybe Int
descend (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) PrimExp v
x
        descend Int
i (FunExp String
_ [PrimExp v]
args PrimType
_) = (Int -> PrimExp v -> Maybe Int) -> Int -> [PrimExp v] -> Maybe Int
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Int -> PrimExp v -> Maybe Int
descend (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [PrimExp v]
args

-- | Perform quick and dirty constant folding on the top level of a
-- PrimExp.  This is necessary because we want to consider
-- e.g. equality modulo constant folding.
constFoldPrimExp :: PrimExp v -> PrimExp v
constFoldPrimExp :: PrimExp v -> PrimExp v
constFoldPrimExp (BinOpExp Add{} PrimExp v
x PrimExp v
y)
  | PrimExp v -> Bool
forall a. PrimExp a -> Bool
zeroIshExp PrimExp v
x = PrimExp v
y
  | PrimExp v -> Bool
forall a. PrimExp a -> Bool
zeroIshExp PrimExp v
y = PrimExp v
x
constFoldPrimExp (BinOpExp Sub{} PrimExp v
x PrimExp v
y)
  | PrimExp v -> Bool
forall a. PrimExp a -> Bool
zeroIshExp PrimExp v
y = PrimExp v
x
constFoldPrimExp (BinOpExp Mul{} PrimExp v
x PrimExp v
y)
  | PrimExp v -> Bool
forall a. PrimExp a -> Bool
oneIshExp PrimExp v
x = PrimExp v
y
  | PrimExp v -> Bool
forall a. PrimExp a -> Bool
oneIshExp PrimExp v
y = PrimExp v
x
  | PrimExp v -> Bool
forall a. PrimExp a -> Bool
zeroIshExp PrimExp v
x, IntType IntType
it <- PrimExp v -> PrimType
forall v. PrimExp v -> PrimType
primExpType PrimExp v
y =
      PrimValue -> PrimExp v
forall v. PrimValue -> PrimExp v
ValueExp (PrimValue -> PrimExp v) -> PrimValue -> PrimExp v
forall a b. (a -> b) -> a -> b
$ IntValue -> PrimValue
IntValue (IntValue -> PrimValue) -> IntValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ IntType -> Int -> IntValue
forall int. Integral int => IntType -> int -> IntValue
intValue IntType
it (Int
0::Int)
  | PrimExp v -> Bool
forall a. PrimExp a -> Bool
zeroIshExp PrimExp v
y, IntType IntType
it <- PrimExp v -> PrimType
forall v. PrimExp v -> PrimType
primExpType PrimExp v
x =
      PrimValue -> PrimExp v
forall v. PrimValue -> PrimExp v
ValueExp (PrimValue -> PrimExp v) -> PrimValue -> PrimExp v
forall a b. (a -> b) -> a -> b
$ IntValue -> PrimValue
IntValue (IntValue -> PrimValue) -> IntValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ IntType -> Int -> IntValue
forall int. Integral int => IntType -> int -> IntValue
intValue IntType
it (Int
0::Int)
constFoldPrimExp (BinOpExp SDiv{} PrimExp v
x PrimExp v
y)
  | PrimExp v -> Bool
forall a. PrimExp a -> Bool
oneIshExp PrimExp v
y = PrimExp v
x
constFoldPrimExp (BinOpExp SQuot{} PrimExp v
x PrimExp v
y)
  | PrimExp v -> Bool
forall a. PrimExp a -> Bool
oneIshExp PrimExp v
y = PrimExp v
x
constFoldPrimExp (BinOpExp UDiv{} PrimExp v
x PrimExp v
y)
  | PrimExp v -> Bool
forall a. PrimExp a -> Bool
oneIshExp PrimExp v
y = PrimExp v
x
constFoldPrimExp (BinOpExp BinOp
bop (ValueExp PrimValue
x) (ValueExp PrimValue
y))
  | Just PrimValue
z <- BinOp -> PrimValue -> PrimValue -> Maybe PrimValue
doBinOp BinOp
bop PrimValue
x PrimValue
y =
      PrimValue -> PrimExp v
forall v. PrimValue -> PrimExp v
ValueExp PrimValue
z
constFoldPrimExp (BinOpExp BinOp
LogAnd PrimExp v
x PrimExp v
y)
  | PrimExp v -> Bool
forall a. PrimExp a -> Bool
oneIshExp PrimExp v
x = PrimExp v
y
  | PrimExp v -> Bool
forall a. PrimExp a -> Bool
oneIshExp PrimExp v
y = PrimExp v
x
  | PrimExp v -> Bool
forall a. PrimExp a -> Bool
zeroIshExp PrimExp v
x = PrimExp v
x
  | PrimExp v -> Bool
forall a. PrimExp a -> Bool
zeroIshExp PrimExp v
y = PrimExp v
y
constFoldPrimExp (BinOpExp BinOp
LogOr PrimExp v
x PrimExp v
y)
  | PrimExp v -> Bool
forall a. PrimExp a -> Bool
oneIshExp PrimExp v
x = PrimExp v
x
  | PrimExp v -> Bool
forall a. PrimExp a -> Bool
oneIshExp PrimExp v
y = PrimExp v
y
  | PrimExp v -> Bool
forall a. PrimExp a -> Bool
zeroIshExp PrimExp v
x = PrimExp v
y
  | PrimExp v -> Bool
forall a. PrimExp a -> Bool
zeroIshExp PrimExp v
y = PrimExp v
x
constFoldPrimExp PrimExp v
e = PrimExp v
e

-- The Num instance performs a little bit of magic: whenever an
-- expression and a constant is combined with a binary operator, the
-- type of the constant may be changed to be the type of the
-- expression, if they are not already the same.  This permits us to
-- write e.g. @x * 4@, where @x@ is an arbitrary PrimExp, and have the
-- @4@ converted to the proper primitive type.  We also support
-- converting integers to floating point values, but not the other way
-- around.  All numeric instances assume unsigned integers for such
-- conversions.
--
-- We also perform simple constant folding, in particular to reduce
-- expressions to constants so that the above works.  However, it is
-- still a bit of a hack.
instance Pretty v => Num (PrimExp v) where
  PrimExp v
x + :: PrimExp v -> PrimExp v -> PrimExp v
+ PrimExp v
y | Just PrimExp v
z <- [Maybe (PrimExp v)] -> Maybe (PrimExp v)
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [(IntType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v)
forall v.
(IntType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v)
asIntOp (IntType -> Overflow -> BinOp
`Add` Overflow
OverflowUndef) PrimExp v
x PrimExp v
y,
                          (FloatType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v)
forall v.
(FloatType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v)
asFloatOp FloatType -> BinOp
FAdd PrimExp v
x PrimExp v
y] = PrimExp v -> PrimExp v
forall v. PrimExp v -> PrimExp v
constFoldPrimExp PrimExp v
z
        | Bool
otherwise = String -> (PrimExp v, PrimExp v) -> PrimExp v
forall a b. Pretty a => String -> a -> b
numBad String
"+" (PrimExp v
x,PrimExp v
y)

  PrimExp v
x - :: PrimExp v -> PrimExp v -> PrimExp v
- PrimExp v
y | Just PrimExp v
z <- [Maybe (PrimExp v)] -> Maybe (PrimExp v)
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [(IntType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v)
forall v.
(IntType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v)
asIntOp (IntType -> Overflow -> BinOp
`Sub` Overflow
OverflowUndef) PrimExp v
x PrimExp v
y,
                          (FloatType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v)
forall v.
(FloatType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v)
asFloatOp FloatType -> BinOp
FSub PrimExp v
x PrimExp v
y] = PrimExp v -> PrimExp v
forall v. PrimExp v -> PrimExp v
constFoldPrimExp PrimExp v
z
        | Bool
otherwise = String -> (PrimExp v, PrimExp v) -> PrimExp v
forall a b. Pretty a => String -> a -> b
numBad String
"-" (PrimExp v
x,PrimExp v
y)

  PrimExp v
x * :: PrimExp v -> PrimExp v -> PrimExp v
* PrimExp v
y | Just PrimExp v
z <- [Maybe (PrimExp v)] -> Maybe (PrimExp v)
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [(IntType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v)
forall v.
(IntType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v)
asIntOp (IntType -> Overflow -> BinOp
`Mul` Overflow
OverflowUndef) PrimExp v
x PrimExp v
y,
                          (FloatType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v)
forall v.
(FloatType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v)
asFloatOp FloatType -> BinOp
FMul PrimExp v
x PrimExp v
y] = PrimExp v -> PrimExp v
forall v. PrimExp v -> PrimExp v
constFoldPrimExp PrimExp v
z
        | Bool
otherwise = String -> (PrimExp v, PrimExp v) -> PrimExp v
forall a b. Pretty a => String -> a -> b
numBad String
"*" (PrimExp v
x,PrimExp v
y)

  abs :: PrimExp v -> PrimExp v
abs PrimExp v
x | IntType IntType
t <- PrimExp v -> PrimType
forall v. PrimExp v -> PrimType
primExpType PrimExp v
x = UnOp -> PrimExp v -> PrimExp v
forall v. UnOp -> PrimExp v -> PrimExp v
UnOpExp (IntType -> UnOp
Abs IntType
t) PrimExp v
x
        | FloatType FloatType
t <- PrimExp v -> PrimType
forall v. PrimExp v -> PrimType
primExpType PrimExp v
x = UnOp -> PrimExp v -> PrimExp v
forall v. UnOp -> PrimExp v -> PrimExp v
UnOpExp (FloatType -> UnOp
FAbs FloatType
t) PrimExp v
x
        | Bool
otherwise = String -> PrimExp v -> PrimExp v
forall a b. Pretty a => String -> a -> b
numBad String
"abs" PrimExp v
x

  signum :: PrimExp v -> PrimExp v
signum PrimExp v
x | IntType IntType
t <- PrimExp v -> PrimType
forall v. PrimExp v -> PrimType
primExpType PrimExp v
x = UnOp -> PrimExp v -> PrimExp v
forall v. UnOp -> PrimExp v -> PrimExp v
UnOpExp (IntType -> UnOp
SSignum IntType
t) PrimExp v
x
           | Bool
otherwise = String -> PrimExp v -> PrimExp v
forall a b. Pretty a => String -> a -> b
numBad String
"signum" PrimExp v
x

  fromInteger :: Integer -> PrimExp v
fromInteger = Int32 -> PrimExp v
forall e. IntegralExp e => Int32 -> e
fromInt32 (Int32 -> PrimExp v) -> (Integer -> Int32) -> Integer -> PrimExp v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int32
forall a. Num a => Integer -> a
fromInteger

instance Pretty v => Fractional (PrimExp v) where
  PrimExp v
x / :: PrimExp v -> PrimExp v -> PrimExp v
/ PrimExp v
y | Just PrimExp v
z <- [Maybe (PrimExp v)] -> Maybe (PrimExp v)
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [(FloatType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v)
forall v.
(FloatType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v)
asFloatOp FloatType -> BinOp
FDiv PrimExp v
x PrimExp v
y] = PrimExp v -> PrimExp v
forall v. PrimExp v -> PrimExp v
constFoldPrimExp PrimExp v
z
        | Bool
otherwise = String -> (PrimExp v, PrimExp v) -> PrimExp v
forall a b. Pretty a => String -> a -> b
numBad String
"/" (PrimExp v
x,PrimExp v
y)

  fromRational :: Rational -> PrimExp v
fromRational = PrimValue -> PrimExp v
forall v. PrimValue -> PrimExp v
ValueExp (PrimValue -> PrimExp v)
-> (Rational -> PrimValue) -> Rational -> PrimExp v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FloatValue -> PrimValue
FloatValue (FloatValue -> PrimValue)
-> (Rational -> FloatValue) -> Rational -> PrimValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> FloatValue
Float64Value (Double -> FloatValue)
-> (Rational -> Double) -> Rational -> FloatValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Double
forall a. Fractional a => Rational -> a
fromRational

instance Pretty v => IntegralExp (PrimExp v) where
  PrimExp v
x div :: PrimExp v -> PrimExp v -> PrimExp v
`div` PrimExp v
y | Just PrimExp v
z <- [Maybe (PrimExp v)] -> Maybe (PrimExp v)
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [(IntType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v)
forall v.
(IntType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v)
asIntOp (IntType -> Safety -> BinOp
`SDiv` Safety
Unsafe) PrimExp v
x PrimExp v
y,
                              (FloatType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v)
forall v.
(FloatType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v)
asFloatOp FloatType -> BinOp
FDiv PrimExp v
x PrimExp v
y] =
                PrimExp v -> PrimExp v
forall v. PrimExp v -> PrimExp v
constFoldPrimExp PrimExp v
z
            | Bool
otherwise = String -> (PrimExp v, PrimExp v) -> PrimExp v
forall a b. Pretty a => String -> a -> b
numBad String
"div" (PrimExp v
x,PrimExp v
y)

  PrimExp v
x mod :: PrimExp v -> PrimExp v -> PrimExp v
`mod` PrimExp v
y | Just PrimExp v
z <- [Maybe (PrimExp v)] -> Maybe (PrimExp v)
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [(IntType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v)
forall v.
(IntType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v)
asIntOp (IntType -> Safety -> BinOp
`SMod` Safety
Unsafe) PrimExp v
x PrimExp v
y] = PrimExp v
z
            | Bool
otherwise = String -> (PrimExp v, PrimExp v) -> PrimExp v
forall a b. Pretty a => String -> a -> b
numBad String
"mod" (PrimExp v
x,PrimExp v
y)

  PrimExp v
x quot :: PrimExp v -> PrimExp v -> PrimExp v
`quot` PrimExp v
y | PrimExp v -> Bool
forall a. PrimExp a -> Bool
oneIshExp PrimExp v
y = PrimExp v
x
             | Just PrimExp v
z <- [Maybe (PrimExp v)] -> Maybe (PrimExp v)
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [(IntType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v)
forall v.
(IntType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v)
asIntOp (IntType -> Safety -> BinOp
`SQuot` Safety
Unsafe) PrimExp v
x PrimExp v
y] = PrimExp v -> PrimExp v
forall v. PrimExp v -> PrimExp v
constFoldPrimExp PrimExp v
z
             | Bool
otherwise = String -> (PrimExp v, PrimExp v) -> PrimExp v
forall a b. Pretty a => String -> a -> b
numBad String
"quot" (PrimExp v
x,PrimExp v
y)

  PrimExp v
x rem :: PrimExp v -> PrimExp v -> PrimExp v
`rem` PrimExp v
y | Just PrimExp v
z <- [Maybe (PrimExp v)] -> Maybe (PrimExp v)
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [(IntType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v)
forall v.
(IntType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v)
asIntOp (IntType -> Safety -> BinOp
`SRem` Safety
Unsafe) PrimExp v
x PrimExp v
y] = PrimExp v -> PrimExp v
forall v. PrimExp v -> PrimExp v
constFoldPrimExp PrimExp v
z
            | Bool
otherwise = String -> (PrimExp v, PrimExp v) -> PrimExp v
forall a b. Pretty a => String -> a -> b
numBad String
"rem" (PrimExp v
x,PrimExp v
y)

  PrimExp v
x divUp :: PrimExp v -> PrimExp v -> PrimExp v
`divUp` PrimExp v
y | Just PrimExp v
z <- [Maybe (PrimExp v)] -> Maybe (PrimExp v)
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [(IntType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v)
forall v.
(IntType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v)
asIntOp (IntType -> Safety -> BinOp
`SDivUp` Safety
Unsafe) PrimExp v
x PrimExp v
y] =
                  PrimExp v -> PrimExp v
forall v. PrimExp v -> PrimExp v
constFoldPrimExp PrimExp v
z
              | Bool
otherwise = String -> (PrimExp v, PrimExp v) -> PrimExp v
forall a b. Pretty a => String -> a -> b
numBad String
"divRoundingUp" (PrimExp v
x,PrimExp v
y)

  sgn :: PrimExp v -> Maybe Int
sgn (ValueExp (IntValue IntValue
i)) = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Num a => a -> a
signum (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ IntValue -> Int
forall int. Integral int => IntValue -> int
valueIntegral IntValue
i
  sgn PrimExp v
_ = Maybe Int
forall a. Maybe a
Nothing

  fromInt8 :: Int8 -> PrimExp v
fromInt8  = PrimValue -> PrimExp v
forall v. PrimValue -> PrimExp v
ValueExp (PrimValue -> PrimExp v)
-> (Int8 -> PrimValue) -> Int8 -> PrimExp v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntValue -> PrimValue
IntValue (IntValue -> PrimValue) -> (Int8 -> IntValue) -> Int8 -> PrimValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int8 -> IntValue
Int8Value
  fromInt16 :: Int16 -> PrimExp v
fromInt16 = PrimValue -> PrimExp v
forall v. PrimValue -> PrimExp v
ValueExp (PrimValue -> PrimExp v)
-> (Int16 -> PrimValue) -> Int16 -> PrimExp v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntValue -> PrimValue
IntValue (IntValue -> PrimValue)
-> (Int16 -> IntValue) -> Int16 -> PrimValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int16 -> IntValue
Int16Value
  fromInt32 :: Int32 -> PrimExp v
fromInt32 = PrimValue -> PrimExp v
forall v. PrimValue -> PrimExp v
ValueExp (PrimValue -> PrimExp v)
-> (Int32 -> PrimValue) -> Int32 -> PrimExp v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntValue -> PrimValue
IntValue (IntValue -> PrimValue)
-> (Int32 -> IntValue) -> Int32 -> PrimValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> IntValue
Int32Value
  fromInt64 :: Int64 -> PrimExp v
fromInt64 = PrimValue -> PrimExp v
forall v. PrimValue -> PrimExp v
ValueExp (PrimValue -> PrimExp v)
-> (Int64 -> PrimValue) -> Int64 -> PrimExp v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntValue -> PrimValue
IntValue (IntValue -> PrimValue)
-> (Int64 -> IntValue) -> Int64 -> PrimValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> IntValue
Int64Value

-- | Lifted logical conjunction.
(.&&.) :: PrimExp v -> PrimExp v -> PrimExp v
PrimExp v
x .&&. :: PrimExp v -> PrimExp v -> PrimExp v
.&&. PrimExp v
y = PrimExp v -> PrimExp v
forall v. PrimExp v -> PrimExp v
constFoldPrimExp (PrimExp v -> PrimExp v) -> PrimExp v -> PrimExp v
forall a b. (a -> b) -> a -> b
$ BinOp -> PrimExp v -> PrimExp v -> PrimExp v
forall v. BinOp -> PrimExp v -> PrimExp v -> PrimExp v
BinOpExp BinOp
LogAnd PrimExp v
x PrimExp v
y

-- | Lifted logical conjunction.
(.||.) :: PrimExp v -> PrimExp v -> PrimExp v
PrimExp v
x .||. :: PrimExp v -> PrimExp v -> PrimExp v
.||. PrimExp v
y = PrimExp v -> PrimExp v
forall v. PrimExp v -> PrimExp v
constFoldPrimExp (PrimExp v -> PrimExp v) -> PrimExp v -> PrimExp v
forall a b. (a -> b) -> a -> b
$ BinOp -> PrimExp v -> PrimExp v -> PrimExp v
forall v. BinOp -> PrimExp v -> PrimExp v -> PrimExp v
BinOpExp BinOp
LogOr PrimExp v
x PrimExp v
y

-- | Lifted relational operators; assuming signed numbers in case of
-- integers.
(.<.), (.>.), (.<=.), (.>=.), (.==.) :: PrimExp v -> PrimExp v -> PrimExp v
PrimExp v
x .<. :: PrimExp v -> PrimExp v -> PrimExp v
.<. PrimExp v
y = PrimExp v -> PrimExp v
forall v. PrimExp v -> PrimExp v
constFoldPrimExp (PrimExp v -> PrimExp v) -> PrimExp v -> PrimExp v
forall a b. (a -> b) -> a -> b
$
          CmpOp -> PrimExp v -> PrimExp v -> PrimExp v
forall v. CmpOp -> PrimExp v -> PrimExp v -> PrimExp v
CmpOpExp CmpOp
cmp PrimExp v
x PrimExp v
y where cmp :: CmpOp
cmp = case PrimExp v -> PrimType
forall v. PrimExp v -> PrimType
primExpType PrimExp v
x of
                                         IntType IntType
t -> IntType -> CmpOp
CmpSlt (IntType -> CmpOp) -> IntType -> CmpOp
forall a b. (a -> b) -> a -> b
$ IntType
t IntType -> IntType -> IntType
forall a. Ord a => a -> a -> a
`min` PrimExp v -> IntType
forall v. PrimExp v -> IntType
primExpIntType PrimExp v
y
                                         FloatType FloatType
t -> FloatType -> CmpOp
FCmpLt FloatType
t
                                         PrimType
_ -> CmpOp
CmpLlt
PrimExp v
x .<=. :: PrimExp v -> PrimExp v -> PrimExp v
.<=. PrimExp v
y = PrimExp v -> PrimExp v
forall v. PrimExp v -> PrimExp v
constFoldPrimExp (PrimExp v -> PrimExp v) -> PrimExp v -> PrimExp v
forall a b. (a -> b) -> a -> b
$
           CmpOp -> PrimExp v -> PrimExp v -> PrimExp v
forall v. CmpOp -> PrimExp v -> PrimExp v -> PrimExp v
CmpOpExp CmpOp
cmp PrimExp v
x PrimExp v
y where cmp :: CmpOp
cmp = case PrimExp v -> PrimType
forall v. PrimExp v -> PrimType
primExpType PrimExp v
x of
                                          IntType IntType
t -> IntType -> CmpOp
CmpSle (IntType -> CmpOp) -> IntType -> CmpOp
forall a b. (a -> b) -> a -> b
$ IntType
t IntType -> IntType -> IntType
forall a. Ord a => a -> a -> a
`min` PrimExp v -> IntType
forall v. PrimExp v -> IntType
primExpIntType PrimExp v
y
                                          FloatType FloatType
t -> FloatType -> CmpOp
FCmpLe FloatType
t
                                          PrimType
_ -> CmpOp
CmpLle
PrimExp v
x .==. :: PrimExp v -> PrimExp v -> PrimExp v
.==. PrimExp v
y = PrimExp v -> PrimExp v
forall v. PrimExp v -> PrimExp v
constFoldPrimExp (PrimExp v -> PrimExp v) -> PrimExp v -> PrimExp v
forall a b. (a -> b) -> a -> b
$
           CmpOp -> PrimExp v -> PrimExp v -> PrimExp v
forall v. CmpOp -> PrimExp v -> PrimExp v -> PrimExp v
CmpOpExp (PrimType -> CmpOp
CmpEq (PrimType -> CmpOp) -> PrimType -> CmpOp
forall a b. (a -> b) -> a -> b
$ PrimExp v -> PrimType
forall v. PrimExp v -> PrimType
primExpType PrimExp v
x PrimType -> PrimType -> PrimType
forall a. Ord a => a -> a -> a
`min` PrimExp v -> PrimType
forall v. PrimExp v -> PrimType
primExpType PrimExp v
y) PrimExp v
x PrimExp v
y
PrimExp v
x .>. :: PrimExp v -> PrimExp v -> PrimExp v
.>. PrimExp v
y = PrimExp v
y PrimExp v -> PrimExp v -> PrimExp v
forall v. PrimExp v -> PrimExp v -> PrimExp v
.<. PrimExp v
x
PrimExp v
x .>=. :: PrimExp v -> PrimExp v -> PrimExp v
.>=. PrimExp v
y = PrimExp v
y PrimExp v -> PrimExp v -> PrimExp v
forall v. PrimExp v -> PrimExp v -> PrimExp v
.<=. PrimExp v
x

-- | Lifted bitwise operators.
(.&.), (.|.), (.^.) :: PrimExp v -> PrimExp v -> PrimExp v
PrimExp v
x .&. :: PrimExp v -> PrimExp v -> PrimExp v
.&. PrimExp v
y = PrimExp v -> PrimExp v
forall v. PrimExp v -> PrimExp v
constFoldPrimExp (PrimExp v -> PrimExp v) -> PrimExp v -> PrimExp v
forall a b. (a -> b) -> a -> b
$
          BinOp -> PrimExp v -> PrimExp v -> PrimExp v
forall v. BinOp -> PrimExp v -> PrimExp v -> PrimExp v
BinOpExp (IntType -> BinOp
And (IntType -> BinOp) -> IntType -> BinOp
forall a b. (a -> b) -> a -> b
$ PrimExp v -> IntType
forall v. PrimExp v -> IntType
primExpIntType PrimExp v
x IntType -> IntType -> IntType
forall a. Ord a => a -> a -> a
`min` PrimExp v -> IntType
forall v. PrimExp v -> IntType
primExpIntType PrimExp v
y) PrimExp v
x PrimExp v
y
PrimExp v
x .|. :: PrimExp v -> PrimExp v -> PrimExp v
.|. PrimExp v
y = PrimExp v -> PrimExp v
forall v. PrimExp v -> PrimExp v
constFoldPrimExp (PrimExp v -> PrimExp v) -> PrimExp v -> PrimExp v
forall a b. (a -> b) -> a -> b
$
          BinOp -> PrimExp v -> PrimExp v -> PrimExp v
forall v. BinOp -> PrimExp v -> PrimExp v -> PrimExp v
BinOpExp (IntType -> BinOp
Or (IntType -> BinOp) -> IntType -> BinOp
forall a b. (a -> b) -> a -> b
$ PrimExp v -> IntType
forall v. PrimExp v -> IntType
primExpIntType PrimExp v
x IntType -> IntType -> IntType
forall a. Ord a => a -> a -> a
`min` PrimExp v -> IntType
forall v. PrimExp v -> IntType
primExpIntType PrimExp v
y) PrimExp v
x PrimExp v
y
PrimExp v
x .^. :: PrimExp v -> PrimExp v -> PrimExp v
.^. PrimExp v
y = PrimExp v -> PrimExp v
forall v. PrimExp v -> PrimExp v
constFoldPrimExp (PrimExp v -> PrimExp v) -> PrimExp v -> PrimExp v
forall a b. (a -> b) -> a -> b
$
          BinOp -> PrimExp v -> PrimExp v -> PrimExp v
forall v. BinOp -> PrimExp v -> PrimExp v -> PrimExp v
BinOpExp (IntType -> BinOp
Xor (IntType -> BinOp) -> IntType -> BinOp
forall a b. (a -> b) -> a -> b
$ PrimExp v -> IntType
forall v. PrimExp v -> IntType
primExpIntType PrimExp v
x IntType -> IntType -> IntType
forall a. Ord a => a -> a -> a
`min` PrimExp v -> IntType
forall v. PrimExp v -> IntType
primExpIntType PrimExp v
y) PrimExp v
x PrimExp v
y

infix 4 .==., .<., .>., .<=., .>=.
infixr 3 .&&.
infixr 2 .||.

-- | Smart constructor for sign extension that does a bit of constant
-- folding.
sExt :: IntType -> PrimExp v -> PrimExp v
sExt :: IntType -> PrimExp v -> PrimExp v
sExt IntType
it (ValueExp (IntValue IntValue
v)) = PrimValue -> PrimExp v
forall v. PrimValue -> PrimExp v
ValueExp (PrimValue -> PrimExp v) -> PrimValue -> PrimExp v
forall a b. (a -> b) -> a -> b
$ IntValue -> PrimValue
IntValue (IntValue -> PrimValue) -> IntValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ IntValue -> IntType -> IntValue
doSExt IntValue
v IntType
it
sExt IntType
it PrimExp v
e
  | PrimExp v -> IntType
forall v. PrimExp v -> IntType
primExpIntType PrimExp v
e IntType -> IntType -> Bool
forall a. Eq a => a -> a -> Bool
== IntType
it = PrimExp v
e
  | Bool
otherwise = ConvOp -> PrimExp v -> PrimExp v
forall v. ConvOp -> PrimExp v -> PrimExp v
ConvOpExp (IntType -> IntType -> ConvOp
SExt (PrimExp v -> IntType
forall v. PrimExp v -> IntType
primExpIntType PrimExp v
e) IntType
it) PrimExp v
e

-- | Smart constructor for zero extension that does a bit of constant
-- folding.
zExt :: IntType -> PrimExp v -> PrimExp v
zExt :: IntType -> PrimExp v -> PrimExp v
zExt IntType
it (ValueExp (IntValue IntValue
v)) = PrimValue -> PrimExp v
forall v. PrimValue -> PrimExp v
ValueExp (PrimValue -> PrimExp v) -> PrimValue -> PrimExp v
forall a b. (a -> b) -> a -> b
$ IntValue -> PrimValue
IntValue (IntValue -> PrimValue) -> IntValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ IntValue -> IntType -> IntValue
doZExt IntValue
v IntType
it
zExt IntType
it PrimExp v
e
  | PrimExp v -> IntType
forall v. PrimExp v -> IntType
primExpIntType PrimExp v
e IntType -> IntType -> Bool
forall a. Eq a => a -> a -> Bool
== IntType
it = PrimExp v
e
  | Bool
otherwise = ConvOp -> PrimExp v -> PrimExp v
forall v. ConvOp -> PrimExp v -> PrimExp v
ConvOpExp (IntType -> IntType -> ConvOp
ZExt (PrimExp v -> IntType
forall v. PrimExp v -> IntType
primExpIntType PrimExp v
e) IntType
it) PrimExp v
e

asIntOp :: (IntType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v)
asIntOp :: (IntType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v)
asIntOp IntType -> BinOp
f PrimExp v
x PrimExp v
y
  -- If either of the operands is a constant, then we prefer the type
  -- of the other operand.  This lets us use literals via fromInteger
  -- without imposing a specific type.
  | ValueExp{} <- PrimExp v
x,
    IntType IntType
y_t <- PrimExp v -> PrimType
forall v. PrimExp v -> PrimType
primExpType PrimExp v
y,
    Just PrimExp v
x' <- IntType -> PrimExp v -> Maybe (PrimExp v)
forall v. IntType -> PrimExp v -> Maybe (PrimExp v)
asIntExp IntType
y_t PrimExp v
x = PrimExp v -> Maybe (PrimExp v)
forall a. a -> Maybe a
Just (PrimExp v -> Maybe (PrimExp v)) -> PrimExp v -> Maybe (PrimExp v)
forall a b. (a -> b) -> a -> b
$ BinOp -> PrimExp v -> PrimExp v -> PrimExp v
forall v. BinOp -> PrimExp v -> PrimExp v -> PrimExp v
BinOpExp (IntType -> BinOp
f IntType
y_t) PrimExp v
x' PrimExp v
y
  | ValueExp{} <- PrimExp v
y,
    IntType IntType
x_t <- PrimExp v -> PrimType
forall v. PrimExp v -> PrimType
primExpType PrimExp v
x,
    Just PrimExp v
y' <- IntType -> PrimExp v -> Maybe (PrimExp v)
forall v. IntType -> PrimExp v -> Maybe (PrimExp v)
asIntExp IntType
x_t PrimExp v
y = PrimExp v -> Maybe (PrimExp v)
forall a. a -> Maybe a
Just (PrimExp v -> Maybe (PrimExp v)) -> PrimExp v -> Maybe (PrimExp v)
forall a b. (a -> b) -> a -> b
$ BinOp -> PrimExp v -> PrimExp v -> PrimExp v
forall v. BinOp -> PrimExp v -> PrimExp v -> PrimExp v
BinOpExp (IntType -> BinOp
f IntType
x_t) PrimExp v
x PrimExp v
y'

  -- Otherwise prefer the type of the leftmost operand.
  | IntType IntType
t <- PrimExp v -> PrimType
forall v. PrimExp v -> PrimType
primExpType PrimExp v
x,
    Just PrimExp v
y' <- IntType -> PrimExp v -> Maybe (PrimExp v)
forall v. IntType -> PrimExp v -> Maybe (PrimExp v)
asIntExp IntType
t PrimExp v
y = PrimExp v -> Maybe (PrimExp v)
forall a. a -> Maybe a
Just (PrimExp v -> Maybe (PrimExp v)) -> PrimExp v -> Maybe (PrimExp v)
forall a b. (a -> b) -> a -> b
$ BinOp -> PrimExp v -> PrimExp v -> PrimExp v
forall v. BinOp -> PrimExp v -> PrimExp v -> PrimExp v
BinOpExp (IntType -> BinOp
f IntType
t) PrimExp v
x PrimExp v
y'
  | IntType IntType
t <- PrimExp v -> PrimType
forall v. PrimExp v -> PrimType
primExpType PrimExp v
y,
    Just PrimExp v
x' <- IntType -> PrimExp v -> Maybe (PrimExp v)
forall v. IntType -> PrimExp v -> Maybe (PrimExp v)
asIntExp IntType
t PrimExp v
x = PrimExp v -> Maybe (PrimExp v)
forall a. a -> Maybe a
Just (PrimExp v -> Maybe (PrimExp v)) -> PrimExp v -> Maybe (PrimExp v)
forall a b. (a -> b) -> a -> b
$ BinOp -> PrimExp v -> PrimExp v -> PrimExp v
forall v. BinOp -> PrimExp v -> PrimExp v -> PrimExp v
BinOpExp (IntType -> BinOp
f IntType
t) PrimExp v
x' PrimExp v
y

  | Bool
otherwise = Maybe (PrimExp v)
forall a. Maybe a
Nothing

asIntExp :: IntType -> PrimExp v -> Maybe (PrimExp v)
asIntExp :: IntType -> PrimExp v -> Maybe (PrimExp v)
asIntExp IntType
t PrimExp v
e
  | PrimExp v -> PrimType
forall v. PrimExp v -> PrimType
primExpType PrimExp v
e PrimType -> PrimType -> Bool
forall a. Eq a => a -> a -> Bool
== IntType -> PrimType
IntType IntType
t = PrimExp v -> Maybe (PrimExp v)
forall a. a -> Maybe a
Just PrimExp v
e
asIntExp IntType
t (ValueExp (IntValue IntValue
v)) =
  PrimExp v -> Maybe (PrimExp v)
forall a. a -> Maybe a
Just (PrimExp v -> Maybe (PrimExp v)) -> PrimExp v -> Maybe (PrimExp v)
forall a b. (a -> b) -> a -> b
$ PrimValue -> PrimExp v
forall v. PrimValue -> PrimExp v
ValueExp (PrimValue -> PrimExp v) -> PrimValue -> PrimExp v
forall a b. (a -> b) -> a -> b
$ IntValue -> PrimValue
IntValue (IntValue -> PrimValue) -> IntValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ IntValue -> IntType -> IntValue
doSExt IntValue
v IntType
t
asIntExp IntType
_ PrimExp v
_ =
  Maybe (PrimExp v)
forall a. Maybe a
Nothing

asFloatOp :: (FloatType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v)
asFloatOp :: (FloatType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v)
asFloatOp FloatType -> BinOp
f PrimExp v
x PrimExp v
y
  | FloatType FloatType
t <- PrimExp v -> PrimType
forall v. PrimExp v -> PrimType
primExpType PrimExp v
x,
    Just PrimExp v
y' <- FloatType -> PrimExp v -> Maybe (PrimExp v)
forall v. FloatType -> PrimExp v -> Maybe (PrimExp v)
asFloatExp FloatType
t PrimExp v
y = PrimExp v -> Maybe (PrimExp v)
forall a. a -> Maybe a
Just (PrimExp v -> Maybe (PrimExp v)) -> PrimExp v -> Maybe (PrimExp v)
forall a b. (a -> b) -> a -> b
$ BinOp -> PrimExp v -> PrimExp v -> PrimExp v
forall v. BinOp -> PrimExp v -> PrimExp v -> PrimExp v
BinOpExp (FloatType -> BinOp
f FloatType
t) PrimExp v
x PrimExp v
y'
  | FloatType FloatType
t <- PrimExp v -> PrimType
forall v. PrimExp v -> PrimType
primExpType PrimExp v
y,
    Just PrimExp v
x' <- FloatType -> PrimExp v -> Maybe (PrimExp v)
forall v. FloatType -> PrimExp v -> Maybe (PrimExp v)
asFloatExp FloatType
t PrimExp v
x = PrimExp v -> Maybe (PrimExp v)
forall a. a -> Maybe a
Just (PrimExp v -> Maybe (PrimExp v)) -> PrimExp v -> Maybe (PrimExp v)
forall a b. (a -> b) -> a -> b
$ BinOp -> PrimExp v -> PrimExp v -> PrimExp v
forall v. BinOp -> PrimExp v -> PrimExp v -> PrimExp v
BinOpExp (FloatType -> BinOp
f FloatType
t) PrimExp v
x' PrimExp v
y
  | Bool
otherwise = Maybe (PrimExp v)
forall a. Maybe a
Nothing

asFloatExp :: FloatType -> PrimExp v -> Maybe (PrimExp v)
asFloatExp :: FloatType -> PrimExp v -> Maybe (PrimExp v)
asFloatExp FloatType
t PrimExp v
e
  | PrimExp v -> PrimType
forall v. PrimExp v -> PrimType
primExpType PrimExp v
e PrimType -> PrimType -> Bool
forall a. Eq a => a -> a -> Bool
== FloatType -> PrimType
FloatType FloatType
t = PrimExp v -> Maybe (PrimExp v)
forall a. a -> Maybe a
Just PrimExp v
e
asFloatExp FloatType
t (ValueExp (FloatValue FloatValue
v)) =
  PrimExp v -> Maybe (PrimExp v)
forall a. a -> Maybe a
Just (PrimExp v -> Maybe (PrimExp v)) -> PrimExp v -> Maybe (PrimExp v)
forall a b. (a -> b) -> a -> b
$ PrimValue -> PrimExp v
forall v. PrimValue -> PrimExp v
ValueExp (PrimValue -> PrimExp v) -> PrimValue -> PrimExp v
forall a b. (a -> b) -> a -> b
$ FloatValue -> PrimValue
FloatValue (FloatValue -> PrimValue) -> FloatValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ FloatValue -> FloatType -> FloatValue
doFPConv FloatValue
v FloatType
t
asFloatExp FloatType
t (ValueExp (IntValue IntValue
v)) =
  PrimExp v -> Maybe (PrimExp v)
forall a. a -> Maybe a
Just (PrimExp v -> Maybe (PrimExp v)) -> PrimExp v -> Maybe (PrimExp v)
forall a b. (a -> b) -> a -> b
$ PrimValue -> PrimExp v
forall v. PrimValue -> PrimExp v
ValueExp (PrimValue -> PrimExp v) -> PrimValue -> PrimExp v
forall a b. (a -> b) -> a -> b
$ FloatValue -> PrimValue
FloatValue (FloatValue -> PrimValue) -> FloatValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ IntValue -> FloatType -> FloatValue
doSIToFP IntValue
v FloatType
t
asFloatExp FloatType
_ PrimExp v
_ =
  Maybe (PrimExp v)
forall a. Maybe a
Nothing

numBad :: Pretty a => String -> a -> b
numBad :: String -> a -> b
numBad String
s a
x =
  String -> b
forall a. HasCallStack => String -> a
error (String -> b) -> String -> b
forall a b. (a -> b) -> a -> b
$ String
"Invalid argument to PrimExp method " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Pretty a => a -> String
pretty a
x

-- | Evaluate a 'PrimExp' in the given monad.  Invokes 'fail' on type
-- errors.
evalPrimExp :: (Pretty v, MonadFail m) => (v -> m PrimValue) -> PrimExp v -> m PrimValue
evalPrimExp :: (v -> m PrimValue) -> PrimExp v -> m PrimValue
evalPrimExp v -> m PrimValue
f (LeafExp v
v PrimType
_) = v -> m PrimValue
f v
v
evalPrimExp v -> m PrimValue
_ (ValueExp PrimValue
v) = PrimValue -> m PrimValue
forall (m :: * -> *) a. Monad m => a -> m a
return PrimValue
v
evalPrimExp v -> m PrimValue
f (BinOpExp BinOp
op PrimExp v
x PrimExp v
y) = do
  PrimValue
x' <- (v -> m PrimValue) -> PrimExp v -> m PrimValue
forall v (m :: * -> *).
(Pretty v, MonadFail m) =>
(v -> m PrimValue) -> PrimExp v -> m PrimValue
evalPrimExp v -> m PrimValue
f PrimExp v
x
  PrimValue
y' <- (v -> m PrimValue) -> PrimExp v -> m PrimValue
forall v (m :: * -> *).
(Pretty v, MonadFail m) =>
(v -> m PrimValue) -> PrimExp v -> m PrimValue
evalPrimExp v -> m PrimValue
f PrimExp v
y
  m PrimValue
-> (PrimValue -> m PrimValue) -> Maybe PrimValue -> m PrimValue
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (BinOp -> (PrimExp v, PrimExp v) -> m PrimValue
forall a b (m :: * -> *) c.
(Pretty a, Pretty b, MonadFail m) =>
a -> b -> m c
evalBad BinOp
op (PrimExp v
x,PrimExp v
y)) PrimValue -> m PrimValue
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PrimValue -> m PrimValue) -> Maybe PrimValue -> m PrimValue
forall a b. (a -> b) -> a -> b
$ BinOp -> PrimValue -> PrimValue -> Maybe PrimValue
doBinOp BinOp
op PrimValue
x' PrimValue
y'
evalPrimExp v -> m PrimValue
f (CmpOpExp CmpOp
op PrimExp v
x PrimExp v
y) = do
  PrimValue
x' <- (v -> m PrimValue) -> PrimExp v -> m PrimValue
forall v (m :: * -> *).
(Pretty v, MonadFail m) =>
(v -> m PrimValue) -> PrimExp v -> m PrimValue
evalPrimExp v -> m PrimValue
f PrimExp v
x
  PrimValue
y' <- (v -> m PrimValue) -> PrimExp v -> m PrimValue
forall v (m :: * -> *).
(Pretty v, MonadFail m) =>
(v -> m PrimValue) -> PrimExp v -> m PrimValue
evalPrimExp v -> m PrimValue
f PrimExp v
y
  m PrimValue -> (Bool -> m PrimValue) -> Maybe Bool -> m PrimValue
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (CmpOp -> (PrimExp v, PrimExp v) -> m PrimValue
forall a b (m :: * -> *) c.
(Pretty a, Pretty b, MonadFail m) =>
a -> b -> m c
evalBad CmpOp
op (PrimExp v
x,PrimExp v
y)) (PrimValue -> m PrimValue
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimValue -> m PrimValue)
-> (Bool -> PrimValue) -> Bool -> m PrimValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> PrimValue
BoolValue) (Maybe Bool -> m PrimValue) -> Maybe Bool -> m PrimValue
forall a b. (a -> b) -> a -> b
$ CmpOp -> PrimValue -> PrimValue -> Maybe Bool
doCmpOp CmpOp
op PrimValue
x' PrimValue
y'
evalPrimExp v -> m PrimValue
f (UnOpExp UnOp
op PrimExp v
x) = do
  PrimValue
x' <- (v -> m PrimValue) -> PrimExp v -> m PrimValue
forall v (m :: * -> *).
(Pretty v, MonadFail m) =>
(v -> m PrimValue) -> PrimExp v -> m PrimValue
evalPrimExp v -> m PrimValue
f PrimExp v
x
  m PrimValue
-> (PrimValue -> m PrimValue) -> Maybe PrimValue -> m PrimValue
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (UnOp -> PrimExp v -> m PrimValue
forall a b (m :: * -> *) c.
(Pretty a, Pretty b, MonadFail m) =>
a -> b -> m c
evalBad UnOp
op PrimExp v
x) PrimValue -> m PrimValue
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PrimValue -> m PrimValue) -> Maybe PrimValue -> m PrimValue
forall a b. (a -> b) -> a -> b
$ UnOp -> PrimValue -> Maybe PrimValue
doUnOp UnOp
op PrimValue
x'
evalPrimExp v -> m PrimValue
f (ConvOpExp ConvOp
op PrimExp v
x) = do
  PrimValue
x' <- (v -> m PrimValue) -> PrimExp v -> m PrimValue
forall v (m :: * -> *).
(Pretty v, MonadFail m) =>
(v -> m PrimValue) -> PrimExp v -> m PrimValue
evalPrimExp v -> m PrimValue
f PrimExp v
x
  m PrimValue
-> (PrimValue -> m PrimValue) -> Maybe PrimValue -> m PrimValue
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ConvOp -> PrimExp v -> m PrimValue
forall a b (m :: * -> *) c.
(Pretty a, Pretty b, MonadFail m) =>
a -> b -> m c
evalBad ConvOp
op PrimExp v
x) PrimValue -> m PrimValue
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PrimValue -> m PrimValue) -> Maybe PrimValue -> m PrimValue
forall a b. (a -> b) -> a -> b
$ ConvOp -> PrimValue -> Maybe PrimValue
doConvOp ConvOp
op PrimValue
x'
evalPrimExp v -> m PrimValue
f (FunExp String
h [PrimExp v]
args PrimType
_) = do
  [PrimValue]
args' <- (PrimExp v -> m PrimValue) -> [PrimExp v] -> m [PrimValue]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((v -> m PrimValue) -> PrimExp v -> m PrimValue
forall v (m :: * -> *).
(Pretty v, MonadFail m) =>
(v -> m PrimValue) -> PrimExp v -> m PrimValue
evalPrimExp v -> m PrimValue
f) [PrimExp v]
args
  m PrimValue
-> (PrimValue -> m PrimValue) -> Maybe PrimValue -> m PrimValue
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> [PrimExp v] -> m PrimValue
forall a b (m :: * -> *) c.
(Pretty a, Pretty b, MonadFail m) =>
a -> b -> m c
evalBad String
h [PrimExp v]
args) PrimValue -> m PrimValue
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PrimValue -> m PrimValue) -> Maybe PrimValue -> m PrimValue
forall a b. (a -> b) -> a -> b
$ do ([PrimType]
_, PrimType
_, [PrimValue] -> Maybe PrimValue
fun) <- String
-> Map
     String ([PrimType], PrimType, [PrimValue] -> Maybe PrimValue)
-> Maybe ([PrimType], PrimType, [PrimValue] -> Maybe PrimValue)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
h Map String ([PrimType], PrimType, [PrimValue] -> Maybe PrimValue)
primFuns
                                     [PrimValue] -> Maybe PrimValue
fun [PrimValue]
args'

evalBad :: (Pretty a, Pretty b, MonadFail m) => a -> b -> m c
evalBad :: a -> b -> m c
evalBad a
op b
arg = String -> m c
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m c) -> String -> m c
forall a b. (a -> b) -> a -> b
$ String
"evalPrimExp: Type error when applying " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                 a -> String
forall a. Pretty a => a -> String
pretty a
op String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ b -> String
forall a. Pretty a => a -> String
pretty b
arg

-- | The type of values returned by a 'PrimExp'.  This function
-- returning does not imply that the 'PrimExp' is type-correct.
primExpType :: PrimExp v -> PrimType
primExpType :: PrimExp v -> PrimType
primExpType (LeafExp v
_ PrimType
t)     = PrimType
t
primExpType (ValueExp PrimValue
v)      = PrimValue -> PrimType
primValueType PrimValue
v
primExpType (BinOpExp BinOp
op PrimExp v
_ PrimExp v
_) = BinOp -> PrimType
binOpType BinOp
op
primExpType CmpOpExp{}        = PrimType
Bool
primExpType (UnOpExp UnOp
op PrimExp v
_)    = UnOp -> PrimType
unOpType UnOp
op
primExpType (ConvOpExp ConvOp
op PrimExp v
_)  = (PrimType, PrimType) -> PrimType
forall a b. (a, b) -> b
snd ((PrimType, PrimType) -> PrimType)
-> (PrimType, PrimType) -> PrimType
forall a b. (a -> b) -> a -> b
$ ConvOp -> (PrimType, PrimType)
convOpType ConvOp
op
primExpType (FunExp String
_ [PrimExp v]
_ PrimType
t)    = PrimType
t

-- | Is the expression a constant zero of some sort?
zeroIshExp :: PrimExp v -> Bool
zeroIshExp :: PrimExp v -> Bool
zeroIshExp (ValueExp PrimValue
v) = PrimValue -> Bool
zeroIsh PrimValue
v
zeroIshExp PrimExp v
_            = Bool
False

-- | Is the expression a constant one of some sort?
oneIshExp :: PrimExp v -> Bool
oneIshExp :: PrimExp v -> Bool
oneIshExp (ValueExp PrimValue
v) = PrimValue -> Bool
oneIsh PrimValue
v
oneIshExp PrimExp v
_            = Bool
False

-- | If the given 'PrimExp' is a constant of the wrong integer type,
-- coerce it to the given integer type.  This is a workaround for an
-- issue in the 'Num' instance.
coerceIntPrimExp :: IntType -> PrimExp v -> PrimExp v
coerceIntPrimExp :: IntType -> PrimExp v -> PrimExp v
coerceIntPrimExp IntType
t (ValueExp (IntValue IntValue
v)) = PrimValue -> PrimExp v
forall v. PrimValue -> PrimExp v
ValueExp (PrimValue -> PrimExp v) -> PrimValue -> PrimExp v
forall a b. (a -> b) -> a -> b
$ IntValue -> PrimValue
IntValue (IntValue -> PrimValue) -> IntValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ IntValue -> IntType -> IntValue
doSExt IntValue
v IntType
t
coerceIntPrimExp IntType
_ PrimExp v
e                       = PrimExp v
e

primExpIntType :: PrimExp v -> IntType
primExpIntType :: PrimExp v -> IntType
primExpIntType PrimExp v
e = case PrimExp v -> PrimType
forall v. PrimExp v -> PrimType
primExpType PrimExp v
e of IntType IntType
t -> IntType
t
                                         PrimType
_         -> IntType
Int64

-- | Boolean-valued PrimExps.
true, false :: PrimExp v
true :: PrimExp v
true = PrimValue -> PrimExp v
forall v. PrimValue -> PrimExp v
ValueExp (PrimValue -> PrimExp v) -> PrimValue -> PrimExp v
forall a b. (a -> b) -> a -> b
$ Bool -> PrimValue
BoolValue Bool
True
false :: PrimExp v
false = PrimValue -> PrimExp v
forall v. PrimValue -> PrimExp v
ValueExp (PrimValue -> PrimExp v) -> PrimValue -> PrimExp v
forall a b. (a -> b) -> a -> b
$ Bool -> PrimValue
BoolValue Bool
False

-- Prettyprinting instances

instance Pretty v => Pretty (PrimExp v) where
  ppr :: PrimExp v -> Doc
ppr (LeafExp v
v PrimType
_)     = v -> Doc
forall a. Pretty a => a -> Doc
ppr v
v
  ppr (ValueExp PrimValue
v)      = PrimValue -> Doc
forall a. Pretty a => a -> Doc
ppr PrimValue
v
  ppr (BinOpExp BinOp
op PrimExp v
x PrimExp v
y) = BinOp -> Doc
forall a. Pretty a => a -> Doc
ppr BinOp
op Doc -> Doc -> Doc
<+> Doc -> Doc
parens (PrimExp v -> Doc
forall a. Pretty a => a -> Doc
ppr PrimExp v
x) Doc -> Doc -> Doc
<+> Doc -> Doc
parens (PrimExp v -> Doc
forall a. Pretty a => a -> Doc
ppr PrimExp v
y)
  ppr (CmpOpExp CmpOp
op PrimExp v
x PrimExp v
y) = CmpOp -> Doc
forall a. Pretty a => a -> Doc
ppr CmpOp
op Doc -> Doc -> Doc
<+> Doc -> Doc
parens (PrimExp v -> Doc
forall a. Pretty a => a -> Doc
ppr PrimExp v
x) Doc -> Doc -> Doc
<+> Doc -> Doc
parens (PrimExp v -> Doc
forall a. Pretty a => a -> Doc
ppr PrimExp v
y)
  ppr (ConvOpExp ConvOp
op PrimExp v
x)  = ConvOp -> Doc
forall a. Pretty a => a -> Doc
ppr ConvOp
op Doc -> Doc -> Doc
<+> Doc -> Doc
parens (PrimExp v -> Doc
forall a. Pretty a => a -> Doc
ppr PrimExp v
x)
  ppr (UnOpExp UnOp
op PrimExp v
x)    = UnOp -> Doc
forall a. Pretty a => a -> Doc
ppr UnOp
op Doc -> Doc -> Doc
<+> Doc -> Doc
parens (PrimExp v -> Doc
forall a. Pretty a => a -> Doc
ppr PrimExp v
x)
  ppr (FunExp String
h [PrimExp v]
args PrimType
_) = String -> Doc
text String
h Doc -> Doc -> Doc
<+> Doc -> Doc
parens ([Doc] -> Doc
commasep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (PrimExp v -> Doc) -> [PrimExp v] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map PrimExp v -> Doc
forall a. Pretty a => a -> Doc
ppr [PrimExp v]
args)

-- | Produce a mapping from the leaves of the 'PrimExp' to their
-- designated types.
leafExpTypes :: Ord a => PrimExp a -> S.Set (a, PrimType)
leafExpTypes :: PrimExp a -> Set (a, PrimType)
leafExpTypes (LeafExp a
x PrimType
ptp) = (a, PrimType) -> Set (a, PrimType)
forall a. a -> Set a
S.singleton (a
x, PrimType
ptp)
leafExpTypes (ValueExp PrimValue
_) = Set (a, PrimType)
forall a. Set a
S.empty
leafExpTypes (UnOpExp UnOp
_ PrimExp a
e) = PrimExp a -> Set (a, PrimType)
forall a. Ord a => PrimExp a -> Set (a, PrimType)
leafExpTypes PrimExp a
e
leafExpTypes (ConvOpExp ConvOp
_ PrimExp a
e) = PrimExp a -> Set (a, PrimType)
forall a. Ord a => PrimExp a -> Set (a, PrimType)
leafExpTypes PrimExp a
e
leafExpTypes (BinOpExp BinOp
_ PrimExp a
e1 PrimExp a
e2) =
  Set (a, PrimType) -> Set (a, PrimType) -> Set (a, PrimType)
forall a. Ord a => Set a -> Set a -> Set a
S.union (PrimExp a -> Set (a, PrimType)
forall a. Ord a => PrimExp a -> Set (a, PrimType)
leafExpTypes PrimExp a
e1) (PrimExp a -> Set (a, PrimType)
forall a. Ord a => PrimExp a -> Set (a, PrimType)
leafExpTypes PrimExp a
e2)
leafExpTypes (CmpOpExp CmpOp
_ PrimExp a
e1 PrimExp a
e2) =
  Set (a, PrimType) -> Set (a, PrimType) -> Set (a, PrimType)
forall a. Ord a => Set a -> Set a -> Set a
S.union (PrimExp a -> Set (a, PrimType)
forall a. Ord a => PrimExp a -> Set (a, PrimType)
leafExpTypes PrimExp a
e1) (PrimExp a -> Set (a, PrimType)
forall a. Ord a => PrimExp a -> Set (a, PrimType)
leafExpTypes PrimExp a
e2)
leafExpTypes (FunExp String
_ [PrimExp a]
pes PrimType
_) =
  [Set (a, PrimType)] -> Set (a, PrimType)
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set (a, PrimType)] -> Set (a, PrimType))
-> [Set (a, PrimType)] -> Set (a, PrimType)
forall a b. (a -> b) -> a -> b
$ (PrimExp a -> Set (a, PrimType))
-> [PrimExp a] -> [Set (a, PrimType)]
forall a b. (a -> b) -> [a] -> [b]
map PrimExp a -> Set (a, PrimType)
forall a. Ord a => PrimExp a -> Set (a, PrimType)
leafExpTypes [PrimExp a]
pes