module DDC.Core.Eval.Prim
( stepPrimCon
, stepPrimOp
, primNewRegion
, primDelRegion)
where
import DDC.Core.Eval.Compounds
import DDC.Core.Eval.Store
import DDC.Core.Eval.Name
import DDC.Type.Compounds
import DDC.Core.Exp
import qualified DDC.Core.Eval.Store as Store
stepPrimCon
:: Name
-> [Exp () Name]
-> Store
-> Maybe ( Store
, Exp () Name)
stepPrimCon (NameInt i) [xR, xUnit] store
| XType tR <- xR
, Just rgn <- takeHandleT tR
, isUnitX xUnit
, Store.hasRgn store rgn
, (store1, l) <- Store.allocBind rgn (tInt tR) (SObj (NameInt i) []) store
= Just ( store1
, XCon () (UPrim (NameLoc l) (tInt tR)))
stepPrimCon n@(NamePrimCon PrimDaConNil) [xR, xA, xUnit] store
| XType tR <- xR
, Just rgn <- takeHandleT tR
, XType tA <- xA
, isUnitX xUnit
, Store.hasRgn store rgn
, (store1, l) <- Store.allocBind rgn (tList tR tA) (SObj n []) store
= Just ( store1
, XCon () (UPrim (NameLoc l) (tList tR tA)))
stepPrimCon n@(NamePrimCon PrimDaConCons) [xR, xA, xHead, xTail] store
| XType tR <- xR
, Just rgn <- takeHandleT tR
, XType tA <- xA
, Just lHead <- takeLocX xHead
, Just lTail <- takeLocX xTail
, Store.hasRgn store rgn
, (store1, l) <- Store.allocBind rgn (tList tR tA) (SObj n [lHead, lTail]) store
= Just ( store1
, XCon () (UPrim (NameLoc l) (tList tR tA)))
stepPrimCon _ _ _
= Nothing
stepPrimOp
:: Name
-> [Exp () Name]
-> Store
-> Maybe ( Store
, Exp () Name)
stepPrimOp (NamePrimOp op) [xR1, xR2, xR3, xL1, xL2] store
| Just fOp <- lookup op
[ (PrimOpAddInt, (+))
, (PrimOpSubInt, ())
, (PrimOpMulInt, (*))
, (PrimOpDivInt, div)
, (PrimOpEqInt, (\x y -> if x == y then 1 else 0))]
, Just r1 <- takeHandleX xR1
, Just r2 <- takeHandleX xR2
, XType tR3 <- xR3
, Just r3 <- takeHandleX xR3
, Just l1 <- stripLocX xL1
, Just l2 <- stripLocX xL2
, Just (r1', _, SObj (NameInt i1) []) <- Store.lookupRegionTypeBind l1 store
, Just (r2', _, SObj (NameInt i2) []) <- Store.lookupRegionTypeBind l2 store
, r1' == r1
, r2' == r2
, Store.hasRgn store r3
, i3 <- i1 `fOp` i2
, (store1, l3) <- Store.allocBind r3 (tInt tR3) (SObj (NameInt i3) []) store
= Just ( store1
, XCon () (UPrim (NameLoc l3) (tInt tR3)))
stepPrimOp (NamePrimOp PrimOpUpdateInt) [xR1, xR2, xMutR1, xL1, xL2] store
| Just r1 <- takeHandleX xR1
, Just r2 <- takeHandleX xR2
, Just r1W <- takeMutableX xMutR1
, Just l1 <- stripLocX xL1
, Just l2 <- stripLocX xL2
, r1W == r1
, Just (r1L, tX1, SObj (NameInt _) []) <- Store.lookupRegionTypeBind l1 store
, Just (r2L, _, SObj (NameInt i2) []) <- Store.lookupRegionTypeBind l2 store
, r1L == r1
, r2L == r2
, store1 <- Store.addBind l1 r1 tX1 (SObj (NameInt i2) []) store
= Just ( store1
, XCon () (UPrim (NamePrimCon PrimDaConUnit) tUnit))
stepPrimOp _ _ _
= Nothing
primNewRegion :: Store -> (Store, Bound Name)
primNewRegion store
= let (store', rgn) = Store.newRgn store
u = UPrim (NameRgn rgn) kRegion
in (store', u)
primDelRegion :: Bound Name -> Store -> Maybe Store
primDelRegion uu store
= case uu of
UPrim (NameRgn rgn) _ -> Just $ Store.delRgn rgn store
_ -> Nothing