module DDC.Core.Salt.Name.PrimOp
( PrimOp (..)
, PrimArith (..), readPrimArith
, PrimCast (..), readPrimCast
, primCastPromoteIsValid
, primCastTruncateIsValid
, PrimStore (..), readPrimStore
, PrimCall (..), readPrimCall
, PrimControl (..), readPrimControl)
where
import DDC.Core.Salt.Name.PrimTyCon
import DDC.Core.Salt.Platform
import DDC.Base.Pretty
import Control.DeepSeq
import Data.Char
import Data.List
data PrimOp
= PrimArith PrimArith
| PrimCast PrimCast
| PrimStore PrimStore
| PrimCall PrimCall
| PrimControl PrimControl
deriving (Eq, Ord, Show)
instance NFData PrimOp where
rnf op
= case op of
PrimArith pa -> rnf pa
PrimCast pc -> rnf pc
PrimStore ps -> rnf ps
PrimCall pc -> rnf pc
PrimControl pc -> rnf pc
instance Pretty PrimOp where
ppr pp
= case pp of
PrimArith op -> ppr op
PrimCast c -> ppr c
PrimStore p -> ppr p
PrimCall c -> ppr c
PrimControl c -> ppr c
data PrimArith
= PrimArithNeg
| PrimArithAdd
| PrimArithSub
| PrimArithMul
| PrimArithDiv
| PrimArithMod
| PrimArithRem
| PrimArithEq
| PrimArithNeq
| PrimArithGt
| PrimArithGe
| PrimArithLt
| PrimArithLe
| PrimArithAnd
| PrimArithOr
| PrimArithShl
| PrimArithShr
| PrimArithBAnd
| PrimArithBOr
| PrimArithBXOr
deriving (Eq, Ord, Show)
instance NFData PrimArith
instance Pretty PrimArith where
ppr op
= let Just (_, n) = find (\(p, _) -> op == p) primArithNames
in (text n)
readPrimArith :: String -> Maybe PrimArith
readPrimArith str
= case find (\(_, n) -> str == n) primArithNames of
Just (p, _) -> Just p
_ -> Nothing
primArithNames :: [(PrimArith, String)]
primArithNames
= [ (PrimArithNeg, "neg#")
, (PrimArithAdd, "add#")
, (PrimArithSub, "sub#")
, (PrimArithMul, "mul#")
, (PrimArithDiv, "div#")
, (PrimArithRem, "rem#")
, (PrimArithMod, "mod#")
, (PrimArithEq , "eq#" )
, (PrimArithNeq, "neq#")
, (PrimArithGt , "gt#" )
, (PrimArithGe , "ge#" )
, (PrimArithLt , "lt#" )
, (PrimArithLe , "le#" )
, (PrimArithAnd, "and#")
, (PrimArithOr , "or#" )
, (PrimArithShl, "shl#")
, (PrimArithShr, "shr#")
, (PrimArithBAnd, "band#")
, (PrimArithBOr, "bor#")
, (PrimArithBXOr, "bxor#") ]
data PrimCast
= PrimCastPromote
| PrimCastTruncate
deriving (Eq, Ord, Show)
instance NFData PrimCast
instance Pretty PrimCast where
ppr c
= case c of
PrimCastPromote -> text "promote#"
PrimCastTruncate -> text "truncate#"
readPrimCast :: String -> Maybe PrimCast
readPrimCast str
= case str of
"promote#" -> Just PrimCastPromote
"truncate#" -> Just PrimCastTruncate
_ -> Nothing
primCastPromoteIsValid
:: Platform
-> PrimTyCon
-> PrimTyCon
-> Bool
primCastPromoteIsValid pp src dst
| primTyConIsIntegral src, primTyConIsIntegral dst
, primTyConIsUnsigned src, primTyConIsUnsigned dst
, primTyConWidth pp dst >= primTyConWidth pp src
= True
| primTyConIsIntegral src, primTyConIsIntegral dst
, primTyConIsSigned src, primTyConIsSigned dst
, primTyConWidth pp dst >= primTyConWidth pp src
= True
| primTyConIsIntegral src, primTyConIsIntegral dst
, primTyConIsUnsigned src, primTyConIsSigned dst
, primTyConWidth pp dst > primTyConWidth pp src
= True
| otherwise
= False
primCastTruncateIsValid
:: Platform
-> PrimTyCon
-> PrimTyCon
-> Bool
primCastTruncateIsValid _pp src dst
| primTyConIsIntegral src
, primTyConIsIntegral dst
= True
| otherwise
= False
data PrimStore
= PrimStoreSize
| PrimStoreSize2
| PrimStoreCreate
| PrimStoreCheck
| PrimStoreRecover
| PrimStoreAlloc
| PrimStoreRead
| PrimStoreWrite
| PrimStorePlusAddr
| PrimStoreMinusAddr
| PrimStorePeek
| PrimStorePoke
| PrimStorePlusPtr
| PrimStoreMinusPtr
| PrimStoreMakePtr
| PrimStoreTakePtr
| PrimStoreCastPtr
deriving (Eq, Ord, Show)
instance NFData PrimStore
instance Pretty PrimStore where
ppr p
= case p of
PrimStoreSize -> text "size#"
PrimStoreSize2 -> text "size2#"
PrimStoreCreate -> text "create#"
PrimStoreCheck -> text "check#"
PrimStoreRecover -> text "recover#"
PrimStoreAlloc -> text "alloc#"
PrimStoreRead -> text "read#"
PrimStoreWrite -> text "write#"
PrimStorePlusAddr -> text "plusAddr#"
PrimStoreMinusAddr -> text "minusAddr#"
PrimStorePeek -> text "peek#"
PrimStorePoke -> text "poke#"
PrimStorePlusPtr -> text "plusPtr#"
PrimStoreMinusPtr -> text "minusPtr#"
PrimStoreMakePtr -> text "makePtr#"
PrimStoreTakePtr -> text "takePtr#"
PrimStoreCastPtr -> text "castPtr#"
readPrimStore :: String -> Maybe PrimStore
readPrimStore str
= case str of
"size#" -> Just PrimStoreSize
"size2#" -> Just PrimStoreSize2
"create#" -> Just PrimStoreCreate
"check#" -> Just PrimStoreCheck
"recover#" -> Just PrimStoreRecover
"alloc#" -> Just PrimStoreAlloc
"read#" -> Just PrimStoreRead
"write#" -> Just PrimStoreWrite
"plusAddr#" -> Just PrimStorePlusAddr
"minusAddr#" -> Just PrimStoreMinusAddr
"peek#" -> Just PrimStorePeek
"poke#" -> Just PrimStorePoke
"plusPtr#" -> Just PrimStorePlusPtr
"minusPtr#" -> Just PrimStoreMinusPtr
"makePtr#" -> Just PrimStoreMakePtr
"takePtr#" -> Just PrimStoreTakePtr
"castPtr#" -> Just PrimStoreCastPtr
_ -> Nothing
data PrimCall
= PrimCallTail Int
deriving (Eq, Ord, Show)
instance NFData PrimCall where
rnf (PrimCallTail i) = rnf i
instance Pretty PrimCall where
ppr pc
= case pc of
PrimCallTail arity
-> text "tailcall" <> int arity <> text "#"
readPrimCall :: String -> Maybe PrimCall
readPrimCall str
| Just rest <- stripPrefix "tailcall" str
, (ds, "#") <- span isDigit rest
, not $ null ds
, n <- read ds
, n > 0
= Just $ PrimCallTail n
| otherwise
= Nothing
data PrimControl
= PrimControlFail
| PrimControlReturn
deriving (Eq, Ord, Show)
instance NFData PrimControl
instance Pretty PrimControl where
ppr pc
= case pc of
PrimControlFail -> text "fail#"
PrimControlReturn -> text "return#"
readPrimControl :: String -> Maybe PrimControl
readPrimControl str
= case str of
"fail#" -> Just $ PrimControlFail
"return#" -> Just $ PrimControlReturn
_ -> Nothing