Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/79010d3ca1e44255ecce26f04a04db2608382726 >--------------------------------------------------------------- commit 79010d3ca1e44255ecce26f04a04db2608382726 Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Fri Aug 17 09:04:00 2012 +0100 Hack in some examples, not quite working >--------------------------------------------------------------- compiler/supercompile/Supercompile/Drive/MSG.hs | 31 ++++++++++++++++++++++- 1 files changed, 30 insertions(+), 1 deletions(-) diff --git a/compiler/supercompile/Supercompile/Drive/MSG.hs b/compiler/supercompile/Supercompile/Drive/MSG.hs index 16a17a9..3496062 100644 --- a/compiler/supercompile/Supercompile/Drive/MSG.hs +++ b/compiler/supercompile/Supercompile/Drive/MSG.hs @@ -40,6 +40,12 @@ import FastString (fsLit) --import BasicTypes (TupleSort(..)) import qualified State +import Id (mkTemplateLocals) +import Type (mkFunTy) +import TysWiredIn +import BasicTypes + + import Control.Monad (join) import Control.Monad.Fix import qualified Data.Foldable as Foldable @@ -60,6 +66,28 @@ traceSC _ = id --traceSC = trace +-- Demonstrates rollback due to heap work duplication +example1 :: SDoc +example1 = pPrint $ msg (MSGMode (mkInScopeSet emptyVarSet)) state1 state2 + where + state1 = (emptyDeeds, Heap (M.fromList [(f, lambdaBound), (g, lambdaBound), (x, internallyBound (renamedTerm $ annedTerm 0 (annedTerm 0 (Var g) `App` y))), (y, lambdaBound)]) (mkInScopeSet (mkVarSet [f, g, x, y])), Tagged 0 (Apply x) `Car` Tagged 0 (Update y) `Car` Loco False, (annedQA 0 (Question f))) + state2 = (emptyDeeds, Heap (M.fromList [(f, lambdaBound), (x, lambdaBound), (y, lambdaBound)]) (mkInScopeSet (mkVarSet [f, x, y])), Tagged 0 (Apply x) `Car` Tagged 0 (Update y) `Car` Loco False, (annedQA 0 (Question f))) + + [f, g, x, y] = mkTemplateLocals [boolTy `mkFunTy` intTy, intTy `mkFunTy` boolTy, boolTy, intTy] + +-- Demonstrates rollback due to stack "work duplication" +example2 :: SDoc +example2 = pPrint $ msg (MSGMode (mkInScopeSet emptyVarSet)) state1 state2 + where + expensive = internallyBound (renamedTerm $ annedTerm 0 (annedTerm 0 (Var f) `App` y)) + pairDC = tupleCon BoxedTuple 2 + + state1 = (emptyDeeds, Heap (M.fromList [(f, lambdaBound), (y, lambdaBound), (a, expensive)]) (mkInScopeSet (mkVarSet [f, y, a])), Loco False, annedQA 0 $ Answer $ renamedValue $ Data pairDC [intTy, intTy] [] [a, a]) + state2 = (emptyDeeds, Heap (M.fromList [(f, lambdaBound), (y, lambdaBound), (a, expensive), (b, expensive)]) (mkInScopeSet (mkVarSet [f, y, a, b])), Loco False, annedQA 0 $ Answer $ renamedValue $ Data pairDC [intTy, intTy] [] [a, b]) + + [a, b, f, y] = mkTemplateLocals [intTy, intTy, boolTy `mkFunTy` intTy, boolTy] + + rnBndr2' :: Applicative t => RnEnv2 -> Var -> Var -> MSGT t (RnEnv2, Var) rnBndr2' rn2 x_l x_r = MSG $ \_ s -> (s, pure (rnBndr2'' (msgInScopeSet s) rn2 x_l x_r)) -- The uniqAway is 1/2 of the story to ensure we don't get clashes between new rigid binders and the new common heap binders @@ -658,7 +686,8 @@ isTypeRenamingNonTrivial :: Renaming -> FreeVars -> Bool isTypeRenamingNonTrivial rn fvs = (\f -> foldVarSet f False fvs) $ \x rest -> (isTyVar x && isNothing (getTyVar_maybe (lookupTyVarSubst rn x))) || rest msg :: MSGMode -> State -> State -> MSG' MSGResult -msg mm (deeds_l, heap_l, k_l, qa_l) (deeds_r, heap_r, k_r, qa_r) = -- (\res -> traceRender ("msg", M.keysSet h_l, residualiseDriveState (Heap h_l prettyIdSupply, k_l, in_e_l), M.keysSet h_r, residualiseDriveState (Heap h_r prettyIdSupply, k_r, in_e_r), res) res) $ +msg = pprTrace "msg" example1 msg' +msg' mm (deeds_l, heap_l, k_l, qa_l) (deeds_r, heap_r, k_r, qa_r) = -- (\res -> traceRender ("msg", M.keysSet h_l, residualiseDriveState (Heap h_l prettyIdSupply, k_l, in_e_l), M.keysSet h_r, residualiseDriveState (Heap h_r prettyIdSupply, k_r, in_e_r), res) res) $ liftM (first (liftA2 (\deeds (heap, rn, k) -> (deeds, heap, rn, k)) (Pair deeds_l deeds_r))) $ msgLoop mm (heap_l, heap_r) (qa_l, qa_r) (k_l, k_r) msgAnned :: (Tag -> b -> Anned b) -> (Tag -> a -> Tag -> a -> MSG b) _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
