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