src/Symantic/Univariant/Letable.hs

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