Wed Jul 29 13:07:59 GMT Daylight Time 2009 t-peterj@microsoft.com * Add a Supercompilation pass. Wed Jul 29 13:41:57 GMT Daylight Time 2009 t-peterj@microsoft.com * Add the directory and the files, not just the plumbing. Thu Jul 30 08:27:52 GMT Daylight Time 2009 t-peterj@microsoft.com * Do not lambda lift for now. Thu Jul 30 16:51:48 GMT Daylight Time 2009 t-peterj@microsoft.com * Compare sizes of contexts to avoid plugging. Fri Jul 31 11:10:56 GMT Daylight Time 2009 t-peterj@microsoft.com * Add a comment and move a function to its proper place. Fri Jul 31 15:57:55 GMT Daylight Time 2009 t-peterj@microsoft.com * Add a parallel homeomrphic embedding test. Fri Jul 31 16:02:46 GMT Daylight Time 2009 t-peterj@microsoft.com * Put the zipped term in the memoization list as well. Fri Jul 31 16:07:23 GMT Daylight Time 2009 t-peterj@microsoft.com * Get the preprocessing right for parallel_scp. Fri Jul 31 16:11:39 GMT Daylight Time 2009 t-peterj@microsoft.com * Add parallel to the boot libraries. Fri Jul 31 17:04:20 GMT Daylight Time 2009 t-peterj@microsoft.com * Enable parallel supercompilation by default. Fri Jul 31 17:04:42 GMT Daylight Time 2009 t-peterj@microsoft.com * Early bailout for renamings. Fri Jul 31 18:22:49 GMT Daylight Time 2009 t-peterj@microsoft.com * Call realFvs'_type on Casts. Sat Aug 1 12:05:58 GMT Daylight Time 2009 t-peterj@microsoft.com * Use a parallell renamings as well. Sat Aug 1 14:12:05 GMT Daylight Time 2009 t-peterj@microsoft.com * Put the size of terms in Rho, and exploit this to prune candidates for folding and splitting. Sun Aug 2 13:48:06 GMT Daylight Time 2009 t-peterj@microsoft.com * Make maybeInline more readable and reduce the number of comparisons. Sun Aug 2 14:41:23 GMT Daylight Time 2009 t-peterj@microsoft.com * Use the plugged term instead of plugging in splitStore. Sun Aug 2 14:52:04 GMT Daylight Time 2009 t-peterj@microsoft.com * Use a FiniteMap instead of a list for local Functions. Sun Aug 2 15:36:16 GMT Daylight Time 2009 t-peterj@microsoft.com * Remove some unecessary intermediate lists. Wed Aug 5 14:39:45 GMT Daylight Time 2009 t-peterj@microsoft.com * Add comments about logging and adjust levels accordingly. Wed Aug 5 14:43:35 GMT Daylight Time 2009 t-peterj@microsoft.com * Give the printout a better description. Wed Aug 12 09:55:40 GMT Daylight Time 2009 t-peterj@microsoft.com * Add the old id to the inscope set, not a fresh one. Wed Aug 12 10:10:06 GMT Daylight Time 2009 t-peterj@microsoft.com * Ditto for function names. Wed Aug 12 11:06:41 GMT Daylight Time 2009 t-peterj@microsoft.com * Return free type variables before free variables. Wed Aug 12 11:07:19 GMT Daylight Time 2009 t-peterj@microsoft.com * Add more alternatives to realFvs'_type. Wed Aug 12 13:40:46 GMT Daylight Time 2009 t-peterj@microsoft.com * Zap occurence and unfoldings in inScope, and replace Vars with what is found in inscope. Wed Aug 12 13:42:45 GMT Daylight Time 2009 t-peterj@microsoft.com * Continue transforming even if there is no rule for constant folding. Wed Aug 12 14:54:40 GMT Daylight Time 2009 t-peterj@microsoft.com * Zap recursive unfoldings as well. Thu Aug 13 14:15:22 GMT Daylight Time 2009 t-peterj@microsoft.com * Signal when we potentially have h functions in our contexts. Thu Aug 13 16:20:54 GMT Daylight Time 2009 t-peterj@microsoft.com * Implement the new homeomorphic embedding. Fri Aug 14 10:18:01 GMT Daylight Time 2009 t-peterj@microsoft.com * Implement a parallell homemb. Fri Aug 14 15:18:10 GMT Daylight Time 2009 t-peterj@microsoft.com * Split on zipped form. Normalize the stored zipper before storing. Sat Aug 15 17:53:19 GMT Daylight Time 2009 t-peterj@microsoft.com * Add match/split working on the zipped representation. Sun Aug 16 17:00:00 GMT Daylight Time 2009 t-peterj@microsoft.com * Let match return the remaining context if there is one. Mon Aug 17 11:41:59 GMT Daylight Time 2009 t-peterj@microsoft.com * Implement Simon's suggestion for the homemb testing. Mon Aug 17 14:55:46 GMT Daylight Time 2009 t-peterj@microsoft.com * Generalise buildContext to take a context as top. Mon Aug 17 17:50:46 GMT Daylight Time 2009 t-peterj@microsoft.com * Make the whistle distinguish constructors from variables. Tue Aug 18 16:41:16 GMT Daylight Time 2009 t-peterj@microsoft.com * Use env' instad of env for handling name shadowing. Tue Aug 18 17:17:46 GMT Daylight Time 2009 t-peterj@microsoft.com * Rip out the clever parts of TermParts and return a closed expression instead. Both simpler and faster. Wed Aug 19 09:39:32 GMT Daylight Time 2009 t-peterj@microsoft.com * Make sure not to lose any terms when we rebuild expressions. Fri Aug 21 09:52:40 GMT Daylight Time 2009 t-peterj@microsoft.com * Make sure realFvs counts predicates. New patches: [Add a Supercompilation pass. t-peterj@microsoft.com**20090729120759] { hunk ./compiler/ghc.cabal.in 145 + supercomp hunk ./compiler/ghc.cabal.in 374 + Scp + ScpMonad hunk ./compiler/main/DynFlags.hs 135 + | Opt_D_dump_scp hunk ./compiler/main/DynFlags.hs 274 + | Opt_Scp hunk ./compiler/main/DynFlags.hs 359 + scpDebugLevel :: Int, -- ^ Debug level for Supercompiler hunk ./compiler/main/DynFlags.hs 609 + scpDebugLevel = 0, hunk ./compiler/main/DynFlags.hs 988 + | CoreDoScp hunk ./compiler/main/DynFlags.hs 1040 +-- | Enable lambda lifting, but not constants. +lambdaFloatOutSwitches :: FloatOutSwitches +lambdaFloatOutSwitches = FloatOutSwitches True False hunk ./compiler/main/DynFlags.hs 1065 + scp = dopt Opt_Scp dflags hunk ./compiler/main/DynFlags.hs 1129 + runWhen scp (CoreDoPasses [(CoreDoFloatOutwards lambdaFloatOutSwitches), + simpl_gently, CoreDoScp ]), + hunk ./compiler/main/DynFlags.hs 1430 + , Flag "ddump-scp" (setDumpFlag Opt_D_dump_scp) + Supported hunk ./compiler/main/DynFlags.hs 1555 + , Flag "fscp-debug-level" + (IntSuffix (\n -> upd (\dfs -> dfs{ scpDebugLevel = n }))) + Supported hunk ./compiler/main/DynFlags.hs 1712 + ( "scp", Opt_Scp, const Supported ), hunk ./compiler/simplCore/SimplCore.lhs 53 +import Scp ( scpProgram ) hunk ./compiler/simplCore/SimplCore.lhs 183 +doCorePass CoreDoScp = {-# SCC "Scp" #-} + describePass "Supercompilation" Opt_D_dump_scp $ + scpProgram hunk ./compiler/specialise/Rules.lhs 27 - lookupRule, mkLocalRule, roughTopNames + lookupRule, mkLocalRule, roughTopNames, + + eqExpr, locallyBoundR, expandId } [Add the directory and the files, not just the plumbing. t-peterj@microsoft.com**20090729124157] { adddir ./compiler/supercomp addfile ./compiler/supercomp/Scp.hs hunk ./compiler/supercomp/Scp.hs 1 +{-# OPTIONS -XRecordWildCards -XNamedFieldPuns #-} +module Scp ( + scpProgram + ) where + +#include "HsVersions.h" + +import CoreMonad +import CoreSyn +import HscTypes +import Rules ( RuleBase, mkRuleBase, lookupRule, getRules, eqExpr, locallyBoundR, expandId ) +import CoreSubst hiding (IdSubstEnv) +import CoreUtils hiding (exprIsConApp_maybe) +import CoreLint ( showPass, endPass ) +import CoreFVs ( exprFreeVars ) +import Id ( idUnfolding, mkUserLocal, idName, idDetails, idType, setIdUnfolding, isDataConWorkId_maybe, isDataConId_maybe, setIdUnfolding, zapIdOccInfo ) +import IdInfo ( IdDetails(..) ) +import VarSet ( varSetElems, mkVarSet, elemVarSet ) +import Type ( Type, coreEqType, tcPartOfType, splitForAllTy_maybe, isFunTy, mkTyVarTy, splitTyConApp, splitTyConApp_maybe, zipOpenTvSubst ) +import qualified Type (substTy) +import DataCon ( dataConUnivTyVars, dataConRepArgTys, dataConExTyVars, dataConEqSpec, dataConRepArity, dataConTyCon, dataConEqTheta, DataCon() ) +import VarEnv ( emptyInScopeSet, emptyVarEnv, uniqAway, extendInScopeSet, extendInScopeSetList, mkRnEnv2, varEnvElts, lookupVarEnv, inRnEnvR, extendVarEnv, nukeRnEnvL, rnOccR, rnOccL, IdEnv, rnInScope, rnBndr2, rnBndrs2, nukeRnEnvR, lookupRnInScope, extendRnInScopeList, elemInScopeSet, getInScopeVars, extendInScopeSetSet, delInScopeSet ) +import Unify ( MatchEnv(..), ruleMatchTyX ) +import Var ( isLocalVar, Var(..), TyVar(), mkTyVar, tyVarKind, Id(), isCoVar, isLocalId ) +import Util ( equalLength, lengthAtLeast ) +import TypeRep ( Type(..) ) +import TyCon ( tyConArity ) +import OccurAnal ( occurAnalysePgm ) + + + +-- For realEqExpr +import Coercion ( coreEqCoercion, mkTransCoercion, coercionKind, mkInstCoercion, decomposeCo, mkSymCoercion, isIdentityCoercion, mkEqPred, getEqPredTys ) + +import PrelRules ( primOpRules ) +import MonadUtils ( mapAndUnzipM ) +import MkId ( mkPrimOpId, mkImpossibleExpr ) +import PrimOp ( allThePrimOps ) + +import PprCore -- ( pprCoreBindings ) +import Outputable +-- For finding main +import OccName hiding (varName) +import PrelNames ( main_RDR_Unqual ) +import FastString ( mkFastString ) +import RdrName +import Name ( Name, nameOccName, nameSrcSpan ) + +import DynFlags ( DynFlags(..), DynFlag(..)) +import UniqSupply +import Maybes ( orElse, fromJust, isJust ) +import ScpMonad + + + +import Data.List ( intersect, nub ) -- , unzip3 ) + +import Debug.Trace ( trace ) + +tr :: (Monad m) => String -> m () +tr _ = return () +-- tr m = trace m (return ()) + +inlineFunctions :: [String] +inlineFunctions = ["append", "lvl", +-- "fromInteger", "fromInteger2", "smallInteger", +-- "plusInteger", "timesInteger", "minusInteger", +-- "plusInt", "p2Num", "$p2Num", "f3", "$f3", +-- "negateInteger", "absInteger", "signumInteger", +-- "+", "f2", "$f2", "$f6", "f6", "D:Num", "Num", +-- "Show", "D:Show", "a12", "a15", +-- "a33", "wa11", "$wa11", "a11", "return", +-- "a13", "getArgs", "lvl11", "a28", +-- "stdout", +-- "lvl15", "lvl10", "a10", +-- "f25", "$f25", "print", "a6", "a23", "a96", +-- ">>", + ">>="] + +approvedFunctions :: [String] +approvedFunctions = inlineFunctions + +forbiddenFunctions :: [String] +forbiddenFunctions = [-- "lvl9", +-- "$wa2", "$wa6", "$wa1", "a12", +-- "a14", +-- "a7", "a48", "$wa", "a15", "alloca", "lvl6", "a35", +-- "a22", "$wa22", "lvl4", +-- "lvl3", "lvl", "$wa7", + "stdout", "stdin", "errnoToIOError", "a13", "alloca"] + +{- + +Environment: goes downwards + +-} + +type InExpr = CoreExpr -- _Before_ transformation + +type OutExpr = CoreExpr -- _After_ transformation +type OutId = Id +type OutVar = Var + +data Context = EmptyCtxt + | AppCtxt InExpr Context + | PrimOpCtxt InExpr [OutExpr] [InExpr] Context + | CaseCtxt InExpr Context + | CastCtxt InExpr Context + + +plug :: Context -> CoreExpr -> CoreExpr +plug EmptyCtxt e = e +plug (AppCtxt arg c) e = plug c (mkApps e [arg]) +plug (PrimOpCtxt (Var v) oes ies c) e = plug c (mkApps (Var v) (oes ++ e:ies)) +plug (CaseCtxt (Case _ b t alts) c) e = plug c (Case e b t alts) +plug (CastCtxt (Cast _ co) c) e = plug c (Cast e co) +{- +refocus :: Context -> CoreExpr -> (Context, CoreExpr) +refocus EmptyCtxt e = (EmptyCtxt, e) +refocus (AppCtxt arg c) e = (c, mkApps e [arg]) +refocus (PrimOpCtxt (Var v) oes ies c) e = (c, mkApps (Var v) (oes ++ e:ies)) +refocus (CaseCtxt (Case _ b t alts) c) e = (c, Case e b t alts) +refocus (CastCtxt (Cast _ co) c) e = (c, Cast e co) +-} +depth :: Context -> Int +depth EmptyCtxt = 0 +depth (AppCtxt _ c) = 1 + depth c +depth (PrimOpCtxt _ _ _ c) = 1 + depth c +depth (CaseCtxt _ c) = 1 + depth c +depth (CastCtxt _ c) = 1 + depth c + +emptyContext :: Context +emptyContext = EmptyCtxt + +makePrimOpCtxt :: Var -> Context -> (CoreExpr, Context) +makePrimOpCtxt v c = go (PrimOpCtxt (Var v) [] [] EmptyCtxt) c + where go (PrimOpCtxt v is oes c) (AppCtxt arg c') = go (PrimOpCtxt v is (oes ++ [arg]) c) c' + go (PrimOpCtxt v is oes _) c = (head oes, PrimOpCtxt v is (tail oes) c) + +splitCaseCtxt :: CoreExpr -> Context -> Maybe (CoreExpr, Context) +splitCaseCtxt _ EmptyCtxt = Nothing +splitCaseCtxt e (AppCtxt arg c) = splitCaseCtxt (App e arg) c +splitCaseCtxt _ (PrimOpCtxt {}) = Nothing +splitCaseCtxt e c@(CaseCtxt {}) = Just (e, c) +splitCaseCtxt e (CastCtxt (Cast _ co) c) = splitCaseCtxt (Cast e co) c + +collectCtxtArgs :: Context -> Maybe ([CoreExpr], Context) +collectCtxtArgs (AppCtxt arg c) = go [arg] c + where go es (AppCtxt arg c) = go (arg:es) c + go es c = Just (reverse es, c) +collectCtxtArgs _ = Nothing + +data RhoElement = RhoE { + freshName :: Var, + inFvs :: [Var], + restExp :: Context, + headExp :: Var +} + +type Store = [(RhoElement, CoreExpr)] + +data ScpEnv = ScpE { + ls :: [RhoElement], -- This is \rho + fuelLimit :: Int, +-- scp_subst :: Subst, + inSet :: InScopeSet, + funSet :: InScopeSet, + binds :: [(Var, CoreExpr)] -- This is \mathcal{G} + } + + +initScpEnv :: DynFlags -> [CoreBind] -> ScpEnv +initScpEnv dflags b + = ScpE { +-- scp_subst = emptySubst, + ls = [], + fuelLimit = 20000, + inSet = emptyInScopeSet, + funSet = emptyInScopeSet, + binds = flattenBinds b + } + +-- scpSubstId :: ScpEnv -> Id -> Maybe CoreExpr +-- scpSubstId _ _ = Nothing +-- scpSubstId env v = case lookupIdSubst (scp_subst env) v of +-- e@(Var v') -> if v == v' then Nothing else Just e +-- e -> Just e + +-- scpSubstTy :: ScpEnv -> Type -> Type +-- scpSubstTy env ty = substTy (scp_subst env) ty + +-- zapScpSubst :: ScpEnv -> ScpEnv +-- zapScpSubst env = env { scp_subst = zapSubstEnv (scp_subst env)} + +-- extendScpInScope :: ScpEnv -> [Var] -> ScpEnv +-- -- Bring the quantified variables into scope +-- extendScpInScope env qvars = env' +-- where env' = env { scp_subst = extendInScopeList (scp_subst env) qvars, +-- inSet = qvars ++ inSet env} + + -- Extend the substitution +-- extendScpSubst :: ScpEnv -> Var -> OutExpr -> ScpEnv +-- extendScpSubst env var expr = env' +-- where env' = env { scp_subst = extendSubst (scp_subst env) var expr, +-- inSet = var:inSet env } + +-- extendScpSubstList :: ScpEnv -> [(Var,OutExpr)] -> ScpEnv +-- extendScpSubstList env prs = env' +-- where env' = env { scp_subst = extendSubstList (scp_subst env) prs, +-- inSet = (map fst prs) ++ inSet env } + +-- extendBndr :: ScpEnv -> Var -> (ScpEnv, Var) +-- extendBndr env bndr = (env { scp_subst = subst', inSet = bndr':inSet env}, bndr') +-- where +-- (subst', bndr') = substBndr (scp_subst env) bndr + +-- extendRecBndrs :: ScpEnv -> [Var] -> (ScpEnv, [Var]) +-- extendRecBndrs env bndrs = (env { scp_subst = subst', +-- inSet = bndrs' ++ inSet env }, bndrs') +-- where +-- (subst', bndrs') = substRecBndrs (scp_subst env) bndrs + +pjBndr :: ScpEnv -> Var -> (ScpEnv, Maybe (Subst, Var)) +pjBndr env bndr = case pjBndrs env [bndr] of + (env, Just (s', bndrs)) -> (env, Just (s', head bndrs)) + (env, Nothing) -> (env, Nothing) + +pjBndrs :: ScpEnv -> [Var] -> (ScpEnv, Maybe (Subst, [Var])) +pjBndrs env bndrs + | collision = (env, Just (go env (mkSubst (inSet env) emptyVarEnv emptyVarEnv, []) bndrs)) + | otherwise = (env', Nothing) + where collision = any ((flip elemInScopeSet) (inSet env)) bndrs || + any ((flip elemInScopeSet) (funSet env)) bndrs + + go _ (s, b) [] = (s, reverse b) + go env (s, b) (h:t) | elemInScopeSet h (inSet env) = go (env {inSet = extendInScopeSet (inSet env) h'}) (s', h':b) t + | otherwise = go (env {inSet = extendInScopeSet (inSet env) h'}) (s, h:b) t + where h' = uniqAway iss h + iss = extendInScopeSetSet (inSet env) (getInScopeVars (funSet env)) + s' | isTyVar h = extendTvSubst s h (mkTyVarTy (mkTyVar (varName h') (tyVarKind h))) + | otherwise = extendSubst s h (Var h') + env' = env {inSet = extendInScopeSetList (inSet env) bndrs} + +pjBndrsF :: ScpEnv -> [Var] -> (ScpEnv, Maybe (Subst, [Var])) +pjBndrsF env bndrs + | collision = (env, Just (go env (mkSubst (inSet env) emptyVarEnv emptyVarEnv, []) bndrs)) + | otherwise = (env', Nothing) + where collision = any ((flip elemInScopeSet) (inSet env)) bndrs || + any ((flip elemInScopeSet) (funSet env)) bndrs + + go _ (s, b) [] = (s, reverse b) + go env (s, b) (h:t) | elemInScopeSet h (funSet env) || elemInScopeSet h (inSet env) = go (env {funSet = extendInScopeSet (funSet env) h'}) (s', h':b) t + | otherwise = go (env {funSet = extendInScopeSet (funSet env) h'}) (s, h:b) t + where h' = uniqAway iss h + iss = extendInScopeSetSet (inSet env) (getInScopeVars (funSet env)) + s' | isTyVar h = extendTvSubst s h (mkTyVarTy (mkTyVar (varName h') (tyVarKind h))) + | otherwise = extendSubst s h (Var h') + env' = env {funSet = extendInScopeSetList (funSet env) bndrs} + + +{- + +The main recursive function, D[] + +-} + + +drive :: ScpEnv -> CoreExpr -> Context -> ScpM Store OutExpr + +drive env (Lit l) (CaseCtxt (Case _ b t alts) c) = do + let (_, _, rhs) = findAlt (LitAlt l) alts + `orElse` (DEFAULT, [], mkImpossibleExpr (coreAltsType alts)) + newrhs = substExpr (newExprSubst env b (Lit l)) rhs + scpLog 5 "R7:" (ppr (checkType "CL" (Case (Lit l) b t alts) newrhs)) + drive env newrhs c +drive env (Lit l) context@(PrimOpCtxt (Var fun) oes [] c) | all isValue oes = do + scpLog 3 ("R8 (" ++ show (length oes) ++ "):") (ppr (plug context (Lit l))) +-- rule_base <- lift getSimplRules + let rule_base = localRuleBase + let rules = getRules rule_base fun + iss = inSet env + Just (_, rule_rhs) = lookupRule (const True) iss fun (oes ++ [Lit l]) rules +-- scpLog 5 "R7" (ppr (checkType "R7" l rule_rhs)) + drive env rule_rhs c +drive env (Var v) context + | Just body <- maybeInline env v = do + scpLog 2 "R3:" (ppr v) + scpLog 4 "R3 ctxt:" (ppr (plug context (Var v))) + maybeFold env v context body + | Just _ <- isDataConId_maybe v, + Just (e, CaseCtxt (Case _ b _ alts) c') <- splitCaseCtxt (Var v) context, + Just (dc, e') <- exprIsConApp_maybe e = do + scpLog 4 "R27/R28:" (ppr e) + let (dc', bs, rhs) = findAlt (DataAlt dc) alts + `orElse` (DEFAULT, [], mkImpossibleExpr (coreAltsType alts)) + n_drop_tys = case dc' of + DataAlt dc'' -> length (dataConUnivTyVars dc'') + _ -> 0 + newargs = drop n_drop_tys e' + newrhs = substExpr (newExprSubst env b e) rhs -- XXXpj: Possibly duplicates computation. + + newe = case bs of + [] -> newrhs + _ -> let (newbs, rhs') = case pjBndrs env bs of + (_, Just (s, bs')) -> (bs', substExpr s newrhs) + _ -> (bs, newrhs) + in mkLets [NonRec b r | (b, r) <- (zip newbs newargs)] rhs' + + scpLog 4 "conApp stuff:" (ppr newe) +-- scpLog 5 "Binds in CASE:" (ppr (checkType "BCC" c newe)) + drive env newe c' + | PrimOpId _ <- idDetails v = do + let (e, context') = makePrimOpCtxt v context + scpLog 4 "PrimopCtxt" (ppr v <+> ppr e) + drive env e context' + | otherwise = do + scpLogDebug 4 "No unfolding:" (ppr v) + build env (Var v) context +drive env c@(Cast e co1) (CastCtxt (Cast _ co2) c') = do + let co' = mkTransCoercion co1 co2 + scpLog 4 "R6:" (ppr (checkType "R9" (Cast c co2) (Cast e co'))) + drive env e (CastCtxt (Cast e co') c') +drive env c@(Cast e co) context + | isIdentityCoercion co = drive env e context + | otherwise = drive env e (CastCtxt c context) +drive env l@(Lam b e) c + | Just (s, b') <- s' = drive env (Lam b' (substExpr s e)) c +-- | AppCtxt arg c' <- c, +-- isTypeArg arg = drive env (substExpr (newExprSubst env b arg) e) c' + | AppCtxt _ _ <- c = do + let Just (args, newc) = collectCtxtArgs c + newexp = doBeta env l args + scpLog 4 "LamBeta" (ppr (checkType "LamBeta" newexp (mkApps l args))) + drive env newexp newc + | CastCtxt (Cast _ co) c' <- c, + Just (args, newc) <- collectCtxtArgs c' = do +-- scpLog 4 "R17/R18/R19:" (ppr (checkType "R17/R18" t newexp)) + scpLog 4 "R17/R18/R19:" (ppr l) +-- scpLog 4 "R17/R18/R19:" (ppr newexp) + let newexp = doBeta env (Cast l co) args + scpLog 4 "LamCBeta" (ppr (checkType "LamBeta" newexp (mkApps (Cast l co) args))) + drive env newexp newc +-- drive env newexp c'' + | otherwise = do + e' <- drive env' e emptyContext + build env (Lam b e') c + where (env', s') = pjBndr env b +drive env l@(Let (NonRec b e) body) c + | Just (s, b') <- s' = do + let newexp = Let (NonRec b' (substExpr s e)) (substExpr s body) + drive env newexp c + | linear b body || exprIsTrivial e = do + let newexp = substExpr (newExprSubst env b e) body + scpLog 4 "R22/R23/R24:" (ppr l) + scpLog 5 "R22/R23/R24:" (ppr (checkType "R22" l newexp)) + drive env newexp c + | otherwise = do + scpLog 4 "R23/R24(nl):" (ppr l) + e' <- drive env e emptyContext + let newid = zapIdOccInfo (b `setIdUnfolding` NoUnfolding) + newbody = substExpr (newExprSubst env b (Var newid)) body + scpLog 5 "R23(nl):" (ppr (checkType "R23nle" e e')) + body' <- drive env' newbody c + scpLog 5 "R23(nl):" (ppr (checkType "R23nlb" (plug c body) body')) + let newexp = Let (NonRec b e') body' + return newexp + where (env', s') = pjBndr env b +drive env l@(Let b@(Rec p) body) c + | Just (s, bs') <- s' = do + let (_, es) = unzip p + newexp = Let (Rec (zip bs' (map (substExpr s) es))) (substExpr s body) + drive env newexp c + | otherwise = do + body' <- drive (env' {binds = p ++ binds env}) body c + bs' <- postLet env' b + let newexp | null bs' = body' + | otherwise = Let (Rec bs') body' + return newexp + where (env', s') = pjBndrsF env (bindersOf b) +drive env (Note _ e) context = drive env e context +drive env c@(Case e b t alts) context + | Just (s, b') <- s' = do + let alts' = map (\(c, bs, e) -> let (s', bs') = substBndrs s bs in (c, bs', substExpr s' e)) alts + newexp = Case e b' t alts' + drive env newexp context + | otherwise = drive env' e (CaseCtxt c context) + where (env', s') = pjBndr env b +drive env (App e1 e2) c = drive env e1 (AppCtxt e2 c) +drive env e c = do + tr ("Fallthrough: " ++ (showSDoc $ ppr (plug c e))) + build env e c + +build :: ScpEnv -> OutExpr -> Context -> ScpM Store OutExpr +build env e (PrimOpCtxt o oes ies c) + | null ies = build env (mkApps o (oes ++ [e])) c + | otherwise = drive env (head ies) (PrimOpCtxt o (oes ++ [e]) (tail ies) c) +build env e (AppCtxt arg c) = do + arg' <- drive env arg emptyContext + build env (mkApps e [arg']) c +build env e (CastCtxt (Cast _ co) c) = build env (Cast e co) c +-- build env (Var x) (CaseCtxt (Case _ b t alts) c) +build env e (CaseCtxt (Case _ b _ alts) c) = do + tr ("Switching: " ++ (showSDoc $ ppr e)) + alts' <- mapM (driveAlt env c) alts + let t' = exprType (trd3 . head $ alts') + return (Case e (zapIdOccInfo (b `setIdUnfolding` NoUnfolding)) t' alts') +build _ e EmptyCtxt = return e + + +driveApp :: ScpEnv -> Id -> Context + -> CoreExpr -- f's unfolding + -> ScpM Store CoreExpr +driveApp env fun context body + | fuelLimit env <= 0 = trace ("Ran out of fuel on " ++ (showSDoc $ ppr (plug context (Var fun)))) $ return (plug context (Var fun)) + | otherwise = do + let l' = plug context (Var fun) +-- (Var fun', args) = collectArgs l' + fvs = realFvs env l' + body_ty = exprType l' + full_ty = mkPiTypes fvs body_ty + let nont = homemb env l' + scpLog 4 "body_ty:" (ppr body_ty) + scpLog 4 "full_ty:" (ppr full_ty) + scpLogDebug 4 "Fvs:" (ppr fvs) + if (not $ null nont) + then do + scpLog 1 "Whistle:" (ppr l') + scpLog 1 "Whistle against:" (ppr nont) + haveWhistled nont l' fun full_ty + else do + -- tr ("Full ty: " ++ (showSDoc $ ppr full_ty)) + -- tr ("Body ty : " ++ (showSDoc $ ppr body_ty) ++ " arg_ty: " ++ (showSDoc $ ppr arg_ty)) + -- tr ("fns : " ++ (showSDoc $ ppr fvs')) + fname <- newName fun full_ty + scpLog 4 "Inserting to rho:" (ppr l') + scpLogDebug 4 "Fresh name:" (ppr fname) + + let newquad = RhoE { freshName = fname, inFvs = fvs, + restExp = context, headExp = fun} + env' = env {ls = newquad:ls env } + scpLog 4 "DriveApp:" (ppr body) + scpLog 4 "DriveApp2:" (ppr (plug context body)) + e' <- drive env' body context + addToStore (newquad, e') + scpLog 5 "DriveApp:" (ppr (checkType "Driveapp" (plug context (Var fun)) e')) + return (mkVarApps (Var fname) fvs) + where haveWhistled nont l' fun full_ty = do +-- ml <- currentStore + let + refl = [(n, in_fvs, e) | (n, in_fvs, e) <- nont, isHomemb env l' e] + if not $ null refl + then do + panic "Backtracking" + scpLog 3 "haveWhistled: Homemb but not renaming" (ppr l') + scpLog 3 "haveWhistled: Returning back up" (ppr refl) + ret <- newName fun full_ty + return (Var ret) + else do + -- Check type for g + gen env fun l' (trd3 . head $ nont) + +gen :: ScpEnv -> Id -> CoreExpr -> CoreExpr -> ScpM Store CoreExpr +gen env fun e1 e2 = do + res@(ground, _) <- msg env fun (e1, e2) + (term, tps) <- case ground of + Var _ -> split' env fun e1 + _ -> return res + let env' = env {inSet = extendInScopeSetList (inSet env) (getTpBinders tps)} + tr ("msg ground:" ++ (showSDocDebug $ ppr term)) + scpLog 3 "msg ground:" (ppr term) +-- scpLogDebug 4 "msg substvars:" (ppr ns) + scpLog 4 "msg subst:" (ppr tps) + term' <- drive env' term emptyContext + tps' <- driveTps env tps + let + rterm = plugTpTerm tps' term' + scpLog 4 "gen3:" (ppr rterm) + return rterm + +driveTps :: ScpEnv -> TermParts -> ScpM Store TermParts +driveTps env (ts, s, alts) = do + let (bs, tmp1) = unzip s + (ins1, _) = unzip tmp1 + (bs', ps) = unzip alts + (vs, ins2, _) = unzip3 ps + tmp1' <- mapM (\(is, e) -> drive (env {inSet = is}) e emptyContext) tmp1 + ps' <- mapM (\(bs, is, e) -> drive (env {inSet = extendInScopeSetList is bs}) e emptyContext) ps + let s' = zip bs (zip ins1 tmp1') + alts' = zip bs' (zip3 vs ins2 ps') + return (ts, s', alts') + + +split' :: ScpEnv -> Id -> CoreExpr -> ScpM s (CoreExpr, TermParts) +split' _ _ c@(Var {}) = return (c, emptyTp) +split' env fun (Lam b e) = do + x <- newName fun (exprType e) + let env' = env {inSet = extendInScopeSet (inSet env) b} + return (Lam b (Var x), newTpAlt env' x [b] e) +split' env fun (App e arg) = do + x1 <- newName fun (exprType e) + x2 <- newName fun (exprType arg) + return (App (Var x1) (Var x2), newTpExps env [x1, x2] [e, arg]) +split' env fun (Let (NonRec b e) body) = do + x1 <- newName fun (exprType e) + x2 <- newName fun (exprType body) + let env' = env {inSet = extendInScopeSet (inSet env) b} + tp = newTpAlt env' x1 [b] e + return (Let (NonRec b (Var x1)) (Var x2), extendTpExp env' tp x2 body) +split' env fun (Let (Rec p) e) = do + let (bs, es) = unzip p + env' = env {inSet = extendInScopeSetList (inSet env) bs} + x <- newName fun (exprType e) + xs <- mapM (newName fun) (map exprType es) + let tp = newTpAlts env' xs (repeat bs) es + return (Let (Rec (zip bs (map Var xs))) (Var x), extendTpExp env' tp x e) +split' env fun (Case e b t alts) = do + let (dc, bs, es) = unzip3 alts + env' = env {inSet = extendInScopeSet (inSet env) b} + x <- newName fun (exprType e) + xs <- mapM (newName fun) (map exprType es) + let alts' = zip3 dc (cycle [[]]) (map Var xs) + tp = newTpAlts env' xs bs es + return (Case (Var x) b t alts', extendTpAlt env tp x [b] e) +split' _ _ l@(Lit {}) = return (l, emptyTp) +split' _ _ d@(Type {}) = return (d, emptyTp) +split' env fun (Cast e c) = do + x <- newName fun (exprType e) + return (Cast (Var x) c, newTpExp env x e) +split' env fun (Note n e) = do + x <- newName fun (exprType e) + return (Note n (Var x), newTpExp env x e) + +driveAlt :: ScpEnv -> Context -> CoreAlt -> ScpM Store CoreAlt +driveAlt env c (con, bs, e) + | Just (s, bs') <- s' = do + let newtrip = (con, bs', substExpr s e) + driveAlt env c newtrip + | otherwise = do + scpLogDebug 4 "Branch fvs" (ppr bs) + scpLog 2 "Driving leg:" (ppr $ plug c e) + e' <- drive env' e c + return (con, bs, e') + where (env', s') = pjBndrs env bs + +maybeFold :: ScpEnv -> Id -> Context -> CoreExpr -> ScpM Store CoreExpr +maybeFold env fun myctxt e = do + scpLog 2 ("Unfolding found, depth " ++ show (depth myctxt)) (ppr fun) + scpLog 4 "Unfolds to:" (ppr e) + ml <- getStore + let -- l = substExpr (scp_subst env) (mkApps (Var fun) (args)) + -- l' = substExpr (scp_subst env) (plug (ctxt env) l) + l' = plug myctxt (Var fun) + res = renamings env (map fst ml) l' +-- scpLog 5 "maybeFold" (ppr (checkType "maybeFold" l unfolded)) + if (not $ null res) + then do + scpLog 4 "Renamings:" (ppr res) + scpLog 2 "Renaming found" (ppr fun) + let (n', in_fvs, (ts, es, vs)) = head res + in_scope = inSet env + s = mkSubst in_scope ts es + newexps = map (substExpr s) (map Var vs) + es' <- mapM (\e -> drive env e emptyContext) newexps + let tmps = mkSubst in_scope ts emptyVarEnv + s' = extendSubstList tmps (zip vs es') +-- fvs = realFvs env l' + newexp = substExpr s' (mkVarApps (Var n') in_fvs) +-- scpLogDebug 3 "Fvs2:" (ppr fvs) + scpLog 5 "Renamingg:" (ppr (checkType "renaming" l' newexp)) + return newexp + else do + -- tr ("driveApp: " ++ (showSDoc $ ppr e)) + scpLog 4 "No renaming:" (ppr l') + driveApp (env {fuelLimit = (fuelLimit env) - 1}) fun myctxt e + +renamings :: ScpEnv -> [RhoElement] -> CoreExpr -> [(Var, [Var], SubstEnv)] +renamings env ml in_exp = + [(freshName, inFvs, s) | RhoE {..} <- ml, + Just s <- [renaming (plug restExp (Var headExp)) inFvs in_exp], + coreEqType (exprType in_exp) (exprType (plug restExp (Var headExp))), + isTrueRenaming s] ++ + [(freshName, inFvs, s) | RhoE {..} <- (ls env), + Just s <- [renaming (plug restExp (Var headExp)) inFvs in_exp], + coreEqType (exprType in_exp) (exprType (plug restExp (Var headExp))) ] + where + in_scope = inSet env + -- See comment above "data MatchEnv" in Unify.lhs + lmenv = mkRnEnv2 in_scope + renaming e1 in_fvs e2 = match menv emptySubstEnv e1 e2 + where menv = ME { me_env = lmenv + , me_tmpls = mkVarSet in_fvs } + isTrueRenaming :: SubstEnv -> Bool + isTrueRenaming (_, es, fvs) = all isVar (map (substExpr s) (map Var fvs)) + where s = mkSubst (inSet env) emptyVarEnv es + + isVar (Var x) | isJust (maybeInline env x) = False + | otherwise = True + isVar _ = False + + +scpProgram :: ModGuts -> CoreM ModGuts +scpProgram mod_guts = do + dflags <- getDynFlags + us <- getUniqueSupplyM + rule_base <- getRuleBase + liftIO $ showPass dflags "Scp2" + + let main_is_flag = mainFunIs dflags + main_fn' = case main_is_flag of + Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) + Nothing -> main_RDR_Unqual + + + main_name <- mainName mod_guts main_fn' + e <- findMain mod_guts main_fn' my_binds + + tr (showSDoc $ ppr my_binds) +-- tr "---------------------------- End binds ----------\n" + + let (binds', store) = case e of + Nothing -> (my_binds, []) + Just e' -> initScp dflags rule_base us (go (initScpEnv dflags my_binds) main_name e') + + -- The simplifier blindly trusts occurence information, and any + -- occurence information still in the program is *very* wrong. + let allBinds = occurAnalysePgm $ + (Rec (createBinds store)):binds' + + dumpIfSet_dyn Opt_D_dump_scp "Scp binds" + (pprCoreBindings allBinds) + tr "------------ End binds ---------\n" + tr (showSDocDebug $ ppr allBinds) + tr "------------ End binds2 ---------\n" + + return (mod_guts { mg_binds = allBinds}) + where + my_binds = mg_binds mod_guts + + go env _ ((NonRec b e), rest_binds) = do + scpLog 1 ("Driving nonrec main") empty + exp <- drive env e emptyContext + return $ rest_binds ++ [(NonRec b exp)] + go env main_name ((Rec bs), rest_binds) = do + bs' <- findAndTransformMain (fromJust main_name) bs + return $ rest_binds ++ [(Rec bs')] + where findAndTransformMain _ [] = return [] + findAndTransformMain main_name ((n, e):binds) = do + if (varName n) == main_name + then do + scpLog 1 ("Driving rec main") (ppr e) + exp <- drive env e emptyContext + return ((n, exp):binds) + else do + binds' <- findAndTransformMain main_name binds + return ((n, e):binds') + + +mainName :: ModGuts -> RdrName -> CoreM (Maybe Name) +mainName mod_guts main_fn = do + main_name <- localMain mod_guts main_fn + return main_name + +findMain :: ModGuts -> RdrName -> [CoreBind] -> CoreM (Maybe (CoreBind, [CoreBind])) +findMain mod_guts main_fn binds + = do + main_name <- localMain mod_guts main_fn + + let p = case (go binds main_name) of + Nothing -> Nothing + Just b -> Just (b, dropBind b binds) + + return p + where + go :: [CoreBind] -> Maybe Name -> Maybe CoreBind + go _ Nothing = Nothing + go [] _ = Nothing + go ((NonRec b e):binds) (Just n) = if (varName b) == n then Just (NonRec b e) else go binds (Just n) + go (Rec b:binds) n = if hasMain b n then Just (Rec b) else go binds n + where hasMain [] _ = False + hasMain ((b, _):binds) (Just n) = if (varName b) == n then True else hasMain binds (Just n) + +dropBind :: CoreBind -> [CoreBind] -> [CoreBind] +dropBind _ [] = [] +dropBind b@(NonRec b1 _) (l@(NonRec b2 _):t) = if b1 == b2 then dropBind b t else l:dropBind b t +dropBind b@(Rec b1) (l@(Rec b2):t) = if bs1 == bs2 then dropBind b t else l:dropBind b t + where bs1 = map fst b1 + bs2 = map fst b2 +dropBind b (l:t) = l:dropBind b t + +localMain :: ModGuts -> RdrName -> CoreM (Maybe Name) +localMain mod_guts main_fn = do + let env = mg_rdr_env mod_guts + mname = case [name | gre <- lookupGRE_RdrName main_fn env, let name = gre_name gre, rdrNameSpace main_fn == occNameSpace (nameOccName name)] of + [name] -> Just name + [] -> Nothing + _ -> panic "Several Main in one module?" + return mname + + +--- XXXpj: Should this go into CoreUtils.lhs? +realNoteEq :: Note -> Note -> Bool +realNoteEq (SCC c1) (SCC c2) = c1 == c2 +realNoteEq (InlineMe) (InlineMe) = True +realNoteEq (CoreNote s1) (CoreNote s2) = s1 == s2 +realNoteEq _ _ = False + + +newName :: Id -> Type -> ScpM s Var +newName e t = do + uniq <- getUniqueM -- Us + let fn_name = idName e + fn_loc = nameSrcSpan fn_name + spec_occ = mkSpecOcc (nameOccName fn_name) +-- spec_name = mkSystemName uniq spec_occ + spec_id = mkUserLocal spec_occ uniq t fn_loc + return spec_id + +maybeInline :: ScpEnv -> Id -> Maybe CoreExpr +maybeInline env fun +-- | Just e <- go binds' fun +-- , elem (occNameString (nameOccName (idName fun))) approvedFunctions = Just e -- trace (showSDoc $ ppr $ idName fun) Just e +-- | Just e <- maybeUnfoldingTemplate (idUnfolding fun) +-- , not (isLocalId fun) +-- , elem (occNameString (nameOccName (idName fun))) approvedFunctions = Just e -- trace (showSDoc $ ppr $ idName fun) Just e + | Just e <- go binds' fun + , not (elem (occNameString (nameOccName (idName fun))) forbiddenFunctions) = Just e -- trace (showSDoc $ ppr $ idName fun) Just e + | Just e <- maybeUnfoldingTemplate (idUnfolding fun) + , not (isLocalId fun) + , not (elem (occNameString (nameOccName (idName fun))) forbiddenFunctions) = Just e -- trace (showSDoc $ ppr $ idName fun) Just e +-- | Just e <- go binds' fun = Just e +-- | Just e <- maybeUnfoldingTemplate (idUnfolding fun) = Just e + | otherwise = Nothing + where binds' = binds env + go [] _ = Nothing + go ((b, e):binds) n = if (varName b) == (idName n) then Just e else go binds n + + +realExprSize :: CoreExpr -> Integer +realExprSize (Var _) = 1 +realExprSize (Lit _) = 1 +realExprSize (App e1 e2) = realExprSize e1 + realExprSize e2 +realExprSize (Lam _ e) = 1 + realExprSize e +realExprSize (Let (NonRec _ e) body) = 1 + realExprSize e + realExprSize body +realExprSize (Let (Rec p) body) = 1 + sum (map (realExprSize . snd) p) + + realExprSize body +realExprSize (Case e _ _ alts) = 1 + realExprSize e + + sum (map (realExprSize . trd3) alts) +realExprSize (Cast e _) = 1 + realExprSize e +realExprSize (Note _ e) = 1 + realExprSize e +realExprSize (Type _) = 1 + + +-- Do not put function names in your inSet, that is what funSet is for. +-- We distinguish between variables and names. +realFvs :: ScpEnv -> CoreExpr -> [Var] +realFvs env e = nub (realFvs' env e) + +realFvs' :: ScpEnv -> CoreExpr -> [Var] +realFvs' env (Var v) | elemInScopeSet v (inSet env) = [v] + | otherwise = [] +realFvs' _ (Lit {}) = [] +realFvs' env (App e1 e2) = realFvs' env e1 ++ realFvs' env e2 +realFvs' env (Lam b e) = delete [b] (realFvs' env e) +realFvs' env (Let b e') = delete (bindersOf b) (concat (map (realFvs' env) (rhssOfBind b)) ++ realFvs' env e') +realFvs' env (Case e b _ alts) = e1 ++ e2 + where e1 = realFvs' env e + e2 = delete [b] (concat (map (realFvs' env) (rhssOfAlts alts))) +realFvs' env (Cast e co) = realFvs' env e -- XXXpj: What about free tvs in co? +realFvs' env (Note _ e) = realFvs' env e +realFvs' env (Type t) = realFvs'_type env t + +realFvs'_type :: ScpEnv -> Type -> [Var] +realFvs'_type env (TyVarTy v) | elemInScopeSet v (inSet env) = [v] + | otherwise = [] +realFvs'_type _ _ = [] + +localRuleBase :: RuleBase +localRuleBase = mkRuleBase (concat (map func allThePrimOps)) + where func op = primOpRules op (idName (mkPrimOpId op)) + + +-- XXXpj: Could merge alt 1 and alt 2 into one subst; still need 3 guards. +doBeta :: ScpEnv -> CoreExpr -> [CoreExpr] -> CoreExpr +doBeta env (Lam b body) args@(a:as) + | Just (s, b') <- s' = doBeta env (Lam b' (substExpr s body)) args + | isTypeArg a = doBeta env (substExpr (extendSubst emptySubst b a) body) as + | otherwise = Let (NonRec b a) (doBeta env' body as) + where (env', s') = pjBndr env b +doBeta env e@(Cast (Lam b body) co) args@(a:as) + | Just (s, b') <- s' = doBeta env (Cast (Lam b' (substExpr s body)) co) args + | otherwise = doBeta env e' (a':as) + where (_, s') = pjBndr env b + (App e' a') = evalPush (App e a) +doBeta _ fn args = mkApps fn args + + +isValue :: CoreExpr -> Bool +isValue (Var {}) = False +isValue (Lit {}) = True +isValue (Lam {}) = True +isValue (Type {}) = True +isValue (App {}) = False +isValue (Let {}) = False +isValue (Case {}) = False +isValue (Note {}) = False +isValue (Cast {}) = False + + +homemb :: ScpEnv -> CoreExpr -> [(Var, [Var], CoreExpr)] +homemb env in_exp = [(freshName, inFvs, plug restExp (Var headExp)) | RhoE {..} <- (ls env), msize > realExprSize (plug restExp (Var headExp)), isHomemb env (plug restExp (Var headExp)) in_exp, coreEqType (exprType (plug restExp (Var headExp))) (exprType in_exp)] -- YYY: UNSOUND + where msize = realExprSize in_exp + +isHomemb :: ScpEnv -> CoreExpr -> CoreExpr -> Bool +isHomemb env e1 e2 = peel env e1 e2 || any (isHomemb env e1) (dive e2) + +dive :: CoreExpr -> [CoreExpr] +dive (Lam _ e) = [e] +dive (App e1 e2) = [e1, e2] +dive (Let b body) = body:rhssOfBind b +dive (Case cond _ _ alts) = cond:rhssOfAlts alts +dive (Cast e _) = [e] +dive (Note _ e) = [e] +dive (Lit {}) = [] +dive (Var {}) = [] +dive (Type {}) = [] + +peel :: ScpEnv -> CoreExpr -> CoreExpr -> Bool +peel env (Var v1) (Var v2) + | v1 == v2 = True + | PrimOpId f1 <- idDetails v1 + , PrimOpId f2 <- idDetails v2 = f1 == f2 + | isJust (maybeInline env v1) || isJust (maybeInline env v2) = False + | otherwise = True +peel _ (Lit {}) (Lit {}) = True +peel env (Lam _ e1) (Lam _ e2) = isHomemb env e1 e2 +peel env e1@(App {}) e2@(App {}) + | (f1, args1) <- collectArgs e1 + , (f2, args2) <- collectArgs e2 + , length args1 == length args2 = + isHomemb env f1 f2 && all (uncurry $ isHomemb env) (zip args1 args2) +peel env (Let (NonRec _ e1) body1) (Let (NonRec _ e2) body2) = + isHomemb env e1 e2 && isHomemb env body1 body2 +peel env (Let b1@(Rec p1) body1) (Let b2@(Rec p2) body2) + | length p1 == length p2 && bindersOf b1 == bindersOf b2 = + isHomemb env body1 body2 && and (zipWith (isHomemb env) (rhssOfBind b1) (rhssOfBind b2)) +peel env (Case c1 _ _ alts1) (Case c2 _ _ alts2) + | length alts1 == length alts2 = isHomemb env c1 c2 && + and (zipWith (isHomemb env) (rhssOfAlts alts1) (rhssOfAlts alts2)) +peel env (Cast e1 _) (Cast e2 _) = isHomemb env e1 e2 +peel env (Note _ e1) (Note _ e2) = isHomemb env e1 e2 +peel _ (Type _) (Type _) = True +peel _ _ _ = False + + +msg :: ScpEnv -> Id -> (CoreExpr, CoreExpr) -> ScpM s (CoreExpr, TermParts) +msg env fun e = do + (e', p) <- msg' env fun e + let (_, _, v) = unzip3 p + tp = foldr plusTp emptyTp v + return (e', tp) + + +msg' :: ScpEnv -> Id -> (CoreExpr, CoreExpr) -> ScpM s (CoreExpr, [([Var], [Var], TermParts)]) +msg' env _ (Var n1, Var n2) + | n1 == n2 = return (Var n1, []) + | otherwise = do + -- Could be handled by the default case, but this gives a name that you + -- can guess where it came from. + n <- newName n1 (exprType (Var n1)) + return (Var n, [([n1], [n2], newTpExp env n (Var n1))]) +msg' env fun (l1@(Lam b1 e1), l2@(Lam b2 e2)) + | b1 == b2 = do + let env' = env {inSet = extendInScopeSet (inSet env) b1} + (e', p) <- msg' env' fun (e1, e2) + let ys = [ fv1 | (fv1, fv2, _) <- p, elem b1 fv1 || elem b2 fv2] + if not $ null ys + then do + let fv1 = varSetElems (exprFreeVars l1) + fv2 = varSetElems (exprFreeVars l2) + n <- newName fun (exprType l1) + return (Var n, [(fv1, fv2, newTpExp env n l1)]) + else return (Lam b1 e', p) +msg' env fun (App (Var n1) arg1, App (Var n2) arg2) + | n1 == n2 = do + (arg, p) <- msg' env fun (arg1, arg2) + return (App (Var n1) arg, p) +msg' env fun (App e1 arg1, App e2 arg2) = do + (e1', p1) <- msg' env fun (e1, e2) + (arg1', p2) <- msg' env fun (arg1, arg2) + return (App e1' arg1', p1 ++ p2) +msg' env fun (l1@(Let (NonRec b1 e1) body1), l2@(Let (NonRec b2 e2) body2)) = do + let env' = env {inSet = extendInScopeSet (inSet env) b1} + (e1', p1) <- msg' env' fun (e1, e2) + (body', p2) <- msg' env' fun (body1, body2) + let p = p1 ++ p2 + ys = [ fv1 | (fv1, fv2, _) <- p, elem b1 fv1 || elem b2 fv2] + if not $ null ys + then do + let fv1 = varSetElems (exprFreeVars l1) + fv2 = varSetElems (exprFreeVars l2) + n <- newName fun (exprType l1) + return (Var n, [(fv1, fv2, newTpExp env n l1)]) + else return (Let (NonRec b1 e1') body', p) +msg' env fun (l1@(Let (Rec p1) body1), l2@(Let (Rec p2) body2)) + | bs1 == bs2 = do + let env' = env {inSet = extendInScopeSetList (inSet env) bs1} + (es', p1) <- mapAndUnzipM (msg' env' fun) (zip es1 es2) + (body', p2) <- msg' env' fun (body1, body2) + let p = p2 ++ concat p1 + ys = [ fv1 | (fv1, fv2, _) <- p, + or ((map ((flip elem) fv1)) bs1) || + or ((map ((flip elem) fv2)) bs2) ] + if any (not . null) ys + then do + let fv1 = varSetElems . exprFreeVars $ l1 + fv2 = varSetElems . exprFreeVars $ l2 + n <- newName fun (exprType l1) + return (Var n, [(fv1, fv2, newTpExp env n l1)]) + else return (Let (Rec (zip bs1 es')) body', p2 ++ concat p1) + where (bs1, es1) = unzip p1 + (bs2, es2) = unzip p2 +msg' env fun (l1@(Case c1 b1 t1 alts1), l2@(Case c2 b2 t2 alts2)) + | t1 `coreEqType` t2 && map fst3 alts1 == map fst3 alts2 = do + let env' = env {inSet = extendInScopeSet (inSet env) b1} + (c', p1) <- msg' env' fun (c1, c2) + let (dc1, bs1, _) = unzip3 alts1 + (_, bs2, _) = unzip3 alts2 + (es1', p2) <- mapAndUnzipM (\((_, bs1, e1), (_, _, e2)) -> msg' (env' {inSet = extendInScopeSetList (inSet env) bs1}) fun (e1, e2)) (zip alts1 alts2) + let ys = [ fv1 | p <- p2, (fv1, fv2, _) <- p, + elem b1 fv1 || elem b2 fv2 || + or ((map ((flip elem) fv1)) (concat bs1)) || + or ((map ((flip elem) fv2)) (concat bs2)) ] + if any (not . null) ys + then do + let fv1 = varSetElems . exprFreeVars $ l1 + fv2 = varSetElems . exprFreeVars $ l2 + n <- newName fun (exprType l1) + return (Var n, [(fv1, fv2, newTpExp env n l1)]) + else let alts1' = zip3 dc1 bs1 es1' + in return (Case c' b1 t1 alts1', p1 ++ concat p2) +msg' _ _ (Lit l1, Lit l2) | l1 == l2 = return (Lit l1, []) +msg' env fun (Cast e1 c1, Cast e2 c2) + | c1 `coreEqCoercion` c2 = do + (e, p) <- msg' env fun (e1, e2) + return (Cast e c1, p) +msg' env fun (l1@(Type t1), l2@(Type t2)) + | t1 `coreEqType` t2 = do + return (Type t1, []) + | otherwise = do + n <- newName fun (exprType (Type t1)) + let x = mkTyVar (varName n) (tyVarKind n) + x' = mkTyVarTy x + fv1 = varSetElems . exprFreeVars $ l1 + fv2 = varSetElems . exprFreeVars $ l2 + return (Type x', [(fv1, fv2, newTpType env x t1)]) +msg' env fun (Note n1 e1, Note n2 e2) + | n1 `realNoteEq` n2 = do + (e, p) <- msg' env fun (e1, e2) + return (Note n1 e, p) +msg' env fun (e1, e2) = do + n <- newName fun (exprType e1) + let fv1 = varSetElems . exprFreeVars $ e1 + fv2 = varSetElems . exprFreeVars $ e2 + return (Var n, [(fv1, fv2, newTpExp env n e1)]) + +fst3 :: (a, b, c) -> a +fst3 (a, _, _) = a + +-- snd3 :: (a, b, c) -> b +-- snd3 (_, b, _) = b + +trd3 :: (a, b, c) -> c +trd3 (_, _, c) = c + +-- Does one of TPush, CPush or Push evaluation steps +evalPush :: CoreExpr -> CoreExpr +evalPush (App (Cast (Lam b e) co) (Type ty)) + | (s1s2, _t1t2) <- coercionKind co -- TPush + , Just (tyvar, _) <- splitForAllTy_maybe s1s2 + , not (isCoVar tyvar) = + let newexp = mkApps (Lam b (Cast e co')) [Type ty] + in newexp + | otherwise = + let newexp = mkApps (Lam b (Cast e' co2)) [Type ty] + in newexp + where co' = mkInstCoercion co ty + e' = substExpr (extendSubst emptySubst b (Cast (Var b) g1)) e + [co1, co2] = decomposeCo 1 co + g1 = mkSymCoercion co1 +evalPush (App (Cast (Lam b e) co) arg) + | (s1s2, _t1t2) <- coercionKind co -- Push + , not (isTypeArg arg) + , isFunTy s1s2 = + let newexp = mkApps (Lam b (Cast e' co2)) [arg] + in newexp + where + [co1, co2] = decomposeCo 2 co -- co1 = right (left co) + g1 = mkSymCoercion co1 + e' = substExpr (extendSubst emptySubst b (Cast (Var b) g1)) e +evalPush e = error ("evalPush: " ++ (showSDoc $ ppr e)) + +checkType :: String -> CoreExpr -> CoreExpr -> Bool +checkType s e1 e2 + | t1 `coreEqType` t2 = True + | t1 `tcPartOfType` t2 = trace ("checkType: " ++ s) True + | otherwise = trace ("CHECKTYPE ASSERTION: " ++ s ++ "\n" ++ (showSDoc $ ppr e1) ++ "::" ++ (showSDoc $ ppr t1) ++ "\n" ++ (showSDoc $ ppr e2)++ "::" ++ (showSDoc $ ppr t2)) True + where t1 = exprType e1 + t2 = exprType e2 + + +newExprSubst :: ScpEnv -> Var -> CoreArg -> Subst +newExprSubst env id expr = extendSubst es id expr + where es = mkSubst (delInScopeSet (inSet env) id) emptyVarEnv emptyVarEnv + +newTvSubst :: ScpEnv -> TyVar -> Type -> Subst +newTvSubst env id tv = extendTvSubst es id tv + where es = mkSubst (inSet env) emptyVarEnv emptyVarEnv + + +linear :: Id -> CoreExpr -> Bool +linear id e = linear' e <= 1 + where linear' :: CoreExpr -> Integer + linear' (Var v) | id == v = 1 + | otherwise = 0 + linear' (Lit {}) = 0 + linear' (App e1 e2) = linear' e1 + linear' e2 + linear' (Lam b e) | id == b = 0 + | otherwise = 2 * linear' e + linear' (Let (NonRec b e) body) | id == b = 0 + | otherwise = linear' e + linear' body + linear' (Let p body) | elem id (bindersOf p) = 0 + | otherwise = linear' body + sum (map linear' (rhssOfBind p)) + linear' (Case e b _ alts) | b == id = linear' e + | otherwise = linear' e + maximum (linear_alts' alts) + linear' (Cast e _) = linear' e + linear' (Type _) = 0 + linear' (Note _ e) = linear' e + + linear_alts' [] = [0] + linear_alts' ((_, bs, e):t) | elem id bs = linear_alts' t + | otherwise = linear' e:linear_alts' t + + +-- TypeSubst, ExpSubst, BinderSubst +type TermParts = ([(Var, Type)], [(Var,(InScopeSet, CoreExpr))], [(Var, ([Var], InScopeSet, CoreExpr))]) + +emptyTp :: TermParts +emptyTp = ([], [], []) + +extendTpExp :: ScpEnv -> TermParts -> Var -> CoreExpr -> TermParts +extendTpExp env (t, s, a) x e = (t, (x, (inSet env, e)):s, a) + +extendTpExps :: ScpEnv -> TermParts -> [Var] -> [CoreExpr] -> TermParts +extendTpExps env (t, s, a) xs es = (t, zip xs (map ((,) (inSet env)) es) ++ s, a) + +extendTpType :: ScpEnv -> TermParts -> Var -> Type -> TermParts +extendTpType _ (s, e, a) x t = ((x, t):s, e, a) + +extendTpAlt :: ScpEnv -> TermParts -> Var -> [Var] -> CoreExpr -> TermParts +extendTpAlt env (t1, t2, s) x bs e = (t1, t2, (x, (bs, inSet env, e)):s) + +extendTpAlts :: ScpEnv -> TermParts -> [Var] -> [[Var]] -> [CoreExpr] -> TermParts +extendTpAlts env (t1, t2, s) xs bss es = + (t1, t2, zip xs (zip3 bss (repeat (inSet env)) es) ++ s) + +delTp :: TermParts -> [Var] -> TermParts +delTp (t, e, s) xs = (t, go' xs e, go xs s) + where go _ [] = [] + go xs (p@(_, (bs, _, _)):t) | any ((flip elem) bs) xs = go xs t + | otherwise = p:go xs t + go' _ [] = [] + go' xs (p@(b, _):t) | elem b xs = go' xs t + | otherwise = p:go' xs t + +newTpExp :: ScpEnv -> Var -> CoreExpr -> TermParts +newTpExp env x e = extendTpExp env emptyTp x e + +newTpExps :: ScpEnv -> [Var] -> [CoreExpr] -> TermParts +newTpExps env xs es = extendTpExps env emptyTp xs es + +newTpType :: ScpEnv -> Var -> Type -> TermParts +newTpType env x t = extendTpType env emptyTp x t + +newTpAlt :: ScpEnv -> Var -> [Var] -> CoreExpr -> TermParts +newTpAlt env x bs e = extendTpAlt env emptyTp x bs e + +newTpAlts :: ScpEnv -> [Var] -> [[Var]] -> [CoreExpr] -> TermParts +newTpAlts env xs bss es = extendTpAlts env emptyTp xs bss es + +getTpBinders :: TermParts -> [Var] +getTpBinders (t, e, a) = map fst t ++ map fst e ++ map fst a + +lookupTpExp :: TermParts -> Var -> Maybe CoreExpr +lookupTpExp (_, env, _) x + | Just (_, e) <- lookup x env = Just e + | otherwise = Nothing + +lookupTpType :: TermParts -> Var -> Maybe Type +lookupTpType (env, _, _) x = lookup x env + +lookupTpAlt :: TermParts -> Var -> Maybe ([Var], CoreExpr) +lookupTpAlt (_, _, env) x + | Just (bs, _, e) <- lookup x env = Just (bs, e) + | otherwise = Nothing + +plugTpTerm :: TermParts -> CoreExpr -> CoreExpr +plugTpTerm tp (Var x) + | Just e <- lookupTpExp tp x = e + | otherwise = Var x +plugTpTerm _ l@(Lit {}) = l +plugTpTerm tp (App e1 e2) = App (plugTpTerm tp e1) (plugTpTerm tp e2) +plugTpTerm tp (Lam _ (Var x)) | Just ([b], e) <- lookupTpAlt tp x = Lam b e +plugTpTerm tp (Lam b e) = Lam b (plugTpTerm (delTp tp [b]) e) +plugTpTerm tp (Let (NonRec _ (Var x)) (Var y)) + | Just ([b], e) <- lookupTpAlt tp x + , Just e' <- lookupTpExp tp y = Let (NonRec b e) e' +plugTpTerm tp (Let (NonRec b e) e') = Let (NonRec b (plugTpTerm tp' e)) e'' + where e'' = plugTpTerm tp' e' + tp' = delTp tp [b] +plugTpTerm tp (Let (Rec p) (Var y)) + | Just e' <- lookupTpExp tp y + , ps <- [ (bs, e) | (_, Var x) <- p, Just (bs, e) <- [lookupTpAlt tp x]] + , length ps == length p + , (bss, es) <- unzip ps = Let (Rec (zip (head bss) es)) e' +plugTpTerm tp (Let p e) = Let (Rec p') (plugTpTerm tp' e) + where p' = zip bs (map (plugTpTerm tp') (rhssOfBind p)) + tp' = delTp tp bs + bs = bindersOf p +plugTpTerm tp (Case (Var x) _ t alts) + | Just ([b'], e) <- lookupTpAlt tp x + , ps <- [(c, bs, e) | (c, _, (Var x)) <- alts, Just (bs, e) <- [lookupTpAlt tp x]] + , length ps == length alts = Case e b' t ps +plugTpTerm tp (Case e b t alts) = + Case (plugTpTerm tp e) b t (map helper alts) + where helper (c, bs, e) = (c, bs, plugTpTerm tp' e) + where tp' = delTp tp (b:bs) +plugTpTerm tp (Cast e co) = Cast (plugTpTerm tp e) co +plugTpTerm tp (Note n e) = Note n (plugTpTerm tp e) +plugTpTerm tp (Type (TyVarTy x)) | Just e <- lookupTpType tp x = Type e +plugTpTerm _ (Type t) = Type t + +plusTp :: TermParts -> TermParts -> TermParts +plusTp (t1, s1, a1) (t2, s2, a2) = (t1 ++ t2, s1 ++ s2, a1 ++ a2) + + +-- Stolen from Rules.lhs + +type SubstEnv = (TvSubstEnv, IdSubstEnv, [Var]) +type IdSubstEnv = IdEnv CoreExpr + +match :: MatchEnv + -> SubstEnv + -> CoreExpr -- Template + -> CoreExpr -- Target + -> Maybe SubstEnv + +-- See the notes with Unify.match, which matches types +-- Everything is very similar for terms + +-- Interesting examples: +-- Consider matching +-- \x->f against \f->f +-- When we meet the lambdas we must remember to rename f to f' in the +-- second expresion. The RnEnv2 does that. +-- +-- Consider matching +-- forall a. \b->b against \a->3 +-- We must rename the \a. Otherwise when we meet the lambdas we +-- might substitute [a/b] in the template, and then erroneously +-- succeed in matching what looks like the template variable 'a' against 3. + +-- The Var case follows closely what happens in Unify.match +match menv subst (Var v1) e2 + | Just subst <- match_var menv subst v1 e2 + = Just subst + +match menv subst e1 (Var v2) -- Note [Expanding variables] + | not (locallyBoundR rn_env v2) -- Note [Do not expand locally-bound variables] + , Just e2' <- expandId v2' + = match (menv { me_env = nukeRnEnvR rn_env }) subst e1 e2' + where + v2' = lookupRnInScope rn_env v2 + rn_env = me_env menv + -- Notice that we look up v2 in the in-scope set + -- See Note [Lookup in-scope] + -- No need to apply any renaming first (hence no rnOccR) + -- becuase of the not-locallyBoundR + +match menv subst (Let b1 body1) (Let b2 body2) + | not (any (locallyBoundR rn_env) bs2) + = do { subst' <- match_binds menv subst b1 b2 + ; match menv' subst' body1 body2 } + where + rn_env = me_env menv + bs2 = bindersOf b2 + menv' = menv { me_env = rnBndrs2 rn_env (bindersOf b1) bs2 } + +match menv subst (Note n1 e1) (Note n2 e2) + | n1 `realNoteEq` n2 = match menv subst e1 e2 + +match _ subst (Lit lit1) (Lit lit2) + | lit1 == lit2 + = Just subst + +match menv subst (App f1 a1) (App f2 a2) + = do { subst' <- match menv subst f1 f2 + ; match menv subst' a1 a2 } + +match menv subst (Lam x1 e1) (Lam x2 e2) + = match menv' subst e1 e2 + where + menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 } + +match menv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) + = do { subst1 <- match_ty menv subst ty1 ty2 + ; subst2 <- match menv subst1 e1 e2 + ; let menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 } + ; match_alts menv' subst2 alts1 alts2 -- Alts are both sorted + } + +match menv subst (Type ty1) (Type ty2) + = match_ty menv subst ty1 ty2 + +match menv subst (Cast e1 co1) (Cast e2 co2) + = do { subst1 <- match_ty menv subst co1 co2 + ; match menv subst1 e1 e2 } + +-- Everything else fails +match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $ + Nothing + +------------------------------------------ +match_var :: MatchEnv + -> SubstEnv + -> Var -- Template + -> CoreExpr -- Target + -> Maybe SubstEnv +match_var menv subst@(tv_subst, id_subst, binds) v1 e2 + | v1' `elemVarSet` me_tmpls menv + = case lookupVarEnv id_subst v1' of + Nothing | any (inRnEnvR rn_env) (varSetElems (exprFreeVars e2)) + -> Nothing -- Occurs check failure + -- e.g. match forall a. (\x-> a x) against (\y. y y) + + | otherwise -- No renaming to do on e2, because no free var + -- of e2 is in the rnEnvR of the envt + -- Note [Matching variable types] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- However, we must match the *types*; e.g. + -- forall (c::Char->Int) (x::Char). + -- f (c x) = "RULE FIRED" + -- We must only match on args that have the right type + -- It's actually quite difficult to come up with an example that shows + -- you need type matching, esp since matching is left-to-right, so type + -- args get matched first. But it's possible (e.g. simplrun008) and + -- this is the Right Thing to do + -> do { tv_subst' <- Unify.ruleMatchTyX menv tv_subst (idType v1') (exprType e2) + -- c.f. match_ty below + ; return (tv_subst', extendVarEnv id_subst v1' e2, v1':binds) } + + Just e1' | eqExpr (nukeRnEnvL rn_env) e1' e2 + -> Just subst + + | otherwise + -> Nothing + + | otherwise -- v1 is not a template variable; check for an exact match with e2 + = case e2 of + Var v2 | v1' == rnOccR rn_env v2 -> Just subst + _ -> Nothing + + where + rn_env = me_env menv + v1' = rnOccL rn_env v1 + -- If the template is + -- forall x. f x (\x -> x) = ... + -- Then the x inside the lambda isn't the + -- template x, so we must rename first! + + + +match_alts :: MatchEnv + -> SubstEnv + -> [CoreAlt] -- Template + -> [CoreAlt] -- Target + -> Maybe SubstEnv +match_alts _ subst [] [] + = return subst +match_alts menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) + | c1 == c2 + = do { subst1 <- match menv' subst r1 r2 + ; match_alts menv subst1 alts1 alts2 } + where + menv' :: MatchEnv + menv' = menv { me_env = rnBndrs2 (me_env menv) vs1 vs2 } + +match_alts _ _ _ _ + = Nothing + + +match_ty :: MatchEnv + -> SubstEnv + -> Type -- Template + -> Type -- Target + -> Maybe SubstEnv +match_ty menv (tv_subst, id_subst, binds) ty1 ty2 + = do { tv_subst' <- Unify.ruleMatchTyX menv tv_subst ty1 ty2 + ; return (tv_subst', id_subst, binds) } + + +match_binds :: MatchEnv -> SubstEnv -> CoreBind -> CoreBind -> Maybe SubstEnv +match_binds menv subst (NonRec _ e1) (NonRec _ e2) = match menv subst e1 e2 +match_binds menv subst ps1@(Rec b1) ps2@(Rec b2) + | equalLength b1 b2 = match_binds' menv' subst (rhssOfBind ps1) (rhssOfBind ps2) + where menv' = menv { me_env = rnBndrs2 (me_env menv) (bindersOf ps1) (bindersOf ps2)} + match_binds' _ subst [] [] = return subst + match_binds' menv subst (h1:t1) (h2:t2) = do + subst' <- match menv subst h1 h2 + match_binds' menv subst' t1 t2 +match_binds _ _ _ _ = Nothing + + + +match' :: MatchEnv + -> SubstEnv + -> CoreExpr -- Template + -> CoreExpr -- Target + -> Maybe SubstEnv + +-- See the notes with Unify.match, which matches types +-- Everything is very similar for terms + +-- Interesting examples: +-- Consider matching +-- \x->f against \f->f +-- When we meet the lambdas we must remember to rename f to f' in the +-- second expresion. The RnEnv2 does that. +-- +-- Consider matching +-- forall a. \b->b against \a->3 +-- We must rename the \a. Otherwise when we meet the lambdas we +-- might substitute [a/b] in the template, and then erroneously +-- succeed in matching what looks like the template variable 'a' against 3. + +-- The Var case follows closely what happens in Unify.match +match' menv subst (Var v1) e2 + | Just subst <- match_var' menv subst v1 e2 + = trace ("match', just out") $ Just subst + +match' menv subst e1 (Var v2) -- Note [Expanding variables] + | not (locallyBoundR rn_env v2) -- Note [Do not expand locally-bound variables] + , Just e2' <- expandId v2' + = match' (menv { me_env = nukeRnEnvR rn_env }) subst e1 e2' + where + v2' = lookupRnInScope rn_env v2 + rn_env = me_env menv + -- Notice that we look up v2 in the in-scope set + -- See Note [Lookup in-scope] + -- No need to apply any renaming first (hence no rnOccR) + -- becuase of the not-locallyBoundR + +-- match menv (tv_subst, id_subst, binds) e1 (Let bind e2) +-- | all freshly_bound bndrs -- See Note [Matching lets] +-- , not (any (locallyBoundR rn_env) bind_fvs) +-- = match (menv { me_env = rn_env' }) +-- (tv_subst, id_subst, binds `snocOL` bind') +-- e1 e2' +-- where +-- rn_env = me_env menv +-- bndrs = bindersOf bind +-- bind_fvs = varSetElems (bindFreeVars bind) +-- freshly_bound x = not (x `rnInScope` rn_env) +-- bind' = bind +-- e2' = e2 +-- rn_env' = extendRnInScopeList rn_env bndrs + +match' menv subst (Let b1 body1) (Let b2 body2) + | not (any (locallyBoundR rn_env) bs2) + = do { subst' <- match_binds menv subst b1 b2 + ; match menv' subst' body1 body2 } + where + rn_env = me_env menv + bs2 = bindersOf b2 + menv' = menv { me_env = rnBndrs2 rn_env (bindersOf b1) bs2 } + +match' menv subst (Note n1 e1) (Note n2 e2) + | n1 `realNoteEq` n2 = match' menv subst e1 e2 + +match' _ subst (Lit lit1) (Lit lit2) + | lit1 == lit2 + = Just subst + +match' menv subst (App f1 a1) (App f2 a2) + = do { subst' <- match' menv subst f1 f2 + ; match' menv subst' a1 a2 } + +match' menv subst (Lam x1 e1) (Lam x2 e2) + = match' menv' subst e1 e2 + where + menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 } + +match' menv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) + = do { subst1 <- match_ty menv subst ty1 ty2 + ; subst2 <- match' menv subst1 e1 e2 + ; let menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 } + ; match_alts' menv' subst2 alts1 alts2 -- Alts are both sorted + } + +match' menv subst (Type ty1) (Type ty2) + = match_ty menv subst ty1 ty2 + +match' menv subst (Cast e1 co1) (Cast e2 co2) + = do { subst1 <- match_ty menv subst co1 co2 + ; match' menv subst1 e1 e2 } + +-- Everything else fails +match' _ _ _e1 _e2 = trace ("Failing at e1:" ++ (showSDocDebug $ ppr _e1) ++ "\ne2:" ++ (showSDocDebug $ ppr _e2)) + Nothing + +match_alts' :: MatchEnv + -> SubstEnv + -> [CoreAlt] -- Template + -> [CoreAlt] -- Target + -> Maybe SubstEnv +match_alts' _ subst [] [] + = return subst +match_alts' menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) + | c1 == c2 + = do { subst1 <- match' menv' subst r1 r2 + ; match_alts' menv subst1 alts1 alts2 } + where + menv' :: MatchEnv + menv' = menv { me_env = rnBndrs2 (me_env menv) vs1 vs2 } + +match_alts' _ _ _ _ + = Nothing + + +match_var':: MatchEnv + -> SubstEnv + -> Var -- Template + -> CoreExpr -- Target + -> Maybe SubstEnv +match_var' menv subst@(tv_subst, id_subst, binds) v1 e2 + | v1' `elemVarSet` me_tmpls menv + = case lookupVarEnv id_subst v1' of + Nothing | any (inRnEnvR rn_env) (varSetElems (exprFreeVars e2)) + -> trace ("occfail") Nothing -- Occurs check failure + -- e.g. match forall a. (\x-> a x) against (\y. y y) + + | otherwise -- No renaming to do on e2, because no free var + -- of e2 is in the rnEnvR of the envt + -- Note [Matching variable types] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- However, we must match the *types*; e.g. + -- forall (c::Char->Int) (x::Char). + -- f (c x) = "RULE FIRED" + -- We must only match on args that have the right type + -- It's actually quite difficult to come up with an example that shows + -- you need type matching, esp since matching is left-to-right, so type + -- args get matched first. But it's possible (e.g. simplrun008) and + -- this is the Right Thing to do + -> do { tv_subst' <- Unify.ruleMatchTyX menv tv_subst (idType v1') (exprType e2) + -- c.f. match_ty below + ; return (tv_subst', extendVarEnv id_subst v1' e2, v1':binds) } + + Just e1' | eqExpr (nukeRnEnvL rn_env) e1' e2 + -> Just subst + + | otherwise + -> trace ("eqExpr") Nothing + + | otherwise -- v1 is not a template variable; check for an exact match with e2 + = case e2 of + Var v2 | v1' == rnOccR rn_env v2 -> Just subst + _ -> trace ("o:not") Nothing + + where + rn_env = me_env menv + v1' = rnOccL rn_env v1 + -- If the template is + -- forall x. f x (\x -> x) = ... + -- Then the x inside the lambda isn't the + -- template x, so we must rename first! + + + + + +emptySubstEnv :: SubstEnv +emptySubstEnv = (emptyVarEnv, emptyVarEnv, []) + + +-- | Returns @Just (dc, [x1..xn])@ if the argument expression is +-- a constructor application of the form @dc x1 .. xn@ +exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr]) +exprIsConApp_maybe (Cast expr co) + = -- Here we do the KPush reduction rule as described in the FC paper + case exprIsConApp_maybe expr of { + Nothing -> Nothing ; + Just (dc, dc_args) -> + + -- The transformation applies iff we have + -- (C e1 ... en) `cast` co + -- where co :: (T t1 .. tn) ~ (T s1 ..sn) + -- That is, with a T at the top of both sides + -- The left-hand one must be a T, because exprIsConApp returned True + -- but the right-hand one might not be. (Though it usually will.) + + let (from_ty, to_ty) = coercionKind co + (from_tc, from_tc_arg_tys) = splitTyConApp from_ty + -- The inner one must be a TyConApp + in + case splitTyConApp_maybe to_ty of { + Nothing -> Nothing ; + Just (to_tc, to_tc_arg_tys) + | from_tc /= to_tc -> Nothing + -- These two Nothing cases are possible; we might see + -- (C x y) `cast` (g :: T a ~ S [a]), + -- where S is a type function. In fact, exprIsConApp + -- will probably not be called in such circumstances, + -- but there't nothing wrong with it + + | otherwise -> + let + tc_arity = tyConArity from_tc + + (univ_args, rest1) = splitAt tc_arity dc_args + (ex_args, rest2) = splitAt n_ex_tvs rest1 + (co_args_spec, rest3) = splitAt n_cos_spec rest2 + (co_args_theta, val_args) = splitAt n_cos_theta rest3 + + arg_tys = dataConRepArgTys dc + dc_univ_tyvars = dataConUnivTyVars dc + dc_ex_tyvars = dataConExTyVars dc + dc_eq_spec = dataConEqSpec dc + dc_eq_theta = dataConEqTheta dc + dc_tyvars = dc_univ_tyvars ++ dc_ex_tyvars + n_ex_tvs = length dc_ex_tyvars + n_cos_spec = length dc_eq_spec + n_cos_theta = length dc_eq_theta + + -- Make the "theta" from Fig 3 of the paper + gammas = decomposeCo tc_arity co + new_tys = gammas ++ map (\ (Type t) -> t) ex_args + theta = zipOpenTvSubst dc_tyvars new_tys + + -- First we cast the existential coercion arguments + cast_co_spec (tv, ty) co + = cast_co_theta (mkEqPred (mkTyVarTy tv, ty)) co + cast_co_theta eqPred (Type co) + | (ty1, ty2) <- getEqPredTys eqPred + = Type $ mkSymCoercion (Type.substTy theta ty1) + `mkTransCoercion` co + `mkTransCoercion` (Type.substTy theta ty2) + new_co_args = zipWith cast_co_spec dc_eq_spec co_args_spec ++ + zipWith cast_co_theta dc_eq_theta co_args_theta + + -- ...and now value arguments + new_val_args = zipWith cast_arg arg_tys val_args + cast_arg arg_ty arg = mkCoerce (Type.substTy theta arg_ty) arg + + in + ASSERT( length univ_args == tc_arity ) + ASSERT( from_tc == dataConTyCon dc ) + ASSERT( and (zipWith coreEqType [t | Type t <- univ_args] from_tc_arg_tys) ) + ASSERT( all isTypeArg (univ_args ++ ex_args) ) + ASSERT2( equalLength val_args arg_tys, ppr dc $$ ppr dc_tyvars $$ ppr dc_ex_tyvars $$ ppr arg_tys $$ ppr dc_args $$ ppr univ_args $$ ppr ex_args $$ ppr val_args $$ ppr arg_tys ) + + Just (dc, map Type to_tc_arg_tys ++ ex_args ++ new_co_args ++ new_val_args) + }} + +exprIsConApp_maybe expr = analyse (collectArgs expr) + where + analyse (Var fun, args) + | Just con <- isDataConWorkId_maybe fun, + args `lengthAtLeast` dataConRepArity con + -- Might be > because the arity excludes type args + = Just (con,args) + + analyse _ = Nothing + +delete :: Eq a => [a] -> [a] -> [a] +delete _ [] = [] +delete es (h:t) | h `elem` es = delete es t + | otherwise = h:delete es t + + +createBinds :: Store -> [(Var, CoreExpr)] +createBinds [] = [] +createBinds ((RhoE {freshName = h, inFvs = xs, ..}, e):t) = (h, mkLams xs e):createBinds t + +splitStore :: ScpEnv -> [Var] -> Store -> (Store, Store) +splitStore env vs s = go s [] [] + where go [] s1 s2 = (reverse s1, reverse s2) + go (e@(RhoE {headExp = f, restExp = c, ..}, _):t) s1 s2 + | null (vs `intersect` fvs) = go t s1 (e:s2) + | otherwise = go t (e:s1) s2 + where fvs = realFvs (env {inSet = funSet env}) plugged + plugged = plug c (Var f) + +postLet :: ScpEnv -> CoreBind -> ScpM Store [(Var, CoreExpr)] +postLet env bs = do + ml <- getStore + let (ls, gs) = splitStore env (bindersOf bs) ml + binds' = createBinds ls + replaceStore gs + return binds' + + +beautify :: Store -> [SDoc] +beautify [] = [] +beautify (((RhoE {freshName = h, inFvs = xs, restExp = c, headExp = f}), e):t) = (text "(" <+> ppr h <+> ppr xs <+> ppr (plug c (Var f)) <+> text "body:" <+> ppr e <+> text ")"):beautify t + addfile ./compiler/supercomp/ScpMonad.hs hunk ./compiler/supercomp/ScpMonad.hs 1 +-- % +-- % (c) The AQUA Project, Glasgow University, 1993-1998 +-- % +-- \section[ScpMonad]{The Supercompiler Monad} +module ScpMonad ( + -- The monad + ScpM, + initScp, + getDOptsSmpl, getSimplRules, + + -- Unique supply + MonadUnique(..), newId, + + -- Store + addToStore, getStore, replaceStore, + + -- Logging + scpLog, scpLogDebug, + ) where + +import Id ( Id, mkSysLocal ) +import Type ( Type ) +import Rules ( RuleBase ) +import UniqSupply +import DynFlags ( DynFlags(..) ) +import FastString +import Outputable + + +-- %************************************************************************ +-- %* * +-- \subsection{Monad plumbing} +-- %* * +-- %************************************************************************ +-- +-- For the supercompiler monad, we want to {\em thread} a unique supply and +-- a counter. +-- (Command-line switches move around through the explicitly-passed SimplEnv.) + +newtype ScpM s result + = SM { unSM :: SimplTopEnv -- Envt that does not change much + -> UniqSupply -- We thread the unique supply because + -- constantly splitting it is rather expensive + -> s + -> (result, UniqSupply, s)} + +data SimplTopEnv = STE { st_flags :: DynFlags + , st_rules :: RuleBase + , st_debug_level :: Int } + +initScp :: DynFlags -> RuleBase + -> UniqSupply + -> ScpM [s] result + -> (result, [s]) + +initScp dflags rules us m + = case unSM m env us [] of + (result, _, store) -> (result, store) + where + env = STE { st_flags = dflags, st_rules = rules, + st_debug_level = scpDebugLevel dflags } + +{-# INLINE thenScp #-} +{-# INLINE thenScp_ #-} +{-# INLINE returnScp #-} + +instance Monad (ScpM s) where + (>>) = thenScp_ + (>>=) = thenScp + return = returnScp + +returnScp :: a -> ScpM s a +returnScp e = SM (\_st_env us sc -> (e, us, sc)) + +thenScp :: ScpM s a -> (a -> ScpM s b) -> ScpM s b +thenScp_ :: ScpM s a -> ScpM s b -> ScpM s b + +thenScp m k + = SM (\ st_env us0 sc0 -> + case (unSM m st_env us0 sc0) of + (m_result, us1, sc1) -> unSM (k m_result) st_env us1 sc1 ) + +thenScp_ m k + = SM (\st_env us0 sc0 -> + case (unSM m st_env us0 sc0) of + (_, us1, sc1) -> unSM k st_env us1 sc1) + + +-- %************************************************************************ +-- %* * +-- \subsection{The unique supply} +-- %* * +-- %************************************************************************ + +instance MonadUnique (ScpM a) where + getUniqueSupplyM + = SM (\_st_env us sc -> case splitUniqSupply us of + (us1, us2) -> (us1, us2, sc)) + + getUniqueM + = SM (\_st_env us sc -> case splitUniqSupply us of + (us1, us2) -> (uniqFromSupply us1, us2, sc)) + + getUniquesM + = SM (\_st_env us sc -> case splitUniqSupply us of + (us1, us2) -> (uniqsFromSupply us1, us2, sc)) + +getDOptsSmpl :: ScpM s DynFlags +getDOptsSmpl = SM (\st_env us sc -> (st_flags st_env, us, sc)) + +getSimplRules :: ScpM s RuleBase +getSimplRules = SM (\st_env us sc -> (st_rules st_env, us, sc)) + +getDebugLevel :: ScpM s Int +getDebugLevel = SM (\st_env us sc -> (st_debug_level st_env, us, sc)) + +newId :: FastString -> Type -> ScpM s Id +newId fs ty = do uniq <- getUniqueM + return (mkSysLocal fs uniq ty) + + + +-- %************************************************************************ +-- %* * +-- \subsection{The store} +-- %* * +-- %************************************************************************ + + +getStore :: ScpM s s +getStore = SM (\_st_env us sc -> (sc, us, sc)) + +addToStore :: s -> ScpM [s] () +-- addToStore x = SM (\_st_env us sc -> ((), us, x:sc)) +addToStore x = SM (\_st_env us sc -> x `seq` ((), us, x:sc)) + +replaceStore :: s -> ScpM s () +replaceStore s = SM (\_st_env us _ -> ((), us, s)) + +-- %************************************************************************ +-- %* * +-- \subsection{Logging} +-- %* * +-- %************************************************************************ + + +scpLog :: Int -> String -> SDoc -> ScpM s () +scpLog l tmsg msg = do + debugLevel <- getDebugLevel + if l <= debugLevel +-- then liftIO $ putStrLn (tmsg ++ ' ':showSDoc msg) + then trace (tmsg ++ ' ':showSDoc msg) $ return () + else return () + + +scpLogDebug :: Int -> String -> SDoc -> ScpM s () +scpLogDebug l tmsg msg = do + debugLevel <- getDebugLevel + if l <= debugLevel +-- then liftIO $ putStrLn (tmsg ++ ' ':showSDocDebug msg) + then trace (tmsg ++ ' ':showSDocDebug msg) $ return () + else return () + + + } [Do not lambda lift for now. t-peterj@microsoft.com**20090730072752] hunk ./compiler/main/DynFlags.hs 1129 - runWhen scp (CoreDoPasses [(CoreDoFloatOutwards lambdaFloatOutSwitches), + runWhen scp (CoreDoPasses [-- (CoreDoFloatOutwards lambdaFloatOutSwitches), [Compare sizes of contexts to avoid plugging. t-peterj@microsoft.com**20090730155148] { hunk ./compiler/supercomp/Scp.hs 421 - let nont = homemb env l' + let nont = homemb env fun context hunk ./compiler/supercomp/Scp.hs 738 +realContextSize :: Context -> Integer +realContextSize EmptyCtxt = 0 +realContextSize (AppCtxt e c) = 1 + realExprSize e + realContextSize c +realContextSize (PrimOpCtxt _ oes ies c) = 1 + sum (map realExprSize (oes ++ ies)) + realContextSize c +realContextSize (CaseCtxt (Case _ _ _ alts) c) = 1 + sum (map realAltSize alts) + realContextSize c +realContextSize (CastCtxt _ c) = 1 + realContextSize c + +realAltSize :: CoreAlt -> Integer +realAltSize (_, _, e) = realExprSize e + hunk ./compiler/supercomp/Scp.hs 819 -homemb :: ScpEnv -> CoreExpr -> [(Var, [Var], CoreExpr)] -homemb env in_exp = [(freshName, inFvs, plug restExp (Var headExp)) | RhoE {..} <- (ls env), msize > realExprSize (plug restExp (Var headExp)), isHomemb env (plug restExp (Var headExp)) in_exp, coreEqType (exprType (plug restExp (Var headExp))) (exprType in_exp)] -- YYY: UNSOUND - where msize = realExprSize in_exp +homemb :: ScpEnv -> Id -> Context -> [(Var, [Var], CoreExpr)] +homemb env v c = [(freshName, inFvs, plug restExp (Var headExp)) | RhoE {..} <- (ls env), msize > realContextSize restExp, isHomemb env (plug restExp (Var headExp)) in_exp, coreEqType (exprType (plug restExp (Var headExp))) (exprType in_exp)] -- YYY: UNSOUND + where msize = realContextSize c + in_exp = plug c (Var v) } [Add a comment and move a function to its proper place. t-peterj@microsoft.com**20090731101056] { hunk ./compiler/supercomp/Scp.hs 1054 +{- + + The TermParts structure and helper functions operating on it. + +-} + hunk ./compiler/supercomp/Scp.hs 1168 +emptySubstEnv :: SubstEnv +emptySubstEnv = (emptyVarEnv, emptyVarEnv, []) + hunk ./compiler/supercomp/Scp.hs 1510 -emptySubstEnv :: SubstEnv -emptySubstEnv = (emptyVarEnv, emptyVarEnv, []) - } [Add a parallel homeomrphic embedding test. t-peterj@microsoft.com**20090731145755] { hunk ./compiler/supercomp/Scp.hs 8 +#define PARALLEL_SCP 0 + hunk ./compiler/supercomp/Scp.hs 59 +#ifdef PARALLEL_SCP +import Control.Parallel ( par ) +#endif hunk ./compiler/supercomp/Scp.hs 426 - let nont = homemb env fun context + let nont = homemb env l' hunk ./compiler/supercomp/Scp.hs 453 --- ml <- currentStore hunk ./compiler/supercomp/Scp.hs 822 +{- + + The whistle (homeomorphic embedding) + +-} + +{- +homemb :: ScpEnv -> CoreExpr -> Context -> [(Var, [Var], CoreExpr)] +homemb env e1 c1 = [(freshName, inFvs, plug restExp (Var headExp)) | + RhoE {..} <- (ls env), + isHomemb env e1 c1 (Var headExp) restExp] + + +isHomemb :: ScpEnv -> CoreExpr -> Context -> CoreExpr -> Context -> Bool +isHomemb env e1 c1 e2 c2 = new_peel env e1 c1 e2 c2 + || any (\es -> let (e, c) = splitTerm es + in isHomemb env v1 c1 e c) es + || + where (es, c) = (dive c2) +-} + +#ifndef PARALLEL_SCP +homemb :: ScpEnv -> CoreExpr -> [(Var, [Var], CoreExpr)] +homemb env in_exp = [(freshName, inFvs, compTerm) | RhoE {..} <- (ls env), msize > realExprSize compTerm, isHomemb env compTerm in_exp, coreEqType (exprType compTerm) in_type] -- YYY: UNSOUND + where msize = realExprSize in_exp + in_type = exprType in_exp + +#else +parBufferWHNF n xs = return xs (start n xs) + where return (x:xs) (y:ys) = y `par` (x:return xs ys) + return xs [] = xs + start n [] = [] + start 0 ys = ys + start n (y:ys) = y `par` start (n-1) ys hunk ./compiler/supercomp/Scp.hs 857 -homemb :: ScpEnv -> Id -> Context -> [(Var, [Var], CoreExpr)] -homemb env v c = [(freshName, inFvs, plug restExp (Var headExp)) | RhoE {..} <- (ls env), msize > realContextSize restExp, isHomemb env (plug restExp (Var headExp)) in_exp, coreEqType (exprType (plug restExp (Var headExp))) (exprType in_exp)] -- YYY: UNSOUND - where msize = realContextSize c - in_exp = plug c (Var v) +homemb :: ScpEnv -> CoreExpr -> [(Var, [Var], CoreExpr)] +homemb env in_exp = concat $ zipWith fixup blist myls + where msize = realExprSize in_exp + in_type = exprType in_exp + myls = ls env + blist = parBufferWHNF 100 (map p myls) + p :: RhoElement -> Bool + p (RhoE {..}) = msize > realExprSize compTerm && isHomemb env compTerm in_exp && coreEqType (exprType compTerm) in_type + fixup True (RhoE {..}) = [(freshName, inFvs, compTerm)] + fixup False _ = [] +#endif } [Put the zipped term in the memoization list as well. t-peterj@microsoft.com**20090731150246] { hunk ./compiler/supercomp/Scp.hs 162 - headExp :: Var + headExp :: Var, + compTerm :: CoreExpr hunk ./compiler/supercomp/Scp.hs 445 - restExp = context, headExp = fun} + restExp = context, headExp = fun, + compTerm = l'} hunk ./compiler/supercomp/Scp.hs 559 - res = renamings env (map fst ml) l' + res = renamings env ml l' hunk ./compiler/supercomp/Scp.hs 582 -renamings :: ScpEnv -> [RhoElement] -> CoreExpr -> [(Var, [Var], SubstEnv)] +renamings :: ScpEnv -> Store -> CoreExpr -> [(Var, [Var], SubstEnv)] hunk ./compiler/supercomp/Scp.hs 584 - [(freshName, inFvs, s) | RhoE {..} <- ml, - Just s <- [renaming (plug restExp (Var headExp)) inFvs in_exp], - coreEqType (exprType in_exp) (exprType (plug restExp (Var headExp))), + [(freshName, inFvs, s) | (RhoE {..}, _) <- ml, + Just s <- [renaming compTerm inFvs in_exp], + coreEqType in_type (exprType compTerm), hunk ./compiler/supercomp/Scp.hs 589 - Just s <- [renaming (plug restExp (Var headExp)) inFvs in_exp], - coreEqType (exprType in_exp) (exprType (plug restExp (Var headExp))) ] + Just s <- [renaming compTerm inFvs in_exp], + coreEqType in_type (exprType compTerm) ] hunk ./compiler/supercomp/Scp.hs 593 + in_type = exprType in_exp hunk ./compiler/supercomp/Scp.hs 1680 + } [Get the preprocessing right for parallel_scp. t-peterj@microsoft.com**20090731150723] { hunk ./compiler/supercomp/Scp.hs 59 -#ifdef PARALLEL_SCP +#if PARALLEL_SCP hunk ./compiler/supercomp/Scp.hs 846 -#ifndef PARALLEL_SCP -homemb :: ScpEnv -> CoreExpr -> [(Var, [Var], CoreExpr)] -homemb env in_exp = [(freshName, inFvs, compTerm) | RhoE {..} <- (ls env), msize > realExprSize compTerm, isHomemb env compTerm in_exp, coreEqType (exprType compTerm) in_type] -- YYY: UNSOUND - where msize = realExprSize in_exp - in_type = exprType in_exp - -#else +#if PARALLEL_SCP hunk ./compiler/supercomp/Scp.hs 864 +#else +homemb :: ScpEnv -> CoreExpr -> [(Var, [Var], CoreExpr)] +homemb env in_exp = [(freshName, inFvs, compTerm) | RhoE {..} <- (ls env), msize > realExprSize compTerm, isHomemb env compTerm in_exp, coreEqType (exprType compTerm) in_type] -- YYY: UNSOUND + where msize = realExprSize in_exp + in_type = exprType in_exp + } [Add parallel to the boot libraries. t-peterj@microsoft.com**20090731151139] { hunk ./compiler/ghc.cabal.in 72 - array >= 0.1 && < 0.3 + array >= 0.1 && < 0.3, + parallel >= 1 && < 2.0 hunk ./ghc.mk 329 +$(eval $(call addPackage,parallel)) hunk ./packages 41 +libraries/parallel packages/parallel darcs } [Enable parallel supercompilation by default. t-peterj@microsoft.com**20090731160420] hunk ./compiler/supercomp/Scp.hs 8 -#define PARALLEL_SCP 0 +#define PARALLEL_SCP 1 [Early bailout for renamings. t-peterj@microsoft.com**20090731160442] { hunk ./compiler/supercomp/Scp.hs 559 - res = renamings env ml l' + res = renamings env ml fun l' hunk ./compiler/supercomp/Scp.hs 582 -renamings :: ScpEnv -> Store -> CoreExpr -> [(Var, [Var], SubstEnv)] -renamings env ml in_exp = - [(freshName, inFvs, s) | (RhoE {..}, _) <- ml, +renamings :: ScpEnv -> Store -> Id -> CoreExpr -> [(Var, [Var], SubstEnv)] +renamings env ml v in_exp = + [(freshName, inFvs, s) | (RhoE {..}, _) <- ml, + v == headExp, hunk ./compiler/supercomp/Scp.hs 589 - [(freshName, inFvs, s) | RhoE {..} <- (ls env), + [(freshName, inFvs, s) | RhoE {..} <- (ls env), + v == headExp, } [Call realFvs'_type on Casts. t-peterj@microsoft.com**20090731172249] { hunk ./compiler/supercomp/Scp.hs 288 + -- XXXpj: This might fail. Print out a debug message when it does. hunk ./compiler/supercomp/Scp.hs 788 -realFvs' env (Cast e co) = realFvs' env e -- XXXpj: What about free tvs in co? +realFvs' env (Cast e co) = realFvs' env e ++ realFvs'_type env co } [Use a parallell renamings as well. t-peterj@microsoft.com**20090801110558] { hunk ./compiler/supercomp/Scp.hs 583 +#if PARALLEL_SCP +renamings :: ScpEnv -> Store -> Id -> CoreExpr -> [(Var, [Var], SubstEnv)] +renamings env ml v in_exp = (concat $ zipWith fixup1 b1list ml) ++ (concat $ zipWith fixup2 b2list myls) + + where + in_scope = inSet env + in_type = exprType in_exp + myls = ls env + -- See comment above "data MatchEnv" in Unify.lhs + lmenv = mkRnEnv2 in_scope + renaming e1 in_fvs e2 = match menv emptySubstEnv e1 e2 + where menv = ME { me_env = lmenv + , me_tmpls = mkVarSet in_fvs } + b1list = parBufferWHNF 100 (map p1 ml) + b2list = parBufferWHNF 100 (map p2 myls) + p1 :: (RhoElement, CoreExpr) -> Maybe SubstEnv + p1 (RhoE {..}, _) | v == headExp, + Just s <- renaming compTerm inFvs in_exp, + coreEqType in_type (exprType compTerm), + isTrueRenaming s = Just s + | otherwise = Nothing + p2 :: RhoElement -> Maybe SubstEnv + p2 (RhoE {..}) | v == headExp, + Just s <- renaming compTerm inFvs in_exp, + coreEqType in_type (exprType compTerm) = Just s + | otherwise = Nothing + fixup1 :: Maybe SubstEnv -> (RhoElement, CoreExpr) -> [(Var, [Var], SubstEnv)] + fixup1 (Just s) ((RhoE {..}), _) = [(freshName, inFvs, s)] + fixup1 Nothing _ = [] + fixup2 :: Maybe SubstEnv -> RhoElement -> [(Var, [Var], SubstEnv)] + fixup2 (Just s) (RhoE {..}) = [(freshName, inFvs, s)] + fixup2 Nothing _ = [] + isTrueRenaming :: SubstEnv -> Bool + isTrueRenaming (_, es, fvs) = all isVar (map (substExpr s) (map Var fvs)) + where s = mkSubst (inSet env) emptyVarEnv es + + isVar (Var x) | isJust (maybeInline env x) = False + | otherwise = True + isVar _ = False +#else hunk ./compiler/supercomp/Scp.hs 649 - +#endif } [Put the size of terms in Rho, and exploit this to prune candidates for folding and splitting. t-peterj@microsoft.com**20090801131205] { hunk ./compiler/supercomp/Scp.hs 163 - compTerm :: CoreExpr + compTerm :: CoreExpr, + compSize :: Integer hunk ./compiler/supercomp/Scp.hs 448 - compTerm = l'} + compTerm = l', compSize = realExprSize l'} hunk ./compiler/supercomp/Scp.hs 592 + msize = realExprSize in_exp hunk ./compiler/supercomp/Scp.hs 601 - p1 (RhoE {..}, _) | v == headExp, + p1 (RhoE {..}, _) | msize == compSize, + v == headExp, hunk ./compiler/supercomp/Scp.hs 604 - coreEqType in_type (exprType compTerm), - isTrueRenaming s = Just s + coreEqType in_type (exprType compTerm) = Just s +-- isTrueRenaming s = Just s hunk ./compiler/supercomp/Scp.hs 608 - p2 (RhoE {..}) | v == headExp, + p2 (RhoE {..}) | -- msize >= compSize, + v == headExp, hunk ./compiler/supercomp/Scp.hs 630 + msize == compSize, hunk ./compiler/supercomp/Scp.hs 633 - coreEqType in_type (exprType compTerm), - isTrueRenaming s] ++ + coreEqType in_type (exprType compTerm) ] ++ hunk ./compiler/supercomp/Scp.hs 641 + msize = realExprSize in_exp hunk ./compiler/supercomp/Scp.hs 909 - p (RhoE {..}) = msize > realExprSize compTerm && isHomemb env compTerm in_exp && coreEqType (exprType compTerm) in_type + p (RhoE {..}) = msize > compSize && isHomemb env compTerm in_exp && coreEqType (exprType compTerm) in_type hunk ./compiler/supercomp/Scp.hs 914 -homemb env in_exp = [(freshName, inFvs, compTerm) | RhoE {..} <- (ls env), msize > realExprSize compTerm, isHomemb env compTerm in_exp, coreEqType (exprType compTerm) in_type] -- YYY: UNSOUND +homemb env in_exp = [(freshName, inFvs, compTerm) | RhoE {..} <- (ls env), msize > compSize, isHomemb env compTerm in_exp, coreEqType (exprType compTerm) in_type] -- YYY: UNSOUND } [Make maybeInline more readable and reduce the number of comparisons. t-peterj@microsoft.com**20090802124806] { hunk ./compiler/supercomp/Scp.hs 774 -maybeInline env fun +maybeInline env fun + | elem (occNameString (nameOccName (idName fun))) forbiddenFunctions = Nothing + | isLocalId fun = go binds' fun + | otherwise = maybeUnfoldingTemplate (idUnfolding fun) hunk ./compiler/supercomp/Scp.hs 783 - | Just e <- go binds' fun - , not (elem (occNameString (nameOccName (idName fun))) forbiddenFunctions) = Just e -- trace (showSDoc $ ppr $ idName fun) Just e - | Just e <- maybeUnfoldingTemplate (idUnfolding fun) - , not (isLocalId fun) - , not (elem (occNameString (nameOccName (idName fun))) forbiddenFunctions) = Just e -- trace (showSDoc $ ppr $ idName fun) Just e +-- | Just e <- go binds' fun +-- , not (elem (occNameString (nameOccName (idName fun))) forbiddenFunctions) = Just e -- trace (showSDoc $ ppr $ idName fun) Just e +-- | not (isLocalId fun), +-- Just e <- maybeUnfoldingTemplate (idUnfolding fun), +-- , not (elem (occNameString (nameOccName (idName fun))) forbiddenFunctions) = Just e -- trace (showSDoc $ ppr $ idName fun) Just e } [Use the plugged term instead of plugging in splitStore. t-peterj@microsoft.com**20090802134123] { hunk ./compiler/supercomp/Scp.hs 1712 - go (e@(RhoE {headExp = f, restExp = c, ..}, _):t) s1 s2 + go (e@(RhoE {..}, _):t) s1 s2 hunk ./compiler/supercomp/Scp.hs 1715 - where fvs = realFvs (env {inSet = funSet env}) plugged - plugged = plug c (Var f) + where fvs = realFvs (env {inSet = funSet env}) compTerm + } [Use a FiniteMap instead of a list for local Functions. t-peterj@microsoft.com**20090802135204] { hunk ./compiler/supercomp/Scp.hs 31 - +import FiniteMap ( FiniteMap, listToFM, addListToFM, lookupFM ) hunk ./compiler/supercomp/Scp.hs 175 - binds :: [(Var, CoreExpr)] -- This is \mathcal{G} + binds :: FiniteMap Var CoreExpr -- This is \mathcal{G} hunk ./compiler/supercomp/Scp.hs 187 - binds = flattenBinds b + binds = listToFM (flattenBinds b) hunk ./compiler/supercomp/Scp.hs 382 - body' <- drive (env' {binds = p ++ binds env}) body c + body' <- drive (env' {binds = addListToFM (binds env) p}) body c hunk ./compiler/supercomp/Scp.hs 776 - | isLocalId fun = go binds' fun + | isLocalId fun = lookupFM (binds env) fun hunk ./compiler/supercomp/Scp.hs 790 - | otherwise = Nothing - where binds' = binds env - go [] _ = Nothing - go ((b, e):binds) n = if (varName b) == (idName n) then Just e else go binds n +-- | otherwise = Nothing } [Remove some unecessary intermediate lists. t-peterj@microsoft.com**20090802143616] { hunk ./compiler/supercomp/Scp.hs 829 -realFvs' env (Let b e') = delete (bindersOf b) (concat (map (realFvs' env) (rhssOfBind b)) ++ realFvs' env e') +realFvs' env (Let b e') = delete (bindersOf b) (concatMap (realFvs' env) (rhssOfBind b) ++ realFvs' env e') hunk ./compiler/supercomp/Scp.hs 832 - e2 = delete [b] (concat (map (realFvs' env) (rhssOfAlts alts))) + e2 = delete [b] (concatMap (realFvs' env) (rhssOfAlts alts)) hunk ./compiler/supercomp/Scp.hs 843 -localRuleBase = mkRuleBase (concat (map func allThePrimOps)) +localRuleBase = mkRuleBase (concatMap func allThePrimOps) hunk ./compiler/supercomp/Scp.hs 947 - isHomemb env f1 f2 && all (uncurry $ isHomemb env) (zip args1 args2) + isHomemb env f1 f2 && and (zipWith (isHomemb env) args1 args2) hunk ./compiler/supercomp/Scp.hs 952 - isHomemb env body1 body2 && and (zipWith (isHomemb env) (rhssOfBind b1) (rhssOfBind b2)) + isHomemb env body1 body2 && and (zipWith (\(_, e1) (_, e2) -> isHomemb env e1 e2) p1 p2) hunk ./compiler/supercomp/Scp.hs 955 - and (zipWith (isHomemb env) (rhssOfAlts alts1) (rhssOfAlts alts2)) + and (zipWith (\(_, _, e1) (_, _, e2) -> isHomemb env e1 e2) alts1 alts2) } [Add comments about logging and adjust levels accordingly. t-peterj@microsoft.com**20090805133945] { hunk ./compiler/supercomp/Scp.hs 8 +-- Define to 0 for a sequential run hunk ./compiler/supercomp/Scp.hs 11 +{- + +Note: [Regression Testing] + +THIS IS IMPORTANT. + +Even small changes to the supercompiler can prevent optimizations from +happening, and it takes literally days to track down +afterwards. Verify that this does not happen, in the following order: + +* The output from append (append xs ys) zs contains a new function + $sappend that takes 3 arguments, and calls a different $sappend that + takes two arguments from the first nil-branch. + +* Supercompile Charcount3, and compare the runtime on a 1M file + between the supercompiled version and the ordinary version. The + supercompiled version should complete in half the time. + +Note: [Logging] + +0: Bug reporting worthy things: missing rules, failed things that should work. + +2: Whistles, folds, new funtcions + +3: Print out whistle candidates and free variables + +4: Functions that are going to be inlined, error prone steps in drive. + +5: All steps in drive (SLOW). + +6: Type checking of individual steps. + +-} + hunk ./compiler/supercomp/Scp.hs 316 - scpLog 5 "R7:" (ppr (checkType "CL" (Case (Lit l) b t alts) newrhs)) + scpLog 6 "R7:" (ppr (checkType "CL" (Case (Lit l) b t alts) newrhs)) hunk ./compiler/supercomp/Scp.hs 319 - scpLog 3 ("R8 (" ++ show (length oes) ++ "):") (ppr (plug context (Lit l))) --- rule_base <- lift getSimplRules + scpLog 4 ("R8 (" ++ show (length oes) ++ "):") (ppr (plug context (Lit l))) + scpLog 4 "l: " (ppr l) + scpLog 4 "oes: " (ppr oes) hunk ./compiler/supercomp/Scp.hs 331 - scpLog 2 "R3:" (ppr v) - scpLog 4 "R3 ctxt:" (ppr (plug context (Var v))) + scpLog 4 "R3:" (ppr v) + scpLog 5 "R3 ctxt:" (ppr (plug context (Var v))) hunk ./compiler/supercomp/Scp.hs 337 - scpLog 4 "R27/R28:" (ppr e) + scpLog 5 "R27/R28:" (ppr e) hunk ./compiler/supercomp/Scp.hs 353 - scpLog 4 "conApp stuff:" (ppr newe) + scpLog 4 "Case selection, new branch:" (ppr newe) hunk ./compiler/supercomp/Scp.hs 365 - scpLog 4 "R6:" (ppr (checkType "R9" (Cast c co2) (Cast e co'))) + scpLog 6 "R6:" (ppr (checkType "R9" (Cast c co2) (Cast e co'))) hunk ./compiler/supercomp/Scp.hs 377 - scpLog 4 "LamBeta" (ppr (checkType "LamBeta" newexp (mkApps l args))) + scpLog 6 "LamBeta" (ppr (checkType "LamBeta" newexp (mkApps l args))) hunk ./compiler/supercomp/Scp.hs 381 --- scpLog 4 "R17/R18/R19:" (ppr (checkType "R17/R18" t newexp)) - scpLog 4 "R17/R18/R19:" (ppr l) --- scpLog 4 "R17/R18/R19:" (ppr newexp) + scpLog 5 "R17/R18/R19:" (ppr l) hunk ./compiler/supercomp/Scp.hs 383 - scpLog 4 "LamCBeta" (ppr (checkType "LamBeta" newexp (mkApps (Cast l co) args))) + scpLog 6 "LamCBeta" (ppr (checkType "LamBeta" newexp (mkApps (Cast l co) args))) hunk ./compiler/supercomp/Scp.hs 385 --- drive env newexp c'' hunk ./compiler/supercomp/Scp.hs 396 - scpLog 5 "R22/R23/R24:" (ppr (checkType "R22" l newexp)) + scpLog 6 "R22/R23/R24:" (ppr (checkType "R22" l newexp)) hunk ./compiler/supercomp/Scp.hs 403 - scpLog 5 "R23(nl):" (ppr (checkType "R23nle" e e')) + scpLog 6 "R23(nl):" (ppr (checkType "R23nle" e e')) hunk ./compiler/supercomp/Scp.hs 405 - scpLog 5 "R23(nl):" (ppr (checkType "R23nlb" (plug c body) body')) + scpLog 6 "R23(nl):" (ppr (checkType "R23nlb" (plug c body) body')) hunk ./compiler/supercomp/Scp.hs 431 - tr ("Fallthrough: " ++ (showSDoc $ ppr (plug c e))) + scpLog 5 "Fallthrough:" (ppr (plug c e)) hunk ./compiler/supercomp/Scp.hs 444 - tr ("Switching: " ++ (showSDoc $ ppr e)) + scpLog 5 "Switching:" (ppr e) hunk ./compiler/supercomp/Scp.hs 463 - scpLog 4 "body_ty:" (ppr body_ty) - scpLog 4 "full_ty:" (ppr full_ty) + scpLog 5 "body_ty:" (ppr body_ty) + scpLog 5 "full_ty:" (ppr full_ty) hunk ./compiler/supercomp/Scp.hs 468 - scpLog 1 "Whistle:" (ppr l') - scpLog 1 "Whistle against:" (ppr nont) + scpLog 2 "Whistle:" (ppr l') + scpLog 3 "Whistle against:" (ppr nont) hunk ./compiler/supercomp/Scp.hs 476 - scpLog 4 "Inserting to rho:" (ppr l') - scpLogDebug 4 "Fresh name:" (ppr fname) + scpLog 5 "Inserting to rho:" (ppr l') + scpLogDebug 1 "Fresh name:" (ppr fname) + scpLog 2 "New function:" (ppr fname <+> ppr fvs <+> ppr fun + <+> ppr (depth context)) hunk ./compiler/supercomp/Scp.hs 489 - scpLog 5 "DriveApp:" (ppr (checkType "Driveapp" (plug context (Var fun)) e')) + scpLog 6 "DriveApp:" (ppr (checkType "Driveapp" (plug context (Var fun)) e')) hunk ./compiler/supercomp/Scp.hs 512 - tr ("msg ground:" ++ (showSDocDebug $ ppr term)) - scpLog 3 "msg ground:" (ppr term) --- scpLogDebug 4 "msg substvars:" (ppr ns) + scpLogDebug 4 "msg ground, full" (ppr term) + scpLog 4 "msg ground:" (ppr term) hunk ./compiler/supercomp/Scp.hs 582 - scpLog 2 "Driving leg:" (ppr $ plug c e) + scpLog 4 "Driving leg:" (ppr $ plug c e) hunk ./compiler/supercomp/Scp.hs 589 - scpLog 2 ("Unfolding found, depth " ++ show (depth myctxt)) (ppr fun) - scpLog 4 "Unfolds to:" (ppr e) + scpLog 5 ("Unfolding found, depth " ++ show (depth myctxt)) (ppr fun) + scpLog 5 "Unfolds to:" (ppr e) hunk ./compiler/supercomp/Scp.hs 600 - scpLog 2 "Renaming found" (ppr fun) hunk ./compiler/supercomp/Scp.hs 604 + scpLog 2 "Renaming found" (ppr fun <+> ppr n') hunk ./compiler/supercomp/Scp.hs 611 - scpLog 5 "Renamingg:" (ppr (checkType "renaming" l' newexp)) + scpLog 6 "Renaming TC:" (ppr (checkType "renaming" l' newexp)) hunk ./compiler/supercomp/Scp.hs 943 - p (RhoE {..}) = msize > compSize && isHomemb env compTerm in_exp && coreEqType (exprType compTerm) in_type + p (RhoE {..}) = msize > compSize && isHomemb env compTerm in_exp && coreEqType (exprType compTerm) in_type -- YYY: UNSOUND } [Give the printout a better description. t-peterj@microsoft.com**20090805134335] hunk ./compiler/supercomp/Scp.hs 604 - scpLog 2 "Renaming found" (ppr fun <+> ppr n') + scpLog 2 "Folding" (ppr fun <+> ppr n') [Add the old id to the inscope set, not a fresh one. t-peterj@microsoft.com**20090812085540] { hunk ./compiler/supercomp/Scp.hs 210 - binds :: FiniteMap Var CoreExpr -- This is \mathcal{G} + binds :: FiniteMap Var CoreExpr -- This is \mathcal{F} hunk ./compiler/supercomp/Scp.hs 279 - | otherwise = go (env {inSet = extendInScopeSet (inSet env) h'}) (s, h:b) t + | otherwise = go (env {inSet = extendInScopeSet (inSet env) h}) (s, h:b) t } [Ditto for function names. t-peterj@microsoft.com**20090812091006] hunk ./compiler/supercomp/Scp.hs 295 - | otherwise = go (env {funSet = extendInScopeSet (funSet env) h'}) (s, h:b) t + | otherwise = go (env {funSet = extendInScopeSet (funSet env) h}) (s, h:b) t [Return free type variables before free variables. t-peterj@microsoft.com**20090812100641] hunk ./compiler/supercomp/Scp.hs 867 -realFvs' env (Cast e co) = realFvs' env e ++ realFvs'_type env co +realFvs' env (Cast e co) = realFvs'_type env co ++ realFvs' env e [Add more alternatives to realFvs'_type. t-peterj@microsoft.com**20090812100719] hunk ./compiler/supercomp/Scp.hs 873 - | otherwise = [] -realFvs'_type _ _ = [] + | otherwise = [] +realFvs'_type env (AppTy t1 t2) = realFvs'_type env t1 ++ realFvs'_type env t2 +realFvs'_type env (TyConApp tc ts) = concatMap (realFvs'_type env) ts +realFvs'_type env (FunTy t1 t2) = realFvs'_type env t1 ++ realFvs'_type env t2 +realFvs'_type env (ForAllTy tv t) = delete [tv] (realFvs'_type env t) +realFvs'_type env (PredTy pt) = [] [Zap occurence and unfoldings in inScope, and replace Vars with what is found in inscope. t-peterj@microsoft.com**20090812124046] { hunk ./compiler/supercomp/Scp.hs 53 -import Id ( idUnfolding, mkUserLocal, idName, idDetails, idType, setIdUnfolding, isDataConWorkId_maybe, isDataConId_maybe, setIdUnfolding, zapIdOccInfo ) +import Id ( idUnfolding, mkUserLocal, idName, idDetails, idType, setIdUnfolding, isDataConWorkId_maybe, isDataConId_maybe, zapIdOccInfo ) hunk ./compiler/supercomp/Scp.hs 59 -import VarEnv ( emptyInScopeSet, emptyVarEnv, uniqAway, extendInScopeSet, extendInScopeSetList, mkRnEnv2, varEnvElts, lookupVarEnv, inRnEnvR, extendVarEnv, nukeRnEnvL, rnOccR, rnOccL, IdEnv, rnInScope, rnBndr2, rnBndrs2, nukeRnEnvR, lookupRnInScope, extendRnInScopeList, elemInScopeSet, getInScopeVars, extendInScopeSetSet, delInScopeSet ) +import VarEnv ( emptyInScopeSet, emptyVarEnv, uniqAway, extendInScopeSet, extendInScopeSetList, mkRnEnv2, varEnvElts, lookupVarEnv, inRnEnvR, extendVarEnv, nukeRnEnvL, rnOccR, rnOccL, IdEnv, rnInScope, rnBndr2, rnBndrs2, nukeRnEnvR, lookupRnInScope, extendRnInScopeList, elemInScopeSet, getInScopeVars, extendInScopeSetSet, delInScopeSet, lookupInScope ) hunk ./compiler/supercomp/Scp.hs 279 - | otherwise = go (env {inSet = extendInScopeSet (inSet env) h}) (s, h:b) t - where h' = uniqAway iss h + | otherwise = go (env {inSet = extendInScopeSet (inSet env) hc}) (s, hc:b) t + where hc | isTyVar h = h + | otherwise = zapIdOccInfo (h `setIdUnfolding` NoUnfolding) + h' = uniqAway iss hc hunk ./compiler/supercomp/Scp.hs 284 - s' | isTyVar h = extendTvSubst s h (mkTyVarTy (mkTyVar (varName h') (tyVarKind h))) - | otherwise = extendSubst s h (Var h') + s' | isTyVar h = extendTvSubst s hc (mkTyVarTy (mkTyVar (varName h') (tyVarKind hc))) + | otherwise = extendSubst s hc (Var h') hunk ./compiler/supercomp/Scp.hs 362 + | Just v' <- lookupInScope (inSet env) v = build env (Var v') context } [Continue transforming even if there is no rule for constant folding. t-peterj@microsoft.com**20090812124245] { hunk ./compiler/supercomp/Scp.hs 328 - Just (_, rule_rhs) = lookupRule (const True) iss fun (oes ++ [Lit l]) rules + case lookupRule (const True) iss fun (oes ++ [Lit l]) rules of + Just (_, rule_rhs) -> drive env rule_rhs c + Nothing -> build env (Lit l) context hunk ./compiler/supercomp/Scp.hs 332 - drive env rule_rhs c + } [Zap recursive unfoldings as well. t-peterj@microsoft.com**20090812135440] { hunk ./compiler/supercomp/Scp.hs 297 - | otherwise = go (env {funSet = extendInScopeSet (funSet env) h}) (s, h:b) t - where h' = uniqAway iss h + | otherwise = go (env {funSet = extendInScopeSet (funSet env) hc}) (s, hc:b) t + where hc | isTyVar h = h + | otherwise = zapIdOccInfo (h `setIdUnfolding` NoUnfolding) + h' = uniqAway iss hc hunk ./compiler/supercomp/Scp.hs 302 - s' | isTyVar h = extendTvSubst s h (mkTyVarTy (mkTyVar (varName h') (tyVarKind h))) - | otherwise = extendSubst s h (Var h') + s' | isTyVar h = extendTvSubst s hc (mkTyVarTy (mkTyVar (varName h') (tyVarKind hc))) + | otherwise = extendSubst s hc (Var h') } [Signal when we potentially have h functions in our contexts. t-peterj@microsoft.com**20090813131522] { hunk ./compiler/supercomp/Scp.hs 25 -* Supercompile Charcount3, and compare the runtime on a 1M file +* Supercompile Charcount9, and compare the runtime on a 1M file hunk ./compiler/supercomp/Scp.hs 207 --- scp_subst :: Subst, +-- scp_subst :: Subst, + hasH :: Bool, hunk ./compiler/supercomp/Scp.hs 221 + hasH = False, hunk ./compiler/supercomp/Scp.hs 444 -build env e (PrimOpCtxt o oes ies c) +build env e (PrimOpCtxt o oes ies c) + | hasH env = do -- Make sure our context does not contain h functions + scpLog 2 "h function in context" (ppr e) + ies' <- mapM (\e -> drive (env {hasH = False}) e emptyContext) ies + build env (mkApps o (oes ++ ies')) c hunk ./compiler/supercomp/Scp.hs 453 - build env (mkApps e [arg']) c + build (env {hasH = True}) (mkApps e [arg']) c } [Implement the new homeomorphic embedding. t-peterj@microsoft.com**20090813152054] { hunk ./compiler/supercomp/Scp.hs 10 +#define NEW_HOMEMB 1 hunk ./compiler/supercomp/Scp.hs 194 +splitTerm :: CoreExpr -> (CoreExpr, Context, [CoreBind]) +splitTerm e = splitTerm' e EmptyCtxt + +splitTerm' :: CoreExpr -> Context -> (CoreExpr, Context, [CoreBind]) +splitTerm' e c = go e c [] + where go v@(Var x) c bs | PrimOpId _ <- idDetails x = (e', c2, bs' ++ bs) + | otherwise = (v, c, bs) + where (e, c1) = makePrimOpCtxt x c + (e', c2, bs') = splitTerm' e c1 + go e@(Lam {}) c bs = (e, c, bs) + go (App e1 e2) c bs = go e1 (AppCtxt e2 c) bs + go e@(Let b1 body) c bs = go body c (b1:bs) + go e@(Case scrut _ _ _) c bs = go scrut (CaseCtxt e c) bs + go e@(Cast e' _) c bs = go e' (CastCtxt e c) bs + go (Note _ e) c bs = go e c bs + go e@(Lit {}) c bs = (e, c, bs) + go e@(Type {}) c bs = (e, c, bs) + hunk ./compiler/supercomp/Scp.hs 494 +#if NEW_HOMEMB + let nont = homemb env (Var fun) context +#else hunk ./compiler/supercomp/Scp.hs 498 +#endif hunk ./compiler/supercomp/Scp.hs 529 +#if NEW_HOMEMB + refl = [(n, in_fvs, e) | (n, in_fvs, e) <- nont, isHomemb env (splitTerm l') (splitTerm e)] +#else hunk ./compiler/supercomp/Scp.hs 533 +#endif hunk ./compiler/supercomp/Scp.hs 957 -{- -homemb :: ScpEnv -> CoreExpr -> Context -> [(Var, [Var], CoreExpr)] -homemb env e1 c1 = [(freshName, inFvs, plug restExp (Var headExp)) | - RhoE {..} <- (ls env), - isHomemb env e1 c1 (Var headExp) restExp] - - -isHomemb :: ScpEnv -> CoreExpr -> Context -> CoreExpr -> Context -> Bool -isHomemb env e1 c1 e2 c2 = new_peel env e1 c1 e2 c2 - || any (\es -> let (e, c) = splitTerm es - in isHomemb env v1 c1 e c) es - || - where (es, c) = (dive c2) --} - -#if PARALLEL_SCP hunk ./compiler/supercomp/Scp.hs 964 +#if NEW_HOMEMB +homemb :: ScpEnv -> CoreExpr -> Context -> [(Var, [Var], CoreExpr)] +homemb env e1 c1 = [(freshName, inFvs, compTerm) | + RhoE {..} <- (ls env), msize > compSize, + isHomemb env ((Var headExp), restExp, []) (e1, c1, []), + coreEqType (exprType compTerm) in_type] -- YYY: UNSOUND + where in_exp = plug c1 e1 + msize = realExprSize in_exp + in_type = exprType in_exp + +isHomemb :: ScpEnv -> (CoreExpr, Context, [CoreBind]) -> + (CoreExpr, Context, [CoreBind]) -> Bool +isHomemb env t1 t2 = new_peel env t1 t2 + || any (isHomemb env t1) (map splitTerm (subterms t2)) +#else + +#if PARALLEL_SCP + hunk ./compiler/supercomp/Scp.hs 998 -#endif +#endif /* PARALLEL_SCP */ hunk ./compiler/supercomp/Scp.hs 1003 +#endif /* NEW_HOMEMB */ + + hunk ./compiler/supercomp/Scp.hs 1017 +#if NEW_HOMEMB +#if 0 +new_dive :: (CoreExpr, Context, [CoreBind]) -> + ([(CoreExpr, Context, [CoreBind])], Context) +new_dive (_, c, bs) = (es ++ go' bs, c') + where (es, c') = go c False + go EmptyCtxt b = ([], EmptyCtxt) + go (AppCtxt e2 c) _ = (splitTerm e2:bs, c') + where (bs, c') = go c True + go (PrimOpCtxt _ oes ies c) _ = (map splitTerm (oes ++ ies), c) + go c@(CaseCtxt (Case _ _ _ alts) c') b + | b = ([], c) + | otherwise = (map splitTerm (rhssOfAlts alts), c') + go (CastCtxt _ c) = go c True + + go' [] = [] + go' ((Rec p):t) = map (splitTerm . snd) p ++ go' t + go' ((NonRec _ e):t) = splitTerm e:go' t +#endif +#else + hunk ./compiler/supercomp/Scp.hs 1064 +#endif + +#if NEW_HOMEMB +subterms :: (CoreExpr, Context, [CoreBind]) -> [CoreExpr] +subterms (e, c, bs) = subterm e ++ subterms_ctxt c ++ concatMap rhssOfBind bs + where subterm (Lam _ e) = [e] + subterm _ = [] + + +subterms_ctxt :: Context -> [CoreExpr] +subterms_ctxt EmptyCtxt = [] +subterms_ctxt(AppCtxt e c) = e:subterms_ctxt c +subterms_ctxt(PrimOpCtxt _ oes ies c) = oes ++ ies ++ subterms_ctxt c +subterms_ctxt(CaseCtxt (Case _ _ _ alts) c) = rhssOfAlts alts ++ subterms_ctxt c +subterms_ctxt(CastCtxt _ c) = subterms_ctxt c + hunk ./compiler/supercomp/Scp.hs 1081 +new_peel :: ScpEnv -> (CoreExpr, Context, [CoreBind]) + -> (CoreExpr, Context, [CoreBind]) -> Bool +new_peel env t1@(Var v1, c1, b1) (Var v2, c2, b2) + | v1 == v2 -- f(e1..en) < f(e1'..en') + , Just _ <- e = peel_con env c1 c2 && peel_bind env b1 b2 + | PrimOpId f1 <- detv1 + , PrimOpId f2 <- detv2 = panic "Failure in splitting term" -- Distinguish + from - + | isJust e || isJust (maybeInline env v2) = False -- Distinguish f from g. + | otherwise = peel_con env c1 c2 && peel_bind env b1 b2 -- x is embedded in y. + where e = maybeInline env v1 + detv1 = idDetails v1 + detv2 = idDetails v2 +new_peel env t1@(Lit v1, c1, b1) (Lit v2, c2, b2) + = peel_con env c1 c2 && peel_bind env b1 b2 -- 9 embedded in 2 +new_peel env t1@(Lam _ e1, c1, b1) (Lam _ e2, c2, b2) + | isHomemb env (splitTerm e1) (splitTerm e2) = peel_con env c1 c2 && peel_bind env b1 b2 +new_peel env t1@(Type _, c1, b1) (Type _, c2, b2) = peel_con env c1 c2 && peel_bind env b1 b2 +new_peel _ t1@(e1, _, _) t2 = trace ("new_peel:" ++ (showSDoc $ ppr e1)) False + +peel_con :: ScpEnv -> Context -> Context -> Bool +peel_con _ EmptyCtxt _ = True +peel_con _ _ EmptyCtxt = False +peel_con env (AppCtxt e1 c1) (AppCtxt e2 c2) + | isHomemb env (splitTerm e1) (splitTerm e2) = peel_con env c1 c2 +peel_con env (PrimOpCtxt (Var v1) oes1 ies1 c1) (PrimOpCtxt (Var v2) oes2 ies2 c2) + | v1 == v2 && length oes1 == length oes2 && length ies1 == length ies2 && + and (zipWith (\e1 e2 -> isHomemb env (splitTerm e1) (splitTerm e2)) oes1 oes2) && and (zipWith (\e1 e2 -> isHomemb env (splitTerm e1) (splitTerm e2)) ies1 ies2) = peel_con env c1 c2 +peel_con env (CaseCtxt (Case s1 b1 t1 alts1) c1) (CaseCtxt (Case s2 b2 t2 alts2) c2) + | length alts1 == length alts2 && isHomemb env (splitTerm s1) (splitTerm s2) && + and (zipWith (\(_, _, e1) (_, _, e2) -> isHomemb env (splitTerm e1) (splitTerm e2)) alts1 alts2) = peel_con env c1 c2 +peel_con env (CastCtxt _ c1) (CastCtxt _ c2) = peel_con env c1 c2 +peel_con env c1 (AppCtxt e c2) = peel_con env c1 c2 +peel_con env c1 (PrimOpCtxt _ _ _ c2) = peel_con env c1 c2 +peel_con env c1 (CaseCtxt _ c2) = peel_con env c1 c2 +peel_con env c1 (CastCtxt _ c2) = peel_con env c1 c2 + + +peel_bind :: ScpEnv -> [CoreBind] -> [CoreBind] -> Bool +peel_bind _ [] _ = True +peel_bind _ _ [] = False +peel_bind env ((NonRec _ e1):t1) ((NonRec _ e2):t2) + | isHomemb env (splitTerm e1) (splitTerm e2) = peel_bind env t1 t2 +peel_bind env ((Rec p1):t1) ((Rec p2):t2) + | length p1 == length p2 && + and (zipWith (\(b1, e1) (b2, e2) -> isHomemb env (splitTerm e1) (splitTerm e2)) p1 p2) = peel_bind env t1 t2 +peel_bind env e (h:t) = peel_bind env e t +#endif + + +{- + + The most specific generalisation + +-} } [Implement a parallell homemb. t-peterj@microsoft.com**20090814091801] { hunk ./compiler/supercomp/Scp.hs 965 + +#if PARALLEL_SCP + +homemb :: ScpEnv -> CoreExpr -> Context -> [(Var, [Var], CoreExpr)] +homemb env e1 c1 = concat $ zipWith fixup blist myls + where in_exp = plug c1 e1 + msize = realExprSize in_exp + in_type = exprType in_exp + myls = ls env + blist = parBufferWHNF 100 (map p myls) + p :: RhoElement -> Bool + p (RhoE {..}) = msize > compSize && isHomemb env (Var headExp, restExp, []) (e1, c1, []) && coreEqType (exprType compTerm) in_type -- YYY: UNSOUND + fixup True (RhoE {..}) = [(freshName, inFvs, compTerm)] + fixup False _ = [] +#else + hunk ./compiler/supercomp/Scp.hs 989 +#endif hunk ./compiler/supercomp/Scp.hs 1035 -#if 0 -new_dive :: (CoreExpr, Context, [CoreBind]) -> - ([(CoreExpr, Context, [CoreBind])], Context) -new_dive (_, c, bs) = (es ++ go' bs, c') - where (es, c') = go c False - go EmptyCtxt b = ([], EmptyCtxt) - go (AppCtxt e2 c) _ = (splitTerm e2:bs, c') - where (bs, c') = go c True - go (PrimOpCtxt _ oes ies c) _ = (map splitTerm (oes ++ ies), c) - go c@(CaseCtxt (Case _ _ _ alts) c') b - | b = ([], c) - | otherwise = (map splitTerm (rhssOfAlts alts), c') - go (CastCtxt _ c) = go c True hunk ./compiler/supercomp/Scp.hs 1036 - go' [] = [] - go' ((Rec p):t) = map (splitTerm . snd) p ++ go' t - go' ((NonRec _ e):t) = splitTerm e:go' t -#endif hunk ./compiler/supercomp/Scp.hs 1098 -new_peel _ t1@(e1, _, _) t2 = trace ("new_peel:" ++ (showSDoc $ ppr e1)) False +new_peel _ t1@(e1, _, _) t2 = False } [Split on zipped form. Normalize the stored zipper before storing. t-peterj@microsoft.com**20090814141810] { hunk ./compiler/supercomp/Scp.hs 11 +#define NEW_SPLIT 1 hunk ./compiler/supercomp/Scp.hs 217 - headExp :: Var, + headExp :: CoreExpr, hunk ./compiler/supercomp/Scp.hs 491 + -- Normalize the expression + (fun', context', []) = splitTerm l' hunk ./compiler/supercomp/Scp.hs 498 - let nont = homemb env (Var fun) context + let nont = homemb env fun' context' hunk ./compiler/supercomp/Scp.hs 521 - restExp = context, headExp = fun, + restExp = context', headExp = fun', hunk ./compiler/supercomp/Scp.hs 546 +#if NEW_HOMEMB + let (fun', context', []) = splitTerm l' + gen env fun fun' context' (trd3 . head $ nont) +#else hunk ./compiler/supercomp/Scp.hs 551 +#endif hunk ./compiler/supercomp/Scp.hs 553 +#if NEW_HOMEMB +gen :: ScpEnv -> Id -> CoreExpr -> Context -> CoreExpr -> ScpM Store CoreExpr +gen env fun e1 c1 e2 = do + res@(ground, _) <- msg env fun (plug c1 e1, e2) + (term, tps) <- case ground of +#if NEW_SPLIT + Var _ -> split' env fun e1 c1 +#else + Var _ -> split' env fun (plug c1 e2) +#endif + _ -> return res + let env' = env {inSet = extendInScopeSetList (inSet env) (getTpBinders tps)} + scpLogDebug 4 "msg ground, full" (ppr term) + scpLog 4 "msg ground:" (ppr term) + scpLog 4 "msg subst:" (ppr tps) + term' <- drive env' term emptyContext + tps' <- driveTps env tps + let + rterm = plugTpTerm tps' term' + scpLog 4 "gen3:" (ppr rterm) + return rterm +#else hunk ./compiler/supercomp/Scp.hs 579 +#if NEW_SPLIT + Var _ -> let (e1', c1, []) = splitTerm e1 in split' env fun e1' c1 +#else hunk ./compiler/supercomp/Scp.hs 583 +#endif hunk ./compiler/supercomp/Scp.hs 595 +#endif + hunk ./compiler/supercomp/Scp.hs 610 +#if NEW_SPLIT +buildContext :: [Context] -> Context +buildContext [] = EmptyCtxt +buildContext ((AppCtxt e _):[]) = AppCtxt e EmptyCtxt +buildContext ((PrimOpCtxt e oes ies _):[])= PrimOpCtxt e oes ies EmptyCtxt +buildContext ((CaseCtxt e _):[]) = CaseCtxt e EmptyCtxt +buildContext ((CastCtxt e _):[]) = CastCtxt e EmptyCtxt +buildContext ((AppCtxt e c):t) = AppCtxt e (buildContext t) +buildContext ((PrimOpCtxt e oes ies c):t)= PrimOpCtxt e oes ies (buildContext t) +buildContext ((CaseCtxt e c):t) = CaseCtxt e (buildContext t) +buildContext ((CastCtxt e c):t) = CastCtxt e (buildContext t) hunk ./compiler/supercomp/Scp.hs 622 +split' :: ScpEnv -> Id -> CoreExpr -> Context -> ScpM s (CoreExpr, TermParts) +split' _ fun _ EmptyCtxt = panic ("split' called on emtpy context: " ++ (showSDoc $ ppr fun)) +split' env fun e1 c = go c [] + where + go c'@(AppCtxt e c) oc + | EmptyCtxt <- c = do + let tp = plug (buildContext (reverse oc)) e1 + x <- newName fun (exprType tp) + return (App (Var x) e, newTpExp env x tp) + | otherwise = go c (c':oc) + go c'@(PrimOpCtxt e oes ies c) oc + | EmptyCtxt <- c = do + let tp = plug (buildContext (reverse oc)) e1 + xs <- mapM (newName fun) (map exprType (tp:oes ++ ies)) + return (mkApps e (map Var xs), newTpExps env xs (tp:oes ++ ies)) + | otherwise = go c (c':oc) + go c'@(CaseCtxt (Case _ b t alts) c) oc + | EmptyCtxt <- c = do + let tp = plug (buildContext (reverse oc)) e1 + x <- newName fun t + return (Case (Var x) b t alts, newTpExp env x tp) + | otherwise = go c (c':oc) + go c'@(CastCtxt (Cast _ co) EmptyCtxt) oc + | EmptyCtxt <- c = do + let tp = plug (buildContext (reverse oc)) e1 + x <- newName fun (exprType tp) + return (Cast (Var x) co, newTpExp env x tp) + | otherwise = go c (c':oc) + +#else hunk ./compiler/supercomp/Scp.hs 691 +#endif hunk ./compiler/supercomp/Scp.hs 713 - res = renamings env ml fun l' + (fun', _, []) = splitTerm l' + res = renamings env ml (Var fun) l' hunk ./compiler/supercomp/Scp.hs 738 -renamings :: ScpEnv -> Store -> Id -> CoreExpr -> [(Var, [Var], SubstEnv)] -renamings env ml v in_exp = (concat $ zipWith fixup1 b1list ml) ++ (concat $ zipWith fixup2 b2list myls) +renamings :: ScpEnv -> Store -> CoreExpr -> CoreExpr -> [(Var, [Var], SubstEnv)] +renamings env ml id in_exp = (concat $ zipWith fixup1 b1list ml) ++ (concat $ zipWith fixup2 b2list myls) hunk ./compiler/supercomp/Scp.hs 755 - v == headExp, + id `weakUnsoundEqExpr` headExp, hunk ./compiler/supercomp/Scp.hs 762 - v == headExp, + id `weakUnsoundEqExpr` headExp, hunk ./compiler/supercomp/Scp.hs 780 -renamings :: ScpEnv -> Store -> Id -> CoreExpr -> [(Var, [Var], SubstEnv)] -renamings env ml v in_exp = +renamings :: ScpEnv -> Store -> CoreExpr -> CoreExpr -> [(Var, [Var], SubstEnv)] +renamings env ml id in_exp = hunk ./compiler/supercomp/Scp.hs 784 - v == headExp, + id == headExp, hunk ./compiler/supercomp/Scp.hs 788 - v == headExp, + id == headExp, hunk ./compiler/supercomp/Scp.hs 1055 - p (RhoE {..}) = msize > compSize && isHomemb env (Var headExp, restExp, []) (e1, c1, []) && coreEqType (exprType compTerm) in_type -- YYY: UNSOUND + p (RhoE {..}) = msize > compSize && isHomemb env (headExp, restExp, []) (e1, c1, []) && coreEqType (exprType compTerm) in_type -- YYY: UNSOUND hunk ./compiler/supercomp/Scp.hs 1063 - isHomemb env ((Var headExp), restExp, []) (e1, c1, []), + isHomemb env (headExp, restExp, []) (e1, c1, []), hunk ./compiler/supercomp/Scp.hs 1979 -beautify (((RhoE {freshName = h, inFvs = xs, restExp = c, headExp = f}), e):t) = (text "(" <+> ppr h <+> ppr xs <+> ppr (plug c (Var f)) <+> text "body:" <+> ppr e <+> text ")"):beautify t +beautify (((RhoE {freshName = h, inFvs = xs, restExp = c, headExp = f}), e):t) = (text "(" <+> ppr h <+> ppr xs <+> ppr (plug c f) <+> text "body:" <+> ppr e <+> text ")"):beautify t hunk ./compiler/supercomp/Scp.hs 1982 +weakUnsoundEqExpr :: CoreExpr -> CoreExpr -> Bool +weakUnsoundEqExpr (Var v1) (Var v2) = v1==v2 +weakUnsoundEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2 +weakUnsoundEqExpr (Note n1 e1) (Note n2 e2) = + e1 `weakUnsoundEqExpr` e2 && n1 `realNoteEq` n2 +weakUnsoundEqExpr (Type t1) (Type t2) = t1 `coreEqType` t2 +weakUnsoundEqExpr (Lam _ _) (Lam _ _) = True +weakUnsoundEqExpr _ _ = False } [Add match/split working on the zipped representation. t-peterj@microsoft.com**20090815165319] { hunk ./compiler/supercomp/Scp.hs 10 -#define NEW_HOMEMB 1 +#define NEW_HOMEMB 0 hunk ./compiler/supercomp/Scp.hs 12 +#define NEW_MATCH 1 +#define NEW_MSG 0 hunk ./compiler/supercomp/Scp.hs 558 +#if NEW_MSG + res@(ground, _) <- msg env fun (e1, c1, []) (splitTerm e2) +#else hunk ./compiler/supercomp/Scp.hs 562 +#endif hunk ./compiler/supercomp/Scp.hs 753 - lmenv = mkRnEnv2 in_scope + lmenv = mkRnEnv2 in_scope + in_exp' = splitTerm in_exp +#if NEW_MATCH + renaming t1 in_fvs t2 = match menv emptySubstEnv t1 t2 + where menv = ME { me_env = lmenv + , me_tmpls = mkVarSet in_fvs } +#else hunk ./compiler/supercomp/Scp.hs 763 +#endif hunk ./compiler/supercomp/Scp.hs 769 +#if NEW_MATCH + Just s <- renaming (headExp, restExp,[]) inFvs in_exp', +#else hunk ./compiler/supercomp/Scp.hs 773 +#endif hunk ./compiler/supercomp/Scp.hs 780 +#if NEW_MATCH + Just s <- renaming (headExp, restExp, []) inFvs in_exp', +#else hunk ./compiler/supercomp/Scp.hs 784 +#endif hunk ./compiler/supercomp/Scp.hs 1235 +#if NEW_MSG +msg :: ScpEnv -> Id -> (CoreExpr, Context, [CoreBind]) -> (CoreExpr, Context, [CoreBind]) -> ScpM s (CoreExpr, TermParts) +msg env fun (e1, c1, b1) (e2, c2, b2) = do + (e1', p1) <- msg_headexp env fun (e1, e2) + let (_, _, v1) = unzip3 p1 + (_, _, v2) = unzip3 p2 + (_, _, v3) = unzip3 p3 + tp = foldr plusTp emptyTp (v1 ++ v2 ++ v3) + return (e', tp) + +msg_headexp :: ScpEnv -> Id -> (CoreExpr, CoreExpr) -> ScpM s (CoreExpr, TermParts) +msg_headexp env fun (Var v1, Var v2) + | v1 == v2 = return (Var v1, []) + | otherwise = do + -- Could be handled by the default case, but this gives a name that you + -- can guess where it came from. + n <- newName v1 (exprType (Var v1)) + return (Var n, [([v1], [v2], newTpExp env n (Var v1))]) +msg_headexp _ _ (Lit l1, Lit l2) | l1 == l2 = return (Lit l1, []) +msg_headexp env fun (l1@(Lam b1 e1), l2@(Lam b2 e2)) + | b1 == b2 = do + let env' = env {inSet = extendInScopeSet (inSet env) b1} + (e', p) <- msg' env' fun (e1, e2) + let ys = [ fv1 | (fv1, fv2, _) <- p, elem b1 fv1 || elem b2 fv2] + if not $ null ys + then do + let fv1 = varSetElems (exprFreeVars l1) + fv2 = varSetElems (exprFreeVars l2) + n <- newName fun (exprType l1) + return (Var n, [(fv1, fv2, newTpExp env n l1)]) + else return (Lam b1 e', p) +msg_headexp env fun (l1@(Type t1), l2@(Type t2)) + | t1 `coreEqType` t2 = do + return (Type t1, []) + | otherwise = do + n <- newName fun (exprType (Type t1)) + let x = mkTyVar (varName n) (tyVarKind n) + x' = mkTyVarTy x + fv1 = varSetElems . exprFreeVars $ l1 + fv2 = varSetElems . exprFreeVars $ l2 + return (Type x', [(fv1, fv2, newTpType env x t1)]) +msg_headexp env fun (e1, e2) = do + n <- newName fun (exprType e1) + let fv1 = varSetElems . exprFreeVars $ e1 + fv2 = varSetElems . exprFreeVars $ e2 + return (Var n, [(fv1, fv2, newTpExp env n e1)]) hunk ./compiler/supercomp/Scp.hs 1282 + +#else hunk ./compiler/supercomp/Scp.hs 1394 +#endif hunk ./compiler/supercomp/Scp.hs 1590 +#if NEW_MATCH + +match :: MatchEnv + -> SubstEnv + -> (CoreExpr, Context, [CoreBind]) -- Template + -> (CoreExpr, Context, [CoreBind]) -- Target + -> Maybe SubstEnv + +-- See the notes with Unify.match, which matches types +-- Everything is very similar for terms + +-- Interesting examples: +-- Consider matching +-- \x->f against \f->f +-- When we meet the lambdas we must remember to rename f to f' in the +-- second expresion. The RnEnv2 does that. +-- +-- Consider matching +-- forall a. \b->b against \a->3 +-- We must rename the \a. Otherwise when we meet the lambdas we +-- might substitute [a/b] in the template, and then erroneously +-- succeed in matching what looks like the template variable 'a' against 3. + +-- The Var case follows closely what happens in Unify.match +match menv subst (e1, c1, b1) (e2, c2, b2) = do + subst1 <- match_headexp menv subst e1 e2 + subst2 <- match_binds menv subst1 b1 b2 + match_context menv subst2 c1 c2 + +match_headexp :: MatchEnv -> SubstEnv -> CoreExpr -> CoreExpr -> Maybe SubstEnv +match_headexp menv subst (Var v1) e2 + | Just subst' <- match_var menv subst v1 e2 = Just subst' + +match_headexp menv subst e1 (Var v2) -- Note [Expanding variables] + | not (locallyBoundR rn_env v2) -- Note [Do not expand locally-bound variables] + , Just e2' <- expandId v2' + = match (menv { me_env = nukeRnEnvR rn_env }) subst (e1, EmptyCtxt, []) (splitTerm e2') + where + v2' = lookupRnInScope rn_env v2 + rn_env = me_env menv + -- Notice that we look up v2 in the in-scope set + -- See Note [Lookup in-scope] + -- No need to apply any renaming first (hence no rnOccR) + -- becuase of the not-locallyBoundR + +match_headexp _ subst (Lit lit1) (Lit lit2) + | lit1 == lit2 = Just subst + +match_headexp menv subst (Lam x1 e1) (Lam x2 e2) = + match menv' subst (splitTerm e1) (splitTerm e2) + where + menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 } + +match_headexp menv subst (Type ty1) (Type ty2) + = match_ty menv subst ty1 ty2 + +-- Everything else fails +match_headexp _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $ + Nothing + + +match_context :: MatchEnv -> SubstEnv -> Context -> Context -> Maybe SubstEnv +-- match menv subst (Let b1 body1) (Let b2 body2) +-- | not (any (locallyBoundR rn_env) bs2) +-- = do { subst' <- match_binds menv subst b1 b2 +-- ; match menv' subst' body1 body2 } +-- where +-- rn_env = me_env menv +-- bs2 = bindersOf b2 +-- menv' = menv { me_env = rnBndrs2 rn_env (bindersOf b1) bs2 } + +-- match menv subst (Note n1 e1) (Note n2 e2) +-- | n1 `realNoteEq` n2 = match menv subst e1 e2 + +match_context _ subst EmptyCtxt EmptyCtxt = Just subst + +match_context menv subst (AppCtxt e1 c1) (AppCtxt e2 c2) + = do { subst' <- match menv subst (splitTerm e1) (splitTerm e2) + ; match_context menv subst' c1 c2 } + +match_context menv subst (PrimOpCtxt (Var v1) oes1 ies1 c1) (PrimOpCtxt (Var v2) oes2 ies2 c2) + | v1 == v2 + = do { subst1 <- match_exps menv subst oes1 oes2 -- Is oes always empty? + ; subst2 <- match_exps menv subst1 ies1 ies2 + ; match_context menv subst2 c1 c2 } + +match_context menv subst (CaseCtxt (Case _ x1 ty1 alts1) c1) (CaseCtxt (Case _ x2 ty2 alts2) c2) + = do { subst1 <- match_ty menv subst ty1 ty2 + ; let menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 } + ; subst2 <- match_alts menv' subst1 alts1 alts2 -- Alts are both sorted + ; match_context menv subst2 c1 c2 + } + +match_context menv subst (CastCtxt (Cast _ co1) c1) (CastCtxt (Cast _ co2) c2) + = do { subst1 <- match_ty menv subst co1 co2 + ; match_context menv subst1 c1 c2 } + + +match_context _ _ _ _ = Nothing + +------------------------------------------ +match_var :: MatchEnv + -> SubstEnv + -> Var -- Template + -> CoreExpr -- Target + -> Maybe SubstEnv +match_var menv subst@(tv_subst, id_subst, binds) v1 e2 + | v1' `elemVarSet` me_tmpls menv + = case lookupVarEnv id_subst v1' of + Nothing | any (inRnEnvR rn_env) (varSetElems (exprFreeVars e2)) + -> Nothing -- Occurs check failure + -- e.g. match forall a. (\x-> a x) against (\y. y y) + + | otherwise -- No renaming to do on e2, because no free var + -- of e2 is in the rnEnvR of the envt + -- Note [Matching variable types] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- However, we must match the *types*; e.g. + -- forall (c::Char->Int) (x::Char). + -- f (c x) = "RULE FIRED" + -- We must only match on args that have the right type + -- It's actually quite difficult to come up with an example that shows + -- you need type matching, esp since matching is left-to-right, so type + -- args get matched first. But it's possible (e.g. simplrun008) and + -- this is the Right Thing to do + -> do { tv_subst' <- Unify.ruleMatchTyX menv tv_subst (idType v1') (exprType e2) + -- c.f. match_ty below + ; return (tv_subst', extendVarEnv id_subst v1' e2, v1':binds) } + + Just e1' | eqExpr (nukeRnEnvL rn_env) e1' e2 + -> Just subst + + | otherwise + -> Nothing + + | otherwise -- v1 is not a template variable; check for an exact match with e2 + = case e2 of + Var v2 | v1' == rnOccR rn_env v2 -> Just subst + _ -> Nothing + + where + rn_env = me_env menv + v1' = rnOccL rn_env v1 + -- If the template is + -- forall x. f x (\x -> x) = ... + -- Then the x inside the lambda isn't the + -- template x, so we must rename first! + + + +match_alts :: MatchEnv + -> SubstEnv + -> [CoreAlt] -- Template + -> [CoreAlt] -- Target + -> Maybe SubstEnv +match_alts _ subst [] [] + = return subst +match_alts menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) + | c1 == c2 + = do { subst1 <- match menv' subst (splitTerm r1) (splitTerm r2) + ; match_alts menv subst1 alts1 alts2 } + where + menv' :: MatchEnv + menv' = menv { me_env = rnBndrs2 (me_env menv) vs1 vs2 } + +match_alts _ _ _ _ + = Nothing + + +match_ty :: MatchEnv + -> SubstEnv + -> Type -- Template + -> Type -- Target + -> Maybe SubstEnv +match_ty menv (tv_subst, id_subst, binds) ty1 ty2 + = do { tv_subst' <- Unify.ruleMatchTyX menv tv_subst ty1 ty2 + ; return (tv_subst', id_subst, binds) } + + +match_binds :: MatchEnv -> SubstEnv -> [CoreBind] -> [CoreBind] -> Maybe SubstEnv +match_binds _ subst [] [] = return subst +match_binds menv subst ((NonRec _ e1):t1)((NonRec _ e2):t2) = do + subst1 <- match menv subst (splitTerm e1) (splitTerm e2) + match_binds menv subst1 t1 t2 +match_binds menv subst (ps1@(Rec b1):t1) (ps2@(Rec b2):t2) + | equalLength b1 b2 = do + subst1 <- match_exps menv' subst (rhssOfBind ps1) (rhssOfBind ps2) + match_binds menv subst1 t1 t2 + where menv' = menv { me_env = rnBndrs2 (me_env menv) (bindersOf ps1) (bindersOf ps2)} + +match_binds _ _ _ _ = Nothing + +match_exps :: MatchEnv -> SubstEnv -> [CoreExpr] -> [CoreExpr] -> Maybe SubstEnv +match_exps _ subst [] [] = Just subst +match_exps menv subst (e1:t1) (e2:t2) = do + subst' <- match menv subst (splitTerm e1) (splitTerm e2) + match_exps menv subst' t1 t2 +match_exps _ _ _ _ = Nothing + +#else + hunk ./compiler/supercomp/Scp.hs 1961 - - +#endif hunk ./compiler/supercomp/Scp.hs 1963 +#if 0 hunk ./compiler/supercomp/Scp.hs 2125 - +#endif } [Let match return the remaining context if there is one. t-peterj@microsoft.com**20090816160000] { hunk ./compiler/supercomp/Scp.hs 724 - scpLog 4 "Renamings:" (ppr res) - let (n', in_fvs, (ts, es, vs)) = head res - in_scope = inSet env +-- scpLog 4 "Renamings:" (ppr res) +#if NEW_MATCH + tmpnam <- newName fun (exprType l') + let (n', in_fvs, ((ts, es, vs), newctxt)) = head res + restterm = plug newctxt (Var tmpnam) + scpLog 2 "Rest term:" (ppr restterm) +#else + let (n', in_fvs, ((ts, es, vs)) = head res +#endif + let in_scope = inSet env hunk ./compiler/supercomp/Scp.hs 744 +#if NEW_MATCH + restterm' <- drive env restterm emptyContext + let newexp' = substExpr (newExprSubst env tmpnam newexp) restterm' + return newexp' +#else hunk ./compiler/supercomp/Scp.hs 750 +#endif hunk ./compiler/supercomp/Scp.hs 757 +#if NEW_MATCH +renamings :: ScpEnv -> Store -> CoreExpr -> CoreExpr -> [(Var, [Var], (SubstEnv, Context))] +#else hunk ./compiler/supercomp/Scp.hs 761 +#endif hunk ./compiler/supercomp/Scp.hs 783 - p1 :: (RhoElement, CoreExpr) -> Maybe SubstEnv +-- p1 :: (RhoElement, CoreExpr) -> Maybe SubstEnv hunk ./compiler/supercomp/Scp.hs 787 - Just s <- renaming (headExp, restExp,[]) inFvs in_exp', + Just s@(_, EmptyCtxt) <- renaming (headExp, restExp,[]) inFvs in_exp', hunk ./compiler/supercomp/Scp.hs 794 - p2 :: RhoElement -> Maybe SubstEnv +-- p2 :: RhoElement -> Maybe SubstEnv hunk ./compiler/supercomp/Scp.hs 804 - fixup1 :: Maybe SubstEnv -> (RhoElement, CoreExpr) -> [(Var, [Var], SubstEnv)] +-- fixup1 :: Maybe SubstEnv -> (RhoElement, CoreExpr) -> [(Var, [Var], SubstEnv)] hunk ./compiler/supercomp/Scp.hs 807 - fixup2 :: Maybe SubstEnv -> RhoElement -> [(Var, [Var], SubstEnv)] +-- fixup2 :: Maybe SubstEnv -> RhoElement -> [(Var, [Var], SubstEnv)] hunk ./compiler/supercomp/Scp.hs 1613 - -> Maybe SubstEnv + -> Maybe (SubstEnv, Context) hunk ./compiler/supercomp/Scp.hs 1643 - = match (menv { me_env = nukeRnEnvR rn_env }) subst (e1, EmptyCtxt, []) (splitTerm e2') + , Just s@(subst', EmptyCtxt) <- match (menv { me_env = nukeRnEnvR rn_env }) subst (e1, EmptyCtxt, []) (splitTerm e2') = Just subst' hunk ./compiler/supercomp/Scp.hs 1655 -match_headexp menv subst (Lam x1 e1) (Lam x2 e2) = - match menv' subst (splitTerm e1) (splitTerm e2) - where +match_headexp menv subst (Lam x1 e1) (Lam x2 e2) + | Just (subst', EmptyCtxt) <- match menv' subst (splitTerm e1) (splitTerm e2) = + Just subst' + where hunk ./compiler/supercomp/Scp.hs 1669 -match_context :: MatchEnv -> SubstEnv -> Context -> Context -> Maybe SubstEnv +match_context :: MatchEnv -> SubstEnv -> Context -> Context -> Maybe (SubstEnv, Context) hunk ./compiler/supercomp/Scp.hs 1682 -match_context _ subst EmptyCtxt EmptyCtxt = Just subst +match_context _ subst EmptyCtxt c = Just (subst, c) hunk ./compiler/supercomp/Scp.hs 1685 - = do { subst' <- match menv subst (splitTerm e1) (splitTerm e2) - ; match_context menv subst' c1 c2 } + | Just (subst', EmptyCtxt) <- match menv subst (splitTerm e1) (splitTerm e2) + = match_context menv subst' c1 c2 hunk ./compiler/supercomp/Scp.hs 1767 - = do { subst1 <- match menv' subst (splitTerm r1) (splitTerm r2) - ; match_alts menv subst1 alts1 alts2 } + , Just (subst1, EmptyCtxt) <- match menv' subst (splitTerm r1) (splitTerm r2) + = match_alts menv subst1 alts1 alts2 hunk ./compiler/supercomp/Scp.hs 1789 -match_binds menv subst ((NonRec _ e1):t1)((NonRec _ e2):t2) = do - subst1 <- match menv subst (splitTerm e1) (splitTerm e2) +match_binds menv subst ((NonRec _ e1):t1)((NonRec _ e2):t2) + | Just (subst1, EmptyCtxt) <- match menv subst (splitTerm e1) (splitTerm e2) = do hunk ./compiler/supercomp/Scp.hs 1802 -match_exps menv subst (e1:t1) (e2:t2) = do - subst' <- match menv subst (splitTerm e1) (splitTerm e2) +match_exps menv subst (e1:t1) (e2:t2) + | Just (subst', EmptyCtxt) <- match menv subst (splitTerm e1) (splitTerm e2) = do } [Implement Simon's suggestion for the homemb testing. t-peterj@microsoft.com**20090817104159] { hunk ./compiler/supercomp/Scp.hs 731 - let (n', in_fvs, ((ts, es, vs)) = head res + let (n', in_fvs, (ts, es, vs)) = head res hunk ./compiler/supercomp/Scp.hs 1093 - p (RhoE {..}) = msize > compSize && isHomemb env (headExp, restExp, []) (e1, c1, []) && coreEqType (exprType compTerm) in_type -- YYY: UNSOUND + p (RhoE {..}) = msize > compSize && weakUnsoundEqExpr headExp e1 && isHomemb env (headExp, restExp, []) (e1, c1, []) && coreEqType (exprType compTerm) in_type -- YYY: UNSOUND hunk ./compiler/supercomp/Scp.hs 1100 - RhoE {..} <- (ls env), msize > compSize, + RhoE {..} <- (ls env), msize > compSize, + weakUnsoundEqExpr headExp e1, } [Generalise buildContext to take a context as top. t-peterj@microsoft.com**20090817135546] { hunk ./compiler/supercomp/Scp.hs 617 -buildContext :: [Context] -> Context -buildContext [] = EmptyCtxt -buildContext ((AppCtxt e _):[]) = AppCtxt e EmptyCtxt -buildContext ((PrimOpCtxt e oes ies _):[])= PrimOpCtxt e oes ies EmptyCtxt -buildContext ((CaseCtxt e _):[]) = CaseCtxt e EmptyCtxt -buildContext ((CastCtxt e _):[]) = CastCtxt e EmptyCtxt -buildContext ((AppCtxt e c):t) = AppCtxt e (buildContext t) -buildContext ((PrimOpCtxt e oes ies c):t)= PrimOpCtxt e oes ies (buildContext t) -buildContext ((CaseCtxt e c):t) = CaseCtxt e (buildContext t) -buildContext ((CastCtxt e c):t) = CastCtxt e (buildContext t) +buildContext :: [Context] -> Context -> Context +buildContext [] c1 = c1 +buildContext ((AppCtxt e _):[]) c1 = AppCtxt e c1 +buildContext ((PrimOpCtxt e oes ies _):[]) c1 = PrimOpCtxt e oes ies c1 +buildContext ((CaseCtxt e _):[]) c1 = CaseCtxt e c1 +buildContext ((CastCtxt e _):[]) c1 = CastCtxt e c1 +buildContext ((AppCtxt e c):t) c1 = AppCtxt e (buildContext t c1) +buildContext ((PrimOpCtxt e oes ies c):t) c1 = PrimOpCtxt e oes ies (buildContext t c1) +buildContext ((CaseCtxt e c):t) c1 = CaseCtxt e (buildContext t c1) +buildContext ((CastCtxt e c):t) c1 = CastCtxt e (buildContext t c1) hunk ./compiler/supercomp/Scp.hs 634 - let tp = plug (buildContext (reverse oc)) e1 + let tp = plug (buildContext (reverse oc) EmptyCtxt) e1 hunk ./compiler/supercomp/Scp.hs 640 - let tp = plug (buildContext (reverse oc)) e1 + let tp = plug (buildContext (reverse oc) EmptyCtxt) e1 hunk ./compiler/supercomp/Scp.hs 646 - let tp = plug (buildContext (reverse oc)) e1 + let tp = plug (buildContext (reverse oc) EmptyCtxt) e1 hunk ./compiler/supercomp/Scp.hs 652 - let tp = plug (buildContext (reverse oc)) e1 + let tp = plug (buildContext (reverse oc) EmptyCtxt) e1 } [Make the whistle distinguish constructors from variables. t-peterj@microsoft.com**20090817165046] { hunk ./compiler/supercomp/Scp.hs 1207 + | isJust conv1 && not (isJust conv2) || not (isJust conv1) && isJust conv2 = False hunk ./compiler/supercomp/Scp.hs 1212 + conv1 = isDataConId_maybe v1 + conv2 = isDataConId_maybe v2 } [Use env' instad of env for handling name shadowing. t-peterj@microsoft.com**20090818154116] { hunk ./compiler/supercomp/Scp.hs 296 - | collision = (env, Just (go env (mkSubst (inSet env) emptyVarEnv emptyVarEnv, []) bndrs)) + | collision = (env, Just (go env (mkSubst (inSet env') emptyVarEnv emptyVarEnv, []) bndrs)) hunk ./compiler/supercomp/Scp.hs 314 - | collision = (env, Just (go env (mkSubst (inSet env) emptyVarEnv emptyVarEnv, []) bndrs)) + | collision = (env, Just (go env (mkSubst (extendInScopeSetSet (inSet env) (getInScopeVars (funSet env'))) emptyVarEnv emptyVarEnv, []) bndrs)) } [Rip out the clever parts of TermParts and return a closed expression instead. Both simpler and faster. t-peterj@microsoft.com**20090818161746] { hunk ./compiler/supercomp/Scp.hs 432 - let newid = zapIdOccInfo (b `setIdUnfolding` NoUnfolding) - newbody = substExpr (newExprSubst env b (Var newid)) body hunk ./compiler/supercomp/Scp.hs 433 - body' <- drive env' newbody c + body' <- drive env' body c hunk ./compiler/supercomp/Scp.hs 734 - scpLog 2 "Folding" (ppr fun <+> ppr n') + scpLogDebug 2 "Folding" (ppr fun <+> ppr n') hunk ./compiler/supercomp/Scp.hs 1304 -msg env fun e = do - (e', p) <- msg' env fun e - let (_, _, v) = unzip3 p - tp = foldr plusTp emptyTp v +msg env fun e@(e1, e2) = do + let fvs = realFvs env e1 + (e', p) <- msg' env fun fvs e + let tp = foldr plusTp emptyTp p hunk ./compiler/supercomp/Scp.hs 1311 -msg' :: ScpEnv -> Id -> (CoreExpr, CoreExpr) -> ScpM s (CoreExpr, [([Var], [Var], TermParts)]) -msg' env _ (Var n1, Var n2) +msg' :: ScpEnv -> Id -> [Var] -> (CoreExpr, CoreExpr) -> ScpM s (CoreExpr, [TermParts]) +msg' env _ fvs1 (Var n1, Var n2) hunk ./compiler/supercomp/Scp.hs 1317 - n <- newName n1 (exprType (Var n1)) - return (Var n, [([n1], [n2], newTpExp env n (Var n1))]) -msg' env fun (l1@(Lam b1 e1), l2@(Lam b2 e2)) + let fvs2 = realFvs env (Var n1) + fvs1' = delete fvs1 fvs2 + n <- newName n1 (mkPiTypes fvs1' (exprType (Var n1))) + let (lterm, newterm) = (mkLams fvs1' (Var n1), mkVarApps (Var n) fvs1') + return (newterm, [newTpExp env n lterm]) +msg' env fun fvs (l1@(Lam b1 e1), l2@(Lam b2 e2)) hunk ./compiler/supercomp/Scp.hs 1325 - (e', p) <- msg' env' fun (e1, e2) - let ys = [ fv1 | (fv1, fv2, _) <- p, elem b1 fv1 || elem b2 fv2] - if not $ null ys - then do - let fv1 = varSetElems (exprFreeVars l1) - fv2 = varSetElems (exprFreeVars l2) - n <- newName fun (exprType l1) - return (Var n, [(fv1, fv2, newTpExp env n l1)]) - else return (Lam b1 e', p) -msg' env fun (App (Var n1) arg1, App (Var n2) arg2) - | n1 == n2 = do - (arg, p) <- msg' env fun (arg1, arg2) - return (App (Var n1) arg, p) -msg' env fun (App e1 arg1, App e2 arg2) = do - (e1', p1) <- msg' env fun (e1, e2) - (arg1', p2) <- msg' env fun (arg1, arg2) + (e', p) <- msg' env' fun fvs (e1, e2) + return (Lam b1 e', p) +-- msg' env fun fvs (App (Var n1) arg1, App (Var n2) arg2) -- XXXpj: Redundant +-- | n1 == n2 = do +-- (arg, p) <- msg' env fun fvs (arg1, arg2) +-- return (App (Var n1) arg, p) +msg' env fun fvs (App e1 arg1, App e2 arg2) = do + (e1', p1) <- msg' env fun fvs (e1, e2) + (arg1', p2) <- msg' env fun fvs (arg1, arg2) hunk ./compiler/supercomp/Scp.hs 1335 -msg' env fun (l1@(Let (NonRec b1 e1) body1), l2@(Let (NonRec b2 e2) body2)) = do +msg' env fun fvs (l1@(Let (NonRec b1 e1) body1), l2@(Let (NonRec b2 e2) body2)) = do hunk ./compiler/supercomp/Scp.hs 1337 - (e1', p1) <- msg' env' fun (e1, e2) - (body', p2) <- msg' env' fun (body1, body2) + (e1', p1) <- msg' env fun fvs (e1, e2) + (body', p2) <- msg' env' fun fvs (body1, body2) hunk ./compiler/supercomp/Scp.hs 1340 - ys = [ fv1 | (fv1, fv2, _) <- p, elem b1 fv1 || elem b2 fv2] - if not $ null ys - then do - let fv1 = varSetElems (exprFreeVars l1) - fv2 = varSetElems (exprFreeVars l2) - n <- newName fun (exprType l1) - return (Var n, [(fv1, fv2, newTpExp env n l1)]) - else return (Let (NonRec b1 e1') body', p) -msg' env fun (l1@(Let (Rec p1) body1), l2@(Let (Rec p2) body2)) + return (Let (NonRec b1 e1') body', p) +msg' env fun fvs (l1@(Let (Rec p1) body1), l2@(Let (Rec p2) body2)) hunk ./compiler/supercomp/Scp.hs 1344 - (es', p1) <- mapAndUnzipM (msg' env' fun) (zip es1 es2) - (body', p2) <- msg' env' fun (body1, body2) - let p = p2 ++ concat p1 - ys = [ fv1 | (fv1, fv2, _) <- p, - or ((map ((flip elem) fv1)) bs1) || - or ((map ((flip elem) fv2)) bs2) ] - if any (not . null) ys - then do - let fv1 = varSetElems . exprFreeVars $ l1 - fv2 = varSetElems . exprFreeVars $ l2 - n <- newName fun (exprType l1) - return (Var n, [(fv1, fv2, newTpExp env n l1)]) - else return (Let (Rec (zip bs1 es')) body', p2 ++ concat p1) + (es', p1) <- mapAndUnzipM (msg' env' fun fvs) (zip es1 es2) + (body', p2) <- msg' env' fun fvs (body1, body2) + return (Let (Rec (zip bs1 es')) body', p2 ++ concat p1) hunk ./compiler/supercomp/Scp.hs 1349 -msg' env fun (l1@(Case c1 b1 t1 alts1), l2@(Case c2 b2 t2 alts2)) +msg' env fun fvs (l1@(Case c1 b1 t1 alts1), l2@(Case c2 b2 t2 alts2)) hunk ./compiler/supercomp/Scp.hs 1352 - (c', p1) <- msg' env' fun (c1, c2) + (c', p1) <- msg' env fun fvs (c1, c2) hunk ./compiler/supercomp/Scp.hs 1355 - (es1', p2) <- mapAndUnzipM (\((_, bs1, e1), (_, _, e2)) -> msg' (env' {inSet = extendInScopeSetList (inSet env) bs1}) fun (e1, e2)) (zip alts1 alts2) - let ys = [ fv1 | p <- p2, (fv1, fv2, _) <- p, - elem b1 fv1 || elem b2 fv2 || - or ((map ((flip elem) fv1)) (concat bs1)) || - or ((map ((flip elem) fv2)) (concat bs2)) ] - if any (not . null) ys - then do - let fv1 = varSetElems . exprFreeVars $ l1 - fv2 = varSetElems . exprFreeVars $ l2 - n <- newName fun (exprType l1) - return (Var n, [(fv1, fv2, newTpExp env n l1)]) - else let alts1' = zip3 dc1 bs1 es1' - in return (Case c' b1 t1 alts1', p1 ++ concat p2) -msg' _ _ (Lit l1, Lit l2) | l1 == l2 = return (Lit l1, []) -msg' env fun (Cast e1 c1, Cast e2 c2) + (es1', p2) <- mapAndUnzipM (\((_, bs1, e1), (_, _, e2)) -> msg' (env' {inSet = extendInScopeSetList (inSet env) bs1}) fun fvs (e1, e2)) (zip alts1 alts2) + let alts1' = zip3 dc1 bs1 es1' + return (Case c' b1 t1 alts1', p1 ++ concat p2) +msg' _ _ _ (Lit l1, Lit l2) | l1 == l2 = return (Lit l1, []) +msg' env fun fvs (Cast e1 c1, Cast e2 c2) hunk ./compiler/supercomp/Scp.hs 1361 - (e, p) <- msg' env fun (e1, e2) + (e, p) <- msg' env fun fvs (e1, e2) hunk ./compiler/supercomp/Scp.hs 1363 -msg' env fun (l1@(Type t1), l2@(Type t2)) +msg' env fun fvs1 (l1@(Type t1), l2@(Type t2)) hunk ./compiler/supercomp/Scp.hs 1367 - n <- newName fun (exprType (Type t1)) + let fvs2 = realFvs env (Type t1) + fvs1' = delete fvs1 fvs2 + n <- newName fun (mkPiTypes fvs1' (exprType (Type t1))) hunk ./compiler/supercomp/Scp.hs 1374 - return (Type x', [(fv1, fv2, newTpType env x t1)]) -msg' env fun (Note n1 e1, Note n2 e2) + (lterm, newterm) = (mkLams fvs1' l1, mkVarApps (Type x') fvs1') + return (newterm, [newTpExp env x lterm]) +msg' env fun fvs (Note n1 e1, Note n2 e2) hunk ./compiler/supercomp/Scp.hs 1378 - (e, p) <- msg' env fun (e1, e2) + (e, p) <- msg' env fun fvs (e1, e2) hunk ./compiler/supercomp/Scp.hs 1380 -msg' env fun (e1, e2) = do - n <- newName fun (exprType e1) - let fv1 = varSetElems . exprFreeVars $ e1 - fv2 = varSetElems . exprFreeVars $ e2 - return (Var n, [(fv1, fv2, newTpExp env n e1)]) +msg' env fun fvs1 (e1, e2) = do + let fvs2 = realFvs env e1 + fvs1' = delete fvs1 fvs2 + n <- newName fun (mkPiTypes fvs1' (exprType e1)) + let (lterm, newterm) = (mkLams fvs1' e1, mkVarApps (Var n) fvs1') + return (newterm, [newTpExp env n lterm]) hunk ./compiler/supercomp/Scp.hs 1435 - where es = mkSubst (delInScopeSet (inSet env) id) emptyVarEnv emptyVarEnv + where es = mkSubst (inSet env) emptyVarEnv emptyVarEnv } [Make sure not to lose any terms when we rebuild expressions. t-peterj@microsoft.com**20090819083932] { hunk ./compiler/supercomp/Scp.hs 468 - build env (mkApps o (oes ++ ies')) c + build (env {hasH = False}) (mkApps o (oes ++ e:ies')) c hunk ./compiler/supercomp/Scp.hs 1372 - fv1 = varSetElems . exprFreeVars $ l1 - fv2 = varSetElems . exprFreeVars $ l2 } [Make sure realFvs counts predicates. t-peterj@microsoft.com**20090821085240] { hunk ./compiler/supercomp/Scp.hs 205 - (e', c2, bs') = splitTerm' e c1 +-- (e', c2, bs') = splitTerm' e c1 + (e', c2, bs') = go e c1 [] hunk ./compiler/supercomp/Scp.hs 518 - scpLog 2 "New function:" (ppr fname <+> ppr fvs <+> ppr fun + scpLogDebug 2 "New function:" (ppr fname <+> ppr fvs <+> ppr fun hunk ./compiler/supercomp/Scp.hs 1034 -realFvs'_type env (PredTy pt) = [] +realFvs'_type env (PredTy pt) = realFvs'_pred env pt + +realFvs'_pred :: ScpEnv -> PredType -> [Var] +realFvs'_pred env (IParam _ ty) = realFvs'_type env ty +realFvs'_pred env (ClassP _ tys) = concatMap (realFvs'_type env) tys +realFvs'_pred env (EqPred ty1 ty2) = realFvs'_type env ty1 ++ realFvs'_type env ty2 + hunk ./compiler/supercomp/Scp.hs 1396 --- snd3 :: (a, b, c) -> b --- snd3 (_, b, _) = b +snd3 :: (a, b, c) -> b +snd3 (_, b, _) = b } Context: [Add CHECK(p), like ASSERT(p) but works even when !defined(DEBUG) Simon Marlow **20090729075433 Ignore-this: a723f456e4b1eaeaa617a675da276aa2 For inexpensive assertions ] [enable the x86-specific versions of atomic_inc()/atomic_dec() Simon Marlow **20090729075307 Ignore-this: a271b7ade5502ec4d8444aac19f4b4c3 ] [fix warning Simon Marlow **20090728103855 Ignore-this: ee626aa5de0a2aed8f44ae1131cc341d ] [fix warning Simon Marlow **20090728102707 Ignore-this: ad4f07a163921d17d242a9452b4bb578 ] [fix a warning Simon Marlow **20090728101731 Ignore-this: 73ead0a0004723757c0a51b56681c991 ] [Be a bit more sensible about choosing external OccNames Simon Marlow **20090728100434 Ignore-this: 4adcd661e76440deb2b4ab498ebd2d1e Instead of chr_$wchr, we now just get $wchr. In general, when an OccName is system-generated, we leave it out of the final external name, preferring to use the name of the exported parent instead (which is necessarily a user-written name). Names should be no less deterministic, but should be shorter and more readable. ] [Remove old 'foreign import dotnet' code Simon Marlow **20090727144524 Ignore-this: 821ebea2c3897415195318f107421472 It still lives in darcs, if anyone wants to revive it sometime. ] [remove a couple of ToDos Simon Marlow **20090727094719 Ignore-this: ef00fc481821dff4381ba9efcd792708 ] [buildinfo files need a $$(wildcard) Simon Marlow **20090727091012 Ignore-this: b4c3201dfa81fef32ee254dd9c955b2d ] [Slight tweak to avoid overflowing the command-line size in bindist Simon Marlow **20090727090946 Ignore-this: 1e2ff207d03fed08576ac59f0b46c08c Not a real fix: if this bites us again we'll have to rethink ] [avoid (benign) error about overriding rules for binary-dist Simon Marlow **20090727090903 Ignore-this: ffb7f7bf1290f2faf96ac177f76a1422 ] [Give a better error message for hidden packages when building Cabal package Ian Lynagh **20090726194915 Fixes #3168 ] [Add a -fbuilding-cabal-package flag Ian Lynagh **20090726181934 This means GHC knows whether it's building a Cabal package, or just Haskell sources. For example, it may wish to give different error messages when building a Cabal package. ] [Add an extension to disable n+k patterns Ian Lynagh **20090725134703] [Fix a warning on Windows Ian Lynagh **20090724221244] [Remove GHC's haskell98 dependency Ian Lynagh **20090724210825] [add number of bytes to +RTS -DS leak reports Simon Marlow **20090724150010 Ignore-this: 3a66585c8fd2b58ce96abab1e154fb6e ] [free the gc_thread structures during shutdown Simon Marlow **20090724145956 Ignore-this: 25efeb189cbfb549af4550d266604f0e ] [Add atomic_inc()/atomic_dec(), and use them to replace gc_running_mutex Simon Marlow **20090724142620 Ignore-this: d775eeaf85fd0f9064d87a0909134bc0 This also fixes a memory leak on Windows with -threaded, because we were calling initMutex(&gc_running_mutex) for each GC, which allocates memory. ] [Rewrite the foreign import string parser using ReadP Simon Marlow **20090723152138 Ignore-this: 1c7db770a29d48710b05e2a3d216b2a8 And kill the duplicate one in HsSyn.Convert ] [point to the wiki Simon Marlow **20090723132345 Ignore-this: c11300bac62ce2f56d7fc271aa26dbcd ] [Remove note about avoiding use of #def in libraries Simon Marlow **20090723111026 Ignore-this: 8a027ed37b2d10094f7a31548aee2535 It should be safe to use now that we aren't relying on C prototypes for foreign functions in via-C code. ] [refactorings Simon Marlow **20090723091230 Ignore-this: 836feb0e819127603dd56623af6e48dc ] [Fix Trac #3391: make generic to/from bindings only for newly-declared types simonpj@microsoft.com**20090723155803 Ignore-this: bb56c2ec054397d421dce13d5eb6c73f Before this patch we were bogusly making to/from bindings for all data types in the TcGblEnv. But that is wrong when we have multiple "chunks" of bindings in Template Haskell. We should start from the declarations themselves. Easy. ] [Print explicit braces and semicolons in do-notation simonpj@microsoft.com**20090723152411 Ignore-this: a97ddf19774d27d15a01d63787708b20 By printing explicit braces we make it more likely that pretty-printed code will be acceptable if fed back into GHC. See http://www.haskell.org/pipermail/glasgow-haskell-users/2009-July/017554.html ] [Documentation for stand-alone deriving (Trac #3012) simonpj@microsoft.com**20090723132558 Ignore-this: 54445c5984594eb7f82151b2ac118695 ] [Windows only: set the encoding on stdin to utf8 Simon Marlow **20090723121913 Ignore-this: d65115d9711b5fb68e77786565ef6de Otherwise it defaults to latin1. ] [Fix Trac #3012: allow more free-wheeling in standalone deriving simonpj@microsoft.com**20090723130145 Ignore-this: 357580b9388ccbe1da3c1da3ba90e456 In standalone deriving, we now do *not* check side conditions. We simply generate the code and typecheck it. If there's a type error, it's the programmer's problem. This means that you can do 'deriving instance Show (T a)', where T is a GADT, for example, provided of course that the boilerplate code does in fact typecheck. I put some work into getting a decent error message. In particular if there's a type error in a method, GHC will show the entire code for that method (since, after all, the user did not write it). Most of the changes are to achieve that goal. Still to come: changes in the documentation. ] [Use the ErrMsg record type simonpj@microsoft.com**20090723130108 Ignore-this: 7fb6dd78d3185da0c33901b8aac8d108 ] [Stop generating redundant parens in 'deriving' code simonpj@microsoft.com**20090723125903 Ignore-this: 6fc82df9648a82bcf7bf6fdfa9b4dad3 This makes the code printed by -ddump-deriv look prettier ] [Wibble to printing tuple sections simonpj@microsoft.com**20090723125756 Ignore-this: af2a1b9784f6447fea0e11d454cf082f ] [Fix Trac #3193: improve line number reporting for equality constraints simonpj@microsoft.com**20090723065504 Ignore-this: b45a68071bcaca48cad7855dccb9c9eb When reporting an error from a failed equality constraint, we were setting the *context* but not the *line number* in TcTyFuns.eqInstMisMatch As a result, the line number didn't match the context at all. It's trivial to fix. I'm 99% certain this fixes #3193, but it's too complicated to reproduce, so I have not actually tested it. ] [Add fmapM_maybe :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b) simonpj@microsoft.com**20090723064932 Ignore-this: db5f6319b52a5e6b5f85d76985f2a7c9 This function isn't used at the moment, but Max added it, and it looks useful. ] [Add tuple sections as a new feature simonpj@microsoft.com**20090723063859 Ignore-this: d42a26fc1efff112b852b5c1135c1746 This patch adds tuple sections, so that (x,,z) means \y -> (x,y,z) Thanks for Max Bolinbroke for doing the hard work. In the end, instead of using two constructors in HsSyn, I used just one (still called ExplicitTuple) whose arguments can be Present (LHsExpr id) or Missing PostTcType While I was at it, I did a bit of refactoring too. ] [NetBSD defines _REENTRANT in its header files, so compiling ghc gives Simon Marlow **20090723075030 Ignore-this: 4722c4ff0541c6080de8f433e498684 redefinition warnings for all files that are including includes/Rts.h. Contributed by: Krister Walfridsson ] [includes/TSO.h: kill trailing whitespace Samuel Bronson **20090722170354 Ignore-this: 36d4afd1a21188d604ed6b432942dcdc ] [Say what StgTSOBlockInfo is for, where to read about it. Samuel Bronson **20090722163011 Ignore-this: 6c09e11f23594251cdc2db1bc642edc9 ] [Make the Integer library used directly configurable in GHC and base Ian Lynagh **20090722151048 Rather than indirecting through an integer package ] [Fix cleaning with the new integer changes Ian Lynagh **20090722142545] [Add integer-simple as a build option Ian Lynagh **20090722013137] [Tweak whitespace Ian Lynagh **20090719221303] [thenIO, bindIO, returnIO moved to GHC.Base Simon Marlow **20090722102219 Ignore-this: 5d6c5988e0abab2c5169540aa8ddedb9 ] [remove unused $(HscIfaceFileVersion) Simon Marlow **20090720145053 Ignore-this: d725cbbde3c68673e2342b370460d87f ] [Choose external names more predictably Simon Marlow **20090720144751 Ignore-this: 17513bc93af646108f21bbed1c8f4a3a Now, for a compiler-generated binding "x", if "x" is referred to by the exported "f", then it will be named "f_x" rather than something like "x23". This means that hopefully - compilation will more often product the same results given the same input (the choice of names is not dependent on the non-deterministic order of bindings within the compiler). - less recompilation will be necessary after making changes - navigating Core might be a bit easier. unfortunately, compilation with -O still does not consistently produce the same ABI. The simplifier sometimes does different things, apparently. Names will be longer, but I can't see a way around that. ] [Use stable ordering in the dependencies Simon Marlow **20090717123449 Ignore-this: e20bac233cf6f834e69c027ff60b5b50 Fixes another cause of wobbly interface files and unnecessary recompilation. ] [fall back on libffi for 'foreign import "wrapper"' if necessary Simon Marlow **20090716134549 Ignore-this: e1073e1ad77e720326865a6d3c4f3790 ] [Take account of GADTs when reporting patterm-match overlap simonpj@microsoft.com**20090722050933 Ignore-this: 7dcbdcb91021e83e6e6208a2e68c50c9 When matching against a GADT, some of the constructors may be impossible. For example data T a where T1 :: T Int T2 :: T Bool T3 :: T a f :: T Int -> Int f T1 = 3 f T3 = 4 Here, does not have any missing cases, despite omittting T2, because T2 :: T Bool. This patch teaches the overlap checker about GADTs, which happily turned out to be rather easy even though the overlap checker needs a serious rewrite. ] [Fix Trac #3382: desugaring of NPats simonpj@microsoft.com**20090720061226 Ignore-this: 4dccdaf2b7d6428141dcf174cb455a20 Max spotted that the short-cut rules for desugaring NPats (where we compare against a literal) were wrong now that we have overloaded strings. ] [Add a -fwarn-dodgy-exports flag; fixes #1911 Ian Lynagh **20090719200124 This is used to control warnings that were previously unconditional. ] [Build terminfo if we /aren't/ on Windows, not if we /are/ Ian Lynagh **20090719111709] [Change how PACKAGES is constructed, so that everything gets cleaned properly Ian Lynagh **20090718210058 If Windows wasn't defined properly then the Win32 package wasn't being cleaned, as it wasn't added to PACKAGES. Now we always add everything to PACKAGES when CLEANING=YES. ] [temporarily turn off unused import warnings for the time library Ian Lynagh **20090718183445] [Follow the split directory rename in the GHC build system rules Ian Lynagh **20090718155618] [Add osuf to the name we use for the split dir Ian Lynagh **20090718145522 This avoids a collision between the directories we use when compiling multiple ways, which in turn leads to a race condition in parallel builds. ] [Temporarily turn off unused-do-bind warnings for the time package Ian Lynagh **20090718134536] [Make ghc-cabal handle "Custom" Setup.hs files that have a configure script Ian Lynagh **20090718131555] [Add the time library, and support for libraries in tarballs Ian Lynagh **20090718121649] [Always serialise Int as 64bit values; fixes trac #3041 Ian Lynagh **20090717224203 This means that, provided the values are small enough, files serialized are portable between architectures. In particular, .haddock files are portable. ] [Remove some code that has always been commented out Ian Lynagh **20090717224100] [Fix Trac #3346: tcSimplify for LHS of RULES with type equalities simonpj@microsoft.com**20090717155722 Ignore-this: dfdd0f9a62d78d63276a4d558831099c ] [Allow mixed case in the LINE pragma; patch from squadette; fixes #1817 Ian Lynagh **20090717133522] [Comment only simonpj@microsoft.com**20090717120154 Ignore-this: f96b11e602fe4b311c1e466af9aa1908 ] [Add missing case for eq_note. t-peterj@microsoft.com**20090624134407] [Rename parameters to make debugging code compile. t-peterj@microsoft.com**20090626105440] [Comment fix: use the same variable names in the conclusion as in the premise. t-peterj@microsoft.com**20090618092235] [Typo fixes, from Alexey Mahotkin Ian Lynagh **20090717010817] [Use names like '$fOrdInt' for dfuns (and TF instances), rather than '$f21' Simon Marlow **20090716125643 Ignore-this: d0b4632cf8ed9e05b67a19aa19ab3e19 2 reasons for this: - compilation is more predictable. Adding or removing an instance is less likely to force unnecessary recompilation due to renumbering other dfun names. - it makes it easier to read Core / C-- / asm The names aren't completely deterministic. To do that, we'd have to include package and module names, which would make the symbol names long and reduce readability. So the compromise is that if there's a clash, we disambiguate by adding an integer suffix. This is fairly unlikely in practice unless you're using overlapping instances. Type family instances are handled in the same way, with the same disambiguation strategy. ] [Use a stable ordering for the export list in the interface Simon Marlow **20090716122601 Ignore-this: 847dd7adc8b52e56f28d2478c78c925 The export list was ordered according to the whim of FastStrings, which meant that interface fingerprints could change for no good reason, causing spurious recompilation. ] [Don't put all of $CFLAGS into $SRC_CC_OPTS Ian Lynagh **20090716131309 Instead, we just put the flags we need in there (e.g. -m64 on OS X 64). This fixes a problem found by Simon M, where we were compiling everything with -g, leading to a bloated RTS. ] [Move showOpt into DynFlags Ian Lynagh **20090716005314] [Make the --info values printable with "ghc --print-foo"; trac #3122 Ian Lynagh **20090716001718 Also, libdir is now part of the --info output, so this subsumes the old --print-libdir flag. The mode parsing was getting rather adhoc, so I've tidied it up a bit in the process. ] [whitespace only Simon Marlow **20090716104217 Ignore-this: 38cff291d9ef15c30e3ed685ffc3c9f9 ] [refactor: use packageConfigId in place of mkPackageId . package Simon Marlow **20090716104145 Ignore-this: f3d73e7bd1b307a67d26585c49f3d89f ] [Fix a flag name in the docs Ian Lynagh **20090714165943] [Add the -fno-shared-implib flag Ian Lynagh **20090714165631 Patch from Max Bolingbroke Rerecorded to avoid conflicts. ] [Derived Foldable instances should use Data.Foldable.foldr m.niloc@gmail.com**20090711130647 Ignore-this: e3eb841e9535a842a98bb1ae0532c6e8 ] [remove Solaris-specific hacks, now unnecessary Simon Marlow **20090713083524 Ignore-this: 500077008e463532e0677ee82f5284bb ] [Simplify timestamp restoration Matthias Kilian **20090711100244 Ignore-this: 7eaede224befa6b5368c91b92366211 ] [FIX #3272 Manuel M T Chakravarty **20090714054559 Ignore-this: 225fe4d82d4eed02e9b1377687661bac ] [Fix warnings Roman Leshchinskiy **20090713092032 Ignore-this: 3631b87164fc54d82e3a02875dc08f7d ] [Separate length from data in DPH arrays Roman Leshchinskiy **20090713044212 Ignore-this: aa2cc3b5ae43bd2c493ce4b330c883cd ] [Stop using -fno-warn-unused-do-bind when compiling the libraries Ian Lynagh **20090709160422 They're now fixed to not generate those warnings ] [Remove maybePrefixMatch, using stripPrefix instead Ian Lynagh **20090709160412 We already require GHC 6.8 to build, and that included stripPrefix in Data.List. ] [TFs: FIX #2203 (second half) Manuel M T Chakravarty **20090710064834 Ignore-this: 46a46feaa73f74feb08524b9e7547414 ] [TFs: Fix should_compile/Simple8 Manuel M T Chakravarty **20090710042728 Ignore-this: 471ab67e3df1c5245921be5286a45f93 ] [workaround new Cygwin bash CRLF behaviour Simon Marlow **20090709132850 Ignore-this: 5cfa2cc9d776ebe315c0f6ad7ab56d98 ] [Use /usr/bin/test if it exists, and fix test syntax. Simon Marlow **20090709124616 Ignore-this: 83a75ba7c3ce2a1d02bddb7bfe414bfe Should fix Solaris build failures ] [Allow mixed case pragmas; #1817. Patch from squadette Ian Lynagh **20090709153737 This patch allow you to use "Language CPP", or even "LaNgUaGe CPP", if you wish, as the manual claims you can. ] [don't create inplace/bin/ghc- Simon Marlow **20090706092031 Ignore-this: 2584d7bf56e77b27ca5b7b557c152c5e ] [Fix ignored-monadic-result warnings Ian Lynagh **20090707181857] [Fix an unused import warning Ian Lynagh **20090707144706] [Fix unused import warnings Ian Lynagh **20090707143216] [Fix unused import warnings Ian Lynagh **20090707133537] [When exporting F(..), all the children of F are also exported Ian Lynagh **20090707133427 This fixes the unused imports warning when Foo (F(x,y,z)) is imported and Foo (F(..)) is exported. ] [Remove unused imports Ian Lynagh **20090707121548] [Major patch to fix reporting of unused imports simonpj@microsoft.com**20090706112503 Ignore-this: 3b5ecdd880474493d73bdbdc0fa0b782 This patch, joint work between and Ian and Simon, fixes Trac #1074 by reporting unused import declarations much more accuratly than before. The specification is described at http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/UnusedImports The implementation is both easier to understand than before, and shorter too. Also fixed are #1148, #2267 Also fixed is -ddump-minimal imports, which now works properly, fixing Trac #1792. ] [Trim unused imports detected by new unused-import code simonpj@microsoft.com**20090706112201 Ignore-this: c6ca46d3a750c1cd1d58ea2c0de9f14f ] [Avoid unnecessary recompilation after ./configure (helps #3228) Simon Marlow **20090707085040 Ignore-this: f8b3e7a2a96bc23cd29505ab9c8dbd7d We cache the old versions of files generated by configure, so that if configure touches the file without changing it, we can detect that and restore the timestamp. ] [check for tabs in compiler/ghc.cabal.in (#3344) Simon Marlow **20090707081845 Ignore-this: 6073db47eafd52e13e76c58ef738afcf ] [remove tabs Simon Marlow **20090707081823 Ignore-this: 3d65831fc019f76cefac03291904842a ] [fix cleaning of libraries (now 'make clean' in libraries/* works again) Simon Marlow **20090703114638 Ignore-this: b3af731d50ff5bfbd453f94aa40cb92c ] [FIX #2677 Manuel M T Chakravarty **20090707055442 Ignore-this: e224dd09d0d1c9ec4f3b46c7accb8d57 ] [Update driver/Makefile for the new build system Ian Lynagh **20090705204041] [Fix generational GC bug (#3348) Simon Marlow **20090706112227 Ignore-this: 5938338efa0ad1550968c664a5a76f31 ] [Windows fixes to build system: use the 'find' and 'sort' found by configure simonpj@microsoft.com**20090706103413 Ignore-this: a96197917f388a637118bafefb427495 The build system should use 'find' and 'sort' that are discovered by configure, not the ones in your path. On Windows the ones in your path might well be the non-Unixy Windows versions. This patch fixes the ones I tripped over. There may be more. ] [Follow Cabal changes Ian Lynagh **20090705180414] [Update TODO list Ian Lynagh **20090705165009] [Make -fext-core a dynamic flag (it was a static flag) Ian Lynagh **20090705132420] [Update a few points about shared libs in other sections Duncan Coutts **20090704212212 And add links to the new shared libs section. ] [Document -dynload flag. Also add it and -shared to the flags reference. Duncan Coutts **20090704212119] [Add new section on using shared libs Duncan Coutts **20090704212003] [Document foreign import prim in the user guide Duncan Coutts **20090704180547 Basically just stat that it exists and refer to the ghc dev wiki for the details, because we don't really want people using it. ] [For now, use -fno-warn-unused-do-bind when building the libraries Ian Lynagh **20090704210654] [Make changes to -fwarn-unused-do-bind and -fwarn-wrong-do-bind suggested by SPJ Max Bolingbroke **20090702150943 Ignore-this: 595368298d2e11623c0bd280ff89d8de ] [Support for -fwarn-unused-do-bind and -fwarn-wrong-do-bind, as per #3263 Max Bolingbroke **20090701200344 Ignore-this: 511117ffc10d4b656e530b751559b8b8 ] [Improved infrastructure for fast-rebuilding of parts of the tree Simon Marlow **20090703074527 Ignore-this: ab348d0988d8bbc28c2b4babbd6bbfb8 e.g. cd compiler make FAST=YES stage1/build/HscTypes.o builds just the specified .o file, without rebuilding dependencies, and omitting some of the makefile phases. FAST=YES works anywhere, to omit depenencies and phases. 'make fast' is shorthand for 'make all FAST=YES'. ] [Fix Trac #3342: missed zonking in TcHsSyn simonpj@microsoft.com**20090702124331 Ignore-this: 9b97b2142dfc665b503f59df7c55dd17 The type in a ViewPat wasn't being zonked. Easily fixed. ] [Type synonym families may be nullary Manuel M T Chakravarty **20090702084826 Ignore-this: bcfe6ed62c901206daf5a5088890bbea ] [New syntax for GADT-style record declarations, and associated refactoring simonpj@microsoft.com**20090702094657 Ignore-this: bd9817230d3773b3b01fae3d7f04c57d The main purpose of this patch is to fix Trac #3306, by fleshing out the syntax for GADT-style record declraations so that you have a context in the type. The new form is data T a where MkT :: forall a. Eq a => { x,y :: !a } -> T a See discussion on the Trac ticket. The old form is still allowed, but give a deprecation warning. When we remove the old form we'll also get rid of the one reduce/reduce error in the grammar. Hurrah! While I was at it, I failed as usual to resist the temptation to do lots of refactoring. The parsing of data/type declarations is now much simpler and more uniform. Less code, less chance of errors, and more functionality. Took longer than I planned, though. ConDecl has record syntax, but it was not being used consistently, so I pushed that through the compiler. ] [White space only simonpj@microsoft.com**20090702094627 Ignore-this: 19f654cbf371c8dcc6517fd4934855b4 ] [Comments only simonpj@microsoft.com**20090702094531 Ignore-this: 384fc2729c7c50a1680775a1f9ff89e4 ] [Look through Notes when matching simonpj@microsoft.com**20090702094444 Ignore-this: 7daea81e905ec6061d3e0fd588d7e61b ] [FIX #3197 Manuel M T Chakravarty **20090702070905 Ignore-this: ebf829f0ae025e82bccdfa4345828ffe ] [Fix #2197 (properly this time) Simon Marlow **20090701122354 Ignore-this: 39b6e4b0bcdd8c2f4660f976b7db768d $ ./inplace/bin/ghc-stage2 --interactive GHCi, version 6.11.20090701: http://www.haskell.org/ghc/ :? for help ghc-stage2: GHCi cannot be used when compiled with -prof [1] 32473 exit 1 ./inplace/bin/ghc-stage2 --interactive ] [make GhcProfiled work, and add a "prof" flavour to build.mk Simon Marlow **20090701114211 Ignore-this: 386d347e4ad8b6c2bd40a2ba7da31ba6 Building a profiled GHC is as simple as adding GhcLibWays += p GhcProfiled = YES to your build.mk and saying 'make'. Then you have a profiled inplace/bin/ghc-stage2. ] [remove unnecessary $(RM)s Simon Marlow **20090701110609 Ignore-this: f326ec8931d0d484a66b67ce1270cc6e ] ['make html' in a library builds the Haddock docs Simon Marlow **20090630111137 Ignore-this: 781bf10e2d4bca23b7f70c6f0465d120 ] [fix GC bug introduced with the C finalizer support Simon Marlow **20090630080834 Ignore-this: 3567e3adb5ae4a5dcbce81733487f348 ] [Add a configure test for whether or not __mingw_vfprintf exists Ian Lynagh **20090627150501] [Fix #3319, and do various tidyups at the same time Simon Marlow **20090626095421 Ignore-this: ea54175f6bd49e101d7b33392764f643 - converting a THSyn FFI declaration to HsDecl was broken; fixed - pretty-printing of FFI declarations was variously bogus; fixed - there was an unused "library" field in CImport; removed ] [rename cache variable to keep recent autoconfs happy Ross Paterson **20090626131410 Ignore-this: 187091bbe78f2b14402162acfb98180f ] [TAG 2009-06-25 Ian Lynagh **20090625155528] Patch bundle hash: ad417828094cfa63fe49437fcfaeefb294c44ab7