{-# LANGUAGE RelaxedPolyRec #-}
module Language.C.Analysis.ConstEval where

import Control.Monad
import Data.Bits
import Data.List (foldl')
import Data.Maybe
import qualified Data.Map as Map
import Language.C.Syntax.AST
import Language.C.Syntax.Constants
import {-# SOURCE #-} Language.C.Analysis.AstAnalysis (tExpr, ExprSide(..))
import Language.C.Analysis.Debug ()
import Language.C.Analysis.DeclAnalysis
import Language.C.Analysis.DefTable
import Language.C.Data
import Language.C.Pretty
import Language.C.Analysis.SemRep
import Language.C.Analysis.TravMonad
import Language.C.Analysis.TypeUtils
import Text.PrettyPrint.HughesPJ

data MachineDesc =
  MachineDesc
  { MachineDesc -> IntType -> Integer
iSize        :: IntType -> Integer
  , MachineDesc -> FloatType -> Integer
fSize        :: FloatType -> Integer
  , MachineDesc -> BuiltinType -> Integer
builtinSize  :: BuiltinType -> Integer
  , MachineDesc -> Integer
ptrSize      :: Integer
  , MachineDesc -> Integer
voidSize     :: Integer
  , MachineDesc -> IntType -> Integer
iAlign       :: IntType -> Integer
  , MachineDesc -> FloatType -> Integer
fAlign       :: FloatType -> Integer
  , MachineDesc -> BuiltinType -> Integer
builtinAlign :: BuiltinType -> Integer
  , MachineDesc -> Integer
ptrAlign     :: Integer
  , MachineDesc -> Integer
voidAlign    :: Integer
  }

intExpr :: (Pos n, MonadName m) => n -> Integer -> m CExpr
intExpr :: n -> Integer -> m CExpr
intExpr n :: n
n i :: Integer
i =
  m Name
forall (m :: * -> *). MonadName m => m Name
genName m Name -> (Name -> m CExpr) -> m CExpr
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \name :: Name
name ->
    CExpr -> m CExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CExpr -> m CExpr) -> CExpr -> m CExpr
forall a b. (a -> b) -> a -> b
$ CConstant NodeInfo -> CExpr
forall a. CConstant a -> CExpression a
CConst (CConstant NodeInfo -> CExpr) -> CConstant NodeInfo -> CExpr
forall a b. (a -> b) -> a -> b
$ CInteger -> NodeInfo -> CConstant NodeInfo
forall a. CInteger -> a -> CConstant a
CIntConst (Integer -> CInteger
cInteger Integer
i) (Position -> Name -> NodeInfo
mkNodeInfo (n -> Position
forall a. Pos a => a -> Position
posOf n
n) Name
name)

sizeofType :: (MonadTrav m, CNode n) => MachineDesc -> n -> Type -> m Integer
sizeofType :: MachineDesc -> n -> Type -> m Integer
sizeofType md :: MachineDesc
md _ (DirectType TyVoid _ _) = Integer -> m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> m Integer) -> Integer -> m Integer
forall a b. (a -> b) -> a -> b
$ MachineDesc -> Integer
voidSize MachineDesc
md
sizeofType md :: MachineDesc
md _ (DirectType (TyIntegral it :: IntType
it) _ _) = Integer -> m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> m Integer) -> Integer -> m Integer
forall a b. (a -> b) -> a -> b
$ MachineDesc -> IntType -> Integer
iSize MachineDesc
md IntType
it
sizeofType md :: MachineDesc
md _ (DirectType (TyFloating ft :: FloatType
ft) _ _) = Integer -> m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> m Integer) -> Integer -> m Integer
forall a b. (a -> b) -> a -> b
$ MachineDesc -> FloatType -> Integer
fSize MachineDesc
md FloatType
ft
sizeofType md :: MachineDesc
md _ (DirectType (TyComplex ft :: FloatType
ft) _ _) = Integer -> m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> m Integer) -> Integer -> m Integer
forall a b. (a -> b) -> a -> b
$ 2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* MachineDesc -> FloatType -> Integer
fSize MachineDesc
md FloatType
ft
sizeofType md :: MachineDesc
md _ (DirectType (TyComp ctr :: CompTypeRef
ctr) _ _) = (Integer, Integer) -> Integer
forall a b. (a, b) -> a
fst ((Integer, Integer) -> Integer)
-> m (Integer, Integer) -> m Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MachineDesc -> CompTypeRef -> m (Integer, Integer)
forall (m :: * -> *).
MonadTrav m =>
MachineDesc -> CompTypeRef -> m (Integer, Integer)
compSizeAndAlign MachineDesc
md CompTypeRef
ctr
sizeofType md :: MachineDesc
md _ (DirectType (TyEnum _) _ _) = Integer -> m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> m Integer) -> Integer -> m Integer
forall a b. (a -> b) -> a -> b
$ MachineDesc -> IntType -> Integer
iSize MachineDesc
md IntType
TyInt
sizeofType md :: MachineDesc
md _ (DirectType (TyBuiltin b :: BuiltinType
b) _ _) = Integer -> m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> m Integer) -> Integer -> m Integer
forall a b. (a -> b) -> a -> b
$ MachineDesc -> BuiltinType -> Integer
builtinSize MachineDesc
md BuiltinType
b
sizeofType md :: MachineDesc
md _ (PtrType _ _ _)  = Integer -> m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> m Integer) -> Integer -> m Integer
forall a b. (a -> b) -> a -> b
$ MachineDesc -> Integer
ptrSize MachineDesc
md
sizeofType md :: MachineDesc
md _ (ArrayType _ (UnknownArraySize _) _ _) = Integer -> m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> m Integer) -> Integer -> m Integer
forall a b. (a -> b) -> a -> b
$ MachineDesc -> Integer
ptrSize MachineDesc
md
sizeofType md :: MachineDesc
md n :: n
n (ArrayType bt :: Type
bt (ArraySize _ sz :: CExpr
sz) _ _) =
  do CExpr
