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