{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, DeriveDataTypeable #-}
module Prim(
            PrimOp(..),
            toPrim,
            toWString,
            stringSize,
            writePrimOp, readPrimOp,
            PrimResult(..), PrimArg(..)
            ) where

import Numeric(floatToDigits)
import Eval
import PPrint
import Id
import Position
import Log2
import IntegerUtil
import RealUtil hiding (log2, log10)
import qualified RealUtil as R (log2,log10)
import ErrorUtil(internalError)
import Error(ErrMsg(..))
import qualified Data.Generics as Generic

data PrimOp =
          PrimAdd
        | PrimSub
        | PrimAnd
        | PrimOr
        | PrimXor

        | PrimMul

        | PrimQuot
        | PrimRem

        | PrimSL
        | PrimSRL
        | PrimSRA

        | PrimInv
        | PrimNeg

        | PrimEQ

        | PrimULE
        | PrimULT

        | PrimSLE
        | PrimSLT

        | PrimSignExt
        | PrimZeroExt

        | PrimTrunc

        | PrimExtract
        | PrimConcat
        | PrimSplit

        | PrimBNot
        | PrimBAnd
        | PrimBOr

        | PrimInoutCast
        | PrimInoutUncast

        | PrimIf
        | PrimMux
        | PrimPriMux

        | PrimFmtConcat

        -- Only in ATS
        -- use: PrimCase e d c1 e1 c2 e2 ... cn en
        -- e is the scrutinized expression, d is the default value, (ck, ek) forms a case arm
        | PrimCase

        -- Only used in intermediate code
        -- primSelect @k @m @n e  selects k bits at position m from n bits
        -- primSelect :: \/ k, m, n :: * -> Bit n -> Bit k
        | PrimSelect

        -- primitives without hardware representation
        | PrimIntegerToBit
        | PrimIntegerToUIntBits
        | PrimIntegerToIntBits
        | PrimBitToInteger -- XXX dangerous
        | PrimIntegerToString

        -- must be called on compile-time values
        | PrimIntBitsToInteger
        | PrimUIntBitsToInteger

        | PrimIsStaticInteger
        | PrimAreStaticBits

        | PrimValueOf
        | PrimStringOf

        | PrimWhen
        | PrimWhenPred -- takes abstract predicate

        | PrimOrd
        | PrimChr

        -- primRange lo hi x, promises lo <= x <= hi
        | PrimRange

        | PrimError
        | PrimGenerateError
        | PrimMessage
        | PrimWarning
        | PrimPoisonedDef

        | PrimDynamicError

        | PrimStringConcat
        | PrimStringToInteger
        | PrimStringEQ
        | PrimStringLength

        | PrimStringSplit
        | PrimStringCons

        | PrimCharToString
        | PrimStringToChar
        | PrimCharOrd
        | PrimCharChr

        | PrimJoinActions
        | PrimNoActions
        | PrimExpIf     -- "split shallow"
        | PrimNoExpIf   -- "nosplit shallow"
        | PrimSplitDeep
        | PrimNosplitDeep
        | PrimAddRules
        | PrimModuleBind
        | PrimModuleReturn
        | PrimModuleFix
        | PrimModuleClock
        | PrimModuleReset
        | PrimBuildModule
        | PrimCurrentClock
        | PrimCurrentReset
        | PrimSameFamilyClock
        | PrimIsAncestorClock
        | PrimChkClockDomain
        | PrimClockEQ
        | PrimClockOf
        | PrimClocksOf
        | PrimNoClock
        | PrimResetEQ
        | PrimResetOf
        | PrimResetsOf
        | PrimNoReset
        | PrimResetUnassertedVal
        | PrimJoinRules
        | PrimJoinRulesPreempt
        | PrimJoinRulesUrgency
        | PrimJoinRulesExecutionOrder
        | PrimJoinRulesMutuallyExclusive
        | PrimJoinRulesConflictFree
        | PrimNoRules
        | PrimRule
        -- PrimAddSchedPragmas :: [SchedulePragma] -> Rules -> Rules
        | PrimAddSchedPragmas

        | PrimGetName
        -- primStateName :: Name -> Module b -> Module b
        -- This primitive is used to name state components.
        -- The first argument is an abstract name that is added to
        -- the names of state elements instantiated by the second argument.
        | PrimStateName
        | PrimGetModuleName

        | PrimJoinNames
        | PrimExtendNameInteger
        | PrimGetNamePosition
        | PrimGetNameString
        | PrimMakeName

        -- primStateAttrib :: Attributes -> Module b -> Module b
        -- This primitive is used to add attributes to submod instantiations.
        -- The first argument is an abstract list of attributes.
        | PrimStateAttrib

        | PrimNoPosition
        | PrimPrintPosition
        | PrimGetStringPosition
        | PrimSetStringPosition
        | PrimGetEvalPosition

        -- environment
        | PrimGenC
        | PrimGenVerilog
        | PrimGenModuleName

        -- elaboration-time file IO
        | PrimOpenFile
        | PrimCloseHandle
        | PrimHandleIsEOF
        | PrimHandleIsOpen
        | PrimHandleIsClosed
        | PrimHandleIsReadable
        | PrimHandleIsWritable
        | PrimSetHandleBuffering
        | PrimGetHandleBuffering
        | PrimFlushHandle
        | PrimWriteHandle
        | PrimReadHandleLine
        | PrimReadHandleChar

        -- reflective type primitives
        | PrimTypeOf
        | PrimPrintType
        | PrimTypeEQ
        | PrimIsIfcType

        -- type-tracking primitive
        | PrimSavePortType

        -- compile time numbers
        | PrimIntegerAdd
        | PrimIntegerSub
        | PrimIntegerNeg
        | PrimIntegerMul
        | PrimIntegerDiv
        | PrimIntegerMod
        | PrimIntegerExp
        | PrimIntegerLog2
        | PrimIntegerLog10
        | PrimIntegerQuot
        | PrimIntegerRem

        | PrimIntegerEQ
        | PrimIntegerLE
        | PrimIntegerLT

        -- Real numbers: Show
        | PrimRealToString
        -- Real numbers: Literal
        | PrimIntegerToReal
        -- Real numbers: Eq and Ord
        | PrimRealEQ
        | PrimRealLE
        | PrimRealLT
        -- Real numbers: Arith
        | PrimRealAdd
        | PrimRealSub
        | PrimRealNeg
        | PrimRealMul
        | PrimRealDiv
        | PrimRealAbs
        | PrimRealSignum
        | PrimRealExpE
        | PrimRealPow
        | PrimRealLogE
        | PrimRealLogBase
        | PrimRealLog2
        | PrimRealLog10
        -- Real numbers: Bits
        | PrimRealToBits
        | PrimBitsToReal
        -- Real numbers: Trig
        | PrimRealSin
        | PrimRealCos
        | PrimRealTan
        | PrimRealSinH
        | PrimRealCosH
        | PrimRealTanH
        | PrimRealASin
        | PrimRealACos
        | PrimRealATan
        | PrimRealASinH
        | PrimRealACosH
        | PrimRealATanH
        | PrimRealATan2
        -- Real numbers: Sqrt
        | PrimRealSqrt
        -- Real numbers: Rounding
        | PrimRealTrunc
        | PrimRealCeil
        | PrimRealFloor
        | PrimRealRound
        -- Real numbers: Introspection
        | PrimSplitReal
        | PrimDecodeReal
        | PrimRealToDigits
        | PrimRealIsInfinite
        | PrimRealIsNegativeZero

        | PrimSeq        -- args are eval in sequence
                        -- for side effects or strictness
        | PrimSeqCond   -- implicit-condition strictness
        | PrimUninitialized
        | PrimRawUninitialized -- error out with a use of an uninitialized value
        | PrimMarkArrayUninitialized -- mark array as uninitialized
        | PrimMarkArrayInitialized -- mark array as initialized
        | PrimUninitBitArray -- make an array of uninitialized bits
        | PrimIsBitArray -- is this Bit n represented as an array
        | PrimUpdateBitArray
        | PrimBuildUndefined -- build a type-appropriate undefined value
        | PrimRawUndefined -- create a "raw" undefined value
        | PrimIsRawUndefined -- test if a value is a "raw" undefined value
        | PrimImpCondOf -- XXX experimental
        | PrimArrayNew  -- Primitive array operators
        | PrimArrayLength
        | PrimArraySelect
        | PrimArrayUpdate
        | PrimArrayDynSelect
        | PrimArrayDynUpdate
        | PrimBuildArray -- only exists after IExpand and in ASyntax

        | PrimSetSelPosition

        | PrimGetParamName -- get the parameter name associated with the function value

        | PrimEQ3 -- === / Verilog case equality
        deriving (Eq, Ord, Show, Enum, Bounded, Generic.Data, Generic.Typeable)

-- Just some size, have to be coordinated with Prelude.bs
stringSize :: String -> Integer
stringSize s = toInteger (8 * length s)        -- in bytes as bits

toPrim :: Id -> PrimOp
toPrim i = tp (getIdBaseString i)                -- XXXXX
  where tp "primAdd" = PrimAdd
        tp "primSub" = PrimSub
        tp "primAnd" = PrimAnd
        tp "primOr"  = PrimOr
        tp "primXor" = PrimXor
        tp "primMul" = PrimMul
        tp "primQuot" = PrimQuot
        tp "primRem" = PrimRem
        tp "primSL"  = PrimSL
        tp "primSRL" = PrimSRL
        tp "primSRA" = PrimSRA
        tp "primInv" = PrimInv
        tp "primNeg" = PrimNeg
        tp "primEQ"  = PrimEQ
        tp "primEQ3" = PrimEQ3
        tp "primULE" = PrimULE
        tp "primULT" = PrimULT
        tp "primSLE" = PrimSLE
        tp "primSLT" = PrimSLT
        tp "primSignExt" = PrimSignExt
        tp "primZeroExt" = PrimZeroExt
        tp "primTrunc" = PrimTrunc
        tp "primExtractInternal" = PrimExtract
        tp "primConcat" = PrimConcat
        tp "primSplit" = PrimSplit
        tp "primBNot" = PrimBNot
        tp "primBAnd" = PrimBAnd
        tp "primBOr" = PrimBOr
        tp "primInoutCast" = PrimInoutCast
        tp "primInoutUncast" = PrimInoutUncast
        tp "primIntegerToBit" = PrimIntegerToBit
        tp "primIntegerToUIntBits" = PrimIntegerToUIntBits
        tp "primIntegerToIntBits"  = PrimIntegerToIntBits
        tp "primBitToInteger" = PrimBitToInteger
        tp "primIntegerToString" = PrimIntegerToString
        tp "primUIntBitsToInteger" = PrimUIntBitsToInteger
        tp "primIntBitsToInteger"  = PrimIntBitsToInteger
        tp "primIsStaticInteger" = PrimIsStaticInteger
        tp "primAreStaticBits" = PrimAreStaticBits
        tp "primWhen" = PrimWhen
        tp "primValueOf" = PrimValueOf
        tp "primStringOf" = PrimStringOf
        tp "primOrd" = PrimOrd
        tp "primChr" = PrimChr
        tp "primIf" = PrimIf
        tp "primRange" = PrimRange
        tp "primError" = PrimError
        tp "primPoisonedDef" = PrimPoisonedDef
        tp "primGenerateError" = PrimGenerateError
        tp "primMessage" = PrimMessage
        tp "primWarning" = PrimWarning
        tp "primDynamicError" = PrimDynamicError

        tp "primJoinActions" = PrimJoinActions
        tp "primNoActions" = PrimNoActions
        tp "primExpIf" = PrimExpIf
        tp "primNoExpIf" = PrimNoExpIf
        tp "primSplitDeep" = PrimSplitDeep
        tp "primNosplitDeep" = PrimNosplitDeep
        tp "primAddRules" = PrimAddRules
        tp "primModuleBind" = PrimModuleBind
        tp "primModuleReturn" = PrimModuleReturn
        tp "primModuleFix" = PrimModuleFix
        tp "primModuleClock" = PrimModuleClock
        tp "primModuleReset" = PrimModuleReset
        tp "primBuildModule" = PrimBuildModule
        tp "primJoinRules" = PrimJoinRules
        tp "primJoinRulesPreempt" = PrimJoinRulesPreempt
        tp "primJoinRulesUrgency" = PrimJoinRulesUrgency
        tp "primJoinRulesExecutionOrder" = PrimJoinRulesExecutionOrder
        tp "primJoinRulesMutuallyExclusive" = PrimJoinRulesMutuallyExclusive
        tp "primJoinRulesConflictFree" = PrimJoinRulesConflictFree
        tp "primNoRules" = PrimNoRules
        tp "primRule" = PrimRule

        tp "primStringConcat" = PrimStringConcat
        tp "primStringToInteger" = PrimStringToInteger
        tp "primStringEQ" = PrimStringEQ
        tp "primStringLength" = PrimStringLength

        tp "primStringSplit" = PrimStringSplit
        tp "primStringCons" = PrimStringCons

        tp "primCharToString" = PrimCharToString
        tp "primStringToChar" = PrimStringToChar
        tp "primCharOrd" = PrimCharOrd
        tp "primCharChr" = PrimCharChr

        tp "primFmtConcat" = PrimFmtConcat
        tp "primCurrentClock" = PrimCurrentClock
        tp "primCurrentReset" = PrimCurrentReset
        tp "primSameFamilyClock" = PrimSameFamilyClock
        tp "primIsAncestorClock" = PrimIsAncestorClock
        tp "primChkClockDomain" = PrimChkClockDomain
        tp "primClockEQ" = PrimClockEQ
        tp "primClockOf" = PrimClockOf
        tp "primClocksOf" = PrimClocksOf
        tp "primNoClock" = PrimNoClock
        tp "primResetEQ" = PrimResetEQ
        tp "primResetOf" = PrimResetOf
        tp "primResetsOf" = PrimResetsOf
        tp "primNoReset" = PrimNoReset
        tp "primResetUnassertedVal" = PrimResetUnassertedVal

        tp "primGetName" = PrimGetName
        tp "primGetParamName" = PrimGetParamName
        tp "primStateName" = PrimStateName
        tp "primGetModuleName" = PrimGetModuleName
        tp "primJoinNames" = PrimJoinNames
        tp "primExtendNameInteger" = PrimExtendNameInteger
        tp "primGetNamePosition" = PrimGetNamePosition
        tp "primGetNameString" = PrimGetNameString
        tp "primMakeName" = PrimMakeName

        tp "primStateAttrib" = PrimStateAttrib

        tp "primNoPosition" = PrimNoPosition
        tp "primPrintPosition" = PrimPrintPosition
        tp "primGetStringPosition" = PrimGetStringPosition
        tp "primSetStringPosition" = PrimSetStringPosition
        tp "primGetEvalPosition" = PrimGetEvalPosition

        tp "primGenC" = PrimGenC
        tp "primGenVerilog" = PrimGenVerilog
        tp "primGenModuleName" = PrimGenModuleName

        tp "primOpenFile" = PrimOpenFile
        tp "primCloseHandle" = PrimCloseHandle
        tp "primHandleIsEOF" = PrimHandleIsEOF
        tp "primHandleIsOpen" = PrimHandleIsOpen
        tp "primHandleIsClosed" = PrimHandleIsClosed
        tp "primHandleIsReadable" = PrimHandleIsReadable
        tp "primHandleIsWritable" = PrimHandleIsWritable
        tp "primSetHandleBuffering" = PrimSetHandleBuffering
        tp "primGetHandleBuffering" = PrimGetHandleBuffering
        tp "primFlushHandle" = PrimFlushHandle
        tp "primWriteHandle" = PrimWriteHandle
        tp "primReadHandleLine" = PrimReadHandleLine
        tp "primReadHandleChar" = PrimReadHandleChar

        tp "primTypeOf" = PrimTypeOf
        tp "primPrintType" = PrimPrintType
        tp "primTypeEQ" = PrimTypeEQ
        tp "primIsIfcType" = PrimIsIfcType

        tp "primSavePortType" = PrimSavePortType

        tp "primSeq" = PrimSeq
        tp "primSeqCond" = PrimSeqCond

        tp "primIntegerAdd" = PrimIntegerAdd
        tp "primIntegerSub" = PrimIntegerSub
        tp "primIntegerNeg" = PrimIntegerNeg
        tp "primIntegerMul" = PrimIntegerMul
        tp "primIntegerDiv" = PrimIntegerDiv
        tp "primIntegerMod" = PrimIntegerMod
        tp "primIntegerQuot" = PrimIntegerQuot
        tp "primIntegerRem" = PrimIntegerRem
        tp "primIntegerExp" = PrimIntegerExp
        tp "primIntegerLog2" = PrimIntegerLog2
        tp "primIntegerLog10" = PrimIntegerLog10

        tp "primIntegerEQ"  = PrimIntegerEQ
        tp "primIntegerLE"  = PrimIntegerLE
        tp "primIntegerLT"  = PrimIntegerLT

        tp "primRealToString" = PrimRealToString
        tp "primIntegerToReal" = PrimIntegerToReal
        tp "primRealEQ"  = PrimRealEQ
        tp "primRealLE"  = PrimRealLE
        tp "primRealLT"  = PrimRealLT
        tp "primRealAdd"  = PrimRealAdd
        tp "primRealSub"  = PrimRealSub
        tp "primRealNeg"  = PrimRealNeg
        tp "primRealMul"  = PrimRealMul
        tp "primRealDiv"  = PrimRealDiv
        tp "primRealAbs"  = PrimRealAbs
        tp "primRealSignum" = PrimRealSignum
        tp "primRealExpE" = PrimRealExpE
        tp "primRealPow"  = PrimRealPow
        tp "primRealLogE" = PrimRealLogE
        tp "primRealLogBase" = PrimRealLogBase
        tp "primRealLog2" = PrimRealLog2
        tp "primRealLog10" = PrimRealLog10
        tp "primRealToBits" = PrimRealToBits
        tp "primBitsToReal" = PrimBitsToReal
        tp "primRealSin"    = PrimRealSin
        tp "primRealCos"    = PrimRealCos
        tp "primRealTan"    = PrimRealTan
        tp "primRealSinH"   = PrimRealSinH
        tp "primRealCosH"   = PrimRealCosH
        tp "primRealTanH"   = PrimRealTanH
        tp "primRealASin"   = PrimRealASin
        tp "primRealACos"   = PrimRealACos
        tp "primRealATan"   = PrimRealATan
        tp "primRealASinH"  = PrimRealASinH
        tp "primRealACosH"  = PrimRealACosH
        tp "primRealATanH"  = PrimRealATanH
        tp "primRealATan2"  = PrimRealATan2
        tp "primRealSqrt"   = PrimRealSqrt
        tp "primRealTrunc"  = PrimRealTrunc
        tp "primRealCeil"   = PrimRealCeil
        tp "primRealFloor"  = PrimRealFloor
        tp "primRealRound"  = PrimRealRound
        tp "primSplitReal"  = PrimSplitReal
        tp "primDecodeReal" = PrimDecodeReal
        tp "primRealToDigits" = PrimRealToDigits
        tp "primRealIsInfinite" = PrimRealIsInfinite
        tp "primRealIsNegativeZero" = PrimRealIsNegativeZero

        tp "primUninitialized" = PrimUninitialized
        tp "primMakeRawUninitialized" = PrimRawUninitialized
        tp "primMarkArrayUninitialized" = PrimMarkArrayUninitialized
        -- the same primitive is used to implement both of these
        tp "primMarkArrayInitialized" = PrimMarkArrayInitialized
        tp "primMarkBitArrayInitialized" = PrimMarkArrayInitialized
        tp "primUninitBitArray" = PrimUninitBitArray
        tp "primIsBitArray" = PrimIsBitArray
        tp "primUpdateBitArray" = PrimUpdateBitArray
        tp "primBuildUndefined" = PrimBuildUndefined
        tp "primMakeRawUndefined" = PrimRawUndefined
        tp "primIsRawUndefined" = PrimIsRawUndefined
        tp "primImpCondOf" = PrimImpCondOf
        tp "primArrayNew" = PrimArrayNew
        tp "primArrayLength" = PrimArrayLength
        tp "primArraySelect" = PrimArraySelect
        tp "primArrayUpdate" = PrimArrayUpdate
        tp "primArrayDynSelect" = PrimArrayDynSelect
        tp "primArrayDynUpdate" = PrimArrayDynUpdate
        tp "primBuildArray" = PrimBuildArray

        tp "primSetSelPosition" = PrimSetSelPosition
        tp s = internalError ("unknown primitive: " ++ s ++ " " ++ prPosition (getIdPosition i))

instance PPrint PrimOp where
    pPrint d p op = text (toString op)

toString :: PrimOp -> String
toString PrimAdd = "+"
toString PrimSub = "-"
toString PrimAnd = "&"
toString PrimOr = "|"
toString PrimXor = "^"
toString PrimMul = "*"
toString PrimQuot = "/"
toString PrimRem = "%"
toString PrimSL = "<<"
toString PrimSRL = ">>"
toString PrimSRA = ">>>"
toString PrimInv = "~"
toString PrimNeg = "-"
toString PrimEQ = "=="
toString PrimEQ3 = "==="
toString PrimULE = "<="
toString PrimULT = "<"
toString PrimSLE = ".<="
toString PrimSLT = ".<"
toString PrimSignExt = "sext"
toString PrimZeroExt = "zext"
toString PrimTrunc = "trunc"
toString PrimExtract = "extract"
toString PrimConcat = "++"
toString PrimSplit = "split"
toString PrimBNot = "!"
toString PrimBAnd = "&&"
toString PrimBOr = "||"
toString PrimInoutCast = "primInoutCast"
toString PrimInoutUncast = "primInoutUncast"
toString PrimIf = "_if_"
toString PrimSelect = "select"
toString PrimValueOf = "valueOf"
toString PrimStringOf = "stringOf"
toString PrimOrd = "ord"
toString PrimChr = "chr"
toString PrimError = "_error"
toString PrimCurrentClock = "primCurrentClock"
toString p = show p

-- to name of wide-data operations
toWString :: PrimOp -> String
toWString PrimAdd = "add"
toWString PrimSub = "sub"
toWString PrimAnd = "and"
toWString PrimOr = "or"
toWString PrimXor = "xor"
toWString PrimMul = "mul"
toWString PrimQuot = "quot"
toWString PrimRem = "rem"
toWString PrimSL = "sl"
toWString PrimSRL = "srl"
toWString PrimSRA = "sra"
toWString PrimInv = "inv"
toWString PrimNeg = "neg"
toWString PrimEQ = "eq"
toWString PrimULE = "ule"
toWString PrimULT = "ult"
toWString PrimSLE = "sle"
toWString PrimSLT = "slt"
toWString PrimSignExt = "sext"
toWString PrimZeroExt = "zext"
toWString PrimTrunc = "trunc"
toWString PrimExtract = "extract"
toWString PrimConcat = "concat"
toWString PrimSplit = "split"
toWString PrimBNot = "bnot"
toWString PrimBAnd = "band"
toWString PrimBOr = "bor"
toWString PrimIf = "_if_"
toWString PrimSelect = "select"
toWString PrimValueOf = "valueOf"
toWString PrimStringOf = "stringOf"
toWString PrimOrd = "ord"
toWString PrimChr = "chr"
toWString PrimError = "_error"
toWString PrimCurrentClock = "primCurrentClock"
toWString p = show p

instance Hyper PrimOp where
    hyper x y = seq x y

-----

-- For writing and readin PrimOp to a file

writePrimOp :: PrimOp -> Int
writePrimOp p = fromEnum p

readPrimOp :: Int -> PrimOp
readPrimOp n = toEnum n

-- -------------------------------------------------------------------
-- Routines for evaluating prim ops with constant arguments

-- shorthand notation
ans :: a -> Maybe (Either ErrMsg a)
ans x = Just $ Right x

err :: ErrMsg -> Maybe (Either ErrMsg a)
err msg = Just $ Left msg

no_answer :: Maybe a
no_answer = Nothing  -- XXX shouldn't these really be errors?
                     -- XXX See discussion of doPrimOp in IPrims.hs


-- ----
-- Data type for mixing argument types

data PrimArg = I Integer
             | D Double
             deriving (Eq)

instance PPrint PrimArg where
    pPrint d p (I i) = pparen (p > 0) $ text "I" <+> pPrint d 0 i
    pPrint d p (D r) = pparen (p > 0) $ text "D" <+> pPrint d 0 r

-- ----
-- Primitives returning Integer
evalPrimToInt :: PrimOp -> [Integer] -> [PrimArg] ->
                 Maybe (Either ErrMsg Integer)

-- basic math on sized values
evalPrimToInt PrimAdd  [s]     [I i1, I i2] = ans $ mask s (i1+i2)
evalPrimToInt PrimSub  [s]     [I i1, I i2] = ans $ mask s (i1-i2)
evalPrimToInt PrimMul  [_,_,s] [I i1, I i2] = ans $ mask s (i1*i2)
evalPrimToInt PrimQuot [s,_]   [I i1, I i2] =
    if (i2 == 0)
    then err EDivideByZero
    else ans $ mask s (i1 `quot` i2)
evalPrimToInt PrimRem  [_,s]   [I i1, I i2] =
    if (i2 == 0)
    then err EDivideByZero
    else ans $ mask s (i1 `rem` i2)
evalPrimToInt PrimNeg  [s]     [I i1]    = ans $ mask s (-i1)

-- bit-wise operators on sized values
evalPrimToInt PrimAnd [s] [I i1, I i2] = ans $ i1 `integerAnd` i2
evalPrimToInt PrimOr  [s] [I i1, I i2] = ans $ i1 `integerOr`  i2
evalPrimToInt PrimXor [s] [I i1, I i2] = ans $ i1 `integerXor` i2
evalPrimToInt PrimInv [s] [I i1]       = ans $ mask s (integerInvert i1)

-- shifting on sized values
evalPrimToInt PrimSL  [s,_] [I x, I sh]  =
    if (sh >= s)
    then ans 0
    else if (sh >= 0)
         then ans $ mask s (x * (2^sh))
         else no_answer
evalPrimToInt PrimSRL [s,_] [I x, I sh]  =
    if (sh >= s)
    then ans 0
    else if (sh >= 0)
         then ans $ x `div` (2^sh)
         else no_answer
evalPrimToInt PrimSRA [s,_] [I x, I sh]  =
    if (sh >= s)
    then -- this behavior, i.e., 0 if you shift too much,
         -- is intended to emulate what verilog simulators
         -- do.  iverilog and ncverilog have this behavior
         ans 0
    else if (sh >= 0)
         then evalPrimToInt PrimSignExt [sh, s-sh, s] [I (x `div` (2^sh))]
         else no_answer

-- extension and truncation on sized values
evalPrimToInt PrimZeroExt [_,_,_]   [I i] = ans i
evalPrimToInt PrimSignExt [_,s1,s2] [I i] =
    if (s1 >= 1 && s2 >= 0)  -- _ + s1 = s2
    then ans $ if i >= 2^(s1-1) then 2^s2 - 2^s1 + i else i
    else no_answer
evalPrimToInt PrimTrunc   [_,s,_]   [I i] = ans $ mask s i

-- extraction, concatenation and range-checking on sized values
evalPrimToInt PrimRange [s] [I lo, I hi, I x] =
    if x < lo || x > hi then
        internalError ("evalPrimToInt: PrimRange " ++ ppReadable (lo,hi,x))
    else
        ans $ x
evalPrimToInt PrimExtract [n,_,m] [I e, I h, I l] =
    if (h-l+1 < 0)
    then internalError
             ("evalPrimToInt: PrimExtract extract negative number of bits "
              ++ ppReadable ((n,m),(h,l,e)))
    else if (l >= 0)
         then ans $ mask m (integerSelect (h-l+1) l e)
         else no_answer
evalPrimToInt PrimConcat [s1,s2,s3] [I i1, I i2] =
    if (s2 >= 0)
    then ans $ i1 * 2^s2 + i2
    else no_answer
evalPrimToInt PrimSelect [k,m,_]    [I i] =
    if (m >= 0)
    then ans $ integerSelect k m i
    else no_answer
-- evalPrimToInt PrimSplit _ _ =

-- math on unbounded Integers
evalPrimToInt PrimIntegerAdd  _ [I i1, I i2] = ans $ i1 + i2
evalPrimToInt PrimIntegerSub  _ [I i1, I i2] = ans $ i1 - i2
evalPrimToInt PrimIntegerNeg  _ [I i1]       = ans $ (-i1)
evalPrimToInt PrimIntegerMul  _ [I i1, I i2] = ans $ i1 * i2
evalPrimToInt PrimIntegerDiv  _ [I i1, I i2] =
    if (i2 == 0)
    then err EDivideByZero
    else ans $ i1 `div` i2
evalPrimToInt PrimIntegerMod  _ [I i1, I i2] =
    if (i2 == 0)
    then err EDivideByZero
    else ans $ i1 `mod` i2
evalPrimToInt PrimIntegerQuot _ [I i1, I i2] =
    if (i2 == 0)
    then err EDivideByZero
    else ans $ i1 `quot` i2
evalPrimToInt PrimIntegerRem  _ [I i1, I i2] =
    if (i2 == 0)
    then err EDivideByZero
    else ans $ i1 `rem` i2
evalPrimToInt PrimIntegerExp  _ [I i1, I i2] =
    if (i2 < 0)
    then err EIntegerNegativeExponent
    else ans $ i1 ^ i2
evalPrimToInt PrimIntegerLog2 _ [I i1]       =
    if (i1 <= 0)
    then err EInvalidLog
    else ans $ log2 i1
evalPrimToInt PrimIntegerLog10 _ [I i1]      =
    if (i1 <= 0)
    then err EInvalidLog
    else ans $ log10 i1

-- conversions from unbounded to sized and vice-versa
evalPrimToInt PrimIntegerToBit [s] [I i] =
    if (i < 2^s && i > -(2^s))
    then ans $ mask s i
    else no_answer
evalPrimToInt PrimBitToInteger _   [I i] = ans i

-- conditional
evalPrimToInt PrimIf [s] [I i1, I i2, I i3] =
    ans $ if (i1 == 1) then i2 else i3

-- conversion to bits
evalPrimToInt PrimRealToBits _ [D d1] =
    ans $ toInteger (doubleToWord64 d1)

-- rounding, truncation, etc.
evalPrimToInt PrimRealTrunc _ [D d1] = ans $ truncate d1
evalPrimToInt PrimRealCeil  _ [D d1] = ans $ ceiling d1
evalPrimToInt PrimRealFloor _ [D d1] = ans $ floor d1
evalPrimToInt PrimRealRound _ [D d1] = ans $ round d1

-- all other prim ops are unhandled
evalPrimToInt _ _ _ = no_answer


-- ----
-- Primitives returning Bool
evalPrimToBool :: PrimOp -> [Integer] -> [PrimArg] ->
                  Maybe (Either ErrMsg Bool)

-- relational operators on sized values
evalPrimToBool PrimEQ  [s] [I i1, I i2] = ans $ i1 == i2
evalPrimToBool PrimEQ3 [s] [I i1, I i2] = ans $ i1 == i2
evalPrimToBool PrimULE [s] [I i1, I i2] = ans $ i1 <= i2
evalPrimToBool PrimULT [s] [I i1, I i2] = ans $ i1 <  i2
evalPrimToBool PrimSLE [s] [I i1, I i2] = ans $ (ext s i1) <= (ext s i2)
evalPrimToBool PrimSLT [s] [I i1, I i2] = ans $ (ext s i1) <  (ext s i2)

-- boolean logic
evalPrimToBool PrimBNot      _ [I i]        = ans $ i == 0
evalPrimToBool PrimBAnd      _ [I i1, I i2] = ans $ (i1 == 1) && (i2 == 1)
evalPrimToBool PrimBOr       _ [I i1, I i2] = ans $ (i1 == 1) || (i2 == 1)

-- relational operators on unbounded Integers
evalPrimToBool PrimIntegerEQ _ [I i1, I i2] = ans $ i1 == i2
evalPrimToBool PrimIntegerLE _ [I i1, I i2] = ans $ i1 <= i2
evalPrimToBool PrimIntegerLT _ [I i1, I i2] = ans $ i1 <  i2

-- relational operators
evalPrimToBool PrimRealEQ _ [D d1, D d2] = ans $ d1 == d2
evalPrimToBool PrimRealLE _ [D d1, D d2] = ans $ d1 <= d2
evalPrimToBool PrimRealLT _ [D d1, D d2] = ans $ d1 <  d2

-- property tests
evalPrimToBool PrimRealIsInfinite     _ [D d1] = ans $ isInfinite d1
evalPrimToBool PrimRealIsNegativeZero _ [D d1] = ans $ isNegativeZero d1

-- all other prim ops are unhandled
evalPrimToBool _ _ _ = no_answer


-- ----
-- Primitives returning Double
evalPrimToDouble :: PrimOp -> [Integer] -> [PrimArg] ->
                    Maybe (Either ErrMsg Double)

evalPrimToDouble PrimIntegerToReal _ [I i1] = ans $ fromInteger i1
evalPrimToDouble PrimBitsToReal    _ [I i1] =
    let d = word64ToDouble (fromInteger i1)
    in  if (isNaN d) then err EFloatNaN else ans d

-- basic math operators
evalPrimToDouble PrimRealAdd _ [D d1, D d2] =
    if ( (isPosInfinite d1 && isNegInfinite d2) ||
         (isNegInfinite d1 && isPosInfinite d2) )
    then err EAddPosAndNegInfinity
    else ans $ d1 + d2
evalPrimToDouble PrimRealSub _ [D d1, D d2] =
    if ( (isPosInfinite d1 && isPosInfinite d2) ||
         (isNegInfinite d1 && isNegInfinite d2) )
    then err EAddPosAndNegInfinity
    else ans $ d1 - d2
evalPrimToDouble PrimRealNeg _ [D d1] = ans (-d1)
evalPrimToDouble PrimRealMul _ [D d1, D d2] =
    if ( (isInfinite d1 && (d2 == 0.0)) ||
         (isInfinite d2 && (d1 == 0.0)) )
    then err EMultiplyZeroAndInfinity
    else ans $ d1 * d2
evalPrimToDouble PrimRealDiv _ [D d1, D d2] =
    if (d2 == 0.0)
    then err EDivideByZero
    else ans $ d1 / d2
evalPrimToDouble PrimRealAbs    _ [D d1] = ans (abs d1)
evalPrimToDouble PrimRealSignum _ [D d1] = ans (signum d1)

-- exponents and logarithms
evalPrimToDouble PrimRealExpE _ [D d1] = ans $ exp d1
evalPrimToDouble PrimRealPow  _ [D d1, D d2] = ans $ d1 ** d2
evalPrimToDouble PrimRealLogE _ [D d1] =
    if (d1 <= 0)
    then err EInvalidLog
    else  ans $ log d1
evalPrimToDouble PrimRealLogBase _ [D d1, D d2] =
    if (d2 <= 0)
    then err EInvalidLog
    else if (d1 <= 0)
    then err EInvalidLogBase
    else if ((d1 == 1) && (d2 == 1))
    then err EInvalidLogOneOne
    else ans $ logBase d1 d2
evalPrimToDouble PrimRealLog2 _ [D d1] =
    if (d1 <= 0)
    then err EInvalidLog
    else ans $ R.log2 d1
evalPrimToDouble PrimRealLog10 _ [D d1] =
    if (d1 <= 0)
    then err EInvalidLog
    else ans $ R.log10 d1
evalPrimToDouble PrimRealSqrt _ [D d1] =
    if (d1 < 0)
    then err ENegativeSqrt
    else ans $ sqrt d1

-- trig functions
evalPrimToDouble PrimRealSin   _ [D d1] = ans $ sin d1
evalPrimToDouble PrimRealCos   _ [D d1] = ans $ cos d1
evalPrimToDouble PrimRealTan   _ [D d1] = ans $ tan d1
evalPrimToDouble PrimRealSinH  _ [D d1] = ans $ sinh d1
evalPrimToDouble PrimRealCosH  _ [D d1] = ans $ cosh d1
evalPrimToDouble PrimRealTanH  _ [D d1] = ans $ tanh d1
evalPrimToDouble PrimRealASin  _ [D d1] = ans $ asin d1
evalPrimToDouble PrimRealACos  _ [D d1] = ans $ acos d1
evalPrimToDouble PrimRealATan  _ [D d1] = ans $ atan d1
evalPrimToDouble PrimRealASinH _ [D d1] = ans $ asinh d1
evalPrimToDouble PrimRealACosH _ [D d1] = ans $ acosh d1
evalPrimToDouble PrimRealATanH _ [D d1] = ans $ atanh d1
evalPrimToDouble PrimRealATan2 _ [D d1, D d2] = ans $ atan2 d1 d2

-- all other prim ops are unhandled
evalPrimToDouble _ _ _ = no_answer


-- ----
-- Double to String primitives
evalPrimToString :: PrimOp -> [Integer] -> [PrimArg] ->
                    Maybe (Either ErrMsg String)

-- XXX PrimIntegerToString could go here, but it needs access to the base
-- XXX (which we could add to PrimArg)
evalPrimToString PrimRealToString _ [D d1] = ans $ show d1

-- all other prim ops on Doubles are unhandled
evalPrimToString _ _ _ = no_answer


-- ----
-- Primitives returning (Integer, Double)
evalPrimToIntDouble :: PrimOp -> [Integer] -> [PrimArg] ->
                       Maybe (Either ErrMsg (Integer,Double))

evalPrimToIntDouble PrimSplitReal _ [D d1] = ans $ properFraction d1

-- all other prim ops are unhandled
evalPrimToIntDouble _ _ _ = no_answer


-- ----
-- Primitives returning (Bool, Integer, Integer)
evalPrimToBoolIntInt :: PrimOp -> [Integer] -> [PrimArg] ->
                        Maybe (Either ErrMsg (Bool,Integer,Integer))

evalPrimToBoolIntInt PrimDecodeReal _ [D d1] =
    let (mantissa, exponent) = decodeFloat d1
        -- include positive zero
        is_pos = (d1 >= 0) && not (isNegativeZero d1)
    in  ans (is_pos, mantissa, (toInteger exponent))

-- all other prim ops are unhandled
evalPrimToBoolIntInt _ _ _ = no_answer


-- ----
-- Primitives returning ([Integer], Integer)
evalPrimToListIntInt :: PrimOp -> [Integer] -> [PrimArg] ->
                        Maybe (Either ErrMsg ([Integer], Integer))

evalPrimToListIntInt PrimRealToDigits _ [I i, D d] =
    let -- "floatToDigits" only works for non-negative values
        (digits, exponent) = floatToDigits i (abs d)
    in  ans (map toInteger digits, toInteger exponent)

-- all other prim ops are unhandled
evalPrimToListIntInt _ _ _ = no_answer


-- -------------------------------------------------------------------
-- Typeclass to simplify evaluation of prim ops

class PrimResult a where
  primResult :: PrimOp -> [Integer] -> [PrimArg] -> Maybe (Either ErrMsg a)
  -- default implementation is to return no_answer for everything
  primResult _ _ _ = no_answer

instance PrimResult Bool where
  primResult op ts vs = evalPrimToBool op ts vs

instance PrimResult Integer where
  primResult op ts vs = evalPrimToInt op ts vs

instance PrimResult Double where
  primResult op ts vs = evalPrimToDouble op ts vs

instance PrimResult String where
  primResult op ts vs = evalPrimToString op ts vs

instance PrimResult (Integer, Double) where
  primResult op ts vs = evalPrimToIntDouble op ts vs

instance PrimResult (Bool, Integer, Integer) where
  primResult op ts vs = evalPrimToBoolIntInt op ts vs

instance PrimResult ([Integer], Integer) where
  primResult op ts vs = evalPrimToListIntInt op ts vs