]> Git — Sourcephile - haskell/symantic-base.git/blob - src/Symantic/Semantics/SharingObserver.hs
impl: gather in submodules
[haskell/symantic-base.git] / src / Symantic / Semantics / SharingObserver.hs
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
7
8 import Control.Applicative (Applicative(..))
9 import Control.Monad (Monad(..))
10 import Data.Bool
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)
18 import Data.Int (Int)
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)
27 import System.IO (IO)
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
36
37 import Symantic.Derive
38
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'.
47 --
48 -- TODO: index 'letName' with 'a' to enable dependent-map
49 ref :: Bool -> letName -> repr a
50 ref isRec name = liftDerived (ref isRec name)
51 default ref ::
52 FromDerived (Referenceable letName) repr =>
53 Bool -> letName -> repr a
54
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)
66 default define ::
67 FromDerived1 (Definable letName) repr =>
68 letName -> repr a -> repr a
69
70 -- * Class 'MakeLetName'
71 class MakeLetName letName where
72 makeLetName :: SharingName -> IO letName
73
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.
77 --
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.
83 --
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.
87 --
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
91
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
97 {-
98 instance Show SharingName where
99 showsPrec _ (SharingName n) = showHex (I# (unsafeCoerce# n))
100 -}
101
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) }
107
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)
112 --
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.
116 observeSharing ::
117 Eq letName =>
118 Hashable letName =>
119 Show letName =>
120 SharingObserver letName repr a ->
121 WithSharing letName repr a
122 observeSharing (SharingObserver m) =
123 let (fs, st) = MT.runReaderT m mempty `MT.runState`
124 SharingObserverState
125 { oss_refs = HM.empty
126 , oss_recs = HS.empty
127 } in
128 let refs = HS.fromList
129 [ letName
130 | (letName, refCount) <- HM.elems (oss_refs st)
131 , refCount > 0
132 ] in
133 --trace (show refs) $
134 MT.runWriter $
135 (`MT.runReaderT` refs) $
136 unFinalizeSharing fs
137
138 -- ** Type 'WithSharing'
139 type WithSharing letName repr a =
140 (repr a, HM.HashMap letName (SomeLet repr))
141 {-
142 -- * Type 'WithSharing'
143 data WithSharing letName repr a = WithSharing
144 { lets :: HM.HashMap letName (SomeLet repr)
145 , body :: repr a
146 }
147 mapWithSharing ::
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
153 , body = f (body ws)
154 }
155 -}
156
157 -- ** Type 'SharingObserverState'
158 data SharingObserverState letName = SharingObserverState
159 { oss_refs :: HashMap SharingName (letName, Int)
160 , oss_recs :: HashSet SharingName
161 }
162
163 observeSharingNode ::
164 Eq letName =>
165 Hashable letName =>
166 Show letName =>
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
173 st <- MT.lift MT.get
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
178 Nothing ->
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
189 MT.lift $ MT.put st
190 { oss_refs = seen
191 , oss_recs = HS.insert nodeName (oss_recs st)
192 }
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
202
203 type instance Derived (SharingObserver letName repr) = SharingFinalizer letName repr
204 instance
205 ( Referenceable letName repr
206 , MakeLetName letName
207 , Eq letName
208 , Hashable letName
209 , Show letName
210 ) => LiftDerived (SharingObserver letName repr) where
211 liftDerived = observeSharingNode . SharingObserver . return
212 instance
213 ( Referenceable letName repr
214 , MakeLetName letName
215 , Eq letName
216 , Hashable letName
217 , Show letName
218 ) => LiftDerived1 (SharingObserver letName repr) where
219 liftDerived1 f a = observeSharingNode $ SharingObserver $
220 f <$> unSharingObserver a
221 instance
222 ( Referenceable letName repr
223 , MakeLetName letName
224 , Eq letName
225 , Hashable letName
226 , Show letName
227 ) => LiftDerived2 (SharingObserver letName repr) where
228 liftDerived2 f a b = observeSharingNode $ SharingObserver $
229 f <$> unSharingObserver a
230 <*> unSharingObserver b
231 instance
232 ( Referenceable letName repr
233 , MakeLetName letName
234 , Eq letName
235 , Hashable letName
236 , Show 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
242 instance
243 ( Referenceable letName repr
244 , MakeLetName letName
245 , Eq letName
246 , Hashable letName
247 , Show 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"
260
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))
267 (repr a) }
268
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
294 instance
295 ( Referenceable letName repr
296 , Eq letName
297 , Hashable letName
298 , Show letName
299 ) => Referenceable letName (SharingFinalizer letName repr) where
300 ref isRec = liftDerived . ref isRec
301 instance
302 ( Referenceable letName repr
303 , Eq letName
304 , Hashable letName
305 , Show letName
306 ) => Definable letName (SharingFinalizer letName repr) where
307 define name body = SharingFinalizer $ do
308 refs <- MT.ask
309 let (repr, defs) =
310 MT.runWriter $ MT.runReaderT (unFinalizeSharing body) refs
311 if name `HS.member` refs
312 then do
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
319 else
320 -- Remove this unreferenced 'define' node.
321 unFinalizeSharing body
322
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))
328 default lets ::
329 Derivable repr =>
330 FromDerived1 (Letsable letName) repr =>
331 LetBindings letName repr -> repr a -> repr a
332
333 -- ** Type 'SomeLet'
334 data SomeLet repr = forall a. SomeLet (repr a)
335
336 -- ** Type 'LetBindings'
337 type LetBindings letName repr = HM.HashMap letName (SomeLet repr)
338
339 {-
340 -- | Not used but can be written nonetheless.
341 instance
342 ( Letsable letName repr
343 , Eq letName
344 , Hashable letName
345 , Show letName
346 ) => Letsable letName (SharingFinalizer letName repr) where
347 lets defs x = SharingFinalizer $ do
348 ds <- traverse (\(SomeLet v) -> do
349 r <- unFinalizeSharing v
350 return (SomeLet r)
351 ) defs
352 MT.lift $ MT.tell ds
353 unFinalizeSharing x
354 -}
355
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
365
366 -- | Least fixpoint combinator.
367 fix :: (a -> a) -> a
368 fix f = final where final = f final
369
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.
374 --
375 -- Used to express mutual recursion and to transparently introduce memoization.
376 --
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
381 where
382 f :: recs a -> recs a
383 f recs = ($ recs) <$> opens