Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/46b917947cfd0634700414375e05b91e01716d9e >--------------------------------------------------------------- commit 46b917947cfd0634700414375e05b91e01716d9e Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Wed Sep 26 20:02:45 2012 +0100 Fix stupid typo in MSG that was causing even stupider tiebacks >--------------------------------------------------------------- compiler/supercompile/Supercompile/Drive/MSG.hs | 4 ++-- .../supercompile/Supercompile/Drive/Process3.hs | 11 ++++++++--- 2 files changed, 10 insertions(+), 5 deletions(-) diff --git a/compiler/supercompile/Supercompile/Drive/MSG.hs b/compiler/supercompile/Supercompile/Drive/MSG.hs index bed1a7d..6fcb4e4 100644 --- a/compiler/supercompile/Supercompile/Drive/MSG.hs +++ b/compiler/supercompile/Supercompile/Drive/MSG.hs @@ -1,5 +1,5 @@ module Supercompile.Drive.MSG ( - MSGMode(..), msg, msgMaybe, + MSGMode(..), MSGResult, msg, msgMaybe, InstanceMatching(..), MSGMatchResult(..), msgMatch ) where @@ -1151,7 +1151,7 @@ initStack xs i (Car kf_l k_l) (Car kf_r k_r) = do _ -> return (xs, Nothing, Nothing) let suck = initSuckStackFrame i mb_x kf_l kf_r liftM (\(mxs, k_lrs, sucks) -> (maybe id (:) mb_mx mxs, liftA2 (\kf_lr (k_avail_lr, k_lr) -> (kf_lr `Car` k_avail_lr, k_lr)) (Pair kf_l kf_r) k_lrs, IM.insert i suck sucks)) $ initStack xs (i + 1) k_l k_r -initStack _ _ k_l k_r = return ([], Pair (Loco (stackGeneralised k_l), k_r) (Loco (stackGeneralised k_r), k_r), IM.empty) +initStack _ _ k_l k_r = return ([], Pair (Loco (stackGeneralised k_l), k_l) (Loco (stackGeneralised k_r), k_r), IM.empty) initSuckStackFrame :: Int -> Maybe (Var {- partial loop -}, Pair Var) -> Tagged StackFrame -> Tagged StackFrame -> MSGU () initSuckStackFrame i mb_x (Tagged tg_l kf_l) (Tagged tg_r kf_r) = do diff --git a/compiler/supercompile/Supercompile/Drive/Process3.hs b/compiler/supercompile/Supercompile/Drive/Process3.hs index 23a7574..5f75203 100644 --- a/compiler/supercompile/Supercompile/Drive/Process3.hs +++ b/compiler/supercompile/Supercompile/Drive/Process3.hs @@ -327,13 +327,12 @@ tryTaG opt shallow_state state = bothWays (\_ -> generaliseSplit opt gen) shallo where gen = mK_GENERALISER shallow_state state tryMSG opt = bothWays $ \shallow_state state -> do - (Pair _ (deeds_r, heap_r@(Heap h_r ids_r), rn_r, k_r), (heap@(Heap _ ids), k, qa)) <- msgMaybe (MSGMode { msgCommonHeapVars = case shallow_state of (_, Heap _ ids, _, _) -> ids }) shallow_state state + msg_result@(Pair _ (deeds_r, heap_r@(Heap h_r ids_r), rn_r, k_r), (heap@(Heap _ ids), k, qa)) <- msgMaybe (MSGMode { msgCommonHeapVars = case shallow_state of (_, Heap _ ids, _, _) -> ids }) shallow_state state -- NB: have to check that we throw away *some* info via MSG or else we can get a loop where we -- MSG back to the same state and thus create a loop (i.e. if previous state is (a, a)^t and new state is (b, c)^t) guard (not (isPureHeapEmpty h_r) || not (isStackEmpty k_r)) let [deeds, deeds_r'] = splitDeeds deeds_r [heapSize heap + stackSize k + annedSize qa, heapSize heap_r + stackSize k_r] - pprTrace "MSG success" (pPrintFullState quietStatePrettiness (deeds, heap, k, qa) $$ - pPrintFullState quietStatePrettiness (deeds_r', heap_r, k_r, fmap Question (annedVar (mkTag 0) nullAddrId))) $ Just $ do + pprTrace "MSG success" (pprMSGResult msg_result) $ Just $ do (deeds', e) <- sc (deeds, heap, k, qa) -- Just to suppress warnings from renameId (since output term may mention h functions). Alternatively, I could rename the State I pass to "sc" -- NB: adding some new bindings to h_r for the h functions is a bit of a hack because: @@ -342,6 +341,12 @@ tryMSG opt = bothWays $ \shallow_state state -> do (h_hs, e') <- renameSCResult ids (rn_r, e) instanceSplit opt (deeds' `plusDeeds` deeds_r', Heap (h_r `M.union` h_hs) ids_r, k_r, e') +pprMSGResult :: MSGResult -> SDoc +pprMSGResult (Pair (deeds_l, heap_l@(Heap h_l ids_l), rn_l, k_l) (deeds_r, heap_r@(Heap h_r ids_r), rn_r, k_r), (heap@(Heap _ ids), k, qa)) + = pPrintFullState quietStatePrettiness (emptyDeeds, heap, k, qa) $$ + pPrintFullState quietStatePrettiness (deeds_l, heap_l, k_l, fmap Question (annedVar (mkTag 0) nullAddrId)) $$ + pPrintFullState quietStatePrettiness (deeds_r, heap_r, k_r, fmap Question (annedVar (mkTag 0) nullAddrId)) + renameSCResult :: InScopeSet -> In FVedTerm -> ScpM (PureHeap, FVedTerm) renameSCResult ids (rn_r, e) = do hs <- outputFreeVars _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