sz' <- MachineDesc -> Map Ident CExpr -> CExpr -> m CExpr
forall (m :: * -> *).
MonadTrav m =>
MachineDesc -> Map Ident CExpr -> CExpr -> m CExpr
constEval MachineDesc
md Map Ident CExpr
forall k a. Map k a
Map.empty CExpr
sz
     case CExpr
sz' of
       CConst (CIntConst i :: CInteger
i _) ->
         do Integer
s <- MachineDesc -> n -> Type -> m Integer
forall (m :: * -> *) n.
(MonadTrav m, CNode n) =>
MachineDesc -> n -> Type -> m Integer
sizeofType MachineDesc
md n
n Type
bt
            Integer -> m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> m Integer) -> Integer -> m Integer
forall a b. (a -> b) -> a -> b
$ CInteger -> Integer
getCInteger CInteger
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
s
       _ -> Integer -> m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> m Integer) -> Integer -> m Integer
forall a b. (a -> b) -> a -> b
$ MachineDesc -> Integer
ptrSize MachineDesc
md
            {-
            astError (nodeInfo sz) $
            "array size is not a constant: " ++ (render . pretty) sz
            -}
sizeofType md :: MachineDesc
md n :: n
n (TypeDefType (TypeDefRef _ t :: Type
t _) _ _) = MachineDesc -> n -> Type -> m Integer
forall (m :: * -> *) n.
(MonadTrav m, CNode n) =>
MachineDesc -> n -> Type -> m Integer
sizeofType MachineDesc
md n
n Type
t
sizeofType md :: MachineDesc
md _ (FunctionType _ _) = Integer -> m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> m Integer) -> Integer -> m Integer
forall a b. (a -> b) -> a -> b
$ MachineDesc -> Integer
ptrSize MachineDesc
md

