src/Kaos/CoreStorage.hs

   1 {-
   2    Kaos - A compiler for creatures scripts
   3    Copyright (C) 2005-2008  Bryan Donlan
   4
   5    This program is free software: you can redistribute it and/or modify
   6    it under the terms of the GNU General Public License as published by
   7    the Free Software Foundation, either version 3 of the License, or
   8    (at your option) any later version.
   9
  10    This program is distributed in the hope that it will be useful,
  11    but WITHOUT ANY WARRANTY; without even the implied warranty of
  12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13    GNU General Public License for more details.
  14
  15    You should have received a copy of the GNU General Public License
  16    along with this program.  If not, see <http://www.gnu.org/licenses/>.
  17 -}
  18 module Kaos.CoreStorage (markStorage, Storage(..), StorageS(..), StorageMap, getSM, checkConstStorage) where
  19
  20 import Kaos.Core
  21 import Kaos.Slot
  22 import Kaos.KaosM
  23 import Data.List
  24 import Data.Maybe
  25 import Data.Generics
  26 import Control.Monad.State hiding (State)
  27 import qualified Control.Monad.State as S
  28 import Kaos.CoreFuture
  29 --import Kaos.CoreAccess
  30 import Kaos.VirtRegister
  31 import Kaos.AST
  32 import Control.Monad.Reader
  33 import Kaos.Dump
  34 import Kaos.CoreInline (inlineFallback)
  35 import Kaos.CoreTraverse
  36
  37 import qualified Data.Map as M
  38
  39 dumpStorageTransitions :: MonadKaos m => StorageMap -> StorageMap -> m ()
  40 dumpStorageTransitions a b = cmpF (M.toList a) (M.toList b)
  41     where
  42         cmpF [] [] = return ()
  43         cmpF xas@(pa@(ka, _):as) xbs@(pb@(kb, _):bs)
  44             | ka < kb
  45             = do debugKM $ "  DEL " ++ show pa
  46                  cmpF as xbs
  47             | kb < ka
  48             = do debugKM $ "  ADD " ++ show pb
  49                  cmpF xas bs
  50             | pa == pb
  51             = cmpF as bs
  52             | otherwise
  53             = do debugKM $ "  MOD " ++ show (pa, pb)
  54                  cmpF as bs
  55         cmpF [] (pb:bs)
  56             = do debugKM $ "  ADD " ++ show pb
  57                  cmpF [] bs
  58         cmpF (pa:as) []
  59             = do debugKM $ "  DEL " ++ show pa
  60                  cmpF as []
  61
  62 data Storage    = Private VirtRegister
  63                 | Shared  VirtRegister
  64                 | Const   ConstValue
  65                 | Phantom
  66                 deriving (Show, Eq, Ord, Data, Typeable)
  67
  68 type StorageMap = M.Map Slot Storage
  69 data StorageS = StorageS { ssStorage :: !StorageMap
  70                          , ssFuture  :: !FutureS
  71                          } deriving (Eq, Ord, Show, Data, Typeable)
  72 type MarkM a = ReaderT FutureS (StateT StorageMap (VRegAllocT KaosM)) a
  73
  74 instance Futurable StorageS where getFuture = getFuture . ssFuture
  75 instance LineAccess StorageS where getLineAccess = getLineAccess . ssFuture
  76
  77 getSM :: StorageS -> StorageMap
  78 getSM = ssStorage
  79
  80 asksFuture :: (MonadReader f m, Futurable f)
  81            => (FutureMap -> a)
  82            -> m a
  83 asksFuture f = asks (f . getFuture)
  84
  85 getStorage :: Slot -> MarkM (Maybe Storage)
  86 getStorage = lift . gets . M.lookup
  87 setStorage :: Storage -> Slot -> MarkM ()
  88 setStorage st sl = lift $
  89     modify $ M.insert sl st
  90 newStorage :: Slot -> Future -> MarkM ()
  91 newStorage slot (Just (Bound b)) = setStorage (Private b) slot
  92 newStorage slot _ = do
  93     vr <- lift . lift $ newVReg
  94     setStorage (Private vr) slot
  95
  96 markStorage :: Core FutureS -> KaosM (Core StorageS)
  97 markStorage = runVRegAllocT . flip evalStateT M.empty . flip runReaderT undefined . markBlock
  98
  99 markBlock :: Core FutureS -> MarkM (Core StorageS)
 100 markBlock (CB l) = saveCtx $ fmap CB $ mapM enterLine l
 101     where
 102         enterLine :: (CoreLine FutureS, FutureS) -> MarkM (CoreLine StorageS, StorageS)
 103         enterLine (line, future) = do
 104             debugDump "dump-storage-assignment" $ "MARKING:\n" ++ dumpCore (fmap (const ()) $ CB [(line, future)])
 105             debugDump "dump-storage-assignment" $ "LOCAL FUTURE:\n" ++ dumpMap (getFuture future)
 106             debugDump "dump-storage-assignment" $ "LOCAL ACCESS:\n" ++ dumpMap (getAM $getLineAccess future)
 107             oldStorage <- get
 108             debugDump "dump-storage-assignment" $ "STORAGE:\n" ++ dumpMap oldStorage
 109             line' <- local (const future) $ markLine line
 110             storage <- get
 111             whenSet "dump-storage-assignment" $
 112                 when (oldStorage /= storage) $ do
 113                     debugKM "CHANGE:"
 114                     dumpStorageTransitions oldStorage storage
 115             return (line', StorageS storage future)
 116
 117 markLine :: CoreLine FutureS -> MarkM (CoreLine StorageS)
 118 markLine l@(CoreNote (ContextNote ctx)) = do
 119     putCtx $ Just ctx
 120     return $ fmap undefined l
 121 markLine l@(CoreNote _) = return $ fmap undefined l
 122 markLine CoreTargZap = return CoreTargZap
 123 markLine l@(CoreTouch sa) = do
 124     markLine $ CoreLine [ TokenSlot sa ]
 125     return $ fmap undefined l
 126 markLine l@(CoreConst dest cv) = do
 127     future <- asksFuture (M.lookup dest)
 128     case future of
 129         Nothing -> return ()
 130         Just Read -> do
 131             setStorage (Const cv) dest
 132         Just (Bound r) -> do
 133             setStorage (Private r) dest
 134         _ -> do
 135             newStorage dest future
 136     return $ fmap undefined l
 137
 138 markLine l@(CoreAssign dest src) = do
 139     fdest <- asksFuture (M.lookup dest)
 140     fsrc  <- asksFuture (M.lookup  src)
 141     modify $ M.delete dest
 142     case (fdest, fsrc) of
 143         (Just (Bound b), _) -> do
 144             setStorage (Private b) dest
 145         (Nothing, _) -> return () -- unused
 146         (_, Nothing) -> do -- rename
 147             ssrc <- getStorage src
 148             modify $ M.alter (const ssrc) dest
 149             modify $ M.delete src
 150         (Just Read, Just Read) -> do -- alias
 151             ssrc <- getStorage src
 152             case ssrc of
 153                 Nothing            -> fail "src storage was Nothing in markLine, alias case"
 154                 (Just (Private r)) -> setStorage (Shared r) src
 155                 _                  -> return ()
 156             ssrc' <- getStorage src
 157             setStorage (fromJust ssrc') dest
 158         (_, _) -> do -- copy
 159             newStorage dest fdest
 160     return $ fmap undefined l
 161
 162 markLine l@(CoreLine tokens) = do
 163     let collected = execState (mapM_ collect tokens) M.empty
 164     mapM_ updateStorage $ M.toList collected
 165     return $ fmap undefined l
 166     where
 167         collect :: CoreToken -> S.State (M.Map Slot AccessType) ()
 168         collect (TokenSlot (SA s access)) = do
 169             access' <- gets (fromMaybe NoAccess . M.lookup s)
 170             modify $ M.insert s (access' `mergeAccess` access)
 171         collect _ = return ()
 172
 173         updateStorage (slot, WriteAccess) = do
 174             future <- asks (M.lookup slot . getFuture)
 175             newStorage slot future
 176         updateStorage _ = return ()
 177
 178 markLine l@(CoreLoop body) = do
 179     trueFuture <- asks getFuture
 180     future     <- setupFuture l trueFuture
 181     body'      <- liftK $ markBlockFuture future body
 182     body''     <- markBlock body'
 183     return $ CoreLoop body''
 184     where
 185         setupFuture :: CoreLine FutureS -> FutureMap -> MarkM FutureMap
 186         setupFuture _ trueFuture = do
 187             acc <- asks getLineAccess
 188             let mut = map fst $ filter ((== MutateAccess) . snd) (M.toList $ getAM acc)
 189             mutF <- mapM fixReg mut
 190             let future' = foldl updReg trueFuture mutF
 191             return future'
 192         updReg m (key, newVal) = M.alter (const newVal) key m
 193         fixReg slot = do
 194             stor <- getStorage slot
 195             case stor of
 196                 Just (Private r) -> return (slot, Just $ Bound r)
 197                 Nothing -> return (slot, Nothing)
 198                 _ -> fail $ "Coreloop, bad fixreg storage " ++ show stor
 199
 200
 201 markLine l@(CoreCond cond ontrue_ onfalse_) = do
 202     trueFuture <- ask
 203     future  <- setupFuture trueFuture
 204     ontrue  <- liftK $ (markBlockFuture future ontrue_)
 205     onfalse <- liftK $ (markBlockFuture future onfalse_)
 206     CoreLine cond' <- markLine (CoreLine cond)
 207     s <- get
 208     ontrue' <- markBlock ontrue
 209     s_t <- get
 210     put s
 211     onfalse' <- markBlock onfalse
 212     s_f <- get
 213     --- In some cases, if a variable is initialized prior to entry, and is
 214     --- both read and written in one of the two branches, only to die afterward;
 215     --- it may not be pinned, and thus end up reallocated in one of the branches.
 216     --- In the other branch it is dead (no future, but storage remains), but
 217     --- the below assertion would be tripped anyway.
 218     ---
 219     --- To solve this, prune the storage state of all variables lost after this
 220     --- branch.
 221     ---
 222     --- Note: We do not prune s (storage after conditional), but do ensure it
 223     --- is subordinate (as it will always come logically before the true/false
 224     --- branches, and cannot contain write/mutate ops; but may pin important
 225     --- slots as alive). This means that the dead slots come back, but since
 226     --- they are unreferenced this is safe as always
 227     let [s_t', s_f'] = map (purgeDead trueFuture) [s_t, s_f]
 228     let u1 = s_f' `M.union` s_t'
 229     let u2 = s_t' `M.union` s_f'
 230     when (u1 /= u2) $ fail $ unlines["Storage states diverged:", dumpCoreLine (fmap (const()) l), dumpMap s_t, dumpMap s_f, dumpMap s, dumpMap future]
 231     put (u1 `M.union` s)
 232     return $ CoreCond cond' ontrue' onfalse'
 233     where
 234         purgeDead :: FutureS -> StorageMap -> StorageMap
 235         purgeDead trueFuture storage =
 236             M.filterWithKey (\k _ -> M.member k (getFuture trueFuture)) storage
 237
 238         setupFuture :: FutureS -> MarkM (M.Map Slot Lookahead)
 239         setupFuture trueFuture = do
 240             let acc = M.toList . getAM $ getLineAccess trueFuture
 241             let tf' = getFuture trueFuture
 242             entries <- fmap concat $ mapM (setupEntry tf') acc
 243             return $ M.fromList entries
 244         setupEntry future (s, acc) = do
 245             setupEntry' (s, acc) (M.lookup s future)
 246 --        If a value is being set which will not be used in the future,
 247 --        it will die before the end of the block (and thus we don't care where
 248 --        we put it).
 249         setupEntry' _ Nothing = return []
 250         setupEntry' (slot, acc) future = do
 251             curAcc <- getStorage slot
 252             case (curAcc, acc) of
 253                 (Just (Private r), _) -> return [(slot, Bound r)]
 254                 (Just (Shared r), ReadAccess) -> return [(slot, Bound r)]
 255                 (Nothing, _) -> do
 256                     newStorage slot future
 257                     Just (Private st) <- getStorage slot
 258                     return [(slot, Bound st)]
 259                 (x, _) -> fail $ "trying to bind a shared slot: " ++ show (slot, x, acc, fmap (const ()) l)
 260
 261 markLine (CoreFoldable folder body) = do
 262     body' <- markLine body
 263     return $ CoreFoldable folder body'
 264
 265 markLine (CoreTargReader ts slot body) = do
 266     markLine (CoreAssign ts slot)
 267     markLine (CoreLine [TokenSlot (SA ts ReadAccess)])
 268     body' <- markBlock body
 269     return $ CoreTargReader ts slot body'
 270
 271 markLine (CoreTargWriter slot body) = do
 272     body' <- markBlock body
 273     markLine (CoreLine [TokenSlot (SA slot WriteAccess)])
 274     return $ CoreTargWriter slot body'
 275
 276 markLine (CoreInlineFlush l) = return $ CoreInlineFlush l
 277 markLine l@(CoreInlineAssign level targUser dest repl) = do
 278     markLine $ inlineFallback l
 279     return $ CoreInlineAssign level targUser dest repl
 280
 281 checkConstStorage :: Core StorageS -> KaosM (Core StorageS)
 282 checkConstStorage l = do
 283     saveCtx $ mapCoreM checkConstLine l
 284     return l
 285
 286 checkConstLine :: CoreLine StorageS -> StorageS -> KaosM (CoreLine StorageS, StorageS)
 287 checkConstLine l@(CoreNote (ContextNote cx)) s = do
 288     putCtx (Just cx)
 289     return (l, s)
 290 checkConstLine l@(CoreLine t) storage = do
 291     mapM_ checkTok t
 292     return (l, storage)
 293     where
 294         checkTok (TokenConstSlot s rc) =
 295             checkStorage s (M.lookup s (getSM storage)) rc
 296         checkTok _ = return ()
 297         checkStorage _ (Just (Const v)) rc = do
 298             case rc v of
 299                 Nothing -> return ()
 300                 Just s -> compileError s
 301         checkStorage _ Nothing _ =
 302             return () -- will be reported in CoreToVirt
 303         checkStorage _ (Just Phantom) _ =
 304             internalError "Phantom storage found where constant expected (what does this mean??)"
 305         checkStorage _ _ _ = compileError "Constant value expected"
 306
 307 checkConstLine l s = return (l, s)