compiler/simplCore/SAT.hs has a TODO comment about the fact that it does a fair bit of appending onto the ends of lists, and that should be done differently. I made an attempt to fix it. The complexity of the recursion, however, leaves me uncertain as to whether I really did or not. I've attached a diff and I hope someone will be able to take a look at it. The only use of Sequence.fromList is source line 172, and the only significant use of Foldable.toList (aside from pretty-printing) is on source line 402. Note that the use of Sequence may be temporary—I want to get the right code structure down before choosing the best data structure.
Thanks, David Feuer
diff --git a/compiler/simplCore/SAT.lhs b/compiler/simplCore/SAT.lhs index a0b3151..aae3e69 100644 --- a/compiler/simplCore/SAT.lhs +++ b/compiler/simplCore/SAT.lhs @@ -67,10 +67,16 @@ import VarSet import Unique import UniqSet import Outputable - import Data.List import FastString +--We're probably not really going to use Data.Sequence +--this is just a temporary temporary thing to see what we'll +--actually need. +import qualified Data.Sequence as S +import Data.Foldable (toList) +import Data.Sequence (Seq, (|>), (<|), (><), fromList) + #include "HsVersions.h" \end{code} @@ -118,7 +124,7 @@ data Staticness a = Static a | NotStatic type IdAppInfo = (Id, SATInfo) -type SATInfo = [Staticness App] +type SATInfo = Seq (Staticness App) -- [Staticness App] type IdSATInfo = IdEnv SATInfo emptyIdSATInfo :: IdSATInfo emptyIdSATInfo = emptyUFM @@ -129,7 +135,7 @@ pprIdSATInfo id_sat_info = vcat (map pprIdAndSATInfo (Map.toList id_sat_info)) -} pprSATInfo :: SATInfo -> SDoc -pprSATInfo staticness = hcat $ map pprStaticness staticness +pprSATInfo staticness = hcat $ map pprStaticness $ toList staticness pprStaticness :: Staticness App -> SDoc pprStaticness (Static (VarApp _)) = ptext (sLit "SV") @@ -139,15 +145,22 @@ pprStaticness NotStatic = ptext (sLit "NS") mergeSATInfo :: SATInfo -> SATInfo -> SATInfo -mergeSATInfo [] _ = [] -mergeSATInfo _ [] = [] -mergeSATInfo (NotStatic:statics) (_:apps) = NotStatic : mergeSATInfo statics apps -mergeSATInfo (_:statics) (NotStatic:apps) = NotStatic : mergeSATInfo statics apps -mergeSATInfo ((Static (VarApp v)):statics) ((Static (VarApp v')):apps) = (if v == v' then Static (VarApp v) else NotStatic) : mergeSATInfo statics apps -mergeSATInfo ((Static (TypeApp t)):statics) ((Static (TypeApp t')):apps) = (if t `eqType` t' then Static (TypeApp t) else NotStatic) : mergeSATInfo statics apps -mergeSATInfo ((Static (CoApp c)):statics) ((Static (CoApp c')):apps) = (if c `coreEqCoercion` c' then Static (CoApp c) else NotStatic) : mergeSATInfo statics apps -mergeSATInfo l r = pprPanic "mergeSATInfo" $ ptext (sLit "Left:") <> pprSATInfo l <> ptext (sLit ", ") - <> ptext (sLit "Right:") <> pprSATInfo r +mergeSATInfo l r = S.zipWith mergeSA l r + where + mergeSA NotStatic _ = NotStatic + mergeSA _ NotStatic = NotStatic + mergeSA (Static (VarApp v)) (Static (VarApp v')) + | v == v' = Static (VarApp v) + | otherwise = NotStatic + mergeSA (Static (TypeApp t)) (Static (TypeApp t')) + | t `eqType` t' = Static (TypeApp t) + | otherwise = NotStatic + mergeSA (Static (CoApp c)) (Static (CoApp c')) + | c `coreEqCoercion` c' = Static (CoApp c) + | otherwise = NotStatic + mergeSA _ _ = pprPanic "mergeSATInfo" $ ptext (sLit "Left:") + <> pprSATInfo l <> ptext (sLit ", ") + <> ptext (sLit "Right:") <> pprSATInfo r mergeIdSATInfo :: IdSATInfo -> IdSATInfo -> IdSATInfo mergeIdSATInfo = plusUFM_C mergeSATInfo @@ -156,7 +169,7 @@ mergeIdSATInfos :: [IdSATInfo] -> IdSATInfo mergeIdSATInfos = foldl' mergeIdSATInfo emptyIdSATInfo bindersToSATInfo :: [Id] -> SATInfo -bindersToSATInfo vs = map (Static . binderToApp) vs +bindersToSATInfo vs = fromList $ map (Static . binderToApp) vs where binderToApp v | isId v = VarApp v | isTyVar v = TypeApp $ mkTyVarTy v | otherwise = CoApp $ mkCoVarCo v @@ -178,7 +191,7 @@ satTopLevelExpr expr interesting_ids = do satExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo) satExpr var@(Var v) interesting_ids = do let app_info = if v `elementOfUniqSet` interesting_ids - then Just (v, []) + then Just (v, S.empty) else Nothing return (var, emptyIdSATInfo, app_info) @@ -195,8 +208,7 @@ satExpr (App fn arg) interesting_ids = do case fn_app of Nothing -> satRemainder Nothing Just (fn_id, fn_app_info) -> - -- TODO: remove this use of append somehow (use a data structure with O(1) append but a left-to-right kind of interface) - let satRemainderWithStaticness arg_staticness = satRemainder $ Just (fn_id, fn_app_info ++ [arg_staticness]) + let satRemainderWithStaticness arg_staticness = satRemainder $ Just (fn_id, fn_app_info |> arg_staticness) in case arg of Type t -> satRemainderWithStaticness $ Static (TypeApp t) Coercion c -> satRemainderWithStaticness $ Static (CoApp c) @@ -371,7 +383,7 @@ saTransformMaybe binder maybe_arg_staticness rhs_binders rhs_body where should_transform staticness = n_static_args > 1 -- THIS IS THE DECISION POINT where - n_static_args = length (filter isStaticValue staticness) + n_static_args = S.length (S.filter isStaticValue staticness) saTransform :: Id -> SATInfo -> [Id] -> CoreExpr -> SatM CoreBind saTransform binder arg_staticness rhs_binders rhs_body @@ -385,13 +397,17 @@ saTransform binder arg_staticness rhs_binders rhs_body -- rhs_binders = [\alpha, \beta, c, n, xs] -- rhs_body = e - binders_w_staticness = rhs_binders `zip` (arg_staticness ++ repeat NotStatic) + (rhs_binders_known_staticness, rhs_binders_unknown_staticness) = splitAt (S.length arg_staticness) rhs_binders + + binders_w_known_staticness = rhs_binders_known_staticness `zip` toList arg_staticness + binders_w_staticness = binders_w_known_staticness ++ + map (\x->(x,NotStatic)) rhs_binders_unknown_staticness -- Any extra args are assumed NotStatic non_static_args :: [Var] -- non_static_args = [xs] -- rhs_binders_without_type_capture = [\alpha', \beta', c, n, xs] - non_static_args = [v | (v, NotStatic) <- binders_w_staticness] + non_static_args = [v | (v, NotStatic) <- binders_w_known_staticness] ++ rhs_binders_unknown_staticness clone (bndr, NotStatic) = return bndr clone (bndr, _ ) = do { uniq <- newUnique
_______________________________________________ ghc-devs mailing list ghc-devs@haskell.org http://www.haskell.org/mailman/listinfo/ghc-devs