alignofType :: (MonadTrav m, CNode n) => MachineDesc -> n -> Type -> m Integer
alignofType :: MachineDesc -> n -> Type -> m Integer
alignofType md :: MachineDesc
md _ (DirectType TyVoid _ _) = Integer -> m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> m Integer) -> Integer -> m Integer
forall a b. (a -> b) -> a -> b
$ MachineDesc -> Integer
voidAlign MachineDesc
md
alignofType md :: MachineDesc
md _ (DirectType (TyIntegral it :: IntType
it) _ _) = Integer -> m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> m Integer) -> Integer -> m Integer
forall a b. (a -> b) -> a -> b
$ MachineDesc -> IntType -> Integer
iAlign MachineDesc
md IntType
it
alignofType md :: MachineDesc
md _ (DirectType (TyFloating ft :: FloatType
ft) _ _) = Integer -> m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> m Integer) -> Integer -> m Integer
forall a b. (a -> b) -> a -> b
$ MachineDesc -> FloatType -> Integer
fAlign MachineDesc
md FloatType
ft
alignofType md :: MachineDesc
md _ (DirectType (TyComplex ft :: FloatType
ft) _ _) = Integer -> m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> m Integer) -> Integer -> m Integer
forall a b. (a -> b) -> a -> b
$ MachineDesc -> FloatType -> Integer
fAlign MachineDesc
md FloatType
ft
alignofType md :: MachineDesc
md _ (DirectType (TyComp ctr :: CompTypeRef
ctr) _ _) = (Integer, Integer) -> Integer
forall a b. (a, b) -> b
snd ((Integer, Integer) -> Integer)
-> m (Integer, Integer) -> m Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MachineDesc -> CompTypeRef -> m (Integer, Integer)
forall (m :: * -> *).
MonadTrav m =>
MachineDesc -> CompTypeRef -> m (Integer, Integer)
compSizeAndAlign MachineDesc
md CompTypeRef
ctr
alignofType md :: MachineDesc
md _ (DirectType (TyEnum _) _ _) = Integer -> m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> m Integer) -> Integer -> m Integer
forall a b. (a -> b) -> a -> b
$ MachineDesc -> IntType -> Integer
iAlign MachineDesc
md IntType
TyInt
alignofType md :: MachineDesc
md _ (DirectType (TyBuiltin b :: BuiltinType
b) _ _) = Integer -> m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> m Integer) -> Integer -> m Integer
forall a b. (a -> b) -> a -> b
$ MachineDesc -> BuiltinType -> Integer
builtinAlign MachineDesc
md BuiltinType
b
alignofType md :: MachineDesc
md _ (PtrType _ _ _)  = Integer -> m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> m Integer) -> Integer -> m Integer
forall a b. (a -> b) -> a -> b
$ MachineDesc -> Integer
ptrAlign MachineDesc
md
alignofType md :: MachineDesc
md _ (ArrayType _ (UnknownArraySize _) _ _) = Integer -> m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> m Integer) -> Integer -> m Integer
forall a b. (a -> b) -> a -> b
$ MachineDesc -> Integer
ptrAlign MachineDesc
md
alignofType md :: MachineDesc
md n :: n
n (ArrayType bt :: Type
bt (ArraySize _ _) _ _) = MachineDesc -> n -> Type -> m Integer
forall (m :: * -> *) n.
(MonadTrav m, CNode n) =>
MachineDesc -> n -> Type -> m Integer
alignofType MachineDesc
md n
n Type
bt
alignofType md :: MachineDesc
md n :: n
n (TypeDefType (TypeDefRef _ t :: Type
t _) _ _) = MachineDesc -> n -> Type -> m Integer
forall (m :: * -> *) n.
(MonadTrav m, CNode n) =>
MachineDesc -> n -> Type -> m Integer
alignofType MachineDesc
md n
n Type
t
alignofType _ n :: n
n t :: Type
t = NodeInfo -> String -> m Integer
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError (n -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo n
n) (String -> m Integer) -> String -> m Integer
forall a b. (a -> b) -> a -> b
$
                 "can't find alignment of type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Doc -> String
render (Doc -> String) -> (Type -> Doc) -> Type -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Doc
forall p. Pretty p => p -> Doc
pretty) Type
t

compSizeAndAlign
  :: MonadTrav m =>
     MachineDesc ->
     CompTypeRef ->
     m (Integer, Integer)
     -- ^ (size, alignment)
compSizeAndAlign :: MachineDesc -> CompTypeRef -> m (Integer, Integer)
compSizeAndAlign md :: MachineDesc
md ctr :: CompTypeRef
ctr =
  do DefTable
dt <- m DefTable
forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable
     case SUERef -> DefTable -> Maybe TagEntry
lookupTag (CompTypeRef -> SUERef
forall a. HasSUERef a => a -> SUERef
sueRef CompTypeRef
ctr) DefTable
dt of
       Just (Left _)   -> NodeInfo -> String -> m (Integer, Integer)
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError (CompTypeRef -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo CompTypeRef
ctr)
                          "composite declared but not defined"
       Just (Right (CompDef (CompType _ tag :: CompTyKind
tag ms :: [MemberDecl]
ms _ ni :: NodeInfo
ni))) ->
         do let ts :: [Type]
ts = (MemberDecl -> Type) -> [MemberDecl] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map MemberDecl -> Type
forall n. Declaration n => n -> Type
declType [MemberDecl]
ms
            [Integer]
sizes <- (Type -> m Integer) -> [Type] -> m [Integer]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MachineDesc -> NodeInfo -> Type -> m Integer
forall (m :: * -> *) n.
(MonadTrav m, CNode n) =>
MachineDesc -> n -> Type -> m Integer
sizeofType MachineDesc
md NodeInfo
ni) [Type]
ts
            [Integer]
aligns <- (Type -> m Integer) -> [Type] -> m [Integer]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MachineDesc -> NodeInfo -> Type -> m Integer
forall (m :: * -> *) n.
(MonadTrav m, CNode n) =>
MachineDesc -> n -> Type -> m Integer
alignofType MachineDesc
md NodeInfo
ni) [Type]
ts
            let alignment :: Integer
