X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fspecialise%2FSpecConstr.lhs;h=e5583e19dc1181c9e03d46d4bc6521ec473f66f9;hb=4a8a81e4c1a6e7b5fe85282229731916d9be908a;hp=1ee5935fa024c57f119b0de7d699aeb6f8c49954;hpb=6be927feb4c910a59990b5d2c32e0c41c3a2a95b;p=ghc-hetmet.git diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs index 1ee5935..e5583e1 100644 --- a/compiler/specialise/SpecConstr.lhs +++ b/compiler/specialise/SpecConstr.lhs @@ -14,13 +14,11 @@ import CoreSyn import CoreLint ( showPass, endPass ) import CoreUtils ( exprType, mkPiTypes ) import CoreFVs ( exprsFreeVars ) -import CoreSubst ( Subst, mkSubst, substExpr ) import CoreTidy ( tidyRules ) import PprCore ( pprRules ) import WwLib ( mkWorkerArgs ) -import DataCon ( dataConRepArity, isVanillaDataCon, - dataConUnivTyVars ) -import Type ( Type, tyConAppArgs, tyVarsOfTypes ) +import DataCon ( dataConRepArity, dataConUnivTyVars ) +import Type ( Type, tyConAppArgs ) import Rules ( matchN ) import Id ( Id, idName, idType, isDataConWorkId_maybe, mkUserLocal, mkSysLocal, idUnfolding, isLocalId ) @@ -429,12 +427,6 @@ data ConValue = CV AltCon [CoreArg] instance Outputable ConValue where ppr (CV con args) = ppr con <+> interpp'SP args -refineConstrEnv :: Subst -> ConstrEnv -> ConstrEnv --- The substitution is a type substitution only -refineConstrEnv subst env = mapVarEnv refine_con_value env - where - refine_con_value (CV con args) = CV con (map (substExpr subst) args) - emptyScEnv = SCE { scope = emptyVarEnv, cons = emptyVarEnv } data HowBound = RecFun -- These are the recursive functions for which @@ -591,10 +583,7 @@ conArgOccs :: ArgOcc -> AltCon -> [ArgOcc] conArgOccs (ScrutOcc fm) (DataAlt dc) | Just pat_arg_occs <- lookupUFM fm dc - = tyvar_unks ++ pat_arg_occs - where - tyvar_unks | isVanillaDataCon dc = [UnkOcc | tv <- dataConUnivTyVars dc] - | otherwise = [] + = [UnkOcc | tv <- dataConUnivTyVars dc] ++ pat_arg_occs conArgOccs other con = repeat UnkOcc \end{code} @@ -746,9 +735,8 @@ specialise env fn bndrs body body_usg [ exprsFreeVars pats `delVarSetList` vs | (vs,pats) <- good_calls ] uniq_calls = nubBy (same_call in_scope) good_calls - in - mapAndUnzipUs (spec_one env fn (mkLams bndrs body)) - (uniq_calls `zip` [1..]) } + ; mapAndUnzipUs (spec_one env fn (mkLams bndrs body)) + (uniq_calls `zip` [1..]) } where -- Two calls are the same if they match both ways same_call in_scope (vs1,as1)(vs2,as2) @@ -887,6 +875,13 @@ argToPat in_scope con_env (Var v) arg_occ then return (True, Var v) else wildCardPat (idType v) +argToPat in_scope con_env (Let _ arg) arg_occ + = argToPat in_scope con_env arg arg_occ + -- Look through let expressions + -- e.g. f (let v = rhs in \y -> ...v...) + -- Here we can specialise for f (\y -> ...) + -- because the rule-matcher will look through the let. + argToPat in_scope con_env arg arg_occ | is_value_lam arg = return (True, arg) @@ -965,4 +960,5 @@ is_con_app_maybe env expr mk_con_app :: AltCon -> [CoreArg] -> CoreExpr mk_con_app (LitAlt lit) [] = Lit lit mk_con_app (DataAlt con) args = mkConApp con args +mk_con_app other args = panic "SpecConstr.mk_con_app" \end{code}