]> Git — Sourcephile - haskell/symantic-base.git/blob - src/Symantic/Semantics/SharingObserver.hs
doc: update `ChangeLog.md`
[haskell/symantic-base.git] / src / Symantic / Semantics / SharingObserver.hs
1 -- For ShowLetName
2 {-# LANGUAGE AllowAmbiguousTypes #-}
3 -- For makeSharingName
4 {-# LANGUAGE BangPatterns #-}
5 -- For ShowLetName
6 {-# LANGUAGE DataKinds #-}
7 -- For SharingName
8 {-# LANGUAGE ExistentialQuantification #-}
9
10 -- {-# LANGUAGE MagicHash #-} -- For unsafeCoerce#
11 module Symantic.Semantics.SharingObserver where
12
13 import Control.Applicative (Applicative (..))
14 import Control.Monad (Monad (..))
15 import Data.Bool
16 import Data.Eq (Eq (..))
17 import Data.Function (($), (.))
18 import Data.Functor (Functor, (<$>))
19 import Data.Functor.Compose (Compose (..))
20 import Data.HashMap.Strict (HashMap)
21 import Data.HashSet (HashSet)
22 import Data.Hashable (Hashable, hash, hashWithSalt)
23 import Data.Int (Int)
24 import Data.Maybe (Maybe (..), isNothing)
25 import Data.Monoid (Monoid (..))
26 import Data.Ord (Ord (..))
27
28 -- import GHC.Exts (Int(..))
29 -- import GHC.Prim (unsafeCoerce#)
30 import GHC.StableName (StableName (..), eqStableName, hashStableName, makeStableName)
31
32 -- import Numeric (showHex)
33
34 import Control.Monad.Trans.Class qualified as MT
35 import Control.Monad.Trans.Reader qualified as MT
36 import Control.Monad.Trans.State qualified as MT
37 import Control.Monad.Trans.Writer qualified as MT
38 import Data.HashMap.Strict qualified as HM
39 import Data.HashSet qualified as HS
40 import System.IO (IO)
41 import System.IO.Unsafe (unsafePerformIO)
42 import Text.Show (Show (..))
43 import Prelude (error, (+))
44
45 import Symantic.Syntaxes.Derive
46
47 -- * Class 'Referenceable'
48
49 -- | This class is not for end-users like usual symantic operators,
50 -- though it will have to be defined on end-users' interpreters.
51 class Referenceable letName sem where
52 -- | @('ref' isRec letName)@ is a reference to @(letName)@.
53 -- It is introduced by 'observeSharing'.
54 -- @(isRec)@ is 'True' iif. this 'ref'erence is recursive,
55 -- ie. appears within its 'define'.
56 --
57 -- TODO: index 'letName' with 'a' to enable dependent-map
58 ref :: Bool -> letName -> sem a
59 ref isRec name = liftDerived (ref isRec name)
60 default ref ::
61 FromDerived (Referenceable letName) sem =>
62 Bool ->
63 letName ->
64 sem a
65
66 -- * Class 'Definable'
67
68 -- | This class is not for end-users like usual symantic operators.
69 -- There should be not need to use it outside this module,
70 -- because used 'define's are gathered in 'Letsable'.
71 class Definable letName sem where
72 -- | @('define' letName sub)@ let-binds @(letName)@ to be equal to @(sub)@.
73 -- This is a temporary node either replaced
74 -- by 'ref' and an entry in 'lets''s 'LetBindings',
75 -- or removed when no 'ref'erence is made to it.
76 define :: letName -> sem a -> sem a
77 define name = liftDerived1 (define name)
78 default define ::
79 FromDerived1 (Definable letName) sem =>
80 letName ->
81 sem a ->
82 sem a
83
84 -- * Class 'MakeLetName'
85 class MakeLetName letName where
86 makeLetName :: SharingName -> IO letName
87
88 -- * Type 'SharingName'
89
90 -- | Note that the observable sharing enabled by 'StableName'
91 -- is not perfect as it will not observe all the sharing explicitely done.
92 --
93 -- Note also that the observed sharing could be different between ghc and ghci.
94 data SharingName = forall a. SharingName (StableName a)
95
96 -- | @('makeSharingName' x)@ is like @('makeStableName' x)@ but it also forces
97 -- evaluation of @(x)@ to ensure that the 'StableName' is correct first time,
98 -- which avoids to produce a tree bigger than needed.
99 --
100 -- Note that this function uses 'unsafePerformIO' instead of returning in 'IO',
101 -- this is apparently required to avoid infinite loops due to unstable 'StableName'
102 -- in compiled code, and sometimes also in ghci.
103 --
104 -- Note that maybe [pseq should be used here](https://gitlab.haskell.org/ghc/ghc/-/issues/2916).
105 makeSharingName :: a -> SharingName
106 makeSharingName !x = SharingName $ unsafePerformIO $ makeStableName x
107
108 instance Eq SharingName where
109 SharingName x == SharingName y = eqStableName x y
110 instance Hashable SharingName where
111 hash (SharingName n) = hashStableName n
112 hashWithSalt salt (SharingName n) = hashWithSalt salt n
113
114 {-
115 instance Show SharingName where
116 showsPrec _ (SharingName n) = showHex (I# (unsafeCoerce# n))
117 -}
118
119 -- * Type 'SharingObserver'
120 newtype SharingObserver letName sem a = SharingObserver
121 { unSharingObserver ::
122 MT.ReaderT
123 (HashSet SharingName)
124 (MT.State (SharingObserverState letName))
125 (SharingFinalizer letName sem a)
126 }
127
128 -- | Interpreter detecting some (Haskell embedded) @let@ definitions used at
129 -- least once and/or recursively, in order to replace them
130 -- with the 'lets' and 'ref' combinators.
131 -- See [Type-safe observable sharing in Haskell](https://doi.org/10.1145/1596638.1596653)
132 --
133 -- Beware not to apply 'observeSharing' more than once on the same term
134 -- otherwise some 'define' introduced by the first call
135 -- would be removed by the second call.
136 observeSharing ::
137 Eq letName =>
138 Hashable letName =>
139 Show letName =>
140 SharingObserver letName sem a ->
141 WithSharing letName sem a
142 observeSharing (SharingObserver m) =
143 let (fs, st) =
144 MT.runReaderT m mempty
145 `MT.runState` SharingObserverState
146 { oss_refs = HM.empty
147 , oss_recs = HS.empty
148 }
149 in let refs =
150 HS.fromList
151 [ letName
152 | (letName, refCount) <- HM.elems (oss_refs st)
153 , refCount > 0
154 ]
155 in --trace (show refs) $
156 MT.runWriter $
157 (`MT.runReaderT` refs) $
158 unFinalizeSharing fs
159
160 -- ** Type 'WithSharing'
161 type WithSharing letName sem a =
162 (sem a, HM.HashMap letName (SomeLet sem))
163
164 {-
165 -- * Type 'WithSharing'
166 data WithSharing letName sem a = WithSharing
167 { lets :: HM.HashMap letName (SomeLet sem)
168 , body :: sem a
169 }
170 mapWithSharing ::
171 (forall v. sem v -> sem v) ->
172 WithSharing letName sem a ->
173 WithSharing letName sem a
174 mapWithSharing f ws = WithSharing
175 { lets = (\(SomeLet sem) -> SomeLet (f sem)) <$> lets ws
176 , body = f (body ws)
177 }
178 -}
179
180 -- ** Type 'SharingObserverState'
181 data SharingObserverState letName = SharingObserverState
182 { oss_refs :: HashMap SharingName (letName, Int)
183 , oss_recs :: HashSet SharingName
184 }
185
186 observeSharingNode ::
187 Eq letName =>
188 Hashable letName =>
189 Show letName =>
190 Referenceable letName sem =>
191 MakeLetName letName =>
192 SharingObserver letName sem a ->
193 SharingObserver letName sem a
194 observeSharingNode (SharingObserver m) = SharingObserver $ do
195 let nodeName = makeSharingName m
196 st <- MT.lift MT.get
197 ((letName, seenBefore), seen) <-
198 getCompose $
199 HM.alterF
200 ( \seenBefore ->
201 -- Compose is used to return (letName, seenBefore) along seen
202 -- in the same HashMap lookup.
203 Compose $
204 return $ case seenBefore of
205 Nothing ->
206 ((letName, seenBefore), Just (letName, 0))
207 where
208 letName = unsafePerformIO $ makeLetName nodeName
209 Just (letName, refCount) ->
210 ((letName, seenBefore), Just (letName, refCount + 1))
211 )
212 nodeName
213 (oss_refs st)
214 parentNames <- MT.ask
215 if nodeName `HS.member` parentNames
216 then do
217 -- recursive reference to nodeName:
218 -- update seen references
219 -- and mark nodeName as recursive
220 MT.lift $
221 MT.put
222 st
223 { oss_refs = seen
224 , oss_recs = HS.insert nodeName (oss_recs st)
225 }
226 return $ ref True letName
227 else do
228 -- non-recursive reference to nodeName:
229 -- update seen references
230 -- and recurse if the nodeName hasn't been seen before
231 -- (would be in a preceding sibling branch, not in parentNames).
232 MT.lift $ MT.put st{oss_refs = seen}
233 if isNothing seenBefore
234 then MT.local (HS.insert nodeName) (define letName <$> m)
235 else return $ ref False letName
236
237 type instance Derived (SharingObserver letName sem) = SharingFinalizer letName sem
238 instance
239 ( Referenceable letName sem
240 , MakeLetName letName
241 , Eq letName
242 , Hashable letName
243 , Show letName
244 ) =>
245 LiftDerived (SharingObserver letName sem)
246 where
247 liftDerived = observeSharingNode . SharingObserver . return
248 instance
249 ( Referenceable letName sem
250 , MakeLetName letName
251 , Eq letName
252 , Hashable letName
253 , Show letName
254 ) =>
255 LiftDerived1 (SharingObserver letName sem)
256 where
257 liftDerived1 f a =
258 observeSharingNode $
259 SharingObserver $
260 f <$> unSharingObserver a
261 instance
262 ( Referenceable letName sem
263 , MakeLetName letName
264 , Eq letName
265 , Hashable letName
266 , Show letName
267 ) =>
268 LiftDerived2 (SharingObserver letName sem)
269 where
270 liftDerived2 f a b =
271 observeSharingNode $
272 SharingObserver $
273 f <$> unSharingObserver a
274 <*> unSharingObserver b
275 instance
276 ( Referenceable letName sem
277 , MakeLetName letName
278 , Eq letName
279 , Hashable letName
280 , Show letName
281 ) =>
282 LiftDerived3 (SharingObserver letName sem)
283 where
284 liftDerived3 f a b c =
285 observeSharingNode $
286 SharingObserver $
287 f <$> unSharingObserver a
288 <*> unSharingObserver b
289 <*> unSharingObserver c
290 instance
291 ( Referenceable letName sem
292 , MakeLetName letName
293 , Eq letName
294 , Hashable letName
295 , Show letName
296 ) =>
297 LiftDerived4 (SharingObserver letName sem)
298 where
299 liftDerived4 f a b c d =
300 observeSharingNode $
301 SharingObserver $
302 f <$> unSharingObserver a
303 <*> unSharingObserver b
304 <*> unSharingObserver c
305 <*> unSharingObserver d
306 instance Referenceable letName (SharingObserver letName sem) where
307 ref = error "[BUG]: observeSharing MUST NOT be applied twice"
308 instance Definable letName (SharingObserver letName sem) where
309 define = error "[BUG]: observeSharing MUST NOT be applied twice"
310 instance Letsable letName (SharingObserver letName sem) where
311 lets = error "[BUG]: observeSharing MUST NOT be applied twice"
312
313 -- * Type 'SharingFinalizer'
314
315 -- | Remove 'define' when non-recursive or unused
316 -- or replace it by 'ref', moving 'define's to the top.
317 newtype SharingFinalizer letName sem a = SharingFinalizer
318 { unFinalizeSharing ::
319 MT.ReaderT
320 (HS.HashSet letName)
321 (MT.Writer (LetBindings letName sem))
322 (sem a)
323 }
324
325 type instance Derived (SharingFinalizer _letName sem) = sem
326 instance
327 (Eq letName, Hashable letName) =>
328 LiftDerived (SharingFinalizer letName sem)
329 where
330 liftDerived = SharingFinalizer . pure
331 instance
332 (Eq letName, Hashable letName) =>
333 LiftDerived1 (SharingFinalizer letName sem)
334 where
335 liftDerived1 f a = SharingFinalizer $ f <$> unFinalizeSharing a
336 instance
337 (Eq letName, Hashable letName) =>
338 LiftDerived2 (SharingFinalizer letName sem)
339 where
340 liftDerived2 f a b =
341 SharingFinalizer $
342 f <$> unFinalizeSharing a
343 <*> unFinalizeSharing b
344 instance
345 (Eq letName, Hashable letName) =>
346 LiftDerived3 (SharingFinalizer letName sem)
347 where
348 liftDerived3 f a b c =
349 SharingFinalizer $
350 f <$> unFinalizeSharing a
351 <*> unFinalizeSharing b
352 <*> unFinalizeSharing c
353 instance
354 (Eq letName, Hashable letName) =>
355 LiftDerived4 (SharingFinalizer letName sem)
356 where
357 liftDerived4 f a b c d =
358 SharingFinalizer $
359 f <$> unFinalizeSharing a
360 <*> unFinalizeSharing b
361 <*> unFinalizeSharing c
362 <*> unFinalizeSharing d
363 instance
364 ( Referenceable letName sem
365 , Eq letName
366 , Hashable letName
367 , Show letName
368 ) =>
369 Referenceable letName (SharingFinalizer letName sem)
370 where
371 ref isRec = liftDerived . ref isRec
372 instance
373 ( Referenceable letName sem
374 , Eq letName
375 , Hashable letName
376 , Show letName
377 ) =>
378 Definable letName (SharingFinalizer letName sem)
379 where
380 define name body = SharingFinalizer $ do
381 refs <- MT.ask
382 let (sem, defs) =
383 MT.runWriter $ MT.runReaderT (unFinalizeSharing body) refs
384 if name `HS.member` refs
385 then do
386 -- This 'define' is 'ref'erenced: move it into the result,
387 -- to put it in scope even when some 'ref' to it exists outside of 'body'
388 -- (which can happen when a body-expression is shared),
389 -- and replace it by a 'ref'.
390 MT.lift $ MT.tell $ HM.insert name (SomeLet sem) defs
391 return $ ref False name
392 else -- Remove this unreferenced 'define' node.
393 unFinalizeSharing body
394
395 -- * Class 'Letsable'
396 class Letsable letName sem where
397 -- | @('lets' defs x)@ let-binds @(defs)@ in @(x)@.
398 lets :: LetBindings letName sem -> sem a -> sem a
399 lets defs = liftDerived1 (lets ((\(SomeLet val) -> SomeLet (derive val)) <$> defs))
400 default lets ::
401 Derivable sem =>
402 FromDerived1 (Letsable letName) sem =>
403 LetBindings letName sem ->
404 sem a ->
405 sem a
406
407 -- ** Type 'SomeLet'
408 data SomeLet sem = forall a. SomeLet (sem a)
409
410 -- ** Type 'LetBindings'
411 type LetBindings letName sem = HM.HashMap letName (SomeLet sem)
412
413 {-
414 -- | Not used but can be written nonetheless.
415 instance
416 ( Letsable letName sem
417 , Eq letName
418 , Hashable letName
419 , Show letName
420 ) => Letsable letName (SharingFinalizer letName sem) where
421 lets defs x = SharingFinalizer $ do
422 ds <- traverse (\(SomeLet v) -> do
423 r <- unFinalizeSharing v
424 return (SomeLet r)
425 ) defs
426 MT.lift $ MT.tell ds
427 unFinalizeSharing x
428 -}
429
430 -- ** Type 'OpenRecs'
431
432 -- | Mutually recursive terms, in open recursion style.
433 type OpenRecs letName a = LetRecs letName (OpenRec letName a)
434
435 -- | Mutually recursive term, in open recursion style.
436 -- The term is given a @final@ (aka. @self@) map
437 -- of other terms it can refer to (including itself).
438 type OpenRec letName a = LetRecs letName a -> a
439
440 -- | Recursive let bindings.
441 type LetRecs letName = HM.HashMap letName
442
443 -- | Least fixpoint combinator.
444 fix :: (a -> a) -> a
445 fix f = final where final = f final
446
447 -- | Least fixpoint combinator of mutually recursive terms.
448 -- @('mutualFix' opens)@ takes a container of terms
449 -- in the open recursion style @(opens)@,
450 -- and return that container of terms with their knots tied-up.
451 --
452 -- Used to express mutual recursion and to transparently introduce memoization.
453 --
454 -- Here all mutually dependent functions are restricted to the same polymorphic type @(a)@.
455 -- See http://okmij.org/ftp/Computation/fixed-point-combinators.html#Poly-variadic
456 mutualFix :: forall recs a. Functor recs => recs ({-finals-} recs a -> a) -> recs a
457 mutualFix opens = fix f
458 where
459 f :: recs a -> recs a
460 f recs = ($ recs) <$> opens