From 5a096519b91d6dcb7c0b21c276c304f3281f043c Mon Sep 17 00:00:00 2001 From: rgvwille Date: Fri, 26 Mar 2010 13:47:29 +0000 Subject: [PATCH] fixed merge bugs --- EHC/src/ehc/GrinCode.cag | 8 ++++---- EHC/src/ehc/GrinCode/AbsSyn.cag | 2 +- EHC/src/ehc/GrinCode/SolveEqs.chs | 3 +-- EHC/src/ehc/GrinCode/Trf/ApplyUnited.cag | 4 +++- EHC/src/ehc/GrinCode/Trf/CopyPropagation.cag | 9 +++++---- EHC/src/ehc/GrinCode/Trf/HptInline.cag | 16 +++++++--------- EHC/src/ehc/GrinCode/Trf/SingleCase.cag | 15 ++++++++------- 7 files changed, 29 insertions(+), 28 deletions(-) diff --git a/EHC/src/ehc/GrinCode.cag b/EHC/src/ehc/GrinCode.cag index 2e7a290d2..e0ea22fc6 100644 --- a/EHC/src/ehc/GrinCode.cag +++ b/EHC/src/ehc/GrinCode.cag @@ -409,12 +409,12 @@ willUseForNodeField n m = maybe False (WillUseFor_NodeField `Set.member`) $ Map. %%[(20 codegen grin) hs instance Serialize GrInl where - sput (GrInl_Call a b) = sputWord8 0 >> sput a >> sput b - sput (GrInl_CAF a ) = sputWord8 1 >> sput a + sput (GrInl_Call a b c d) = sputWord8 0 >> sput a >> sput b >> sput c >> sput d + sput (GrInl_CAF a b) = sputWord8 1 >> sput a >> sput b sget = do t <- sgetWord8 case t of - 0 -> liftM2 GrInl_Call sget sget - 1 -> liftM GrInl_CAF sget + 0 -> liftM4 GrInl_Call sget sget sget sget + 1 -> liftM2 GrInl_CAF sget sget instance Serialize GrExpr where sput (GrExpr_Seq a b c ) = sputWord8 0 >> sput a >> sput b >> sput c diff --git a/EHC/src/ehc/GrinCode/AbsSyn.cag b/EHC/src/ehc/GrinCode/AbsSyn.cag index b40c543c5..306980715 100644 --- a/EHC/src/ehc/GrinCode/AbsSyn.cag +++ b/EHC/src/ehc/GrinCode/AbsSyn.cag @@ -49,7 +49,7 @@ DATA GrExpr pat : GrPatLam body : GrExpr | Unit val : GrVal - type : GrType + type : GrType | UpdateUnit nm : {HsName} val : GrVal | Case val : GrVal diff --git a/EHC/src/ehc/GrinCode/SolveEqs.chs b/EHC/src/ehc/GrinCode/SolveEqs.chs index 9f7d81922..6fb9018ec 100644 --- a/EHC/src/ehc/GrinCode/SolveEqs.chs +++ b/EHC/src/ehc/GrinCode/SolveEqs.chs @@ -72,7 +72,7 @@ envChanges equat env ; IsSelection d v i t -> d ; IsEvaluation d v ev -> d ; IsApplication d vs ev -> d - } in if True {-d == 222-} then trace ("222 eq = " ++ show equat) a else a) $ + } in if True {-d == 222-} then trace ("eq = " ++ show equat) a else a) $ case equat of IsBasic d -> return [(d, AbsBasic)] @@ -248,7 +248,6 @@ procChange env (i,e1) = do { (c,_,e0) <- readArray env i ; let e2 = e0 `mappend` e1 changed = e0 /= e2 - ; case e2 of { AbsError e -> error $ "variable " ++ show i ++ " going bad, err = " ++ e; _ -> return ()} ; when changed (writeArray env i (c,True,e2) --(const $ "\ninserting " ++ show @pat.getName ++ " with expr = " ++ show @expr.grTrf) >>> Map.insert @pat.getName val @lhs.env) (case @expr.grTrf of - GrExpr_Unit val@(GrVal_Node (GrTag_PApp _ _) _) -> Just val + GrExpr_Unit val@(GrVal_Node (GrTag_PApp _ _) _) _ -> Just val _ -> Nothing ) diff --git a/EHC/src/ehc/GrinCode/Trf/CopyPropagation.cag b/EHC/src/ehc/GrinCode/Trf/CopyPropagation.cag index 1f3ed660c..5f8068335 100644 --- a/EHC/src/ehc/GrinCode/Trf/CopyPropagation.cag +++ b/EHC/src/ehc/GrinCode/Trf/CopyPropagation.cag @@ -198,10 +198,11 @@ getHsName nm subst = case Map.lookup nm subst of Nothing -> nm Just repl -> case repl of - GrVal_Var v -> v - _ -> error ("CopyPropagation cannot substitute for name " ++ show nm ++ "\nvalue " ++ disp (ppGrExpr (GrExpr_Unit repl)) 0 "" - ++ "\nvalue2 = " ++ show repl - ++ "\nsubst = " ++ show subst) + GrVal_Var v -> v + _ -> error ("CopyPropagation cannot substitute for name " ++ show nm ++ "\nvalue " + ++ disp (ppGrExpr (GrExpr_Unit repl GrType_None)) 0 "" + ++ "\nvalue2 = " ++ show repl + ++ "\nsubst = " ++ show subst) mbSubstTag nm subst = case Map.lookup nm subst of diff --git a/EHC/src/ehc/GrinCode/Trf/HptInline.cag b/EHC/src/ehc/GrinCode/Trf/HptInline.cag index 6ce837dc8..528de7c80 100644 --- a/EHC/src/ehc/GrinCode/Trf/HptInline.cag +++ b/EHC/src/ehc/GrinCode/Trf/HptInline.cag @@ -23,8 +23,9 @@ %%[(20 codegen grin) -8.grInline hs export(hptInline) hptInline :: Bool -> HsNameS -> GrInlMp -> (GrModule,HptMap) -> Maybe ((GrModule,HptMap),GrInlMp) -hptInline allow expNmS inlMp (grMod,hptMap) = - let inlineResult = grInline allow expNmS inlMp grMod +hptInline allow expNmS inlMp (grMod,evalInlinedHptMap) = + let inlineResult = grInline allow expNmS inlMp grMod + hptMap = heapPointsToAnalysis grMod debug = False processInline :: (GrModule,GrInlMp,[(HsName,HsName)]) -> ((GrModule,HptMap),GrInlMp) processInline (grMod,inlMp,varSubs) = @@ -36,17 +37,14 @@ hptInline allow expNmS inlMp (grMod,hptMap) = hptExtended :: HptMap hptExtended = - let (low,high) = bounds hptMap - extra = foldl (\i -> max i . getNr . snd) high varSubs - high - res = listArray (low, high+extra) (elems hptMap ++ replicate extra AbsBottom) - hptAddedBinds :: [(Int,AbstractValue)] + let hptAddedBinds :: [(Int,AbstractValue)] hptAddedBinds = map (\(fromId,toId) -> (getNr toId,AbsBottom)) varSubs in addEnvNamedElems hptMap hptAddedBinds - (count,updatedHpt) = --(0,hptWithNewBindings) - -- heapPointsToAnalysis grMod - continuedHeapPointsToAnalysis (hptExtended,grMod) + (count,updatedHpt) = -- (0,hptWithNewBindings) + heapPointsToAnalysis grMod + -- continuedHeapPointsToAnalysis (hptExtended,grMod) diffHpt = diffMap hptExtended (snd $ heapPointsToAnalysis grMod) in ((grMod,updatedHpt),inlMp) <<< (const $ "hptExtended = " ++ disp (pp hptExtended) 80 []) diff --git a/EHC/src/ehc/GrinCode/Trf/SingleCase.cag b/EHC/src/ehc/GrinCode/Trf/SingleCase.cag index 511b5fde4..efe1d1adf 100644 --- a/EHC/src/ehc/GrinCode/Trf/SingleCase.cag +++ b/EHC/src/ehc/GrinCode/Trf/SingleCase.cag @@ -70,11 +70,12 @@ SEM GrPatAlt -- Do the replacement if possible SEM GrExpr - | Case (lhs.grTrf,lhs.changed) = maybe (@loc.grTrf,False) - (\(p,e) -> (case p of - Nothing -> e - Just pat -> GrExpr_Seq (GrExpr_Unit @val.grTrf) pat e - ,True)) - - @altL.onlyAlt + | Case (lhs.grTrf,lhs.changed) = + maybe (@loc.grTrf,False) + (\(p,e) -> (case p of + Nothing -> e + Just pat -> GrExpr_Seq (GrExpr_Unit @val.grTrf GrType_None) pat e + ,True)) + + @altL.onlyAlt %%]