X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSAT.lhs;h=61182895cf84da31913b04e0fbaca50af7da5fb6;hb=ba33ff9b0ae36ebeeda2eb5a37758984779fc11d;hp=329c95ca11a7cf2bea5fb72e00b38cf190e42116;hpb=6084fb5517da34f65034370a3695e2af3b85ce2b;p=ghc-hetmet.git diff --git a/compiler/simplCore/SAT.lhs b/compiler/simplCore/SAT.lhs index 329c95c..6118289 100644 --- a/compiler/simplCore/SAT.lhs +++ b/compiler/simplCore/SAT.lhs @@ -52,16 +52,13 @@ essential to make this work well! module SAT ( doStaticArgs ) where -import DynFlags import Var import CoreSyn -import CoreLint import CoreUtils import Type -import TcType +import Coercion import Id import Name -import OccName import VarEnv import UniqSupply import Util @@ -78,11 +75,8 @@ import FastString \end{code} \begin{code} -doStaticArgs :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind] -doStaticArgs dflags us binds = do - showPass dflags "Static argument" - let binds' = snd $ mapAccumL sat_bind_threaded_us us binds - endPass dflags "Static argument" Opt_D_verbose_core2core binds' +doStaticArgs :: UniqSupply -> [CoreBind] -> [CoreBind] +doStaticArgs us binds = snd $ mapAccumL sat_bind_threaded_us us binds where sat_bind_threaded_us us bind = let (us1, us2) = splitUniqSupply us @@ -119,7 +113,7 @@ satBind (Rec pairs) interesting_ids = do return (Rec (zipEqual "satBind" binders rhss'), mergeIdSATInfos sat_info_rhss') \end{code} \begin{code} -data App = VarApp Id | TypeApp Type +data App = VarApp Id | TypeApp Type | CoApp Coercion data Staticness a = Static a | NotStatic type IdAppInfo = (Id, SATInfo) @@ -130,7 +124,7 @@ emptyIdSATInfo :: IdSATInfo emptyIdSATInfo = emptyUFM {- -pprIdSATInfo id_sat_info = vcat (map pprIdAndSATInfo (fmToList id_sat_info)) +pprIdSATInfo id_sat_info = vcat (map pprIdAndSATInfo (Map.toList id_sat_info)) where pprIdAndSATInfo (v, sat_info) = hang (ppr v <> colon) 4 (pprSATInfo sat_info) -} @@ -140,6 +134,7 @@ pprSATInfo staticness = hcat $ map pprStaticness staticness pprStaticness :: Staticness App -> SDoc pprStaticness (Static (VarApp _)) = ptext (sLit "SV") pprStaticness (Static (TypeApp _)) = ptext (sLit "ST") +pprStaticness (Static (CoApp _)) = ptext (sLit "SC") pprStaticness NotStatic = ptext (sLit "NS") @@ -149,7 +144,8 @@ 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 `coreEqType` t' then Static (TypeApp t) 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 @@ -161,9 +157,9 @@ mergeIdSATInfos = foldl' mergeIdSATInfo emptyIdSATInfo bindersToSATInfo :: [Id] -> SATInfo bindersToSATInfo vs = map (Static . binderToApp) vs - where binderToApp v = if isId v - then VarApp v - else TypeApp $ mkTyVarTy v + where binderToApp v | isId v = VarApp v + | isTyVar v = TypeApp $ mkTyVarTy v + | otherwise = CoApp $ mkCoVarCo v finalizeApp :: Maybe IdAppInfo -> IdSATInfo -> IdSATInfo finalizeApp Nothing id_sat_info = id_sat_info @@ -202,9 +198,10 @@ satExpr (App fn arg) interesting_ids = do -- 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]) in case arg of - Type t -> satRemainderWithStaticness $ Static (TypeApp t) - Var v -> satRemainderWithStaticness $ Static (VarApp v) - _ -> satRemainderWithStaticness $ NotStatic + Type t -> satRemainderWithStaticness $ Static (TypeApp t) + Coercion c -> satRemainderWithStaticness $ Static (CoApp c) + Var v -> satRemainderWithStaticness $ Static (VarApp v) + _ -> satRemainderWithStaticness $ NotStatic where boring :: CoreExpr -> IdSATInfo -> Maybe IdAppInfo -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo) boring fn' sat_info_fn app_info = @@ -236,6 +233,9 @@ satExpr (Note note expr) interesting_ids = do satExpr ty@(Type _) _ = do return (ty, emptyIdSATInfo, Nothing) + +satExpr co@(Coercion _) _ = do + return (co, emptyIdSATInfo, Nothing) satExpr (Cast expr coercion) interesting_ids = do (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids @@ -332,7 +332,7 @@ If we don't we get something like this: [Arity 3] GHC.Base.until = \ (@ a_aiK) - (p_a6T :: a_aiK -> GHC.Bool.Bool) + (p_a6T :: a_aiK -> GHC.Types.Bool) (f_a6V :: a_aiK -> a_aiK) (x_a6X :: a_aiK) -> letrec { @@ -342,17 +342,17 @@ GHC.Base.until = \ (x_a6X :: a_aiK) -> let { sat_shadow_r17 :: forall a_a3O. - (a_a3O -> GHC.Bool.Bool) -> (a_a3O -> a_a3O) -> a_a3O -> a_a3O + (a_a3O -> GHC.Types.Bool) -> (a_a3O -> a_a3O) -> a_a3O -> a_a3O [] sat_shadow_r17 = \ (@ a_aiK) - (p_a6T :: a_aiK -> GHC.Bool.Bool) + (p_a6T :: a_aiK -> GHC.Types.Bool) (f_a6V :: a_aiK -> a_aiK) (x_a6X :: a_aiK) -> sat_worker_s1aU x_a6X } in case p_a6T x_a6X of wild_X3y [ALWAYS Dead Nothing] { - GHC.Bool.False -> GHC.Base.until @ a_aiK p_a6T f_a6V (f_a6V x_a6X); - GHC.Bool.True -> x_a6X + GHC.Types.False -> GHC.Base.until @ a_aiK p_a6T f_a6V (f_a6V x_a6X); + GHC.Types.True -> x_a6X }; } in sat_worker_s1aU x_a6X @@ -428,4 +428,4 @@ isStaticValue :: Staticness App -> Bool isStaticValue (Static (VarApp _)) = True isStaticValue _ = False -\end{code} \ No newline at end of file +\end{code}