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

import Control.Monad
import Data.Bits
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
  { iSize        :: IntType -> Integer
  , fSize        :: FloatType -> Integer
  , builtinSize  :: BuiltinType -> Integer
  , ptrSize      :: Integer
  , voidSize     :: Integer
  , iAlign       :: IntType -> Integer
  , fAlign       :: FloatType -> Integer
  , builtinAlign :: BuiltinType -> Integer
  , ptrAlign     :: Integer
  , voidAlign    :: Integer
  }

intExpr :: (Pos n, MonadName m) => n -> Integer -> m CExpr
intExpr n i =
  genName >>= \name ->
    return $ CConst $ CIntConst (cInteger i) (mkNodeInfo (posOf n) name)

sizeofType :: (MonadTrav m, CNode n) => MachineDesc -> n -> Type -> m Integer
sizeofType md _ (DirectType TyVoid _ _) = return $ voidSize md
sizeofType md _ (DirectType (TyIntegral it) _ _) = return $ iSize md it
sizeofType md _ (DirectType (TyFloating ft) _ _) = return $ fSize md ft
sizeofType md _ (DirectType (TyComplex ft) _ _) = return $ 2 * fSize md ft
sizeofType md _ (DirectType (TyComp ctr) _ _) = compSize md ctr
sizeofType md _ (DirectType (TyEnum _) _ _) = return $ iSize md TyInt
sizeofType md _ (DirectType (TyBuiltin b) _ _) = return $ builtinSize md b
sizeofType md _ (PtrType _ _ _)  = return $ ptrSize md
sizeofType md n (ArrayType bt (UnknownArraySize _) _ _) = return $ ptrSize md
sizeofType md n (ArrayType bt (ArraySize _ sz) _ _) =
  do sz' <- constEval md Map.empty sz
     case sz' of
       CConst (CIntConst i _) ->
         do s <- sizeofType md n bt
            return $ getCInteger i * s
       _ -> return $ ptrSize md
            {-
            astError (nodeInfo sz) $
            "array size is not a constant: " ++ (render . pretty) sz
            -}
sizeofType md n (TypeDefType (TypeDefRef _ (Just t) _) _ _) = sizeofType md n t
sizeofType md _ (FunctionType _ _) = return $ ptrSize md
sizeofType _ n t = astError (nodeInfo n) $
                 "can't find size of type: " ++ (render . pretty) t

alignofType :: (MonadTrav m, CNode n) => MachineDesc -> n -> Type -> m Integer
alignofType md _ (DirectType TyVoid _ _) = return $ voidAlign md
alignofType md _ (DirectType (TyIntegral it) _ _) = return $ iAlign md it
alignofType md _ (DirectType (TyFloating ft) _ _) = return $ fAlign md ft
alignofType md _ (DirectType (TyComplex ft) _ _) = return $ fAlign md ft
alignofType md _ (DirectType (TyEnum _) _ _) = return $ iAlign md TyInt
alignofType md _ (DirectType (TyBuiltin b) _ _) = return $ builtinAlign md b
alignofType md _ (PtrType _ _ _)  = return $ ptrAlign md
alignofType md n (ArrayType bt (UnknownArraySize _) _ _) = return $ ptrAlign md
alignofType md n (ArrayType bt (ArraySize _ sz) _ _) = alignofType md n bt
alignofType md n (TypeDefType (TypeDefRef _ (Just t) _) _ _) = alignofType md n t
alignofType _ n t = astError (nodeInfo n) $
                 "can't find alignment of type: " ++ (render . pretty) t

compSize :: MonadTrav m => MachineDesc -> CompTypeRef -> m Integer
compSize md ctr =
  do dt <- getDefTable
     case lookupTag (sueRef ctr) dt of
       Just (Left _)   -> astError (nodeInfo ctr)
                          "composite declared but not defined"
       Just (Right (CompDef (CompType _ tag ms _ ni))) ->
         do let ts = map declType ms
            sizes <- mapM (sizeofType md ni) ts
            -- XXX: handle padding
            case tag of
              StructTag -> return $ sum sizes
              UnionTag  -> return $ maximum sizes
       Just (Right (EnumDef _)) -> return $ iSize md TyInt
       Nothing         -> astError (nodeInfo ctr) "unknown composite"


