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