1 {-# LANGUAGE AllowAmbiguousTypes #-} -- For ShowLetName
2 {-# LANGUAGE BangPatterns #-} -- For makeSharingName
3 {-# LANGUAGE DataKinds #-} -- For ShowLetName
4 {-# LANGUAGE ExistentialQuantification #-} -- For SharingName
5 -- {-# LANGUAGE MagicHash #-} -- For unsafeCoerce#
6 module Symantic.SharingObserver where
8 import Control.Applicative (Applicative(..))
9 import Control.Monad (Monad(..))
11 import Data.Eq (Eq(..))
12 import Data.Function (($), (.))
13 import Data.Functor (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)
19 import Data.Maybe (Maybe(..), isNothing)
20 import Data.Monoid (Monoid(..))
21 import Data.Ord (Ord(..))
22 -- import GHC.Exts (Int(..))
23 -- import GHC.Prim (unsafeCoerce#)
24 import GHC.StableName (StableName(..), makeStableName, hashStableName, eqStableName)
25 -- import Numeric (showHex)
26 import Prelude ((+), error)
28 import System.IO.Unsafe (unsafePerformIO)
29 import Text.Show (Show(..))
30 import qualified Control.Monad.Trans.Class as MT
31 import qualified Control.Monad.Trans.Reader as MT
32 import qualified Control.Monad.Trans.State as MT
33 import qualified Control.Monad.Trans.Writer as MT
34 import qualified Data.HashMap.Strict as HM
35 import qualified Data.HashSet as HS
37 import Symantic.Derive
39 -- * Class 'Referenceable'
40 -- | This class is not for end-users like usual symantic operators,
41 -- though it will have to be defined on end-users' interpreters.
42 class Referenceable letName repr where
43 -- | @('ref' isRec letName)@ is a reference to @(letName)@.
44 -- It is introduced by 'observeSharing'.
45 -- @(isRec)@ is 'True' iif. this 'ref'erence is recursive,
46 -- ie. appears within its 'define'.
48 -- TODO: index 'letName' with 'a' to enable dependent-map
49 ref :: Bool -> letName -> repr a
50 ref isRec name = liftDerived (ref isRec name)
52 FromDerived (Referenceable letName) repr =>
53 Bool -> letName -> repr a
55 -- * Class 'Definable'
56 -- | This class is not for end-users like usual symantic operators.
57 -- There should be not need to use it outside this module,
58 -- because used 'define's are gathered in 'Letsable'.
59 class Definable letName repr where
60 -- | @('define' letName sub)@ let-binds @(letName)@ to be equal to @(sub)@.
61 -- This is a temporary node either replaced
62 -- by 'ref' and an entry in 'lets''s 'LetBindings',
63 -- or removed when no 'ref'erence is made to it.
64 define :: letName -> repr a -> repr a
65 define name = liftDerived1 (define name)
67 FromDerived1 (Definable letName) repr =>
68 letName -> repr a -> repr a
70 -- * Class 'MakeLetName'
71 class MakeLetName letName where
72 makeLetName :: SharingName -> IO letName
74 -- * Type 'SharingName'
75 -- | Note that the observable sharing enabled by 'StableName'
76 -- is not perfect as it will not observe all the sharing explicitely done.
78 -- Note also that the observed sharing could be different between ghc and ghci.
79 data SharingName = forall a. SharingName (StableName a)
80 -- | @('makeSharingName' x)@ is like @('makeStableName' x)@ but it also forces
81 -- evaluation of @(x)@ to ensure that the 'StableName' is correct first time,
82 -- which avoids to produce a tree bigger than needed.
84 -- Note that this function uses 'unsafePerformIO' instead of returning in 'IO',
85 -- this is apparently required to avoid infinite loops due to unstable 'StableName'
86 -- in compiled code, and sometimes also in ghci.
88 -- Note that maybe [pseq should be used here](https://gitlab.haskell.org/ghc/ghc/-/issues/2916).
89 makeSharingName :: a -> SharingName
90 makeSharingName !x = SharingName $ unsafePerformIO $ makeStableName x
92 instance Eq SharingName where
93 SharingName x == SharingName y = eqStableName x y
94 instance Hashable SharingName where
95 hash (SharingName n) = hashStableName n
96 hashWithSalt salt (SharingName n) = hashWithSalt salt n
98 instance Show SharingName where
99 showsPrec _ (SharingName n) = showHex (I# (unsafeCoerce# n))
102 -- * Type 'SharingObserver'
103 newtype SharingObserver letName repr a = SharingObserver { unSharingObserver ::
104 MT.ReaderT (HashSet SharingName)
105 (MT.State (SharingObserverState letName))
106 (SharingFinalizer letName repr a) }
108 -- | Interpreter detecting some (Haskell embedded) @let@ definitions used at
109 -- least once and/or recursively, in order to replace them
110 -- with the 'lets' and 'ref' combinators.
111 -- See [Type-safe observable sharing in Haskell](https://doi.org/10.1145/1596638.1596653)
113 -- Beware not to apply 'observeSharing' more than once on the same term
114 -- otherwise some 'define' introduced by the first call
115 -- would be removed by the second call.
120 SharingObserver letName repr a ->
121 WithSharing letName repr a
122 observeSharing (SharingObserver m) =
123 let (fs, st) = MT.runReaderT m mempty `MT.runState`
125 { oss_refs = HM.empty
126 , oss_recs = HS.empty
128 let refs = HS.fromList
130 | (letName, refCount) <- HM.elems (oss_refs st)
133 --trace (show refs) $
135 (`MT.runReaderT` refs) $
138 -- ** Type 'WithSharing'
139 type WithSharing letName repr a =
140 (repr a, HM.HashMap letName (SomeLet repr))
142 -- * Type 'WithSharing'
143 data WithSharing letName repr a = WithSharing
144 { lets :: HM.HashMap letName (SomeLet repr)
148 (forall v. repr v -> repr v) ->
149 WithSharing letName repr a ->
150 WithSharing letName repr a
151 mapWithSharing f ws = WithSharing
152 { lets = (\(SomeLet repr) -> SomeLet (f repr)) <$> lets ws
157 -- ** Type 'SharingObserverState'
158 data SharingObserverState letName = SharingObserverState
159 { oss_refs :: HashMap SharingName (letName, Int)
160 , oss_recs :: HashSet SharingName
163 observeSharingNode ::
167 Referenceable letName repr =>
168 MakeLetName letName =>
169 SharingObserver letName repr a ->
170 SharingObserver letName repr a
171 observeSharingNode (SharingObserver m) = SharingObserver $ do
172 let nodeName = makeSharingName m
174 ((letName, seenBefore), seen) <- getCompose $ HM.alterF (\seenBefore ->
175 -- Compose is used to return (letName, seenBefore) along seen
176 -- in the same HashMap lookup.
177 Compose $ return $ case seenBefore of
179 ((letName, seenBefore), Just (letName, 0))
180 where letName = unsafePerformIO $ makeLetName nodeName
181 Just (letName, refCount) ->
182 ((letName, seenBefore), Just (letName, refCount + 1))
183 ) nodeName (oss_refs st)
184 parentNames <- MT.ask
185 if nodeName `HS.member` parentNames
186 then do -- recursive reference to nodeName:
187 -- update seen references
188 -- and mark nodeName as recursive
191 , oss_recs = HS.insert nodeName (oss_recs st)
193 return $ ref True letName
194 else do -- non-recursive reference to nodeName:
195 -- update seen references
196 -- and recurse if the nodeName hasn't been seen before
197 -- (would be in a preceding sibling branch, not in parentNames).
198 MT.lift $ MT.put st{ oss_refs = seen }
199 if isNothing seenBefore
200 then MT.local (HS.insert nodeName) (define letName <$> m)
201 else return $ ref False letName
203 type instance Derived (SharingObserver letName repr) = SharingFinalizer letName repr
205 ( Referenceable letName repr
206 , MakeLetName letName
210 ) => LiftDerived (SharingObserver letName repr) where
211 liftDerived = observeSharingNode . SharingObserver . return
213 ( Referenceable letName repr
214 , MakeLetName letName
218 ) => LiftDerived1 (SharingObserver letName repr) where
219 liftDerived1 f a = observeSharingNode $ SharingObserver $
220 f <$> unSharingObserver a
222 ( Referenceable letName repr
223 , MakeLetName letName
227 ) => LiftDerived2 (SharingObserver letName repr) where
228 liftDerived2 f a b = observeSharingNode $ SharingObserver $
229 f <$> unSharingObserver a
230 <*> unSharingObserver b
232 ( Referenceable letName repr
233 , MakeLetName letName
237 ) => LiftDerived3 (SharingObserver letName repr) where
238 liftDerived3 f a b c = observeSharingNode $ SharingObserver $
239 f <$> unSharingObserver a
240 <*> unSharingObserver b
241 <*> unSharingObserver c
243 ( Referenceable letName repr
244 , MakeLetName letName
248 ) => LiftDerived4 (SharingObserver letName repr) where
249 liftDerived4 f a b c d = observeSharingNode $ SharingObserver $
250 f <$> unSharingObserver a
251 <*> unSharingObserver b
252 <*> unSharingObserver c
253 <*> unSharingObserver d
254 instance Referenceable letName (SharingObserver letName repr) where
255 ref = error "[BUG]: observeSharing MUST NOT be applied twice"
256 instance Definable letName (SharingObserver letName repr) where
257 define = error "[BUG]: observeSharing MUST NOT be applied twice"
258 instance Letsable letName (SharingObserver letName repr) where
259 lets = error "[BUG]: observeSharing MUST NOT be applied twice"
261 -- * Type 'SharingFinalizer'
262 -- | Remove 'define' when non-recursive or unused
263 -- or replace it by 'ref', moving 'define's to the top.
264 newtype SharingFinalizer letName repr a = SharingFinalizer { unFinalizeSharing ::
265 MT.ReaderT (HS.HashSet letName)
266 (MT.Writer (LetBindings letName repr))
269 type instance Derived (SharingFinalizer _letName repr) = repr
270 instance (Eq letName, Hashable letName) =>
271 LiftDerived (SharingFinalizer letName repr) where
272 liftDerived = SharingFinalizer . pure
273 instance (Eq letName, Hashable letName) =>
274 LiftDerived1 (SharingFinalizer letName repr) where
275 liftDerived1 f a = SharingFinalizer $ f <$> unFinalizeSharing a
276 instance (Eq letName, Hashable letName) =>
277 LiftDerived2 (SharingFinalizer letName repr) where
278 liftDerived2 f a b = SharingFinalizer $
279 f <$> unFinalizeSharing a
280 <*> unFinalizeSharing b
281 instance (Eq letName, Hashable letName) =>
282 LiftDerived3 (SharingFinalizer letName repr) where
283 liftDerived3 f a b c = SharingFinalizer $
284 f <$> unFinalizeSharing a
285 <*> unFinalizeSharing b
286 <*> unFinalizeSharing c
287 instance (Eq letName, Hashable letName) =>
288 LiftDerived4 (SharingFinalizer letName repr) where
289 liftDerived4 f a b c d = SharingFinalizer $
290 f <$> unFinalizeSharing a
291 <*> unFinalizeSharing b
292 <*> unFinalizeSharing c
293 <*> unFinalizeSharing d
295 ( Referenceable letName repr
299 ) => Referenceable letName (SharingFinalizer letName repr) where
300 ref isRec = liftDerived . ref isRec
302 ( Referenceable letName repr
306 ) => Definable letName (SharingFinalizer letName repr) where
307 define name body = SharingFinalizer $ do
310 MT.runWriter $ MT.runReaderT (unFinalizeSharing body) refs
311 if name `HS.member` refs
313 -- This 'define' is 'ref'erenced: move it into the result,
314 -- to put it in scope even when some 'ref' to it exists outside of 'body'
315 -- (which can happen when a body-expression is shared),
316 -- and replace it by a 'ref'.
317 MT.lift $ MT.tell $ HM.insert name (SomeLet repr) defs
318 return $ ref False name
320 -- Remove this unreferenced 'define' node.
321 unFinalizeSharing body
323 -- * Class 'Letsable'
324 class Letsable letName repr where
325 -- | @('lets' defs x)@ let-binds @(defs)@ in @(x)@.
326 lets :: LetBindings letName repr -> repr a -> repr a
327 lets defs = liftDerived1 (lets ((\(SomeLet val) -> SomeLet (derive val)) <$> defs))
330 FromDerived1 (Letsable letName) repr =>
331 LetBindings letName repr -> repr a -> repr a
334 data SomeLet repr = forall a. SomeLet (repr a)
336 -- ** Type 'LetBindings'
337 type LetBindings letName repr = HM.HashMap letName (SomeLet repr)
340 -- | Not used but can be written nonetheless.
342 ( Letsable letName repr
346 ) => Letsable letName (SharingFinalizer letName repr) where
347 lets defs x = SharingFinalizer $ do
348 ds <- traverse (\(SomeLet v) -> do
349 r <- unFinalizeSharing v
356 -- ** Type 'OpenRecs'
357 -- | Mutually recursive terms, in open recursion style.
358 type OpenRecs letName a = LetRecs letName (OpenRec letName a)
359 -- | Mutually recursive term, in open recursion style.
360 -- The term is given a @final@ (aka. @self@) map
361 -- of other terms it can refer to (including itself).
362 type OpenRec letName a = LetRecs letName a -> a
363 -- | Recursive let bindings.
364 type LetRecs letName = HM.HashMap letName
366 -- | Least fixpoint combinator.
368 fix f = final where final = f final
370 -- | Least fixpoint combinator of mutually recursive terms.
371 -- @('mutualFix' opens)@ takes a container of terms
372 -- in the open recursion style @(opens)@,
373 -- and return that container of terms with their knots tied-up.
375 -- Used to express mutual recursion and to transparently introduce memoization.
377 -- Here all mutually dependent functions are restricted to the same polymorphic type @(a)@.
378 -- See http://okmij.org/ftp/Computation/fixed-point-combinators.html#Poly-variadic
379 mutualFix :: forall recs a. Functor recs => recs ({-finals-}recs a -> a) -> recs a
380 mutualFix opens = fix f
382 f :: recs a -> recs a
383 f recs = ($ recs) <$> opens