alignment = [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (1 Integer -> [Integer] -> [Integer]
forall a. a -> [a] -> [a]
: [Integer]
aligns)
                size :: Integer
size = case CompTyKind
tag of
                  UnionTag -> Integer -> Integer -> Integer
roundToAlignment Integer
alignment ([Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (0 Integer -> [Integer] -> [Integer]
forall a. a -> [a] -> [a]
: [Integer]
sizes))
                  StructTag ->
                    let sizeAndNextAlignment :: [(Integer, Integer)]
sizeAndNextAlignment =
                          [Integer] -> [Integer] -> [(Integer, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer]
sizes ([Integer] -> [Integer]
forall a. [a] -> [a]
tail [Integer]
aligns [Integer] -> [Integer] -> [Integer]
forall a. [a] -> [a] -> [a]
++ [Integer
alignment])
                        offsets :: Integer
offsets = (Integer -> (Integer, Integer) -> Integer)
-> Integer -> [(Integer, Integer)] -> Integer
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
                          (\offset :: Integer
offset (memberSize :: Integer
memberSize, nextAlign :: Integer
nextAlign)
                           -> Integer -> Integer -> Integer
roundToAlignment Integer
nextAlign (Integer
offset Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
memberSize))
                          0
                          [(Integer, Integer)]
sizeAndNextAlignment
                    in Integer
offsets
            (Integer, Integer) -> m (Integer, Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
size, Integer
alignment)
       Just (Right (EnumDef _)) -> (Integer, Integer) -> m (Integer, Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Integer, Integer) -> m (Integer, Integer))
-> (Integer, Integer) -> m (Integer, Integer)
forall a b. (a -> b) -> a -> b
$ (MachineDesc -> IntType -> Integer
iSize MachineDesc
md IntType
TyInt, MachineDesc -> IntType -> Integer
iAlign MachineDesc
md IntType
TyInt)
       Nothing         -> NodeInfo -> String -> m (Integer, Integer)
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError (CompTypeRef -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo CompTypeRef
ctr) "unknown composite"

-- | Find the next multiple of an alignment
roundToAlignment
  :: Integer
  -- ^ The alignment
  -> Integer
  -- ^ The value to align
  -> Integer
  -- ^ The next multiple of alignment
roundToAlignment :: Integer -> Integer -> Integer
roundToAlignment alignment :: Integer
alignment value :: Integer
value =
  Integer
alignment Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* ((Integer
value Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ (Integer
alignment Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- 1)) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`quot` Integer
alignment)

{- Expression evaluation -}

-- Use the withWordBytes function to wrap the results around to the
-- correct word size
intOp :: CBinaryOp -> Integer -> Integer -> Integer
intOp :: CBinaryOp -> Integer -> Integer -> Integer
intOp CAddOp i1 :: Integer
i1 i2 :: Integer
i2 = Integer
i1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
i2
intOp CSubOp i1 :: Integer
i1 i2 :: Integer
i2 = Integer
i1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
i2
intOp CMulOp i1 :: Integer
i1 i2 :: Integer
i2 = Integer
i1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
i2
intOp CDivOp i1 :: Integer
i1 i2 :: Integer
i2 = Integer
i1 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
i2
intOp CRmdOp i1 :: Integer
i1 i2 :: Integer
i2 = Integer
i1 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
i2
intOp CShlOp i1 :: Integer
i1 i2 :: Integer
i2 = Integer
i1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
i2
intOp CShrOp i1 :: Integer
i1 i2 :: Integer
i2 = Integer
i1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
i2
intOp CLeOp  i1 :: Integer
i1 i2 :: Integer
i2 = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> Int) -> Bool -> Int
forall a b. (a -> b) -> a -> b
$ Integer
i1 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
i2
intOp CGrOp  i1 :: Integer
i1 i2 :: Integer
i2 = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> Int) -> Bool -> Int
forall a b. (a -> b) -> a -> b
$ Integer
i1 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
i2
intOp CLeqOp i1 :: Integer
i1 i2 :: Integer
i2 = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> Int) -> Bool -> Int
forall a b. (a -> b) -> a -> b
$ Integer
i1 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
i2
intOp CGeqOp i1 :: Integer
i1 i2 :: Integer
i2 = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> Int) -> Bool -> Int
forall a b. (a -> b) -> a -> b
$ Integer
i1 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
i2
intOp CEqOp  i1 :: Integer
i1 i2 :: Integer
i2 = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> Int) -> Bool -> Int
forall a b. (a -> b) -> a -> b
$ Integer
i1 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
i2
intOp CNeqOp i1 :: Integer
i1 i2 :: Integer
i2 = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> Int) -> Bool -> Int
forall a b. (a -> b) -> a -> b
$ Integer
i1 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
i2
intOp CAndOp i1 :: Integer
i1 i2 :: Integer
i2 = Integer
i1 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.&. Integer
i2
intOp CXorOp i1 :: Integer
i1 i2 :: Integer
i2 = Integer
i1 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
`xor` Integer
i2
intOp COrOp  i1 :: Integer
i1 i2 :: Integer
i2 = Integer
i1 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. Integer
i2
intOp CLndOp i1 :: Integer
i1 i2 :: Integer
i2 = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> Int) -> Bool -> Int
forall a b. (a -> b) -> a -> b
$ (Integer
i1 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= 0) Bool -> Bool -> Bool
&& (Integer
i2 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= 0)
intOp CLorOp i1 :: Integer
i1 i2 :: Integer
i2 = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> Int) -> Bool -> Int
forall a b. (a -> b) -> a -> b
$ (Integer
i1 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= 0) Bool -> Bool -> Bool
|| (Integer
i2 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= 0)

