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