src/Kaos/CoreFuture.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.CoreFuture (
  19     markFuture, markBlockFuture, markBlockFuture',
  20     Lookahead(..), Future,
  21     Futurable(..), lineFuture, FutureMap, FutureS
  22     ) where
  23
  24 import Kaos.Core
  25 import Kaos.CoreTraverse
  26 import Kaos.Slot
  27 import Kaos.KaosM
  28 import Data.List
  29 import Data.Maybe
  30 import Data.Generics
  31 import Control.Monad.State hiding (State)
  32 import Kaos.VirtRegister
  33
  34 import Control.Monad.Identity
  35
  36 import qualified Data.Map as M
  37
  38 data Lookahead = Bound VirtRegister
  39                | Read
  40                | Mutate
  41                deriving (Show, Eq, Ord, Data, Typeable)
  42
  43 type FutureMap = M.Map Slot Lookahead
  44 data FutureS = FutureS { fsFuture ::  FutureMap
  45                        , fsAccess :: !AccessMap
  46                        } deriving (Eq, Ord, Show, Data, Typeable)
  47 type Future  = Maybe Lookahead
  48
  49 class Futurable a where getFuture :: a -> FutureMap
  50 instance Futurable FutureS where getFuture = fsFuture
  51 instance LineAccess FutureS where getLineAccess = fsAccess
  52
  53 lineFuture :: Futurable t => (CoreLine t, t) -> FutureMap
  54 lineFuture = getFuture . snd
  55
  56 type FutureM a = StateT FutureMap KaosM a
  57
  58 lookupFuture :: Slot -> FutureM Future
  59 lookupFuture = gets . M.lookup
  60
  61 poisonFuture :: forall t. LineAccess t => Core t -> Core FutureS
  62 poisonFuture = runIdentity . mapCoreM poison
  63     where
  64         poison :: CoreLine FutureS -> t -> Identity (CoreLine FutureS, FutureS)
  65         poison l la = return (l, FutureS err (getLineAccess la))
  66             where
  67                 err = error $ "Using the future of a deep block: " ++
  68                                 show (fmap (const ()) l)
  69
  70 markFuture :: LineAccess t => Core t -> KaosM (Core FutureS)
  71 markFuture = markBlockFuture M.empty . poisonFuture
  72
  73 markBlockFuture ::
  74     FutureMap -> Core FutureS -> KaosM (Core FutureS)
  75 markBlockFuture assumedFuture =
  76     fmap fst . markBlockFuture' assumedFuture
  77
  78 markBlockFuture' :: LineAccess t =>
  79     FutureMap -> Core t -> KaosM (Core FutureS, FutureMap)
  80 markBlockFuture' assumedFuture =
  81     flip runStateT assumedFuture . markBlock . poisonFuture
  82
  83 markBlock :: Core FutureS -> FutureM (Core FutureS)
  84 markBlock (CB l) = do
  85     ls <- mapM markLine_ (reverse l)
  86     return $ CB (reverse ls)
  87     where
  88         markLine_ :: (CoreLine FutureS, FutureS) -> FutureM (CoreLine FutureS, FutureS)
  89         markLine_ (line, oldS) = do
  90             let acc = getLineAccess oldS
  91             future <- get
  92             line' <- markLine line acc
  93             return (line', FutureS future acc)
  94
  95 markLine :: CoreLine FutureS -> AccessMap -> FutureM (CoreLine FutureS)
  96 markLine cl@(CoreNote _) _ = return cl
  97 markLine cl@(CoreTouch sa) accM = do
  98     markLine (CoreLine [ TokenSlot sa ]) accM
  99     return cl
 100 markLine cl@(CoreConst dest _) _ = do
 101     modify $ M.delete dest
 102     return cl
 103
 104 markLine cl@(CoreAssign dest src) _ = do
 105     fsrc  <- lookupFuture src
 106     fdest <- lookupFuture dest
 107     modify $ M.delete dest
 108     case (fsrc, fdest) of
 109         (Nothing, Nothing) -> return () -- discard
 110         (Just Read, Just Read) -> return () -- share
 111         (Nothing, _) -> do -- rename
 112             modify $ M.alter (const fdest) src
 113         (_, _) -> return () -- overwrite; we don't set future as it's already non-Nothing
 114     return cl
 115
 116 markLine (CoreTargReader tempslot readslot block) _ = do
 117     body <- markBlock block
 118     -- TARG temp
 119     markLine (CoreLine undefined) . AM $ M.singleton tempslot ReadAccess
 120     -- temp = slot
 121     markLine (CoreAssign tempslot readslot) undefined
 122     return $ CoreTargReader tempslot readslot body
 123
 124 markLine (CoreTargWriter slot block) _ = do
 125     -- temp = TARG
 126     markLine (CoreLine undefined) . AM $  M.singleton slot WriteAccess
 127     body <- markBlock block
 128     return $ CoreTargWriter slot body
 129
 130 markLine l acc = do
 131     mapM_ update (M.toList $ getAM acc)
 132     return l
 133     where
 134         update :: (Slot, AccessType) -> FutureM ()
 135         update (s, WriteAccess)  = modify $ M.delete s
 136         update (s, ReadAccess)   = modify $ flip M.alter s (`mplus` Just Read)
 137         update (s, MutateAccess) = modify . flip M.alter s $ \st ->
 138             case st of
 139                 Just (Bound _) -> st
 140                 _              -> Just Mutate
 141         update (_, NoAccess)     = return ()