-- Use the withWordBytes function to wrap the results around to the
-- correct word size
intUnOp :: CUnaryOp -> Integer -> Maybe Integer
intUnOp :: CUnaryOp -> Integer -> Maybe Integer
intUnOp CPlusOp i :: Integer
i = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
i
intUnOp CMinOp  i :: Integer
i = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ -Integer
i
intUnOp CCompOp i :: Integer
i = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall a. Bits a => a -> a
complement Integer
i
intUnOp CNegOp  i :: Integer
i = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> Int) -> Bool -> Int
forall a b. (a -> b) -> a -> b
$ Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 0
intUnOp _       _ = Maybe Integer
forall a. Maybe a
Nothing

withWordBytes :: Int -> Integer -> Integer
withWordBytes :: Int -> Integer -> Integer
withWordBytes bytes :: Int
bytes n :: Integer
n = Integer
n Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`rem` (1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` (Int
bytes Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` 3))

boolValue :: CExpr -> Maybe Bool
boolValue :: CExpr -> Maybe Bool
boolValue (CConst (CIntConst i :: CInteger
i _))  = Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ CInteger -> Integer
getCInteger CInteger
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= 0
boolValue (CConst (CCharConst c :: CChar
c _)) = Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ CChar -> Integer
getCCharAsInt CChar
c Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= 0
boolValue (CConst (CStrConst _ _))  = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
boolValue _                         = Maybe Bool
forall a. Maybe a
Nothing

intValue :: CExpr -> Maybe Integer
intValue :: CExpr -> Maybe Integer
intValue (CConst (CIntConst i :: CInteger
i _))  = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ CInteger -> Integer
getCInteger CInteger
i
intValue (CConst (CCharConst c :: CChar
c _)) = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ CChar -> Integer
getCCharAsInt CChar
c
intValue _                         = Maybe Integer
forall a. Maybe a
Nothing

constEval :: (MonadTrav m) =>
             MachineDesc -> Map.Map Ident CExpr -> CExpr -> m CExpr
constEval :: MachineDesc -> Map Ident CExpr -> CExpr -> m CExpr
constEval md :: MachineDesc
md env :: Map Ident CExpr
env (CCond e1 :: CExpr
e1 me2 :: Maybe CExpr
me2 e3 :: CExpr
e3 ni :: NodeInfo
ni) =
  do CExpr
e1'  <- MachineDesc -> Map Ident CExpr -> CExpr -> m CExpr
forall (m :: * -> *).
MonadTrav m =>
MachineDesc -> Map Ident CExpr -> CExpr -> m CExpr
constEval MachineDesc
md Map Ident CExpr
env CExpr
e1
     Maybe CExpr
