src/Symantic/Semantics/SharingObserver.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-} -- For ShowLetName
   2 {-# LANGUAGE BangPatterns #-} -- For makeSharingName
   3 {-# LANGUAGE DataKinds #-} -- For ShowLetName
   4 {-# LANGUAGE ExistentialQuantification #-} -- For SharingName
   5 -- {-# LANGUAGE MagicHash #-} -- For unsafeCoerce#
   6 module Symantic.SharingObserver where
   7
   8 import Control.Applicative (Applicative(..))
   9 import Control.Monad (Monad(..))
  10 import Data.Bool
  11 import Data.Eq (Eq(..))
  12 import Data.Function (($), (.))
  13 import Data.Functor (Functor, (<$>))
  14 import Data.Functor.Compose (Compose(..))
  15 import Data.HashMap.Strict (HashMap)
  16 import Data.HashSet (HashSet)
  17 import Data.Hashable (Hashable, hashWithSalt, hash)
  18 import Data.Int (Int)
  19 import Data.Maybe (Maybe(..), isNothing)
  20 import Data.Monoid (Monoid(..))
  21 import Data.Ord (Ord(..))
  22 -- import GHC.Exts (Int(..))
  23 -- import GHC.Prim (unsafeCoerce#)
  24 import GHC.StableName (StableName(..), makeStableName, hashStableName, eqStableName)
  25 -- import Numeric (showHex)
  26 import Prelude ((+), error)
  27 import System.IO (IO)
  28 import System.IO.Unsafe (unsafePerformIO)
  29 import Text.Show (Show(..))
  30 import qualified Control.Monad.Trans.Class as MT
  31 import qualified Control.Monad.Trans.Reader as MT
  32 import qualified Control.Monad.Trans.State as MT
  33 import qualified Control.Monad.Trans.Writer as MT
  34 import qualified Data.HashMap.Strict as HM
  35 import qualified Data.HashSet as HS
  36
  37 import Symantic.Derive
  38
  39 -- * Class 'Referenceable'
  40 -- | This class is not for end-users like usual symantic operators,
  41 -- though it will have to be defined on end-users' interpreters.
  42 class Referenceable letName sem where
  43   -- | @('ref' isRec letName)@ is a reference to @(letName)@.
  44   -- It is introduced by 'observeSharing'.
  45   -- @(isRec)@ is 'True' iif. this 'ref'erence is recursive,
  46   -- ie. appears within its 'define'.
  47   --
  48   -- TODO: index 'letName' with 'a' to enable dependent-map
  49   ref :: Bool -> letName -> sem a
  50   ref isRec name = liftDerived (ref isRec name)
  51   default ref ::
  52     FromDerived (Referenceable letName) sem =>
  53     Bool -> letName -> sem a
  54
  55 -- * Class 'Definable'
  56 -- | This class is not for end-users like usual symantic operators.
  57 -- There should be not need to use it outside this module,
  58 -- because used 'define's are gathered in 'Letsable'.
  59 class Definable letName sem where
  60   -- | @('define' letName sub)@ let-binds @(letName)@ to be equal to @(sub)@.
  61   -- This is a temporary node either replaced
  62   -- by 'ref' and an entry in 'lets''s 'LetBindings',
  63   -- or removed when no 'ref'erence is made to it.
  64   define :: letName -> sem a -> sem a
  65   define name = liftDerived1 (define name)
  66   default define ::
  67     FromDerived1 (Definable letName) sem =>
  68     letName -> sem a -> sem a
  69
  70 -- * Class 'MakeLetName'
  71 class MakeLetName letName where
  72   makeLetName :: SharingName -> IO letName
  73
  74 -- * Type 'SharingName'
  75 -- | Note that the observable sharing enabled by 'StableName'
  76 -- is not perfect as it will not observe all the sharing explicitely done.
  77 --
  78 -- Note also that the observed sharing could be different between ghc and ghci.
  79 data SharingName = forall a. SharingName (StableName a)
  80 -- | @('makeSharingName' x)@ is like @('makeStableName' x)@ but it also forces
  81 -- evaluation of @(x)@ to ensure that the 'StableName' is correct first time,
  82 -- which avoids to produce a tree bigger than needed.
  83 --
  84 -- Note that this function uses 'unsafePerformIO' instead of returning in 'IO',
  85 -- this is apparently required to avoid infinite loops due to unstable 'StableName'
  86 -- in compiled code, and sometimes also in ghci.
  87 --
  88 -- Note that maybe [pseq should be used here](https://gitlab.haskell.org/ghc/ghc/-/issues/2916).
  89 makeSharingName :: a -> SharingName
  90 makeSharingName !x = SharingName $ unsafePerformIO $ makeStableName x
  91
  92 instance Eq SharingName where
  93   SharingName x == SharingName y = eqStableName x y
  94 instance Hashable SharingName where
  95   hash (SharingName n) = hashStableName n
  96   hashWithSalt salt (SharingName n) = hashWithSalt salt n
  97 {-
  98 instance Show SharingName where
  99   showsPrec _ (SharingName n) = showHex (I# (unsafeCoerce# n))
 100 -}
 101
 102 -- * Type 'SharingObserver'
 103 newtype SharingObserver letName sem a = SharingObserver { unSharingObserver ::
 104   MT.ReaderT (HashSet SharingName)
 105              (MT.State (SharingObserverState letName))
 106              (SharingFinalizer letName sem a) }
 107
 108 -- | Interpreter detecting some (Haskell embedded) @let@ definitions used at
 109 -- least once and/or recursively, in order to replace them
 110 -- with the 'lets' and 'ref' combinators.
 111 -- See [Type-safe observable sharing in Haskell](https://doi.org/10.1145/1596638.1596653)
 112 --
 113 -- Beware not to apply 'observeSharing' more than once on the same term
 114 -- otherwise some 'define' introduced by the first call
 115 -- would be removed by the second call.
 116 observeSharing ::
 117   Eq letName =>
 118   Hashable letName =>
 119   Show letName =>
 120   SharingObserver letName sem a ->
 121   WithSharing letName sem a
 122 observeSharing (SharingObserver m) =
 123   let (fs, st) = MT.runReaderT m mempty `MT.runState`
 124         SharingObserverState
 125           { oss_refs = HM.empty
 126           , oss_recs = HS.empty
 127           } in
 128   let refs = HS.fromList
 129         [ letName
 130         | (letName, refCount) <- HM.elems (oss_refs st)
 131         , refCount > 0
 132         ] in
 133   --trace (show refs) $
 134   MT.runWriter $
 135   (`MT.runReaderT` refs) $
 136   unFinalizeSharing fs
 137
 138 -- ** Type 'WithSharing'
 139 type WithSharing letName sem a =
 140   (sem a, HM.HashMap letName (SomeLet sem))
 141 {-
 142 -- * Type 'WithSharing'
 143 data WithSharing letName sem a = WithSharing
 144   { lets :: HM.HashMap letName (SomeLet sem)
 145   , body :: sem a
 146   }
 147 mapWithSharing ::
 148   (forall v. sem v -> sem v) ->
 149   WithSharing letName sem a ->
 150   WithSharing letName sem a
 151 mapWithSharing f ws = WithSharing
 152   { lets = (\(SomeLet sem) -> SomeLet (f sem)) <$> lets ws
 153   , body = f (body ws)
 154   }
 155 -}
 156
 157 -- ** Type 'SharingObserverState'
 158 data SharingObserverState letName = SharingObserverState
 159   { oss_refs :: HashMap SharingName (letName, Int)
 160   , oss_recs :: HashSet SharingName
 161   }
 162
 163 observeSharingNode ::
 164   Eq letName =>
 165   Hashable letName =>
 166   Show letName =>
 167   Referenceable letName sem =>
 168   MakeLetName letName =>
 169   SharingObserver letName sem a ->
 170   SharingObserver letName sem a
 171 observeSharingNode (SharingObserver m) = SharingObserver $ do
 172   let nodeName = makeSharingName m
 173   st <- MT.lift MT.get
 174   ((letName, seenBefore), seen) <- getCompose $ HM.alterF (\seenBefore ->
 175     -- Compose is used to return (letName, seenBefore) along seen
 176     -- in the same HashMap lookup.
 177     Compose $ return $ case seenBefore of
 178       Nothing ->
 179         ((letName, seenBefore), Just (letName, 0))
 180         where letName = unsafePerformIO $ makeLetName nodeName
 181       Just (letName, refCount) ->
 182         ((letName, seenBefore), Just (letName, refCount + 1))
 183     ) nodeName (oss_refs st)
 184   parentNames <- MT.ask
 185   if nodeName `HS.member` parentNames
 186   then do -- recursive reference to nodeName:
 187           -- update seen references
 188           -- and mark nodeName as recursive
 189     MT.lift $ MT.put st
 190       { oss_refs = seen
 191       , oss_recs = HS.insert nodeName (oss_recs st)
 192       }
 193     return $ ref True letName
 194   else do -- non-recursive reference to nodeName:
 195           -- update seen references
 196           -- and recurse if the nodeName hasn't been seen before
 197           -- (would be in a preceding sibling branch, not in parentNames).
 198     MT.lift $ MT.put st{ oss_refs = seen }
 199     if isNothing seenBefore
 200       then MT.local (HS.insert nodeName) (define letName <$> m)
 201       else return $ ref False letName
 202
 203 type instance Derived (SharingObserver letName sem) = SharingFinalizer letName sem
 204 instance
 205   ( Referenceable letName sem
 206   , MakeLetName letName
 207   , Eq letName
 208   , Hashable letName
 209   , Show letName
 210   ) => LiftDerived (SharingObserver letName sem) where
 211   liftDerived = observeSharingNode . SharingObserver . return
 212 instance
 213   ( Referenceable letName sem
 214   , MakeLetName letName
 215   , Eq letName
 216   , Hashable letName
 217   , Show letName
 218   ) => LiftDerived1 (SharingObserver letName sem) where
 219   liftDerived1 f a = observeSharingNode $ SharingObserver $
 220     f <$> unSharingObserver a
 221 instance
 222   ( Referenceable letName sem
 223   , MakeLetName letName
 224   , Eq letName
 225   , Hashable letName
 226   , Show letName
 227   ) => LiftDerived2 (SharingObserver letName sem) where
 228   liftDerived2 f a b = observeSharingNode $ SharingObserver $
 229     f <$> unSharingObserver a
 230       <*> unSharingObserver b
 231 instance
 232   ( Referenceable letName sem
 233   , MakeLetName letName
 234   , Eq letName
 235   , Hashable letName
 236   , Show letName
 237   ) => LiftDerived3 (SharingObserver letName sem) where
 238   liftDerived3 f a b c = observeSharingNode $ SharingObserver $
 239     f <$> unSharingObserver a
 240       <*> unSharingObserver b
 241       <*> unSharingObserver c
 242 instance
 243   ( Referenceable letName sem
 244   , MakeLetName letName
 245   , Eq letName
 246   , Hashable letName
 247   , Show letName
 248   ) => LiftDerived4 (SharingObserver letName sem) where
 249   liftDerived4 f a b c d = observeSharingNode $ SharingObserver $
 250     f <$> unSharingObserver a
 251       <*> unSharingObserver b
 252       <*> unSharingObserver c
 253       <*> unSharingObserver d
 254 instance Referenceable letName (SharingObserver letName sem) where
 255   ref = error "[BUG]: observeSharing MUST NOT be applied twice"
 256 instance Definable letName (SharingObserver letName sem) where
 257   define = error "[BUG]: observeSharing MUST NOT be applied twice"
 258 instance Letsable letName (SharingObserver letName sem) where
 259   lets = error "[BUG]: observeSharing MUST NOT be applied twice"
 260
 261 -- * Type 'SharingFinalizer'
 262 -- | Remove 'define' when non-recursive or unused
 263 -- or replace it by 'ref', moving 'define's to the top.
 264 newtype SharingFinalizer letName sem a = SharingFinalizer { unFinalizeSharing ::
 265   MT.ReaderT (HS.HashSet letName)
 266     (MT.Writer (LetBindings letName sem))
 267       (sem a) }
 268
 269 type instance Derived (SharingFinalizer _letName sem) = sem
 270 instance (Eq letName, Hashable letName) =>
 271   LiftDerived (SharingFinalizer letName sem) where
 272   liftDerived = SharingFinalizer . pure
 273 instance (Eq letName, Hashable letName) =>
 274   LiftDerived1 (SharingFinalizer letName sem) where
 275   liftDerived1 f a = SharingFinalizer $ f <$> unFinalizeSharing a
 276 instance (Eq letName, Hashable letName) =>
 277   LiftDerived2 (SharingFinalizer letName sem) where
 278   liftDerived2 f a b = SharingFinalizer $
 279     f <$> unFinalizeSharing a
 280       <*> unFinalizeSharing b
 281 instance (Eq letName, Hashable letName) =>
 282   LiftDerived3 (SharingFinalizer letName sem) where
 283   liftDerived3 f a b c = SharingFinalizer $
 284     f <$> unFinalizeSharing a
 285       <*> unFinalizeSharing b
 286       <*> unFinalizeSharing c
 287 instance (Eq letName, Hashable letName) =>
 288   LiftDerived4 (SharingFinalizer letName sem) where
 289   liftDerived4 f a b c d = SharingFinalizer $
 290     f <$> unFinalizeSharing a
 291       <*> unFinalizeSharing b
 292       <*> unFinalizeSharing c
 293       <*> unFinalizeSharing d
 294 instance
 295   ( Referenceable letName sem
 296   , Eq letName
 297   , Hashable letName
 298   , Show letName
 299   ) => Referenceable letName (SharingFinalizer letName sem) where
 300   ref isRec = liftDerived . ref isRec
 301 instance
 302   ( Referenceable letName sem
 303   , Eq letName
 304   , Hashable letName
 305   , Show letName
 306   ) => Definable letName (SharingFinalizer letName sem) where
 307   define name body = SharingFinalizer $ do
 308     refs <- MT.ask
 309     let (sem, defs) =
 310           MT.runWriter $ MT.runReaderT (unFinalizeSharing body) refs
 311     if name `HS.member` refs
 312       then do
 313         -- This 'define' is 'ref'erenced: move it into the result,
 314         -- to put it in scope even when some 'ref' to it exists outside of 'body'
 315         -- (which can happen when a body-expression is shared),
 316         -- and replace it by a 'ref'.
 317         MT.lift $ MT.tell $ HM.insert name (SomeLet sem) defs
 318         return $ ref False name
 319       else
 320         -- Remove this unreferenced 'define' node.
 321         unFinalizeSharing body
 322
 323 -- * Class 'Letsable'
 324 class Letsable letName sem where
 325   -- | @('lets' defs x)@ let-binds @(defs)@ in @(x)@.
 326   lets :: LetBindings letName sem -> sem a -> sem a
 327   lets defs = liftDerived1 (lets ((\(SomeLet val) -> SomeLet (derive val)) <$> defs))
 328   default lets ::
 329     Derivable sem =>
 330     FromDerived1 (Letsable letName) sem =>
 331     LetBindings letName sem -> sem a -> sem a
 332
 333 -- ** Type 'SomeLet'
 334 data SomeLet sem = forall a. SomeLet (sem a)
 335
 336 -- ** Type 'LetBindings'
 337 type LetBindings letName sem = HM.HashMap letName (SomeLet sem)
 338
 339 {-
 340 -- | Not used but can be written nonetheless.
 341 instance
 342   ( Letsable letName sem
 343   , Eq letName
 344   , Hashable letName
 345   , Show letName
 346   ) => Letsable letName (SharingFinalizer letName sem) where
 347   lets defs x = SharingFinalizer $ do
 348     ds <- traverse (\(SomeLet v) -> do
 349       r <- unFinalizeSharing v
 350       return (SomeLet r)
 351       ) defs
 352     MT.lift $ MT.tell ds
 353     unFinalizeSharing x
 354 -}
 355
 356 -- ** Type 'OpenRecs'
 357 -- | Mutually recursive terms, in open recursion style.
 358 type OpenRecs letName a = LetRecs letName (OpenRec letName a)
 359 -- | Mutually recursive term, in open recursion style.
 360 -- The term is given a @final@ (aka. @self@) map
 361 -- of other terms it can refer to (including itself).
 362 type OpenRec letName a = LetRecs letName a -> a
 363 -- | Recursive let bindings.
 364 type LetRecs letName = HM.HashMap letName
 365
 366 -- | Least fixpoint combinator.
 367 fix :: (a -> a) -> a
 368 fix f = final where final = f final
 369
 370 -- | Least fixpoint combinator of mutually recursive terms.
 371 -- @('mutualFix' opens)@ takes a container of terms
 372 -- in the open recursion style @(opens)@,
 373 -- and return that container of terms with their knots tied-up.
 374 --
 375 -- Used to express mutual recursion and to transparently introduce memoization.
 376 --
 377 -- Here all mutually dependent functions are restricted to the same polymorphic type @(a)@.
 378 -- See http://okmij.org/ftp/Computation/fixed-point-combinators.html#Poly-variadic
 379 mutualFix :: forall recs a. Functor recs => recs ({-finals-}recs a -> a) -> recs a
 380 mutualFix opens = fix f
 381   where
 382   f :: recs a -> recs a
 383   f recs = ($ recs) <$> opens