src/Symantic/Typed/ObserveSharing.hs

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