me2' <- m (Maybe CExpr)
-> (CExpr -> m (Maybe CExpr)) -> Maybe CExpr -> m (Maybe CExpr)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe CExpr -> m (Maybe CExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe CExpr
forall a. Maybe a
Nothing) (\e :: CExpr
e -> CExpr -> Maybe CExpr
forall a. a -> Maybe a
Just (CExpr -> Maybe CExpr) -> m CExpr -> m (Maybe CExpr)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` MachineDesc -> Map Ident CExpr -> CExpr -> m CExpr
forall (m :: * -> *).
MonadTrav m =>
MachineDesc -> Map Ident CExpr -> CExpr -> m CExpr
constEval MachineDesc
md Map Ident CExpr
env CExpr
e) Maybe CExpr
me2
     CExpr
e3'  <- MachineDesc -> Map Ident CExpr -> CExpr -> m CExpr
forall (m :: * -> *).
MonadTrav m =>
MachineDesc -> Map Ident CExpr -> CExpr -> m CExpr
constEval MachineDesc
md Map Ident CExpr
env CExpr
e3
     case CExpr -> Maybe Bool
boolValue CExpr
e1' of
       Just True  -> CExpr -> m CExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CExpr -> m CExpr) -> CExpr -> m CExpr
forall a b. (a -> b) -> a -> b
$ CExpr -> Maybe CExpr -> CExpr
forall a. a -> Maybe a -> a
fromMaybe CExpr
e1' Maybe CExpr
me2'
       Just False -> CExpr -> m CExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CExpr
e3'
       Nothing    -> CExpr -> m CExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CExpr -> m CExpr) -> CExpr -> m CExpr
forall a b. (a -> b) -> a -> b
$ CExpr -> Maybe CExpr -> CExpr -> NodeInfo -> CExpr
forall a.
CExpression a
-> Maybe (CExpression a) -> CExpression a -> a -> CExpression a
CCond CExpr
e1' Maybe CExpr
me2' CExpr
e3' NodeInfo
ni
constEval md :: MachineDesc
md env :: Map Ident CExpr
env e :: CExpr
e@(CBinary op :: CBinaryOp
op e1 :: CExpr
e1 e2 :: CExpr
e2 ni :: NodeInfo
ni) =
  do CExpr
e1' <- MachineDesc -> Map Ident CExpr -> CExpr -> m CExpr
forall (m :: * -> *).
MonadTrav m =>
MachineDesc -> Map Ident CExpr -> CExpr -> m CExpr
constEval MachineDesc
md Map Ident CExpr
env CExpr
e1
     CExpr
e2' <- MachineDesc -> Map Ident CExpr -> CExpr -> m CExpr
forall (m :: * -> *).
MonadTrav m =>
MachineDesc -> Map Ident CExpr -> CExpr -> m CExpr
constEval MachineDesc
md Map Ident CExpr
env CExpr
e2
     Type
t <- [StmtCtx] -> ExprSide -> CExpr -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr [] ExprSide
RValue CExpr
e
     Int
bytes <- Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> m Integer -> m Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` MachineDesc -> CExpr -> Type -> m Integer
forall (m :: * -> *) n.
(MonadTrav m, CNode n) =>
MachineDesc -> n -> Type -> m Integer
sizeofType MachineDesc
md CExpr
e Type
t
     case (CExpr -> Maybe Integer
intValue CExpr
e1', CExpr -> Maybe Integer
intValue CExpr
e2') of
       (Just i1 :: Integer
i1, Just i2 :: Integer
i2) -> NodeInfo -> Integer -> m CExpr
forall n (m :: * -> *).
(Pos n, MonadName m) =>
n -> Integer -> m CExpr
intExpr NodeInfo
ni (Int -> Integer -> Integer
withWordBytes Int
bytes (CBinaryOp -> Integer -> Integer -> Integer
intOp CBinaryOp
op Integer
i1 Integer
i2))
       (_, _)             -> CExpr -> m CExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CExpr -> m CExpr) -> CExpr -> m CExpr
forall a b. (a -> b) -> a -> b
$ CBinaryOp -> CExpr -> CExpr -> NodeInfo -> CExpr
forall a.
CBinaryOp -> CExpression a -> CExpression a -> a -> CExpression a
CBinary CBinaryOp
op CExpr
e1' CExpr
e2' NodeInfo
ni
constEval md :: MachineDesc
md env :: Map Ident CExpr
env (CUnary op :: CUnaryOp
op e :: CExpr
e ni :: NodeInfo
ni) =
  do CExpr
e' <- MachineDesc -> Map Ident CExpr -> CExpr -> m CExpr
forall (m :: * -> *).
MonadTrav m =>
MachineDesc -> Map Ident CExpr -> CExpr -> m CExpr
constEval MachineDesc
md Map Ident CExpr
env CExpr
e
     Type
t <- [StmtCtx] -> ExprSide -> CExpr -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr [] ExprSide
RValue CExpr
e
     Int
bytes <- Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> m Integer -> m Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` MachineDesc -> CExpr -> Type -> m Integer
forall (m :: * -> *) n.
(MonadTrav m, CNode n) =>
MachineDesc -> n -> Type -> m Integer
sizeofType MachineDesc
md CExpr
e Type
t
     case CExpr -> Maybe Integer
intValue CExpr
e' of
       Just i :: Integer
i  -> case CUnaryOp -> Integer -> Maybe Integer
intUnOp CUnaryOp
op Integer
i of
                    Just i' :: Integer
i' -> NodeInfo -> Integer -> m CExpr
forall n (m :: * -> *).
(Pos n, MonadName m) =>
n -> Integer -> m CExpr
intExpr NodeInfo
ni (Int -> Integer -> Integer
withWordBytes Int
bytes Integer
i')
                    Nothing -> NodeInfo -> String -> m CExpr
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
ni
                               "invalid unary operator applied to constant"
       Nothing -> CExpr -> m CExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CExpr -> m CExpr) -> CExpr -> m CExpr
forall a b. (a -> b) -> a -> b
$ CUnaryOp -> CExpr -> NodeInfo -> CExpr
forall a. CUnaryOp -> CExpression a -> a -> CExpression a
CUnary CUnaryOp
op CExpr
e' NodeInfo
ni
constEval md :: MachineDesc
md env :: Map Ident CExpr
env (CCast d :: CDeclaration NodeInfo
d e :: CExpr
e ni :: NodeInfo
ni) =
  do CExpr
e' <- MachineDesc -> Map Ident CExpr -> CExpr -> m CExpr
forall (m :: * -> *).
MonadTrav m =>
MachineDesc -> Map Ident CExpr -> CExpr -> m CExpr
constEval MachineDesc
md Map Ident CExpr
env CExpr
e
     Type
t <- CDeclaration NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
CDeclaration NodeInfo -> m Type
analyseTypeDecl CDeclaration NodeInfo
d
     Int
bytes <- Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> m Integer -> m Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` MachineDesc -> CDeclaration NodeInfo -> Type -> m Integer
forall (m :: * -> *) n.
(MonadTrav m, CNode n) =>
MachineDesc -> n -> Type -> m Integer
sizeofType MachineDesc
md CDeclaration NodeInfo
d Type
t
     case CExpr -> Maybe Integer
intValue CExpr
e' of
       Just i :: Integer
i -> NodeInfo -> Integer -> m CExpr
forall n (m :: * -> *).
(Pos n, MonadName m) =>
n -> Integer -> m CExpr
intExpr NodeInfo
ni (Int -> Integer -> Integer
withWordBytes Int
bytes Integer
i)
       Nothing -> CExpr -> m CExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CExpr -> m CExpr) -> CExpr -> m CExpr
