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 DDC.Core.DaCon
import qualified DDC.Core.Eval.Store as Store
stepPrimCon
:: DaCon Name
-> [Exp () Name]
-> Store
-> Maybe ( Store
, Exp () Name)
stepPrimCon dc xsArgs store
| DaConUnit <- daConName dc
, [] <- xsArgs
= Just ( store
, xLoc locUnit tUnit )
stepPrimCon dc xsArgs store
| Just _ <- takeIntDC dc
, [xR, xUnit'] <- xsArgs
, XType tR <- xR
, Just rgn <- takeHandleT tR
, isUnitOrLocX xUnit'
, Store.hasRgn store rgn
, (store1, l) <- Store.allocBind rgn
(tInt tR) (SObj dc []) store
= Just ( store1
, xLoc l (tInt tR))
| Just (NamePrimCon PrimDaConPr) <- takeNameOfDaCon dc
, [xR, xA, xB, x1, x2] <- xsArgs
, XType tR <- xR
, Just rgn <- takeHandleT tR
, XType tA <- xA
, XType tB <- xB
, Just l1 <- takeLocX x1
, Just l2 <- takeLocX x2
, Store.hasRgn store rgn
, (store1, l) <- Store.allocBind rgn
(tPair tR tA tB) (SObj dc [l1, l2]) store
= Just ( store1
, xLoc l (tPair tR tA tB))
| Just (NamePrimCon PrimDaConNil) <- takeNameOfDaCon dc
, [xR, xA, xUnit'] <- xsArgs
, XType tR <- xR
, Just rgn <- takeHandleT tR
, XType tA <- xA
, isUnitOrLocX xUnit'
, Store.hasRgn store rgn
, (store1, l) <- Store.allocBind rgn
(tList tR tA) (SObj dc []) store
= Just ( store1
, xLoc l (tList tR tA))
| Just (NamePrimCon PrimDaConCons) <- takeNameOfDaCon dc
, [xR, xA, xHead, xTail] <- xsArgs
, 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 dc [lHead, lTail]) store
= Just ( store1
, xLoc 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 dc1 []) <- Store.lookupRegionTypeBind l1 store
, Just i1 <- takeIntDC dc1
, Just (r2', _, SObj dc2 []) <- Store.lookupRegionTypeBind l2 store
, Just i2 <- takeIntDC dc2
, r1' == r1
, r2' == r2
, Store.hasRgn store r3
, i3 <- i1 `fOp` i2
, (store1, l3) <- Store.allocBind r3 (tInt tR3)
(SObj (dcInt i3) [])
store
= Just ( store1
, xLoc 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 dc1 []) <- Store.lookupRegionTypeBind l1 store
, Just _i1 <- takeIntDC dc1
, Just (r2L, _, SObj dc2 []) <- Store.lookupRegionTypeBind l2 store
, Just i2 <- takeIntDC dc2
, r1L == r1
, r2L == r2
, store1 <- Store.addBind l1 r1 tX1 (SObj (dcInt i2) []) store
= Just ( store1
, xUnit)
stepPrimOp (NamePrimOp op) [xR1, xR2, xL1] store
| Just fOp <- lookup op
[ (PrimOpCopyInt, id)
, (PrimOpNegInt, negate) ]
, Just r1 <- takeHandleX xR1
, XType tR2 <- xR2
, Just r2 <- takeHandleX xR2
, Just l1 <- stripLocX xL1
, Just (r1L, _, SObj dc1 []) <- Store.lookupRegionTypeBind l1 store
, Just i1 <- takeIntDC dc1
, r1L == r1
, Store.hasRgn store r2
, i2 <- fOp i1
, (store1, l2) <- Store.allocBind r2 (tInt tR2) (SObj (dcInt i2) []) store
= Just ( store1
, xLoc l2 (tInt tR2))
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