CC-delcont-ref-tf (empty) → 0.1.0.0
raw patch · 5 files changed
+983/−0 lines, 5 filesdep +basedep +mtldep +ref-tfsetup-changed
Dependencies added: base, mtl, ref-tf
Files
- Bench_nondet.hs +263/−0
- CC-delcont-ref-tf.cabal +42/−0
- Control/Monad/CC/CCRef.hs +645/−0
- LICENSE +30/−0
- Setup.lhs +3/−0
+ Bench_nondet.hs view
@@ -0,0 +1,263 @@+{-# LANGUAGE FlexibleInstances #-}++-- A benchmark of shift/reset: Filinski's representing non-determinism monads+--+-- The benchmark is taken from Sec 6.1 of+-- Martin Gasbichler, Michael Sperber: Final Shift for Call/cc: Direct+-- Implementation of Shift and Reset, ICFP'02, pp. 271-282. +-- http://www-pu.informatik.uni-tuebingen.de/users/sperber/papers/shift-reset-direct.pdf+-- This code is a straightforward translation of bench_nondet.ml+--+-- This is a micro-benchmark: it is very non-determinism-intensive. It is+-- *not* representative: the benchmark does nothing else but+-- concatenates lists. The List monad does this directly; whereas+-- continuation monads do the concatenation with more overhead (e.g.,+-- building the closures representing continuations). Therefore,+-- the List monad here outperforms all other implementations of +-- non-determinism.+-- It should be stressed that the delimited control is optimized+-- for the case where control operations are infrequent, so we pay+-- as we go. The use of the delimited control operators is more+-- expensive, but the code that does not use delimited control does not+-- have to pay anything for delimited control. +-- Again, in the present micro-benchmark, there is hardly any code that+-- does not use non-determinism, so the overhead of delimited control+-- is very noticeable. That is why this benchmark is good at estimating+-- the overhead of different implementations of delimited control.++-- To compile this code+-- ghc --make -O2 -main-is Bench_nondet.main_list5 Bench_nondet.hs+-- To run this code+-- GHCRTS="-tstderr" /usr/bin/time ./Bench_nondet++module Bench_nondet where++-- import Control.Monad.CC.CCExc+-- import Control.Monad.CC.CCCxe+import Control.Monad.CC.CCRef++import Data.List (sort)+import Control.Monad.Identity+import Control.Monad (MonadPlus(..), liftM2, msum)+-- import System.CPUTime++-- Small language with non-determinism: just like the one in our DSL-WC paper++int :: MonadPlus repr => Int -> repr Int+int x = return x++add :: MonadPlus repr => repr Int -> repr Int -> repr Int+add xs ys = liftM2 (+) xs ys++lam :: MonadPlus repr => (repr a -> repr b) -> repr (a -> repr b)+lam f = return $ f . return++app :: MonadPlus repr => repr (a -> repr b) -> (repr a -> repr b)+app xs ys = do {x <- xs; y <- ys; x y}++amb :: MonadPlus repr => [repr Int] -> repr Int+amb = msum++-- Benchmark cases++test_ww :: MonadPlus repr => repr Int+test_ww = + let f = lam (\x ->+ add (add x (amb [int 6, int 4, int 2, int 8])) + (amb [int 2, int 4, int 5, int 4, int 1]))+ in f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32]++ww_answer = + sort [8, 10, 11, 10, 7, 6, 8, 9, 8, 5, 4, 6, 7, 6, 3, 10, 12, 13,+ 12, 9, 10, 12, 13, 12, 9, 8, 10, 11, 10, 7, 6, 8, 9, 8, 5, 12, 14, 15,+ 14, 11, 11, 13, 14, 13, 10, 9, 11, 12, 11, 8, 7, 9, 10, 9, 6, 13, 15,+ 16, 15, 12, 12, 14, 15, 14, 11, 10, 12, 13, 12, 9, 8, 10, 11, 10, 7,+ 14, 16, 17, 16, 13, 13, 15, 16, 15, 12, 11, 13, 14, 13, 10, 9, 11, 12,+ 11, 8, 15, 17, 18, 17, 14, 40, 42, 43, 42, 39, 38, 40, 41, 40, 37, 36,+ 38, 39, 38, 35, 42, 44, 45, 44, 41]++-- Real benchmark cases++test_www :: MonadPlus repr => repr Int+test_www = + let f = lam (\x ->+ add (add x (amb [int 6, int 4, int 2, int 8])) + (amb [int 2, int 4, int 5, int 4, int 1]))+ in f `app` (f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32])++test_wwww :: MonadPlus repr => repr Int+test_wwww = + let f = lam (\x ->+ add (add x (amb [int 6, int 4, int 2, int 8])) + (amb [int 2, int 4, int 5, int 4, int 1]))+ in f `app` (f `app` (f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32]))++test_w5 :: MonadPlus repr => repr Int+test_w5 = + let f = lam (\x ->+ add (add x (amb [int 6, int 4, int 2, int 8])) + (amb [int 2, int 4, int 5, int 4, int 1]))+ in f `app` (f `app` + (f `app` (f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32])))+++-- Different implementations of our language (MonadPlus)++-- The List monad: Non-determinism monad as a list of successes++run_list :: [Int] -> [Int]+run_list = id++testl1 = (==) [101, 201, 102, 202] . run_list $+ add (amb [int 1, int 2]) (amb [int 100, int 200])++testl2 = ww_answer == sort (run_list test_ww)+++-- CPS-monad, implemented by hand; it must be quite efficient therefore+newtype CPS a = CPS{unCPS:: (a -> [Int]) -> [Int]}++instance Monad CPS where+ return x = CPS $ \k -> k x+ m >>= f = CPS $ \k -> unCPS m (\a -> unCPS (f a) k)++instance MonadPlus CPS where+ mzero = CPS $ \_ -> []+ mplus m1 m2 = CPS $ \k -> unCPS m1 k ++ unCPS m2 k++run_cps :: CPS Int -> [Int]+run_cps m = unCPS m (\x -> [x])+++testc1 = (==) [101, 201, 102, 202] . run_cps $+ add (amb [int 1, int 2]) (amb [int 100, int 200])++testc2 = ww_answer == sort (run_cps test_ww)+{-+-- CCEx monad++-- Not a very optimal implementation of mplus (a tree would be better)+-- But is suffices as a benchmark of different implementations of CC+instance Monad m => MonadPlus (CC (PS [Int]) m) where+ mzero = abortP ps (return [])+ mplus m1 m2 = takeSubCont ps (\k ->+ liftM2 (++)+ (pushPrompt ps (pushSubCont k m1))+ (pushPrompt ps (pushSubCont k m2)))++run_dir :: CC (PS [Int]) Identity Int -> [Int]+run_dir m = runIdentity . runCC $+ pushPrompt ps (m >>= return . (:[]))+++testd1 = (==) [101, 201, 102, 202] . run_dir $+ add (amb [int 1, int 2]) (amb [int 100, int 200])++testd2 = ww_answer == sort (run_dir test_ww)+-}++-- CCRef monad++-- Need a reader-monad layer to propagate the prompt+newtype CCR m a = CCR{unCCR :: Prompt m [Int] -> CC m a}++instance Monad m => Monad (CCR m) where+ return x = CCR $ \_ -> return x+ m >>= f = CCR $ \p -> unCCR m p >>= \v -> unCCR (f v) p+++-- Not a very optimal implementation of mplus (a tree would be better)+-- But is suffices as a benchmark of different implementations of CC+instance (Monad m, MonadRef m) => MonadPlus (CCR m) where+ mzero = CCR $ \p -> abortP p (return [])+ mplus m1 m2 = CCR $ \p ->+ takeSubCont p (\k ->+ liftM2 (++)+ (pushDelimSubCont k (unCCR m1 p))+ (pushDelimSubCont k (unCCR m2 p)))++run_ref :: CCR IO Int -> IO [Int]+run_ref m = runCC $ do+ p <- newPrompt+ pushPrompt p (unCCR m p >>= return . (:[]))++testr1 = ((return . ((==) [101, 201, 102, 202])) =<<) . run_ref $+ add (amb [int 1, int 2]) (amb [int 100, int 200])++testr2 = do+ r <- run_ref test_ww+ return $ ww_answer == sort r++main_ref5io = do+ l <- run_ref test_w5+ print $ length l == 960000++++-- Benchmarks themselves++main_list3 = print $ 2400 == (length . run_list $ test_www)+main_list4 = print $ 48000 == (length . run_list $ test_wwww)+main_list5 = print $ 960000 == (length . run_list $ test_w5)++main_cps3 = print $ 2400 == (length . run_cps $ test_www)+main_cps4 = print $ 48000 == (length . run_cps $ test_wwww)+main_cps5 = print $ 960000 == (length . run_cps $ test_w5)+{-+-- We expect the direct implementation to be slower since CC is the transformer,+-- whereas CPS is not. The latter is hand-written for a specific answer-type.+main_dir3 = print $ 2400 == (length . run_dir $ test_www)+main_dir4 = print $ 48000 == (length . run_dir $ test_wwww)+main_dir5 = print $ 960000 == (length . run_dir $ test_w5)++-- Instantiate CC to the IO as the base monad, attempting to quantify the+-- effect of the Identity transformer+main_dir5io = do+ l <- runCC $ pushPrompt ps (test_w5 >>= return . (:[]))+ print $ length l == 960000+-}+{- Median of 5 runs++main_list5+<<ghc: 186526764 bytes, 356 GCs, 619182/1156760 avg/max bytes residency (3 samples), 4M in use, 0.00 INIT (0.00 elapsed), 0.25 MUT (0.25 elapsed), 0.06 GC (0.06 elapsed) :ghc>>+ 0.30 real 0.30 user 0.00 sys++main_cps5+<<ghc: 231580040 bytes, 442 GCs, 4017/4104 avg/max bytes residency (24 samples), 2M in use, 0.00 INIT (0.00 elapsed), 0.28 MUT (0.28 elapsed), 0.31 GC (0.33 elapsed) :ghc>>+ 0.60 real 0.58 user 0.01 sys++main_dir5 (CCExc implementation)+<<ghc: 780415108 bytes, 1489 GCs, 10459973/39033060 avg/max bytes residency (14 samples), 110M in use, 0.00 INIT (0.00 elapsed), 1.30 MUT (1.32 elapsed), 2.92 GC (3.14 elapsed) :ghc>>+ 4.48 real 4.22 user 0.24 sys++main_dir5io (CCExc implementation)+<<ghc: 1148031880 bytes, 2190 GCs, 10339954/38941944 avg/max bytes residency (14 samples), 108M in use, 0.00 INIT (0.00 elapsed), 2.15 MUT (2.20 elapsed), 3.04 GC (3.24 elapsed) :ghc>>+ 5.45 real 5.18 user 0.21 sys+++main_dir5 (CCCxe implementation)+./Bench_nondet +RTS -tstderr +True+<<ghc: 991065016 bytes, 1891 GCs, 10473968/38790660 avg/max bytes residency (14 samples), 110M in use, 0.00 INIT (0.00 elapsed), 1.45 MUT (1.49 elapsed), 2.99 GC (3.20 elapsed) :ghc>>+ 4.70 real 4.44 user 0.23 sys++main_dir5io (CCCxe implementation)+./Bench_nondet +RTS -tstderr +True+<<ghc: 991065412 bytes, 1891 GCs, 10364029/37920012 avg/max bytes residency (14 samples), 109M in use, 0.00 INIT (0.00 elapsed), 1.46 MUT (1.50 elapsed), 2.99 GC (3.20 elapsed) :ghc>>+ 4.72 real 4.44 user 0.23 sys++main_ref5io (without pushDelimSubCont)+./Bench_nondet +RTS -tstderr +True+<<ghc: 19050261764 bytes, 36337 GCs, 10620542/49328200 avg/max bytes residency (16 samples), 123M in use, 0.00 INIT (0.00 elapsed), 61.45 MUT (62.70 elapsed), 6.06 GC (6.21 elapsed) :ghc>>+ 68.94 real 67.51 user 1.03 sys+++main_ref5io (with pushDelimSubCont)+./Bench_nondet +RTS -tstderr +True+<<ghc: 5666546308 bytes, 10809 GCs, 10538302/46414760 avg/max bytes residency (14 samples), 114M in use, 0.00 INIT (0.00 elapsed), 16.27 MUT (16.68 elapsed), 3.65 GC (3.80 elapsed) :ghc>>+ 20.50 real 19.92 user 0.46 sys++-}
+ CC-delcont-ref-tf.cabal view
@@ -0,0 +1,42 @@+name: CC-delcont-ref-tf +version: 0.1.0.0 +author: Oleg Kiselyov +maintainer: shelarcy <shelarcy@gmail.com> +license: BSD3 +license-file: LICENSE +category: Control +Synopsis: A monad transformers for multi-prompt delimited control using refercence cells +Description: This library implements the superset of the interface described in + * /A Monadic Framework for Delimited Continuations/, + R. Kent Dybvig, Simon Peyton Jones, and Amr Sabry + JFP, v17, N6, pp. 687--730, 2007. + <http://www.cs.indiana.edu/cgi-bin/techreports/TRNNN.cgi?trnum=TR615> + . + This library is closest to the interface of Dybvig, Peyton Jones and Sabry. + "Control.Monad.CC.CCRef" is derived from the definitional interpreter using + the implementation techniques described and justified in the FLOPS 2010 paper. + The monad transformer 'CC' implemented by "Control.Monad.CC.CCRef" requires + the base monad to support reference cells. In other words, the base monad + must be a member of the type class 'MonadRef': that is, must be 'IO', 'ST', + 'STM' or their transformer. "Control.Monad.CC.CCRef" adds to the original + interface the frequently used function 'abortP' as a primitive. + . + See the original article at <http://okmij.org/ftp/continuations/implementations.html#CC-monads> + for more information. + . + This package uses <http://hackage.haskell.org/package/ref-tf>'s 'MonadRef' class + instead of 'Mutation' class what is used in + <http://hackage.haskell.org/package/CC-delcont-ref> package. +stability: experimental +cabal-version: >= 1.8 +build-type: Simple +extra-source-files: + Bench_nondet.hs + +library + build-depends: base >= 3 && < 5, mtl, ref-tf + exposed-modules: + Control.Monad.CC.CCRef + other-modules: + cc-options: + ld-options:
+ Control/Monad/CC/CCRef.hs view
@@ -0,0 +1,645 @@+{-# LANGUAGE TypeFamilies #-}++-- | Monad transformer for multi-prompt delimited control+--+-- This library implements the superset of the interface described in+--+-- * \"/A Monadic Framework for Delimited Continuations/\",+-- R. Kent Dybvig, Simon Peyton Jones, and Amr Sabry+-- JFP, v17, N6, pp. 687--730, 2007.+-- <http://www.cs.indiana.edu/cgi-bin/techreports/TRNNN.cgi?trnum=TR615>+--+-- This code is the straightforward implementation of the+-- definitional machine described in the above paper. To be precise,+-- we implement an equivalent machine, where captured continuations are+-- always sandwiched between two prompts. This equivalence as+-- well as the trick to make it all well-typed are described in+-- the FLOPS 2010 paper. Therefore, to the great extent+-- this code is the straightforward translation of delimcc from OCaml.+-- The parallel stack of delimcc is the `real' stack now (containing+-- parts of the real continuation, that is).+--+-- This code implements, in CPS, what amounts to a segmented stack+-- (the technique of implementing call/cc efficiently, first described in+-- Hieb, Dybvig and Bruggeman's PLDI 1990 paper).++module Control.Monad.CC.CCRef (+ -- * Types+ CC,+ SubCont,+ Prompt,++ -- * Basic delimited control operations+ newPrompt,+ pushPrompt,+ takeSubCont,+ pushSubCont,+ runCC,++ -- * Optimized primitives+ abortP,+ pushDelimSubCont,++ -- * Useful derived operations+ shiftP,+ shift0P,+ controlP,+ isPromptSet,+ + -- * re-export+ module Control.Monad.Ref+ ) where+++import Control.Monad (liftM2)+import Control.Monad.Trans+import Control.Monad.Ref -- Generic references++import Control.Monad.ST -- For tests only++-- | Delimited-continuation monad transformer+-- The (CC m) monad is the Cont monad with the answer-type (),+-- combined with the persistent-state monad. The state PTop is the+-- `parallel stack' of delimcc, which is the real stack now. +-- The base monad m must support reference cells, that is,+-- be a member of the type class MonadRef.+-- Since we need reference cells anyway, we represent the persistent+-- state as a reference cell PTop, which is passed as the environment.++newtype CC m a = CC{unCC:: (a -> m ()) -> PTop m -> m ()}++-- We manipulate portions of the stack between two exception frames.+-- The type of the exception DelimCCE is ()++-- | The type of prompts is just like that in OCaml's delimcc+data Prompt m a = Prompt{mbox :: Ref m (CC m a),+ mark :: Mark m}++-- | A frame of the parallel stack, associated with each active prompt.+-- The frame refers to the prompt indirectly, by pointing to the+-- mark field of the prompt. Different prompts have different marks.+-- Therefore, although prompts generally have different types, all pframes+-- have the same type and can be placed into the same list.+-- A pframe also points to an exception frame (in the pfr_ek field).+-- That exception frame is created by push_prompt, see below.++data PFrame m = PFrame{pfr_mark :: Mark m,+ pfr_ek :: EK m} -- see scAPI below++type PStack m = [PFrame m] -- The parallel stack+type PTop m = Ref m (PStack m) -- The `machine' stack++-- | The context between two exception frames: The captured sub-continuation+-- It is a fragment of the parallel stack: a list of PFrames in inverse order.+-- Since we are in the Cont monad, there is no `real' stack:+-- the type Ekfragment is ()++data SubCont m a b = SubCont{subcont_pa :: Prompt m a,+ subcont_pb :: Prompt m b,+ subcont_ps :: [PFrame m]}+++-- --------------------------------------------------------------------+-- scAPI (see the caml-shift paper)++-- | The type of exceptions associated with exception frames+-- Only DelimCCE exceptions could ever be raised+type DelimCCE = ()++-- | The pointer to an exception frame: a continuation accepting DelimCCE+-- (since the monadic action is already a `thunk', we don't need+-- to make another one)+type EK m = m ()++{-+-- How to implement try and obtain the identity EK of the pushed+-- exception frame++-- The code looks like call/cc, but not quite: we split the +-- machine context at the exception frame, evaluating the body in +-- essentially the empty environment. To be precise, we evaluate body+-- on the stack that contains a single underflow frame, called pop below.+-- The operation pop switches the control to the `previous' stack.++ctry :: (Monad m, MonadRef m) => (EK m -> CC m ()) -> CC m () -> CC m ()+ctry body handler = CC $ \k ptop -> do+ stack <- readRef ptop+ let ek = unCC handler k ptop : stack+ writeRef ptop ek+ let pop () = do+ (_:t) <- readRef ptop+ writeRef ptop t+ k ()+ unCC (body ek) pop ptop+-}+++-- in OCaml: reset_ek : ek -> exn -> 'a+-- reset_ek :: EK m -> CC m any+-- reset_ek ek = CC $ \_ _ -> ek ()++-- | Since we are in the Cont monad, there is no `real' stack:+type Ekfragment = ()+-- hence, the rest of scAPI is irrelevant:+-- copy_stack_fragment and push_stack_fragment do nothing at all++-- --------------------------------------------------------------------+-- | CC monad: general monadic operations++instance Monad m => Monad (CC m) where+ return x = CC $ \k _ -> k x+ m >>= f = CC $ \k ptop -> unCC m (\v -> unCC (f v) k ptop) ptop++instance MonadTrans CC where+ lift m = CC $ \k _ -> m >>= k++instance MonadIO m => MonadIO (CC m) where+ liftIO = lift . liftIO++instance (Monad m, MonadRef m)+ => MonadRef (CC m) where+ type Ref (CC m) = Ref m+ newRef = lift . newRef+ readRef = lift . readRef+ writeRef = (lift .) . writeRef+ modifyRef = (lift .) . modifyRef++instance (Monad m, MonadAtomicRef m)+ => MonadAtomicRef (CC m) where+ atomicModifyRef = (lift .) . atomicModifyRef++runCC :: (Monad m, MonadRef m) => CC m a -> m a+runCC m = do+ ptop <- newRef [] -- make the parallel stack+ -- where to store the answer to+ ans <- newRef (error "runCC: no prompt was ever set!")+ unCC m (writeRef ans) ptop+ readRef ans+++-- --------------------------------------------------------------------+-- Utilities++-- | Mark is Ref m Bool rather than Ref m () as was in OCaml,+-- since we use equi-mutability rather than physical equality when+-- comparing marks. Normally, mark is Ref False; we flip it to +-- True when we do the equi-mutability test.+type Mark m = Ref m Bool++new_mark :: MonadRef m => m (Mark m)+new_mark = newRef False++-- | Do the equi-mutability test+with_marked_mark :: (Monad m, MonadRef m) => Mark m -> m a -> m a+with_marked_mark mark body = do+ writeRef mark True -- set the mark+ r <- body+ writeRef mark False -- reset it back+ return r++-- | Check if the given mark is marked+is_marked :: MonadRef m => Mark m -> m Bool+is_marked = readRef+++-- | Contents of the empty mbox +-- (see the FLOPS 2010 paper for the explanations)+mbox_empty :: CC m a+mbox_empty = error "Empty mbox"++mbox_receive :: (Monad m, MonadRef m) => Prompt m a -> CC m a+mbox_receive p = do+ k <- readRef (mbox p)+ writeRef (mbox p) mbox_empty+ k++-- | Operations on the global PStack++push_pframe :: (Monad m, MonadRef m) => PTop m -> PFrame m -> m ()+push_pframe ptop fr = do+ stack <- readRef ptop+ writeRef ptop (fr:stack)++pop_pframe :: (Monad m, MonadRef m) => PTop m -> m (PFrame m)+pop_pframe ptop = readRef ptop >>= check+ where check [] = error "Empty PStack! Can't be happening"+ check (h:t) = writeRef ptop t >> return h+ ++get_pstack :: (Monad m, MonadRef m) => CC m (PStack m)+get_pstack = CC $ \k ptop -> readRef ptop >>= k+++-- | Split the parallel stack at the given mark, remove the prefix+-- (up to but not including the marked frame) and return it in+-- the inverse frame order. The frame that used to be at the top of pstack+-- is now at the bottom of the returned list.+-- The other two returned values are the marked frame and the+-- rest of pstack (which contains the marked frame at the top).++unwind :: (Monad m, MonadRef m) =>+ [PFrame m] -> Mark m -> PStack m ->+ m (PFrame m, PStack m, [PFrame m])+unwind acc mark stack = with_marked_mark mark (loop acc stack)+ where+ loop acc [] = error "No prompt was set" + loop acc s@(h:t) = do+ marked <- is_marked (pfr_mark h)+ if marked then return (h,s,acc) else loop (h:acc) t++-- | The same as above, but the removed frames are discarded+unwind_abort :: (Monad m, MonadRef m) =>+ Mark m -> PStack m -> m (PFrame m, PStack m)+unwind_abort mark stack = with_marked_mark mark (loop stack)+ where+ loop [] = error "No prompt was set" + loop s@(h:t) = do+ marked <- is_marked (pfr_mark h)+ if marked then return (h,s) else loop t++-- rev_append l1 l2 == reverse l1 ++ l2+rev_append :: [a] -> [a] -> [a]+rev_append [] l2 = l2+rev_append (h:t) l2 = rev_append t (h:l2)++-- --------------------------------------------------------------------+-- Basic Operations of the delimited control interface+-- All control operators in the end jump to the exception frame+-- (in delimcc, that was `raise DelimCCE'; here it is `pfr_ek h')++newPrompt :: (Monad m, MonadRef m) => CC m (Prompt m a)+newPrompt = lift $ liftM2 Prompt (newRef mbox_empty) new_mark++-- The exception-handling part of try in pushPrompt+popPrompt :: (Monad m, MonadRef m) =>+ Prompt m w -> CC m w+popPrompt p = CC $ \k ptop -> do+ h <- pop_pframe ptop -- remove the exception frame+ -- assert (h.pfr_mark == p.mark)+ unCC (mbox_receive p) k ptop++pushPrompt :: (Monad m, MonadRef m) =>+ Prompt m w -> CC m w -> CC m w+pushPrompt p body = CC $ \k ptop -> do+ let ek = unCC (popPrompt p) k ptop+ let raise = do -- raise the exception+ (h:_) <- readRef ptop+ pfr_ek h -- h must be an exception frame+ push_pframe ptop (PFrame (mark p) ek) -- push the exception frame+ unCC body (\res -> writeRef (mbox p) (return res) >> raise) ptop+++takeSubCont :: (Monad m, MonadRef m) =>+ Prompt m b -> (SubCont m a b -> CC m b) -> CC m a+takeSubCont p f = newPrompt >>= \pa -> CC $ \k ptop -> do+ let ek = unCC (popPrompt pa) k ptop+ stack <- readRef ptop+ (h,s,subcontchain) <- unwind [] (mark p) (PFrame (mark pa) ek:stack)+ writeRef ptop s+ writeRef (mbox p) (f (SubCont pa p subcontchain))+ pfr_ek h -- reset_ek is the identity+++pushSubCont :: (Monad m, MonadRef m) =>+ SubCont m a b -> CC m a -> CC m b+pushSubCont (SubCont pa pb subcontchain) m = CC $ \k ptop -> do+ let ek = unCC (popPrompt pb) k ptop+ ephemeral <- new_mark -- p'' in the caml-shift paper+ stack <- readRef ptop+ let stack'@(h:_) = rev_append subcontchain (PFrame ephemeral ek:stack)+ writeRef ptop stack'+ writeRef (mbox pa) m+ pfr_ek h -- raise the exception+++-- | An optimization: pushing the _delimited_ continuation.+-- This is the optimization of the pattern+--+-- > pushPrompt (subcont_pb sk) (pushSubcont sk m)+--+-- corresponding to pushing the continuation captured by shift/shift0. +-- The latter continuation always has the delimiter at the end.+-- Indeed shift can be implemented more efficiently as a primitive+-- rather than via push_prompt/control combination...++pushDelimSubCont :: (Monad m, MonadRef m) =>+ SubCont m a b -> CC m a -> CC m b+pushDelimSubCont (SubCont pa pb subcontchain) m = CC $ \k ptop -> do+ let ek = unCC (popPrompt pb) k ptop+ stack <- readRef ptop+ let stack'@(h:_) = rev_append subcontchain (PFrame (mark pb) ek:stack)+ writeRef ptop stack'+ writeRef (mbox pa) m+ pfr_ek h+++-- | An efficient variation of take_subcont, which does not capture+-- any continuation.+-- This code makes it clear that abort is essentially raise.++abortP :: (Monad m, MonadRef m) => + Prompt m w -> CC m w -> CC m any+abortP p res = CC $ \k ptop -> do+ stack <- readRef ptop+ (h,s) <- unwind_abort (mark p) stack+ writeRef ptop s+ writeRef (mbox p) res+ pfr_ek h -- reset_ek is the identity+++-- | Check to see if a prompt is set+isPromptSet :: (Monad m, MonadRef m) => + Prompt m w -> CC m Bool+isPromptSet p = do+ stack <- get_pstack+ with_marked_mark (mark p) (loop stack)+ where+ loop [] = return False+ loop s@(h:t) = do+ marked <- is_marked (pfr_mark h)+ if marked then return True else loop t++-- pstack_size :: (Monad m, MonadRef m) => String -> CC m ()+-- pstack_size str = do+-- stack <- get_pstack+-- trace (unwords ["Pstack:",str,show (length stack)]) (return ())++-- --------------------------------------------------------------------+-- Useful derived operations++shiftP :: (Monad m, MonadRef m) => + Prompt m w -> ((a -> CC m w) -> CC m w) -> CC m a+shiftP p f = takeSubCont p $ \sk -> + pushPrompt p (f (\c -> + pushDelimSubCont sk (return c)))++shift0P :: (Monad m, MonadRef m) => + Prompt m w -> ((a -> CC m w) -> CC m w) -> CC m a+shift0P p f = takeSubCont p $ \sk -> + f (\c -> + pushDelimSubCont sk (return c))++controlP :: (Monad m, MonadRef m) => + Prompt m w -> ((a -> CC m w) -> CC m w) -> CC m a+controlP p f = takeSubCont p $ \sk -> + pushPrompt p (f (\c -> + pushSubCont sk (return c)))++++----------------------------------------------------------------------+-- Tests++expect ve vp = if ve == vp then putStrLn $ "expected answer " ++ (show ve)+ else error $ "expected " ++ (show ve) +++ ", computed " ++ (show vp)++assure :: Monad m => CC m Bool -> CC m ()+assure m = do+ v <- m+ if v then return () else error "assertion failed"+++test0 = runCC (return 1 >>= (return . (+ 4))) >>= expect 5+-- 5++test1 = (expect 1 =<<) . runCC $ do+ p <- newPrompt+ assure (isPromptSet p >>= return . not)+ pushPrompt p $ (assure (isPromptSet p) >> return 1)++incr :: Monad m => Int -> m Int -> m Int+incr n m = m >>= return . (n +)++test2 = (expect 9 =<<) . runCC $ do+ p <- newPrompt+ incr 4 . pushPrompt p $ pushPrompt p (return 5)++test3 = (expect 9 =<<) . runCC $ do+ p <- newPrompt+ incr 4 . pushPrompt p $ (incr 6 $ abortP p (return 5))++test3' = (expect 9 =<<) . runCC $ do+ p <- newPrompt+ incr 4 . pushPrompt p . pushPrompt p $ (incr 6 $ abortP p (return 5))++-- The same, but less efficient+test3'1 = (expect 9 =<<) . runCC $ do+ p <- newPrompt+ incr 4 . pushPrompt p . pushPrompt p $ + (incr 6 $ takeSubCont p (\_ -> (return 5)))++test3'' = (expect 27 =<<) . runCC $ do+ p <- newPrompt+ incr 20 . pushPrompt p $ + do+ v1 <- pushPrompt p (incr 6 $ abortP p (return 5))+ v2 <- abortP p (return 7)+ return $ v1 + v2 + 10++test3''1 = (expect 27 =<<) . runCC $ do+ p <- newPrompt+ incr 20 . pushPrompt p $ + do+ v1 <- pushPrompt p (incr 6 $ takeSubCont p (\_ -> return 5))+ v2 <- takeSubCont p (\_ -> return 7)+ return $ v1 + v2 + 10++test3''' = (print =<<) . runCC $ do+ p <- newPrompt+ v <- pushPrompt p $ + do+ v1 <- pushPrompt p (incr 6 $ abortP p (return 5))+ v2 <- abortP p (return 7)+ return $ v1 + v2 + 10+ assure (isPromptSet p >>= return . not)+ v <- abortP p (return 9)+ assure (return False)+ return $ v + 20+-- error++test4 = (expect 35 =<<) . runCC $ do + p <- newPrompt+ incr 20 . pushPrompt p $+ incr 10 . takeSubCont p $ \sk -> + pushPrompt p (pushSubCont sk (return 5))++test41 = (expect 35 =<<) . runCC $ do+ p <- newPrompt+ incr 20 . pushPrompt p $ + incr 10 . takeSubCont p $ \sk -> + pushSubCont sk (pushPrompt p (pushSubCont sk (abortP p (return 5))))+++-- Danvy/Filinski's test+--(display (+ 10 (reset (+ 2 (shift k (+ 100 (k (k 3))))))))+--; --> 117++test5 = (expect 117 =<<) . runCC $ do+ p <- newPrompt+ incr 10 . pushPrompt p $+ incr 2 . shiftP p $ \sk -> incr 100 $ sk =<< (sk 3)+-- 117++test5'' = (expect 115 =<<) . runCC $ do+ p0 <- newPrompt+ p1 <- newPrompt+ incr 10 . pushPrompt p0 $+ incr 2 . shiftP p0 $ \sk -> + incr 100 $ sk =<< + (pushPrompt p1 (incr 9 $ sk =<< (abortP p1 (return 3))))++test5''' = (expect 115 =<<) . runCC $ do+ p0 <- newPrompt+ p1 <- newPrompt+ incr 10 . pushPrompt p0 $+ incr 2 . (id =<<) . shiftP p0 $ \sk -> + incr 100 $ sk + (pushPrompt p1 (incr 9 $ sk (abortP p1 (return 3))))++test54 = (expect 124 =<<) . runCC $ do+ p0 <- newPrompt+ p1 <- newPrompt+ incr 10 . pushPrompt p0 $+ incr 2 . (id =<<) . shiftP p0 $ \sk -> + incr 100 $ sk + (pushPrompt p1 (incr 9 $ sk (abortP p0 (return 3))))++test6 = (expect 15 =<<) . runCC $ do+ p1 <- newPrompt+ p2 <- newPrompt+ let pushtwice sk = pushSubCont sk (pushSubCont sk (return 3))+ incr 10 . pushPrompt p1 $ + incr 1 . pushPrompt p2 $ takeSubCont p1 pushtwice++-- The most difficult test. The difference between the prompts really matters+-- now+test7 = (expect 135 =<<) . runCC $ do+ p1 <- newPrompt+ p2 <- newPrompt+ p3 <- newPrompt+ let pushtwice sk = pushSubCont sk (pushSubCont sk + (takeSubCont p2+ (\sk2 -> pushSubCont sk2+ (pushSubCont sk2 (return 3)))))+ incr 100 . pushPrompt p1 $+ incr 1 . pushPrompt p2 $+ incr 10 . pushPrompt p3 $ (takeSubCont p1 pushtwice)+-- 135++test7' = (expect 135 =<<) . runCC $ do+ p1 <- newPrompt+ p2 <- newPrompt+ p3 <- newPrompt+ let pushtwice f = f (f (shiftP p2 (\f2 -> f2 =<< (f2 3))))+ incr 100 . pushPrompt p1 $+ incr 1 . pushPrompt p2 $+ incr 10 . pushPrompt p3 $ (shiftP p1 pushtwice >>= id)+-- 135++test7'' = (expect 135 =<<) . runCC $ do+ p1 <- newPrompt+ p2 <- newPrompt+ p3 <- newPrompt+ let pushtwice f = f (f (shift0P p2 (\f2 -> f2 =<< (f2 3))))+ incr 100 . pushPrompt p1 $+ incr 1 . pushPrompt p2 $+ incr 10 . pushPrompt p3 $ (shift0P p1 pushtwice >>= id)++-- test7 in the ST monad. After all, CC is a monad transformer.+-- The only difference is the presence of runST...+test7st = runST (runCC $ do+ p1 <- newPrompt+ p2 <- newPrompt+ p3 <- newPrompt+ let pushtwice sk = pushSubCont sk (pushSubCont sk + (takeSubCont p2+ (\sk2 -> pushSubCont sk2+ (pushSubCont sk2 (return 3)))))+ incr 100 . pushPrompt p1 $+ incr 1 . pushPrompt p2 $+ incr 10 . pushPrompt p3 $ (takeSubCont p1 pushtwice))++test7st_check = return test7st >>= expect 135++++-- Checking shift, shift0, control ++testls = (expect ["a"] =<<) . runCC $ do+ p <- newPrompt+ pushPrompt p (+ do+ let x = shiftP p (\f -> f [] >>= (return . ("a":)))+ xv <- x+ shiftP p (\_ -> return xv))+++-- (display (prompt0 (cons 'a (prompt0 (shift0 f (shift0 g '()))))))+testls0 = (expect [] =<<) . runCC $ do+ p <- newPrompt+ pushPrompt p (+ (return . ("a":)) =<< + (pushPrompt p (shift0P p (\_ -> (shift0P p (\_ -> return []))))))+ +testls01 = (expect ["a"] =<<) . runCC $ do+ p <- newPrompt+ pushPrompt p (+ (return . ("a":)) =<< + (pushPrompt p + (shift0P p (\f -> f (shift0P p (\_ -> return []))) >>= id)))+ ++testlc = (expect [] =<<) . runCC $ do+ p <- newPrompt+ pushPrompt p (+ do+ let x = controlP p (\f -> f [] >>= (return . ("a":)))+ xv <- x+ controlP p (\_ -> return xv))+ ++testlc' = (expect ["a"] =<<) . runCC $ do+ p <- newPrompt+ pushPrompt p (+ do+ let x = controlP p (\f -> f [] >>= (return . ("a":)))+ xv <- x+ controlP p (\g -> g xv))+-- ["a"]++testlc1 = (expect 2 =<<) . runCC $ do+ p <- newPrompt+ pushPrompt p (do+ takeSubCont p (\sk -> + pushPrompt p (pushSubCont sk (return 1)))+ takeSubCont p (\sk -> pushSubCont sk (return 2)))+++-- traversing puzzle by Olivier Danvy++type DelimControl m a b = + Prompt m b -> ((a -> CC m b) -> CC m b) -> CC m a++traverse :: Show a => DelimControl IO [a] [a] -> [a] -> IO ()+traverse op lst = (print =<<) . runCC $ do+ p <- newPrompt+ let visit [] = return []+ visit (h:t) = do+ v <- op p (\f -> f t >>= (return . (h:)))+ visit v+ pushPrompt p (visit lst)+++-- *CC_Refn> traverse shiftP [1,2,3,4,5]+-- [1,2,3,4,5]+-- *CC_Refn> traverse controlP [1,2,3,4,5]+-- [5,4,3,2,1]++doall = sequence_ [test0, test1, test2, test3, test3', test3'1, + test3'', test3''1, + test4, test41, test5, test5'', test5''', test54,+ test6, test7, test7', test7'', test7st_check,+ testls, testls0, testls01, testlc, testlc', testlc1+ ]+-- test3''' should raise an error
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2010 Oleg Kiselyov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain