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