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
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 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)
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
38 import Symantic.Derive
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 'def'inition.
49 -- TODO: index 'letName' with 'a' to enable dependent-map
50 ref :: Bool -> letName -> repr a
51 ref isRec name = liftDerived (ref isRec name)
53 FromDerived (Referenceable letName) repr =>
54 Bool -> letName -> repr a
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 'def'initions are gathered in 'Letsable'.
60 class Definable letName repr where
61 -- | @('def' 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 def :: letName -> repr a -> repr a
66 def name = liftDerived1 (def name)
68 FromDerived1 (Definable letName) repr =>
69 letName -> repr a -> repr a
71 -- * Class 'MakeLetName'
72 class MakeLetName letName where
73 makeLetName :: SharingName -> IO letName
75 -- ** Type 'ShowLetName'
76 -- | Useful on golden unit tests because 'StableName's
77 -- change often when changing unrelated source code
78 -- or even when changing basic GHC or executable flags.
79 class ShowLetName (showName::Bool) letName where
80 showLetName :: letName -> String
82 instance Show letName => ShowLetName 'True letName where
84 -- | Always return @"<hidden>"@,
85 instance ShowLetName 'False letName where
86 showLetName _p = "<hidden>"
88 -- * Type 'SharingName'
89 -- | Note that the observable sharing enabled by 'StableName'
90 -- is not perfect as it will not observe all the sharing explicitely done.
92 -- Note also that the observed sharing could be different between ghc and ghci.
93 data SharingName = forall a. SharingName (StableName a)
94 -- | @('makeSharingName' x)@ is like @('makeStableName' x)@ but it also forces
95 -- evaluation of @(x)@ to ensure that the 'StableName' is correct first time,
96 -- which avoids to produce a tree bigger than needed.
98 -- Note that this function uses 'unsafePerformIO' instead of returning in 'IO',
99 -- this is apparently required to avoid infinite loops due to unstable 'StableName'
100 -- in compiled code, and sometimes also in ghci.
102 -- Note that maybe [pseq should be used here](https://gitlab.haskell.org/ghc/ghc/-/issues/2916).
103 makeSharingName :: a -> SharingName
104 makeSharingName !x = SharingName $ unsafePerformIO $ makeStableName x
106 instance Eq SharingName where
107 SharingName x == SharingName y = eqStableName x y
108 instance Hashable SharingName where
109 hash (SharingName n) = hashStableName n
110 hashWithSalt salt (SharingName n) = hashWithSalt salt n
112 instance Show SharingName where
113 showsPrec _ (SharingName n) = showHex (I# (unsafeCoerce# n))
116 -- * Type 'ObserveSharing'
117 newtype ObserveSharing letName repr a = ObserveSharing { unObserveSharing ::
118 MT.ReaderT (HashSet SharingName)
119 (MT.State (ObserveSharingState letName))
120 (FinalizeSharing letName repr a) }
122 -- | Interpreter detecting some (Haskell embedded) @let@ definitions used at
123 -- least once and/or recursively, in order to replace them
124 -- with the 'lets' and 'ref' combinators.
125 -- See [Type-safe observable sharing in Haskell](https://doi.org/10.1145/1596638.1596653)
127 -- Beware not to apply 'observeSharing' more than once on the same term
128 -- otherwise some 'def' introduced by the first call
129 -- would be removed by the second call.
134 ObserveSharing letName repr a ->
135 WithSharing letName repr a
136 observeSharing (ObserveSharing m) =
137 let (fs, st) = MT.runReaderT m mempty `MT.runState`
139 { oss_refs = HM.empty
140 , oss_recs = HS.empty
142 let refs = HS.fromList
144 | (letName, refCount) <- HM.elems (oss_refs st)
147 --trace (show refs) $
149 (`MT.runReaderT` refs) $
152 -- ** Type 'WithSharing'
153 type WithSharing letName repr a =
154 (repr a, HM.HashMap letName (SomeLet repr))
156 -- * Type 'WithSharing'
157 data WithSharing letName repr a = WithSharing
158 { lets :: HM.HashMap letName (SomeLet repr)
162 (forall v. repr v -> repr v) ->
163 WithSharing letName repr a ->
164 WithSharing letName repr a
165 mapWithSharing f ws = WithSharing
166 { lets = (\(SomeLet repr) -> SomeLet (f repr)) <$> lets ws
171 -- ** Type 'ObserveSharingState'
172 data ObserveSharingState letName = ObserveSharingState
173 { oss_refs :: HashMap SharingName (letName, Int)
174 , oss_recs :: HashSet SharingName
177 observeSharingNode ::
181 Referenceable letName repr =>
182 MakeLetName letName =>
183 ObserveSharing letName repr a ->
184 ObserveSharing letName repr a
185 observeSharingNode (ObserveSharing m) = ObserveSharing $ do
186 let nodeName = makeSharingName m
188 ((letName, seenBefore), seen) <- getCompose $ HM.alterF (\seenBefore ->
189 -- Compose is used to return (letName, seenBefore) along seen
190 -- in the same HashMap lookup.
191 Compose $ return $ case seenBefore of
193 ((letName, seenBefore), Just (letName, 0))
194 where letName = unsafePerformIO $ makeLetName nodeName
195 Just (letName, refCount) ->
196 ((letName, seenBefore), Just (letName, refCount + 1))
197 ) nodeName (oss_refs st)
198 parentNames <- MT.ask
199 if nodeName `HS.member` parentNames
200 then do -- recursive reference to nodeName:
201 -- update seen references
202 -- and mark nodeName as recursive
205 , oss_recs = HS.insert nodeName (oss_recs st)
207 return $ ref True letName
208 else do -- non-recursive reference to nodeName
209 -- update seen references
210 -- and recurse if the nodeName hasn't been seen before
211 -- (would be in a preceding sibling branch, not in parentNames).
212 MT.lift $ MT.put st{ oss_refs = seen }
213 if isNothing seenBefore
214 then MT.local (HS.insert nodeName) (def letName <$> m)
215 else return $ ref False letName
217 type instance Derived (ObserveSharing letName repr) = FinalizeSharing letName repr
219 ( Referenceable letName repr
220 , MakeLetName letName
224 ) => LiftDerived (ObserveSharing letName repr) where
225 liftDerived = observeSharingNode . ObserveSharing . return
227 ( Referenceable letName repr
228 , MakeLetName letName
232 ) => LiftDerived1 (ObserveSharing letName repr) where
233 liftDerived1 f a = observeSharingNode $ ObserveSharing $
234 f <$> unObserveSharing a
236 ( Referenceable letName repr
237 , MakeLetName letName
241 ) => LiftDerived2 (ObserveSharing letName repr) where
242 liftDerived2 f a b = observeSharingNode $ ObserveSharing $
243 f <$> unObserveSharing a
244 <*> unObserveSharing b
246 ( Referenceable letName repr
247 , MakeLetName letName
251 ) => LiftDerived3 (ObserveSharing letName repr) where
252 liftDerived3 f a b c = observeSharingNode $ ObserveSharing $
253 f <$> unObserveSharing a
254 <*> unObserveSharing b
255 <*> unObserveSharing c
257 ( Referenceable letName repr
258 , MakeLetName letName
262 ) => LiftDerived4 (ObserveSharing letName repr) where
263 liftDerived4 f a b c d = observeSharingNode $ ObserveSharing $
264 f <$> unObserveSharing a
265 <*> unObserveSharing b
266 <*> unObserveSharing c
267 <*> unObserveSharing d
268 instance Referenceable letName (ObserveSharing letName repr) where
269 ref = error "[BUG]: observeSharing MUST NOT be applied twice"
270 instance Definable letName (ObserveSharing letName repr) where
271 def = error "[BUG]: observeSharing MUST NOT be applied twice"
272 instance Letsable letName (ObserveSharing letName repr) where
273 lets = error "[BUG]: observeSharing MUST NOT be applied twice"
275 -- * Type 'FinalizeSharing'
276 -- | Remove 'def' when non-recursive or unused
277 -- or replace it by 'ref', moving 'def's to the top.
278 newtype FinalizeSharing letName repr a = FinalizeSharing { unFinalizeSharing ::
279 MT.ReaderT (HS.HashSet letName)
280 (MT.Writer (LetBindings letName repr))
283 type instance Derived (FinalizeSharing _letName repr) = repr
284 instance (Eq letName, Hashable letName) =>
285 LiftDerived (FinalizeSharing letName repr) where
286 liftDerived = FinalizeSharing . pure
287 instance (Eq letName, Hashable letName) =>
288 LiftDerived1 (FinalizeSharing letName repr) where
289 liftDerived1 f a = FinalizeSharing $ f <$> unFinalizeSharing a
290 instance (Eq letName, Hashable letName) =>
291 LiftDerived2 (FinalizeSharing letName repr) where
292 liftDerived2 f a b = FinalizeSharing $
293 f <$> unFinalizeSharing a
294 <*> unFinalizeSharing b
295 instance (Eq letName, Hashable letName) =>
296 LiftDerived3 (FinalizeSharing letName repr) where
297 liftDerived3 f a b c = FinalizeSharing $
298 f <$> unFinalizeSharing a
299 <*> unFinalizeSharing b
300 <*> unFinalizeSharing c
301 instance (Eq letName, Hashable letName) =>
302 LiftDerived4 (FinalizeSharing letName repr) where
303 liftDerived4 f a b c d = FinalizeSharing $
304 f <$> unFinalizeSharing a
305 <*> unFinalizeSharing b
306 <*> unFinalizeSharing c
307 <*> unFinalizeSharing d
309 ( Referenceable letName repr
313 ) => Referenceable letName (FinalizeSharing letName repr) where
314 ref isRec = liftDerived . ref isRec
316 ( Referenceable letName repr
320 ) => Definable letName (FinalizeSharing letName repr) where
321 def name body = FinalizeSharing $ do
324 MT.runWriter $ MT.runReaderT (unFinalizeSharing body) refs
325 if name `HS.member` refs
327 -- This 'def' is 'ref'erenced: move it into the result,
328 -- to put it in scope even when some 'ref' to it exists outside of 'body'
329 -- (which can happen when a body-expression is shared),
330 -- and replace it by a 'ref'.
331 MT.lift $ MT.tell $ HM.insert name (SomeLet repr) defs
332 return $ ref False name
334 -- Remove this unreferenced 'def' node.
335 unFinalizeSharing body
337 -- ** Class 'Letsable'
338 class Letsable letName repr where
339 -- | @('lets' defs x)@ let-binds @(defs)@ in @(x)@.
340 lets :: LetBindings letName repr -> repr a -> repr a
341 lets defs = liftDerived1 (lets ((\(SomeLet val) -> SomeLet (derive val)) <$> defs))
344 FromDerived1 (Letsable letName) repr =>
345 LetBindings letName repr -> repr a -> repr a
347 -- *** Type 'SomeLet'
348 data SomeLet repr = forall a. SomeLet (repr a)
350 -- *** Type 'LetBindings'
351 type LetBindings letName repr = HM.HashMap letName (SomeLet repr)
354 -- | Not used but can be written nonetheless.
356 ( Letsable letName repr
360 ) => Letsable letName (FinalizeSharing letName repr) where
361 lets defs x = FinalizeSharing $ do
362 ds <- traverse (\(SomeLet v) -> do
363 r <- unFinalizeSharing v
370 -- *** Type 'OpenRecs'
371 -- | Mutually recursive terms, in open recursion style.
372 type OpenRecs letName a = LetRecs letName (OpenRec letName a)
373 -- | Mutually recursive term, in open recursion style.
374 -- The term is given a @final@ (aka. @self@) map
375 -- of other terms it can refer to (including itself).
376 type OpenRec letName a = LetRecs letName a -> a
377 -- | Recursive let bindings.
378 type LetRecs letName = HM.HashMap letName
380 -- | Least fixpoint combinator.
382 fix f = final where final = f final
384 -- | Lest fixpoint combinator of mutually recursive terms.
385 -- @('mutualFix' opens)@ takes a container of terms
386 -- in the open recursion style @(opens)@,
387 -- and return that container of terms with their knots tied-up.
389 -- Used to express mutual recursion and to transparently introduce memoization,
390 -- between observed sharing ('defLet', 'call', 'jump')
391 -- and also between join points ('defJoin', 'refJoin').
393 -- Here all mutually dependent functions are restricted to the same polymorphic type @(a)@.
394 -- See http://okmij.org/ftp/Computation/fixed-point-combinators.html#Poly-variadic
395 mutualFix :: forall recs a. Functor recs => recs ({-finals-}recs a -> a) -> recs a
396 mutualFix opens = fix f
398 f :: recs a -> recs a
399 f recs = ($ recs) <$> opens