{- Expression evaluation -}

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

-- Use the withWordBytes function to wrap the results around to the
-- correct word size
intUnOp :: CUnaryOp -> Integer -> Maybe Integer
intUnOp CPlusOp i = Just i
intUnOp CMinOp  i = Just $ -i
intUnOp CCompOp i = Just $ complement i
intUnOp CNegOp  i = Just $ toInteger $ fromEnum $ i == 0
intUnOp _       _ = Nothing

withWordBytes :: Int -> Integer -> Integer
withWordBytes bytes n = n `rem` (1 `shiftL` (bytes `shiftL` 3))

boolValue :: CExpr -> Maybe Bool
boolValue (CConst (CIntConst i _))  = Just $ getCInteger i /= 0
boolValue (CConst (CCharConst c _)) = Just $ getCCharAsInt c /= 0
boolValue (CConst (CStrConst _ _))  = Just True
boolValue _                         = Nothing

intValue :: CExpr -> Maybe Integer
intValue (CConst (CIntConst i _))  = Just $ getCInteger i
intValue (CConst (CCharConst c _)) = Just $ getCCharAsInt c
intValue _                         = Nothing

constEval :: (MonadTrav m) =>
             MachineDesc -> Map.Map Ident CExpr -> CExpr -> m CExpr
constEval md env (CCond e1 me2 e3 ni) =
  do e1'  <- constEval md env e1
     me2' <- maybe (return Nothing) (\e -> Just `liftM` constEval md env e) me2
     e3'  <- constEval md env e3
     case boolValue e1' of
       Just True  -> return $ fromMaybe e1' me2'
       Just False -> return e3'
       Nothing    -> return $ CCond e1' me2' e3' ni
constEval md env e@(CBinary op e1 e2 ni) =
  do e1' <- constEval md env e1
     e2' <- constEval md env e2
     t <- tExpr [] RValue e
     bytes <- fromIntegral `liftM` sizeofType md e t
     case (intValue e1', intValue e2') of
       (Just i1, Just i2) -> intExpr ni (withWordBytes bytes (intOp op i1 i2))
       (_, _)             -> return $ CBinary op e1' e2' ni
constEval md env (CUnary op e ni) =
  do e' <- constEval md env e
     t <- tExpr [] RValue e
     bytes <- fromIntegral `liftM` sizeofType md e t
     case intValue e' of
       Just i  -> case intUnOp op i of
                    Just i' -> intExpr ni (withWordBytes bytes i')
                    Nothing -> astError ni
                               "invalid unary operator applied to constant"
       Nothing -> return $ CUnary op e' ni
constEval md env (CCast d e ni) =
  do e' <- constEval md env e
     t <- analyseTypeDecl d
     bytes <- fromIntegral `liftM` sizeofType md d t
     case intValue e' of
       Just i -> intExpr ni (withWordBytes bytes i)
       Nothing -> return $ CCast d e' ni
constEval md _ (CSizeofExpr e ni) =
  do t <- tExpr [] RValue e
     sz <- sizeofType md e t
     intExpr ni sz
constEval md _ (CSizeofType d ni) =
  do t <- analyseTypeDecl d
     sz <- sizeofType md d t
     intExpr ni sz
constEval md _ (CAlignofExpr e ni) =
  do t <- tExpr [] RValue e
     sz <- alignofType md e t
     intExpr ni sz
constEval md _ (CAlignofType d ni) =
  do t <- analyseTypeDecl d
     sz <- alignofType md d t
     intExpr ni sz
constEval md env e@(CVar i _) | Map.member i env =
  return $ fromMaybe e $ Map.lookup i env
constEval md env e@(CVar i _) =
  do t <- tExpr [] RValue e
     case derefTypeDef t of
       DirectType (TyEnum etr) _ _ ->
         do dt <- getDefTable
            case lookupTag (sueRef etr) dt of
              Just (Right (EnumDef (EnumType _ es _ _))) ->
                do env' <- foldM enumConst env es
                   return $ fromMaybe e $ Map.lookup i env'
              _ -> return e
       _ -> return e
  where enumConst env' (Enumerator n e' _ _) =
          do c <- constEval md env' e'
             return $ Map.insert n c env'
constEval _ _ e = return e