src/Symantic/Univariant/Letable.hs

   1 {-# LANGUAGE DefaultSignatures #-}
   2 {-# LANGUAGE ExistentialQuantification #-} -- For SharingName
   3 -- {-# LANGUAGE MagicHash #-} -- For unsafeCoerce#
   4 module Symantic.Univariant.Letable where
   5
   6 import Control.Applicative (Applicative(..))
   7 import Control.Monad (Monad(..))
   8 import Data.Bool (Bool(..))
   9 import Data.Eq (Eq(..))
  10 import Data.Foldable (foldMap)
  11 import Data.Function (($), (.))
  12 import Data.Functor ((<$>))
  13 import Data.Functor.Compose (Compose(..))
  14 import Data.HashMap.Strict (HashMap)
  15 import Data.HashSet (HashSet)
  16 import Data.Hashable (Hashable, hashWithSalt, hash)
  17 import Data.Int (Int)
  18 import Data.Maybe (Maybe(..), isNothing)
  19 import Data.Monoid (Monoid(..))
  20 import Data.Ord (Ord(..))
  21 -- import GHC.Exts (Int(..))
  22 -- import GHC.Prim (unsafeCoerce#)
  23 import GHC.StableName (StableName(..), makeStableName, hashStableName, eqStableName)
  24 -- import Numeric (showHex)
  25 import Prelude ((+))
  26 import System.IO (IO)
  27 import System.IO.Unsafe (unsafePerformIO)
  28 -- import Text.Show (Show(..))
  29 import qualified Control.Monad.Trans.Class as MT
  30 import qualified Control.Monad.Trans.Reader as MT
  31 import qualified Control.Monad.Trans.State as MT
  32 import qualified Data.HashMap.Strict as HM
  33 import qualified Data.HashSet as HS
  34
  35 import Symantic.Univariant.Trans
  36
  37 -- import Debug.Trace (trace)
  38
  39 -- * Class 'Letable'
  40 -- | This class is not for manual usage like usual symantic operators,
  41 -- here 'def' and 'ref' are introduced by 'observeSharing'.
  42 class Letable letName repr where
  43   -- | @('def' letName x)@ let-binds @(letName)@ to be equal to @(x)@.
  44   def :: letName -> repr a -> repr a
  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 'def'inition.
  48   ref :: Bool -> letName -> repr a
  49   default def ::
  50     Liftable1 repr => Letable letName (Output repr) =>
  51     letName -> repr a -> repr a
  52   default ref ::
  53     Liftable repr => Letable letName (Output repr) =>
  54     Bool -> letName -> repr a
  55   def n = lift1 (def n)
  56   ref r n = lift (ref r n)
  57
  58 -- * Class 'MakeLetName'
  59 class MakeLetName letName where
  60   makeLetName :: SharingName -> IO letName
  61
  62 -- * Type 'SharingName'
  63 -- | Note that the observable sharing enabled by 'StableName'
  64 -- is not perfect as it will not observe all the sharing explicitely done.
  65 --
  66 -- Note also that the observed sharing could be different between ghc and ghci.
  67 data SharingName = forall a. SharingName (StableName a)
  68 -- | @('makeSharingName' x)@ is like @('makeStableName' x)@ but it also forces
  69 -- evaluation of @(x)@ to ensure that the 'StableName' is correct first time,
  70 -- which avoids to produce a tree bigger than needed.
  71 --
  72 -- Note that this function uses 'unsafePerformIO' instead of returning in 'IO',
  73 -- this is apparently required to avoid infinite loops due to unstable 'StableName'
  74 -- in compiled code, and sometimes also in ghci.
  75 --
  76 -- Note that maybe [pseq should be used here](https://gitlab.haskell.org/ghc/ghc/-/issues/2916).
  77 makeSharingName :: a -> SharingName
  78 makeSharingName !x = SharingName $ unsafePerformIO $ makeStableName x
  79
  80 instance Eq SharingName where
  81   SharingName x == SharingName y = eqStableName x y
  82 instance Hashable SharingName where
  83   hash (SharingName n) = hashStableName n
  84   hashWithSalt salt (SharingName n) = hashWithSalt salt n
  85 {-
  86 instance Show SharingName where
  87   showsPrec _ (SharingName n) = showHex (I# (unsafeCoerce# n))
  88 -}
  89
  90 -- * Type 'ObserveSharing'
  91 -- | Interpreter detecting some (Haskell embedded) @let@ definitions used at
  92 -- least once and/or recursively, in order to replace them
  93 -- with the 'def' and 'ref' combinators.
  94 -- See [Type-safe observable sharing in Haskell](https://doi.org/10.1145/1596638.1596653)
  95 newtype ObserveSharing letName repr a = ObserveSharing { unObserveSharing ::
  96   MT.ReaderT (HashSet SharingName)
  97              (MT.State (ObserveSharingState letName))
  98              (CleanDefs letName repr a) }
  99
 100 observeSharing ::
 101   Eq letName =>
 102   Hashable letName =>
 103   ObserveSharing letName repr a -> repr a
 104 observeSharing (ObserveSharing m) = do
 105   let (a, st) = MT.runReaderT m mempty `MT.runState`
 106         ObserveSharingState
 107           { oss_refs = HM.empty
 108           , oss_recs = HS.empty
 109           }
 110   let refs = HS.fromList $
 111         (`foldMap` oss_refs st) $ (\(letName, refCount) ->
 112           if refCount > 0 then [letName] else [])
 113   -- trace (show refs) $
 114   unCleanDefs a refs
 115
 116 -- ** Type 'ObserveSharingState'
 117 data ObserveSharingState letName = ObserveSharingState
 118   { oss_refs :: HashMap SharingName (letName, Int)
 119   , oss_recs :: HashSet SharingName
 120     -- ^ TODO: unused so far, will it be useful somewhere at a later stage?
 121   }
 122
 123 observeSharingNode ::
 124   Eq letName =>
 125   Hashable letName =>
 126   Letable letName repr =>
 127   MakeLetName letName =>
 128   ObserveSharing letName repr a -> ObserveSharing letName repr a
 129 observeSharingNode (ObserveSharing m) = ObserveSharing $ do
 130   let nodeName = makeSharingName m
 131   st <- MT.lift MT.get
 132   ((letName, before), preds) <- getCompose $ HM.alterF (\before ->
 133     Compose $ case before of
 134       Nothing -> do
 135         let letName = unsafePerformIO $ makeLetName nodeName
 136         return ((letName, before), Just (letName, 0))
 137       Just (letName, refCount) -> do
 138         return ((letName, before), Just (letName, refCount + 1))
 139     ) nodeName (oss_refs st)
 140   parentNames <- MT.ask
 141   if nodeName `HS.member` parentNames
 142   then do
 143     MT.lift $ MT.put st
 144       { oss_refs = preds
 145       , oss_recs = HS.insert nodeName (oss_recs st)
 146       }
 147     return $ ref True letName
 148   else do
 149     MT.lift $ MT.put st{ oss_refs = preds }
 150     if isNothing before
 151       then MT.local (HS.insert nodeName) (def letName <$> m)
 152       else return $ ref False letName
 153
 154 type instance Output (ObserveSharing letName repr) = CleanDefs letName repr
 155 instance
 156   ( Letable letName repr
 157   , MakeLetName letName
 158   , Eq letName
 159   , Hashable letName
 160   ) => Trans (CleanDefs letName repr) (ObserveSharing letName repr) where
 161   trans = observeSharingNode . ObserveSharing . return
 162 instance
 163   ( Letable letName repr
 164   , MakeLetName letName
 165   , Eq letName
 166   , Hashable letName
 167   ) => Trans1 (CleanDefs letName repr) (ObserveSharing letName repr) where
 168   trans1 f x = observeSharingNode $ ObserveSharing $
 169     f <$> unObserveSharing x
 170 instance
 171   ( Letable letName repr
 172   , MakeLetName letName
 173   , Eq letName
 174   , Hashable letName
 175   ) => Trans2 (CleanDefs letName repr) (ObserveSharing letName repr) where
 176   trans2 f x y = observeSharingNode $ ObserveSharing $
 177     f <$> unObserveSharing x
 178       <*> unObserveSharing y
 179 instance
 180   ( Letable letName repr
 181   , MakeLetName letName
 182   , Eq letName
 183   , Hashable letName
 184   ) => Trans3 (CleanDefs letName repr) (ObserveSharing letName repr) where
 185   trans3 f x y z = observeSharingNode $ ObserveSharing $
 186     f <$> unObserveSharing x
 187       <*> unObserveSharing y
 188       <*> unObserveSharing z
 189 instance
 190   ( Letable letName repr
 191   , MakeLetName letName
 192   , Eq letName
 193   , Hashable letName
 194   ) => Letable letName (ObserveSharing letName repr)
 195
 196 -- * Type 'CleanDefs'
 197 -- | Remove 'def' when non-recursive or unused.
 198 newtype CleanDefs letName repr a = CleanDefs { unCleanDefs ::
 199   HS.HashSet letName -> repr a }
 200
 201 type instance Output (CleanDefs _letName repr) = repr
 202 instance Trans repr (CleanDefs letName repr) where
 203   trans = CleanDefs . pure
 204 instance Trans1 repr (CleanDefs letName repr) where
 205   trans1 f x = CleanDefs $ f <$> unCleanDefs x
 206 instance Trans2 repr (CleanDefs letName repr) where
 207   trans2 f x y = CleanDefs $
 208     f <$> unCleanDefs x
 209       <*> unCleanDefs y
 210 instance Trans3 repr (CleanDefs letName repr) where
 211   trans3 f x y z = CleanDefs $
 212     f <$> unCleanDefs x
 213       <*> unCleanDefs y
 214       <*> unCleanDefs z
 215 instance
 216   ( Letable letName repr
 217   , Eq letName
 218   , Hashable letName
 219   ) => Letable letName (CleanDefs letName repr) where
 220   def name x = CleanDefs $ \refs ->
 221     if name `HS.member` refs
 222     then -- Perserve 'def'
 223       def name $ unCleanDefs x refs
 224     else -- Remove 'def'
 225       unCleanDefs x refs