Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch :
http://hackage.haskell.org/trac/ghc/changeset/37d1c06c095933ecb2242ef63d4a7a995db54f0c >--------------------------------------------------------------- commit 37d1c06c095933ecb2242ef63d4a7a995db54f0c Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Wed Apr 18 18:48:22 2012 +0100 Better setting of generalisation flags in MSG >--------------------------------------------------------------- compiler/supercompile/Supercompile/Drive/MSG.hs | 35 ++++++++++------------ 1 files changed, 16 insertions(+), 19 deletions(-) diff --git a/compiler/supercompile/Supercompile/Drive/MSG.hs b/compiler/supercompile/Supercompile/Drive/MSG.hs index 024d2d9..dd08bff 100644 --- a/compiler/supercompile/Supercompile/Drive/MSG.hs +++ b/compiler/supercompile/Supercompile/Drive/MSG.hs @@ -435,7 +435,7 @@ msgEC init_rn2 = go init_rn2 (kf_r, k_r) <- splitCar "right" k_r (rn2'', mkf') <- msgECFrame rn2' kf_l kf_r return (map (liftM (second (\it rn2 -> liftM2 (\kf (k_l, k, k_r) -> (k_l, kf `Car` k, k_r)) (mkf' rn2) (it rn2)))) $ go rn2'' k_l k_r)) ++ - [return (rn2', \_ -> return (k_l, Loco False, k_r))] + [return (rn2', \_ -> return (k_l, Loco (not (nullTrain k_r)), k_r))] -- Right biased generalisation flag msgECFrame :: RnEnv2 -> Tagged StackFrame -> Tagged StackFrame -> MSG' (RnEnv2, RnEnv2 -> MSG (Tagged StackFrame)) msgECFrame init_rn2 kf_l kf_r = liftM (second (liftM (Tagged (tag kf_r)) .)) $ go (tagee kf_l) (tagee kf_r) -- Right biased @@ -472,24 +472,21 @@ msgPureHeap {- mm -} rn2 msg_s init_h_l init_h_r (k_bvs_l, k_fvs_l) (k_bvs_r, k_ -- Just like an internal binder, we have to be sure to match the binders themselves (for e.g. type variables) | Right (msg_s, x_common) <- flip unMSG (msg_s { msgPending = rest }) (msgBndrExtras rn2 x_common x_l x_r) - = prod (do (used_l', hb_l) <- mb_common_l - (used_r', hb_r) <- mb_common_r - (msg_s, hb) <- case (inject hb_l, inject hb_r) of - (Just (Just (let_bound_l, in_e_l)), Just (Just (let_bound_r, in_e_r))) - | let_bound_l == let_bound_r - , Right (msg_s, in_e) <- flip unMSG msg_s $ msgIn renameAnnedTerm annedTermFreeVars msgTerm rn2 in_e_l in_e_r - -> return (msg_s, (if let_bound_r then letBound else internallyBound) in_e) - (Just Nothing, Just Nothing) - | x_l == x_r - -> return (msg_s, hb_r) -- Right biased - -- NB: we reject two lambda bound things as not matching so that we go into the "generalise" - -- code path. By doing it this way, we ensure we not only add the common lambdaBound heap binding, - -- but also appropriate renamings to both rn_l and rn_r. - --(Nothing, Nothing) - -- -> return (msg_s, lambdaBound) - _ -> Left "msgPureHeap: non-unifiable heap bindings" + = prod (do (used_l, hb_l) <- mb_common_l + (used_r, hb_r) <- mb_common_r + (rn_l, rn_r, msg_s, hb) <- case (inject hb_l, inject hb_r) of + (Just (Just (let_bound_l, in_e_l)), Just (Just (let_bound_r, in_e_r))) + | let_bound_l == let_bound_r + , Right (msg_s, in_e) <- flip unMSG msg_s $ msgIn renameAnnedTerm annedTermFreeVars msgTerm rn2 in_e_l in_e_r + -> return (rn_l, rn_r, msg_s, (if let_bound_r then letBound else internallyBound) in_e) + (Just Nothing, Just Nothing) + | x_l == x_r + -> return (rn_l, rn_r, msg_s, hb_r) -- Right biased + (Nothing, Nothing) + -> return (M.insert x_common x_l rn_l, M.insert x_common x_r rn_r, msg_s, lambdaBound) + _ -> Left "msgPureHeap: non-unifiable heap bindings" -- If they match, we need to make a common heap binding - return (go rn_l rn_r used_l' used_r' + return (go rn_l rn_r used_l used_r h_l h_r (M.insert x_common hb h) msg_s)) ++ -- If they don't match, we need to generalise prod (do -- Whenever we add a new "outside" binding like this we have to transitively copy in all the things @@ -497,7 +494,7 @@ msgPureHeap {- mm -} rn2 msg_s init_h_l init_h_r (k_bvs_l, k_fvs_l) (k_bvs_r, k_ (used_l', h_l') <- mb_individual_l >>= suck init_h_l k_bvs_l h_l x_l (used_r', h_r') <- mb_individual_r >>= suck init_h_r k_bvs_r h_r x_r return $ go (M.insert x_common x_l rn_l) (M.insert x_common x_r rn_r) used_l' used_r' - h_l' h_r' (M.insert x_common lambdaBound h) msg_s) + h_l' h_r' (M.insert x_common generalised h) msg_s) -- FIXME: only mark as generalised if *right hand side* was not e.g. a lambda bound | otherwise = [Left "msgPureHeap: non-unifiable heap binders"] where _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