forall a b. (a -> b) -> a -> b
$ CDeclaration NodeInfo -> CExpr -> NodeInfo -> CExpr
forall a. CDeclaration a -> CExpression a -> a -> CExpression a
CCast CDeclaration NodeInfo
d CExpr
e' NodeInfo
ni
constEval md :: MachineDesc
md _ (CSizeofExpr e :: CExpr
e ni :: NodeInfo
ni) =
  do Type
t <- [StmtCtx] -> ExprSide -> CExpr -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr [] ExprSide
RValue CExpr
e
     Integer
sz <- MachineDesc -> CExpr -> Type -> m Integer
forall (m :: * -> *) n.
(MonadTrav m, CNode n) =>
MachineDesc -> n -> Type -> m Integer
sizeofType MachineDesc
md CExpr
e Type
t
     NodeInfo -> Integer -> m CExpr
forall n (m :: * -> *).
(Pos n, MonadName m) =>
n -> Integer -> m CExpr
intExpr NodeInfo
ni Integer
sz
constEval md :: MachineDesc
md _ (CSizeofType d :: CDeclaration NodeInfo
d ni :: NodeInfo
ni) =
  do Type
t <- CDeclaration NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
CDeclaration NodeInfo -> m Type
analyseTypeDecl CDeclaration NodeInfo
d
     Integer
sz <- MachineDesc -> CDeclaration NodeInfo -> Type -> m Integer
forall (m :: * -> *) n.
(MonadTrav m, CNode n) =>
MachineDesc -> n -> Type -> m Integer
sizeofType MachineDesc
md CDeclaration NodeInfo
d Type
t
     NodeInfo -> Integer -> m CExpr
forall n (m :: * -> *).
(Pos n, MonadName m) =>
n -> Integer -> m CExpr
intExpr NodeInfo
ni Integer
sz
constEval md :: MachineDesc
md _ (CAlignofExpr e :: CExpr
e ni :: NodeInfo
ni) =
  do Type
t <- [StmtCtx] -> ExprSide -> CExpr -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr [] ExprSide
RValue CExpr
e
     Integer
sz <- MachineDesc -> CExpr -> Type -> m Integer
forall (m :: * -> *) n.
(MonadTrav m, CNode n) =>
MachineDesc -> n -> Type -> m Integer
alignofType MachineDesc
md CExpr
e Type
t
     NodeInfo -> Integer -> m CExpr
