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