module DDC.Core.Eval.Store
( Store (..)
, Loc (..)
, Rgn (..)
, SBind (..)
, initial
, locUnit, isUnitOrLocX
, newLoc, newLocs
, newRgn, newRgns
, delRgn
, hasRgn
, setGlobal
, addBind
, allocBind, allocBinds
, lookupBind
, lookupTypeOfLoc
, lookupRegionTypeBind)
where
import DDC.Core.Exp
import DDC.Core.Eval.Name
import DDC.Core.Eval.Compounds
import Control.Monad
import DDC.Core.Pretty hiding (empty)
import Data.Map (Map)
import Data.Set (Set)
import qualified Data.Map as Map
import qualified Data.Set as Set
data Store
= Store
{
storeNextLoc :: Int
, storeNextRgn :: Int
, storeRegions :: Set Rgn
, storeGlobal :: Set Rgn
, storeBinds :: Map Loc (Rgn, Type Name, SBind) }
deriving Show
data SBind
= SObj
{ sbindDataTag :: DaCon Name
, sbindDataArgs :: [Loc] }
| SLams
{ sbindLamBinds :: [(Bool, Bind Name)]
, sbindLamBody :: Exp () Name }
| SThunk
{ sbindThunkExp :: Exp () Name }
deriving (Eq, Show)
instance Pretty Store where
ppr (Store nextLoc nextRgn regions global binds)
= vcat
[ text "* STORE"
, text " NextLoc: " <> text (show nextLoc)
, text " NextRgn: " <> text (show nextRgn)
, text " Regions: " <> braces (sep $ punctuate comma
$ map ppr $ Set.toList regions)
, text " Global: " <> braces (sep $ punctuate comma
$ map ppr $ Set.toList global)
, text ""
, text " Binds:"
, vcat $ [ text " " <> ppr l <> colon <> ppr r <> text " -> " <> ppr sbind
<> line
<> text " :: " <> ppr t
| (l, (r, t, sbind)) <- Map.toList binds] ]
instance Pretty SBind where
ppr (SObj tag [])
= text "OBJ" <+> ppr tag
ppr (SObj tag svs)
= text "OBJ" <+> ppr tag
<+> (sep $ map ppr svs)
ppr (SLams fbs x)
= text "LAMS" <+> sep (map (parens . ppr) fbs)
<> text "."
<> text (renderPlain $ ppr x)
ppr (SThunk x)
= text "THUNK" <+> text (renderPlain $ ppr x)
initial :: Store
initial = Store
{ storeNextLoc = 1
, storeNextRgn = 1
, storeRegions
= Set.fromList [Rgn 0]
, storeGlobal
= Set.fromList [Rgn 0]
, storeBinds
= Map.fromList
[ (Loc 0 tUnit, (Rgn 0, tUnit, SObj dcUnit []))]
}
locUnit :: Loc
locUnit = Loc 0 tUnit
isUnitOrLocX :: Show a => Exp a Name -> Bool
isUnitOrLocX xx
= case xx of
XCon _ DaConUnit -> True
XVar _ (UPrim (NameLoc (Loc 0 _)) _) -> True
_ -> False
newLoc :: Type Name -> Store -> (Store, Loc)
newLoc t store
= let loc = storeNextLoc store
store' = store { storeNextLoc = loc + 1 }
in (store', Loc loc t)
newLocs :: [Type Name] -> Store -> (Store, [Loc])
newLocs ts store
= let n = length ts
lFirst = storeNextLoc store
lLast = lFirst + n
locs = [lFirst .. lLast]
store' = store { storeNextLoc = lLast + 1 }
in (store', [Loc l t | l <- locs | t <- ts])
newRgn :: Store -> (Store, Rgn)
newRgn store
= let rgn = storeNextRgn store
store' = store { storeNextRgn = rgn + 1
, storeRegions = Set.insert (Rgn rgn) (storeRegions store) }
in (store', Rgn rgn)
newRgns :: Int -> Store -> (Store, [Rgn])
newRgns 0 store = (store, [])
newRgns count store
= let rgns = map Rgn $ [ storeNextRgn store .. storeNextRgn store + count 1]
store' = store { storeNextRgn = storeNextRgn store + count
, storeRegions = Set.union (Set.fromList rgns) (storeRegions store) }
in (store', rgns)
delRgn :: Rgn -> Store -> Store
delRgn rgn store
= let binds' = [x | x@(_, (r, _, _)) <- Map.toList $ storeBinds store
, r /= rgn ]
in store { storeBinds = Map.fromList binds'
, storeRegions = Set.delete rgn (storeRegions store)
, storeGlobal = Set.delete rgn (storeGlobal store) }
hasRgn :: Store -> Rgn -> Bool
hasRgn store rgn
= Set.member rgn (storeRegions store)
setGlobal :: Rgn -> Store -> Store
setGlobal rgn store
= store
{ storeGlobal = Set.insert rgn (storeGlobal store) }
addBind :: Loc -> Rgn -> Type Name -> SBind -> Store -> Store
addBind loc rgn t sbind store
= store
{ storeBinds = Map.insert loc (rgn, t, sbind) (storeBinds store) }
allocBind :: Rgn -> Type Name -> SBind -> Store -> (Store, Loc)
allocBind rgn t sbind store
= let (store1, loc) = newLoc t store
store2 = addBind loc rgn t sbind store1
in (store2, loc)
allocBinds :: [[Loc] -> (Rgn, Type Name, SBind)] -> [Type Name] -> Store -> (Store, [Loc])
allocBinds mkSBinds ts store
= let (store1, locs) = newLocs ts store
rgnBinds = map (\mk -> mk locs) mkSBinds
store2 = foldr (\(l, (r, t, b)) -> addBind l r t b) store1
$ zip locs rgnBinds
in (store2, locs)
lookupBind :: Loc -> Store -> Maybe SBind
lookupBind loc store
= liftM (\(_, _, sb) -> sb)
$ Map.lookup loc (storeBinds store)
lookupTypeOfLoc :: Loc -> Store -> Maybe (Type Name)
lookupTypeOfLoc loc store
= case Map.lookup loc (storeBinds store) of
Nothing -> Nothing
Just (_, t, _) -> Just t
lookupRegionTypeBind :: Loc -> Store -> Maybe (Rgn, Type Name, SBind)
lookupRegionTypeBind loc store
= Map.lookup loc (storeBinds store)