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 (Bool(..))
  11 import Data.Eq (Eq(..))
  12 import Data.Foldable (foldMap)
  13 import Data.Function (($), (.))
  14 import Data.Functor ((<$>))
  15 import Data.Functor.Compose (Compose(..))
  16 import Data.HashMap.Strict (HashMap)
  17 import Data.HashSet (HashSet)
  18 import Data.Hashable (Hashable, hashWithSalt, hash)
  19 import Data.Int (Int)
  20 import Data.Maybe (Maybe(..), isNothing)
  21 import Data.Monoid (Monoid(..))
  22 import Data.Ord (Ord(..))
  23 import Data.String (String)
  24 -- import GHC.Exts (Int(..))
  25 -- import GHC.Prim (unsafeCoerce#)
  26 import GHC.StableName (StableName(..), makeStableName, hashStableName, eqStableName)
  27 -- import Numeric (showHex)
  28 import Prelude ((+), error)
  29 import System.IO (IO)
  30 import System.IO.Unsafe (unsafePerformIO)
  31 import Text.Show (Show(..))
  32 import qualified Control.Monad.Trans.Class as MT
  33 import qualified Control.Monad.Trans.Reader as MT
  34 import qualified Control.Monad.Trans.State as MT
  35 import qualified Control.Monad.Trans.Writer as MT
  36 import qualified Data.HashMap.Strict as HM
  37 import qualified Data.HashSet as HS
  38
  39 import Symantic.Derive
  40
  41 -- * Class 'Letable'
  42 -- | This class is not for end-users like usual symantic operators,
  43 -- here 'shareable' and 'ref' are introduced by 'observeSharing'.
  44 class Letable letName repr where
  45   -- | @('ref' isRec letName)@ is a reference to @(letName)@.
  46   -- @(isRec)@ is 'True' iif. this 'ref'erence is recursive,
  47   -- ie. is reachable within its 'shareable' definition.
  48   ref :: Bool -> letName -> repr a
  49   ref isRec n = liftDerived (ref isRec n)
  50   default ref ::
  51     FromDerived (Letable letName) repr =>
  52     Bool -> letName -> repr a
  53
  54   -- | @('shareable' letName x)@ let-binds @(letName)@ to be equal to @(x)@.
  55   shareable :: letName -> repr a -> repr a
  56   shareable n = liftDerived1 (shareable n)
  57   default shareable ::
  58     FromDerived1 (Letable letName) repr =>
  59     letName -> repr a -> repr a
  60
  61 -- * Class 'MakeLetName'
  62 class MakeLetName letName where
  63   makeLetName :: SharingName -> IO letName
  64
  65 -- ** Type 'ShowLetName'
  66 -- | Useful on golden unit tests because 'StableName's
  67 -- change often when changing unrelated source code
  68 -- or even when changing basic GHC or executable flags.
  69 class ShowLetName (showName::Bool) letName where
  70   showLetName :: letName -> String
  71 -- | Like 'Show'.
  72 instance Show letName => ShowLetName 'True letName where
  73   showLetName = show
  74 -- | Always return @"<hidden>"@,
  75 instance ShowLetName 'False letName where
  76   showLetName _p = "<hidden>"
  77
  78 -- * Type 'SharingName'
  79 -- | Note that the observable sharing enabled by 'StableName'
  80 -- is not perfect as it will not observe all the sharing explicitely done.
  81 --
  82 -- Note also that the observed sharing could be different between ghc and ghci.
  83 data SharingName = forall a. SharingName (StableName a)
  84 -- | @('makeSharingName' x)@ is like @('makeStableName' x)@ but it also forces
  85 -- evaluation of @(x)@ to ensure that the 'StableName' is correct first time,
  86 -- which avoids to produce a tree bigger than needed.
  87 --
  88 -- Note that this function uses 'unsafePerformIO' instead of returning in 'IO',
  89 -- this is apparently required to avoid infinite loops due to unstable 'StableName'
  90 -- in compiled code, and sometimes also in ghci.
  91 --
  92 -- Note that maybe [pseq should be used here](https://gitlab.haskell.org/ghc/ghc/-/issues/2916).
  93 makeSharingName :: a -> SharingName
  94 makeSharingName !x = SharingName $ unsafePerformIO $ makeStableName x
  95
  96 instance Eq SharingName where
  97   SharingName x == SharingName y = eqStableName x y
  98 instance Hashable SharingName where
  99   hash (SharingName n) = hashStableName n
 100   hashWithSalt salt (SharingName n) = hashWithSalt salt n
 101 {-
 102 instance Show SharingName where
 103   showsPrec _ (SharingName n) = showHex (I# (unsafeCoerce# n))
 104 -}
 105
 106 -- * Type 'ObserveSharing'
 107 newtype ObserveSharing letName repr a = ObserveSharing { unObserveSharing ::
 108   MT.ReaderT (HashSet SharingName)
 109              (MT.State (ObserveSharingState letName))
 110              (FinalizeSharing letName repr a) }
 111
 112 -- | Interpreter detecting some (Haskell embedded) @let@ definitions used at
 113 -- least once and/or recursively, in order to replace them
 114 -- with the 'shareable' and 'ref' combinators.
 115 -- See [Type-safe observable sharing in Haskell](https://doi.org/10.1145/1596638.1596653)
 116 --
 117 -- Beware not to apply 'observeSharing' more than once on the same term
 118 -- otherwise some 'shareable' introduced by the first call
 119 -- would be removed by the second call.
 120 observeSharing ::
 121   Eq letName =>
 122   Hashable letName =>
 123   Show letName =>
 124   ObserveSharing letName repr a ->
 125   WithSharing letName repr a
 126 observeSharing (ObserveSharing m) =
 127   let (fs, st) = MT.runReaderT m mempty `MT.runState`
 128         ObserveSharingState
 129           { oss_refs = HM.empty
 130           , oss_recs = HS.empty
 131           } in
 132   let refs = HS.fromList $
 133         (`foldMap` oss_refs st) $ (\(letName, refCount) ->
 134           [letName | refCount > 0]) in
 135   --trace (show refs) $
 136   MT.runWriter $
 137     (`MT.runReaderT` refs) $
 138       unFinalizeSharing fs
 139
 140 -- ** Type 'SomeLet'
 141 data SomeLet repr = forall a. SomeLet (repr a)
 142
 143 -- ** Type 'WithSharing'
 144 type WithSharing letName repr a =
 145   (repr a, HM.HashMap letName (SomeLet repr))
 146 {-
 147 -- * Type 'WithSharing'
 148 data WithSharing letName repr a = WithSharing
 149   { lets :: HM.HashMap letName (SomeLet repr)
 150   , body :: repr a
 151   }
 152 mapWithSharing ::
 153   (forall v. repr v -> repr v) ->
 154   WithSharing letName repr a ->
 155   WithSharing letName repr a
 156 mapWithSharing f ws = WithSharing
 157   { lets = (\(SomeLet repr) -> SomeLet (f repr)) <$> lets ws
 158   , body = f (body ws)
 159   }
 160 -}
 161
 162 -- ** Type 'ObserveSharingState'
 163 data ObserveSharingState letName = ObserveSharingState
 164   { oss_refs :: HashMap SharingName (letName, Int)
 165   , oss_recs :: HashSet SharingName
 166     -- ^ TODO: unused so far, will it be useful somewhere at a later stage?
 167   }
 168
 169 observeSharingNode ::
 170   Eq letName =>
 171   Hashable letName =>
 172   Show letName =>
 173   Letable letName repr =>
 174   MakeLetName letName =>
 175   ObserveSharing letName repr a ->
 176   ObserveSharing letName repr a
 177 observeSharingNode (ObserveSharing m) = ObserveSharing $ do
 178   let nodeName = makeSharingName m
 179   st <- MT.lift MT.get
 180   ((letName, before), preds) <- getCompose $ HM.alterF (\before ->
 181     Compose $ case before of
 182       Nothing -> do
 183         let letName = unsafePerformIO $ makeLetName nodeName
 184         return ((letName, before), Just (letName, 0))
 185       Just (letName, refCount) -> do
 186         return ((letName, before), Just (letName, refCount + 1))
 187     ) nodeName (oss_refs st)
 188   parentNames <- MT.ask
 189   if nodeName `HS.member` parentNames
 190   then do
 191     MT.lift $ MT.put st
 192       { oss_refs = preds
 193       , oss_recs = HS.insert nodeName (oss_recs st)
 194       }
 195     return $ ref True letName
 196   else do
 197     MT.lift $ MT.put st{ oss_refs = preds }
 198     if isNothing before
 199       then MT.local (HS.insert nodeName) (shareable letName <$> m)
 200       else return $ ref False letName
 201
 202 type instance Derived (ObserveSharing letName repr) = FinalizeSharing letName repr
 203 instance
 204   ( Letable letName repr
 205   , MakeLetName letName
 206   , Eq letName
 207   , Hashable letName
 208   , Show letName
 209   ) => LiftDerived (ObserveSharing letName repr) where
 210   liftDerived = observeSharingNode . ObserveSharing . return
 211 instance
 212   ( Letable letName repr
 213   , MakeLetName letName
 214   , Eq letName
 215   , Hashable letName
 216   , Show letName
 217   ) => LiftDerived1 (ObserveSharing letName repr) where
 218   liftDerived1 f x = observeSharingNode $ ObserveSharing $
 219     f <$> unObserveSharing x
 220 instance
 221   ( Letable letName repr
 222   , MakeLetName letName
 223   , Eq letName
 224   , Hashable letName
 225   , Show letName
 226   ) => LiftDerived2 (ObserveSharing letName repr) where
 227   liftDerived2 f x y = observeSharingNode $ ObserveSharing $
 228     f <$> unObserveSharing x
 229       <*> unObserveSharing y
 230 instance
 231   ( Letable letName repr
 232   , MakeLetName letName
 233   , Eq letName
 234   , Hashable letName
 235   , Show letName
 236   ) => LiftDerived3 (ObserveSharing letName repr) where
 237   liftDerived3 f x y z = observeSharingNode $ ObserveSharing $
 238     f <$> unObserveSharing x
 239       <*> unObserveSharing y
 240       <*> unObserveSharing z
 241 instance Letable letName (ObserveSharing letName repr) where
 242   shareable = error "[BUG]: observeSharing MUST NOT be applied twice"
 243   ref = error "[BUG]: observeSharing MUST NOT be applied twice"
 244 instance Letsable letName (ObserveSharing letName repr) where
 245   lets = error "[BUG]: observeSharing MUST NOT be applied twice"
 246
 247 -- * Type 'FinalizeSharing'
 248 -- | Remove 'shareable' when non-recursive or unused
 249 -- or replace it by 'ref', moving 'shareable's to the top.
 250 newtype FinalizeSharing letName repr a = FinalizeSharing { unFinalizeSharing ::
 251   MT.ReaderT (HS.HashSet letName)
 252     (MT.Writer (LetBindings letName repr))
 253       (repr a) }
 254
 255 -- ** Type 'LetBindings'
 256 type LetBindings letName repr = HM.HashMap letName (SomeLet repr)
 257
 258 type instance Derived (FinalizeSharing _letName repr) = repr
 259 instance
 260   ( Eq letName
 261   , Hashable letName
 262   ) => LiftDerived (FinalizeSharing letName repr) where
 263   liftDerived = FinalizeSharing . pure
 264 instance
 265   ( Eq letName
 266   , Hashable letName
 267   ) => LiftDerived1 (FinalizeSharing letName repr) where
 268   liftDerived1 f x = FinalizeSharing $ f <$> unFinalizeSharing x
 269 instance
 270   ( Eq letName
 271   , Hashable letName
 272   ) => LiftDerived2 (FinalizeSharing letName repr) where
 273   liftDerived2 f x y = FinalizeSharing $
 274     f <$> unFinalizeSharing x
 275       <*> unFinalizeSharing y
 276 instance
 277   ( Eq letName
 278   , Hashable letName
 279   ) => LiftDerived3 (FinalizeSharing letName repr) where
 280   liftDerived3 f x y z = FinalizeSharing $
 281     f <$> unFinalizeSharing x
 282       <*> unFinalizeSharing y
 283       <*> unFinalizeSharing z
 284 instance
 285   ( Letable letName repr
 286   , Eq letName
 287   , Hashable letName
 288   , Show letName
 289   ) => Letable letName (FinalizeSharing letName repr) where
 290   shareable name x = FinalizeSharing $ do
 291     refs <- MT.ask
 292     if name `HS.member` refs
 293       -- This 'shareable' is 'ref'erenced, move it into the result,
 294       -- to put it in scope even when some 'ref' to it exists outside of 'x'
 295       -- (which can happen when a sub-expression is shared),
 296       -- and replace it by a 'ref'.
 297       then do
 298         let (repr, defs) = MT.runWriter $ MT.runReaderT (unFinalizeSharing x) refs
 299         MT.lift $ MT.tell $ HM.insert name (SomeLet repr) defs
 300         return $ ref False name
 301       -- Remove 'shareable'.
 302       else
 303         unFinalizeSharing x
 304
 305 -- * Class 'Letsable'
 306 class Letsable letName repr where
 307   -- | @('lets' defs x)@ let-binds @(defs)@ in @(x)@.
 308   lets :: LetBindings letName repr -> repr a -> repr a
 309   lets defs = liftDerived1 (lets ((\(SomeLet val) -> SomeLet (derive val)) <$> defs))
 310   default lets ::
 311     Derivable repr =>
 312     FromDerived1 (Letsable letName) repr =>
 313     LetBindings letName repr -> repr a -> repr a
 314 {-
 315 -- | Not used but can be written nonetheless.
 316 instance
 317   ( Letsable letName repr
 318   , Eq letName
 319   , Hashable letName
 320   , Show letName
 321   ) => Letsable letName (FinalizeSharing letName repr) where
 322   lets defs x = FinalizeSharing $ do
 323     ds <- traverse (\(SomeLet v) -> do
 324       r <- unFinalizeSharing v
 325       return (SomeLet r)
 326       ) defs
 327     MT.lift $ MT.tell ds
 328     unFinalizeSharing x
 329 -}