src/Symantic/Semantics/SharingObserver.hs

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