forall n (m :: * -> *).
(Pos n, MonadName m) =>
n -> Integer -> m CExpr
intExpr NodeInfo
ni Integer
sz
constEval md :: MachineDesc
md _ (CAlignofType d :: CDeclaration NodeInfo
d ni :: NodeInfo
ni) =
  do Type
t <- CDeclaration NodeInfo -> m Type
forall (m :: * -> *).
MonadTrav m =>
CDeclaration NodeInfo -> m Type
analyseTypeDecl CDeclaration NodeInfo
d
     Integer
sz <- MachineDesc -> CDeclaration NodeInfo -> Type -> m Integer
forall (m :: * -> *) n.
(MonadTrav m, CNode n) =>
MachineDesc -> n -> Type -> m Integer
alignofType MachineDesc
md CDeclaration NodeInfo
d Type
t
     NodeInfo -> Integer -> m CExpr
forall n (m :: * -> *).
(Pos n, MonadName m) =>
n -> Integer -> m CExpr
intExpr NodeInfo
ni Integer
sz
constEval _ env :: Map Ident CExpr
env e :: CExpr
e@(CVar i :: Ident
i _) | Ident -> Map Ident CExpr -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Ident
i Map Ident CExpr
env =
  CExpr -> m CExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CExpr -> m CExpr) -> CExpr -> m CExpr
forall a b. (a -> b) -> a -> b
$ CExpr -> Maybe CExpr -> CExpr
forall a. a -> Maybe a -> a
fromMaybe CExpr
e (Maybe CExpr -> CExpr) -> Maybe CExpr -> CExpr
forall a b. (a -> b) -> a -> b
$ Ident -> Map Ident CExpr -> Maybe CExpr
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ident
i Map Ident CExpr
env
constEval md :: MachineDesc
md env :: Map Ident CExpr
env e :: CExpr
e@(CVar i :: Ident
i _) =
  do Type
t <- [StmtCtx] -> ExprSide -> CExpr -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr [] ExprSide
RValue CExpr
e
     case Type -> Type
derefTypeDef Type
t of
       DirectType (TyEnum etr :: EnumTypeRef
etr) _ _ ->
         do DefTable
dt <- m DefTable
forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable
            case SUERef -> DefTable -> Maybe TagEntry
lookupTag (EnumTypeRef -> SUERef
forall a. HasSUERef a => a -> SUERef
sueRef EnumTypeRef
etr) DefTable
dt of
              Just (Right (EnumDef (EnumType _ es :: [Enumerator]
es _ _))) ->
                do Map Ident CExpr
env' <- (Map Ident CExpr -> Enumerator -> m (Map Ident CExpr))
-> Map Ident CExpr -> [Enumerator] -> m (Map Ident CExpr)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Map Ident CExpr -> Enumerator -> m (Map Ident CExpr)
forall (m :: * -> *).
MonadTrav m =>
Map Ident CExpr -> Enumerator -> m (Map Ident CExpr)
enumConst Map Ident CExpr
env [Enumerator]
es
                   CExpr -> m CExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CExpr -> m CExpr) -> CExpr -> m CExpr
forall a b. (a -> b) -> a -> b
$ CExpr -> Maybe CExpr -> CExpr
forall a. a -> Maybe a -> a
fromMaybe CExpr
e (Maybe CExpr -> CExpr) -> Maybe CExpr -> CExpr
forall a b. (a -> b) -> a -> b
$ Ident -> Map Ident CExpr -> Maybe CExpr
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ident
i Map Ident CExpr
env'
              _ -> CExpr -> m CExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CExpr
e
       _ -> CExpr -> m CExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CExpr
e
  where enumConst :: Map Ident CExpr -> Enumerator -> m (Map Ident CExpr)
enumConst env' :: Map Ident CExpr
env' (Enumerator n :: Ident
n e' :: CExpr
e' _ _) =
          do CExpr
c <- MachineDesc -> Map Ident CExpr -> CExpr -> m CExpr
forall (m :: * -> *).
MonadTrav m =>
MachineDesc -> Map Ident CExpr -> CExpr -> m CExpr
constEval MachineDesc
md Map Ident CExpr
env' CExpr
e'
             Map Ident CExpr -> m (Map Ident CExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Ident CExpr -> m (Map Ident CExpr))
-> Map Ident CExpr -> m (Map Ident CExpr)
forall a b. (a -> b) -> a -> b
$ Ident -> CExpr -> Map Ident CExpr -> Map Ident CExpr
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Ident
n CExpr
c Map Ident CExpr
env'
constEval _ _ e :: CExpr
e = CExpr -> m CExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CExpr
e