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