Commit 8287e232 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Some refactoring of SpecConstr

This was originally to improve the case when SpecConstr generated a
function with an unused argument (see Trac #4941), but I ended up
giving up on that.  But the refactoring is still an improvement.

In particular I got rid of BothOcc, which was unused.
parent 46ff3d8c
...@@ -63,7 +63,6 @@ import Data.List ...@@ -63,7 +63,6 @@ import Data.List
#ifndef GHCI #ifndef GHCI
type SpecConstrAnnotation = () type SpecConstrAnnotation = ()
#else #else
import Literal ( literalType )
import TyCon ( TyCon ) import TyCon ( TyCon )
import GHC.Exts( SpecConstrAnnotation(..) ) import GHC.Exts( SpecConstrAnnotation(..) )
#endif #endif
...@@ -500,7 +499,7 @@ this doesn't look like a specialisable call. ...@@ -500,7 +499,7 @@ this doesn't look like a specialisable call.
Note [NoSpecConstr] Note [NoSpecConstr]
~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~
The ignoreAltCon stuff allows you to say The ignoreDataCon stuff allows you to say
{-# ANN type T NoSpecConstr #-} {-# ANN type T NoSpecConstr #-}
to mean "don't specialise on arguments of this type. It was added to mean "don't specialise on arguments of this type. It was added
before we had ForceSpecConstr. Lacking ForceSpecConstr we specialised before we had ForceSpecConstr. Lacking ForceSpecConstr we specialised
...@@ -782,18 +781,16 @@ decreaseSpecCount env n_specs ...@@ -782,18 +781,16 @@ decreaseSpecCount env n_specs
--------------------------------------------------- ---------------------------------------------------
-- See Note [SpecConstrAnnotation] -- See Note [SpecConstrAnnotation]
ignoreType :: ScEnv -> Type -> Bool ignoreType :: ScEnv -> Type -> Bool
ignoreAltCon :: ScEnv -> AltCon -> Bool ignoreDataCon :: ScEnv -> DataCon -> Bool
forceSpecBndr :: ScEnv -> Var -> Bool forceSpecBndr :: ScEnv -> Var -> Bool
#ifndef GHCI #ifndef GHCI
ignoreType _ _ = False ignoreType _ _ = False
ignoreAltCon _ _ = False ignoreDataCon _ _ = False
forceSpecBndr _ _ = False forceSpecBndr _ _ = False
#else /* GHCI */ #else /* GHCI */
ignoreAltCon env (DataAlt dc) = ignoreTyCon env (dataConTyCon dc) ignoreDataCon env dc = ignoreTyCon env (dataConTyCon dc)
ignoreAltCon env (LitAlt lit) = ignoreType env (literalType lit)
ignoreAltCon _ DEFAULT = panic "ignoreAltCon" -- DEFAULT cannot be in a ConVal
ignoreType env ty ignoreType env ty
= case splitTyConApp_maybe ty of = case splitTyConApp_maybe ty of
...@@ -900,11 +897,6 @@ combineUsages :: [ScUsage] -> ScUsage ...@@ -900,11 +897,6 @@ combineUsages :: [ScUsage] -> ScUsage
combineUsages [] = nullUsage combineUsages [] = nullUsage
combineUsages us = foldr1 combineUsage us combineUsages us = foldr1 combineUsage us
lookupOcc :: ScUsage -> OutVar -> (ScUsage, ArgOcc)
lookupOcc (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndr
= (SCU {scu_calls = sc_calls, scu_occs = delVarEnv sc_occs bndr},
lookupVarEnv sc_occs bndr `orElse` NoOcc)
lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc]) lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])
lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs
= (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs}, = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},
...@@ -913,12 +905,13 @@ lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs ...@@ -913,12 +905,13 @@ lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs
data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument
| UnkOcc -- Used in some unknown way | UnkOcc -- Used in some unknown way
| ScrutOcc (UniqFM [ArgOcc]) -- See Note [ScrutOcc] | ScrutOcc -- See Note [ScrutOcc]
(DataConEnv [ArgOcc]) -- How the sub-components are used
| BothOcc -- Definitely taken apart, *and* perhaps used in some other way
{- Note [ScrutOcc] type DataConEnv a = UniqFM a -- Keyed by DataCon
{- Note [ScrutOcc]
~~~~~~~~~~~~~~~~~~~
An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing, An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
is *only* taken apart or applied. is *only* taken apart or applied.
...@@ -938,9 +931,11 @@ A pattern binds b, x::a, y::b, z::b->a, but not 'a'! ...@@ -938,9 +931,11 @@ A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
instance Outputable ArgOcc where instance Outputable ArgOcc where
ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs
ppr UnkOcc = ptext (sLit "unk-occ") ppr UnkOcc = ptext (sLit "unk-occ")
ppr BothOcc = ptext (sLit "both-occ")
ppr NoOcc = ptext (sLit "no-occ") ppr NoOcc = ptext (sLit "no-occ")
evalScrutOcc :: ArgOcc
evalScrutOcc = ScrutOcc emptyUFM
-- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
-- that if the thing is scrutinised anywhere then we get to see that -- that if the thing is scrutinised anywhere then we get to see that
-- in the overall result, even if it's also used in a boxed way -- in the overall result, even if it's also used in a boxed way
...@@ -949,10 +944,9 @@ combineOcc :: ArgOcc -> ArgOcc -> ArgOcc ...@@ -949,10 +944,9 @@ combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
combineOcc NoOcc occ = occ combineOcc NoOcc occ = occ
combineOcc occ NoOcc = occ combineOcc occ NoOcc = occ
combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys) combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
combineOcc _occ (ScrutOcc ys) = ScrutOcc ys combineOcc UnkOcc (ScrutOcc ys) = ScrutOcc ys
combineOcc (ScrutOcc xs) _occ = ScrutOcc xs combineOcc (ScrutOcc xs) UnkOcc = ScrutOcc xs
combineOcc UnkOcc UnkOcc = UnkOcc combineOcc UnkOcc UnkOcc = UnkOcc
combineOcc _ _ = BothOcc
combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc] combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
...@@ -967,16 +961,6 @@ setScrutOcc env usg (Var v) occ ...@@ -967,16 +961,6 @@ setScrutOcc env usg (Var v) occ
| otherwise = usg | otherwise = usg
setScrutOcc _env usg _other _occ -- Catch-all setScrutOcc _env usg _other _occ -- Catch-all
= usg = usg
conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
-- Find usage of components of data con; returns [UnkOcc...] if unknown
-- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case
conArgOccs (ScrutOcc fm) (DataAlt dc)
| Just pat_arg_occs <- lookupUFM fm dc
= [UnkOcc | _ <- dataConUnivTyVars dc] ++ pat_arg_occs
conArgOccs _other _con = repeat UnkOcc
\end{code} \end{code}
%************************************************************************ %************************************************************************
...@@ -1031,25 +1015,24 @@ scExpr' env (Case scrut b ty alts) ...@@ -1031,25 +1015,24 @@ scExpr' env (Case scrut b ty alts)
; (alt_usgs, alt_occs, alts') ; (alt_usgs, alt_occs, alts')
<- mapAndUnzip3M (sc_alt alt_env scrut' b') alts <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts
; let (alt_usg, b_occ) = lookupOcc (combineUsages alt_usgs) b' ; let scrut_occ = foldr1 combineOcc alt_occs -- Never empty
scrut_occ = foldr combineOcc b_occ alt_occs scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ
scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ
-- The combined usage of the scrutinee is given -- The combined usage of the scrutinee is given
-- by scrut_occ, which is passed to scScrut, which -- by scrut_occ, which is passed to scScrut, which
-- in turn treats a bare-variable scrutinee specially -- in turn treats a bare-variable scrutinee specially
; return (alt_usg `combineUsage` scrut_usg', ; return (foldr combineUsage scrut_usg' alt_usgs,
Case scrut' b' (scSubstTy env ty) alts') } Case scrut' b' (scSubstTy env ty) alts') }
sc_alt env scrut' b' (con,bs,rhs) sc_alt env scrut' b' (con,bs,rhs)
= do { let (env1, bs1) = extendBndrsWith RecArg env bs = do { let (env1, bs1) = extendBndrsWith RecArg env bs
(env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1 (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1
; (usg,rhs') <- scExpr env2 rhs ; (usg, rhs') <- scExpr env2 rhs
; let (usg', arg_occs) = lookupOccs usg bs2 ; let (usg', b_occ:arg_occs) = lookupOccs usg (b':bs2)
scrut_occ = case con of scrut_occ = case con of
DataAlt dc -> ScrutOcc (unitUFM dc arg_occs) DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
_ -> ScrutOcc emptyUFM _ -> ScrutOcc emptyUFM
; return (usg', scrut_occ, (con, bs2, rhs')) } ; return (usg', b_occ `combineOcc` scrut_occ, (con, bs2, rhs')) }
scExpr' env (Let (NonRec bndr rhs) body) scExpr' env (Let (NonRec bndr rhs) body)
| isTyCoVar bndr -- Type-lets may be created by doBeta | isTyCoVar bndr -- Type-lets may be created by doBeta
...@@ -1074,7 +1057,7 @@ scExpr' env (Let (NonRec bndr rhs) body) ...@@ -1074,7 +1057,7 @@ scExpr' env (Let (NonRec bndr rhs) body)
(SI [] 0 (Just rhs_usg)) (SI [] 0 (Just rhs_usg))
; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' } ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
`combineUsage` spec_usg, `combineUsage` rhs_usg `combineUsage` spec_usg,
mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body') mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body')
} }
...@@ -1094,12 +1077,13 @@ scExpr' env (Let (Rec prs) body) ...@@ -1094,12 +1077,13 @@ scExpr' env (Let (Rec prs) body)
; (spec_usg, specs) <- specLoop (scForce rhs_env2 force_spec) ; (spec_usg, specs) <- specLoop (scForce rhs_env2 force_spec)
(scu_calls body_usg) rhs_infos nullUsage (scu_calls body_usg) rhs_infos nullUsage
[SI [] 0 (Just usg) | usg <- rhs_usgs] [SI [] 0 (Just usg) | usg <- rhs_usgs]
-- Do not unconditionally use rhs_usgs. -- Do not unconditionally generate specialisations from rhs_usgs
-- Instead use them only if we find an unspecialised call -- Instead use them only if we find an unspecialised call
-- See Note [Local recursive groups] -- See Note [Local recursive groups]
; let all_usg = spec_usg `combineUsage` body_usg ; let rhs_usg = combineUsages rhs_usgs
bind' = Rec (concat (zipWith specInfoBinds rhs_infos specs)) all_usg = spec_usg `combineUsage` rhs_usg `combineUsage` body_usg
bind' = Rec (concat (zipWith specInfoBinds rhs_infos specs))
; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' }, ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
Let bind' body') } Let bind' body') }
...@@ -1134,15 +1118,8 @@ scApp env (Var fn, args) -- Function is a variable ...@@ -1134,15 +1118,8 @@ scApp env (Var fn, args) -- Function is a variable
fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args') fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')
-- Do beta-reduction and try again -- Do beta-reduction and try again
Var fn' -> return (arg_usg `combineUsage` fn_usg, mkApps (Var fn') args') Var fn' -> return (arg_usg `combineUsage` mk_fn_usg fn' args',
where mkApps (Var fn') args')
fn_usg = case lookupHowBound env fn' of
Just RecFun -> SCU { scu_calls = unitVarEnv fn' [(sc_vals env, args')],
scu_occs = emptyVarEnv }
Just RecArg -> SCU { scu_calls = emptyVarEnv,
scu_occs = unitVarEnv fn' (ScrutOcc emptyUFM) }
Nothing -> nullUsage
other_fn' -> return (arg_usg, mkApps other_fn' args') } other_fn' -> return (arg_usg, mkApps other_fn' args') }
-- NB: doing this ignores any usage info from the substituted -- NB: doing this ignores any usage info from the substituted
...@@ -1154,6 +1131,14 @@ scApp env (Var fn, args) -- Function is a variable ...@@ -1154,6 +1131,14 @@ scApp env (Var fn, args) -- Function is a variable
doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args) doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
doBeta fn args = mkApps fn args doBeta fn args = mkApps fn args
mk_fn_usg fn' args'
= case lookupHowBound env fn' of
Just RecFun -> SCU { scu_calls = unitVarEnv fn' [(sc_vals env, args')]
, scu_occs = emptyVarEnv }
Just RecArg -> SCU { scu_calls = emptyVarEnv
, scu_occs = unitVarEnv fn' evalScrutOcc }
Nothing -> nullUsage
-- The function is almost always a variable, but not always. -- The function is almost always a variable, but not always.
-- In particular, if this pass follows float-in, -- In particular, if this pass follows float-in,
-- which it may, we can get -- which it may, we can get
...@@ -1215,7 +1200,10 @@ scRecRhs env (bndr,rhs) ...@@ -1215,7 +1200,10 @@ scRecRhs env (bndr,rhs)
specInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)] specInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]
specInfoBinds (RI fn new_rhs _ _ _) (SI specs _ _) specInfoBinds (RI fn new_rhs _ _ _) (SI specs _ _)
= [(id,rhs) | OS _ _ id rhs <- specs] ++ = [(id,rhs) | OS _ _ id rhs <- specs] ++
-- First the specialised bindings
[(fn `addIdSpecialisations` rules, new_rhs)] [(fn `addIdSpecialisations` rules, new_rhs)]
-- And now the original binding
where where
rules = [r | OS _ r _ _ <- specs] rules = [r | OS _ r _ _ <- specs]
...@@ -1262,6 +1250,7 @@ specLoop :: ScEnv ...@@ -1262,6 +1250,7 @@ specLoop :: ScEnv
-> [RhsInfo] -> [RhsInfo]
-> ScUsage -> [SpecInfo] -- One per binder; acccumulating parameter -> ScUsage -> [SpecInfo] -- One per binder; acccumulating parameter
-> UniqSM (ScUsage, [SpecInfo]) -- ...ditto... -> UniqSM (ScUsage, [SpecInfo]) -- ...ditto...
specLoop env all_calls rhs_infos usg_so_far specs_so_far specLoop env all_calls rhs_infos usg_so_far specs_so_far
= do { specs_w_usg <- zipWithM (specialise env all_calls) rhs_infos specs_so_far = do { specs_w_usg <- zipWithM (specialise env all_calls) rhs_infos specs_so_far
; let (new_usg_s, all_specs) = unzip specs_w_usg ; let (new_usg_s, all_specs) = unzip specs_w_usg
...@@ -1280,6 +1269,9 @@ specialise ...@@ -1280,6 +1269,9 @@ specialise
-> SpecInfo -- Original RHS plus patterns dealt with -> SpecInfo -- Original RHS plus patterns dealt with
-> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage -> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage
-- Note: this only generates *specialised* bindings
-- The original binding is added by specInfoBinds
--
-- Note: the rhs here is the optimised version of the original rhs -- Note: the rhs here is the optimised version of the original rhs
-- So when we make a specialised copy of the RHS, we're starting -- So when we make a specialised copy of the RHS, we're starting
-- from an RHS whose nested functions have been optimised already. -- from an RHS whose nested functions have been optimised already.
...@@ -1479,7 +1471,6 @@ they are constructor applications. ...@@ -1479,7 +1471,6 @@ they are constructor applications.
\begin{code} \begin{code}
type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments
callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat]) callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat])
-- Result has no duplicate patterns, -- Result has no duplicate patterns,
-- nor ones mentioned in done_pats -- nor ones mentioned in done_pats
...@@ -1487,7 +1478,7 @@ callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPa ...@@ -1487,7 +1478,7 @@ callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPa
callsToPats env done_specs bndr_occs calls callsToPats env done_specs bndr_occs calls
= do { mb_pats <- mapM (callToPats env bndr_occs) calls = do { mb_pats <- mapM (callToPats env bndr_occs) calls
; let good_pats :: [([Var], [CoreArg])] ; let good_pats :: [CallPat]
good_pats = catMaybes mb_pats good_pats = catMaybes mb_pats
done_pats = [p | OS p _ _ _ <- done_specs] done_pats = [p | OS p _ _ _ <- done_specs]
is_done p = any (samePat p) done_pats is_done p = any (samePat p) done_pats
...@@ -1505,9 +1496,8 @@ callToPats env bndr_occs (con_env, args) ...@@ -1505,9 +1496,8 @@ callToPats env bndr_occs (con_env, args)
= return Nothing = return Nothing
| otherwise | otherwise
= do { let in_scope = substInScope (sc_subst env) = do { let in_scope = substInScope (sc_subst env)
; prs <- argsToPats env in_scope con_env (args `zip` bndr_occs) ; (interesting, pats) <- argsToPats env in_scope con_env args bndr_occs
; let (interesting_s, pats) = unzip prs ; let pat_fvs = varSetElems (exprsFreeVars pats)
pat_fvs = varSetElems (exprsFreeVars pats)
qvars = filterOut (`elemInScopeSet` in_scope) pat_fvs qvars = filterOut (`elemInScopeSet` in_scope) pat_fvs
-- Quantify over variables that are not in sccpe -- Quantify over variables that are not in sccpe
-- at the call site -- at the call site
...@@ -1519,7 +1509,7 @@ callToPats env bndr_occs (con_env, args) ...@@ -1519,7 +1509,7 @@ callToPats env bndr_occs (con_env, args)
-- variable may mention a type variable -- variable may mention a type variable
; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $ ; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $
if or interesting_s if interesting
then return (Just (qvars', pats)) then return (Just (qvars', pats))
else return Nothing } else return Nothing }
...@@ -1535,9 +1525,10 @@ argToPat :: ScEnv ...@@ -1535,9 +1525,10 @@ argToPat :: ScEnv
-> CoreArg -- A call arg (or component thereof) -> CoreArg -- A call arg (or component thereof)
-> ArgOcc -> ArgOcc
-> UniqSM (Bool, CoreArg) -> UniqSM (Bool, CoreArg)
-- Returns (interesting, pat), -- Returns (interesting, pat),
-- where pat is the pattern derived from the argument -- where pat is the pattern derived from the argument
-- intersting=True if the pattern is non-trivial (not a variable or type) -- interesting=True if the pattern is non-trivial (not a variable or type)
-- E.g. x:xs --> (True, x:xs) -- E.g. x:xs --> (True, x:xs)
-- f xs --> (False, w) where w is a fresh wildcard -- f xs --> (False, w) where w is a fresh wildcard
-- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard -- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard
...@@ -1605,26 +1596,25 @@ argToPat in_scope val_env arg arg_occ ...@@ -1605,26 +1596,25 @@ argToPat in_scope val_env arg arg_occ
-- Check for a constructor application -- Check for a constructor application
-- NB: this *precedes* the Var case, so that we catch nullary constrs -- NB: this *precedes* the Var case, so that we catch nullary constrs
argToPat env in_scope val_env arg arg_occ argToPat env in_scope val_env arg arg_occ
| Just (ConVal dc args) <- isValue val_env arg | Just (ConVal (DataAlt dc) args) <- isValue val_env arg
, not (ignoreAltCon env dc) -- See Note [NoSpecConstr] , not (ignoreDataCon env dc) -- See Note [NoSpecConstr]
, sc_force env || scrutinised , Just arg_occs <- mb_scrut dc
= do { args' <- argsToPats env in_scope val_env (args `zip` conArgOccs arg_occ dc) = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args
; return (True, mk_con_app dc (map snd args')) } ; (_, args') <- argsToPats env in_scope val_env rest_args arg_occs
; return (True,
mkConApp dc (ty_args ++ args')) }
where where
scrutinised mb_scrut dc = case arg_occ of
= case arg_occ of ScrutOcc bs
ScrutOcc _ -> True -- Used only by case scrutinee | Just occs <- lookupUFM bs dc
BothOcc -> case arg of -- Used elsewhere -> Just (occs) -- See Note [Reboxing]
App {} -> True -- see Note [Reboxing] _other | sc_force env -> Just (repeat UnkOcc)
_other -> False | otherwise -> Nothing
_other -> False -- No point; the arg is not decomposed
-- Check if the argument is a variable that -- Check if the argument is a variable that
-- is in scope at the function definition site -- (a) is used in an interesting way in the body
-- It's worth specialising on this if
-- (a) it's used in an interesting way in the body
-- (b) we know what its value is -- (b) we know what its value is
-- In that case it counts as "interesting"
argToPat env in_scope val_env (Var v) arg_occ argToPat env in_scope val_env (Var v) arg_occ
| sc_force env || case arg_occ of { UnkOcc -> False; _other -> True }, -- (a) | sc_force env || case arg_occ of { UnkOcc -> False; _other -> True }, -- (a)
is_value, -- (b) is_value, -- (b)
...@@ -1661,17 +1651,18 @@ argToPat _env _in_scope _val_env arg _arg_occ ...@@ -1661,17 +1651,18 @@ argToPat _env _in_scope _val_env arg _arg_occ
= wildCardPat (exprType arg) = wildCardPat (exprType arg)
wildCardPat :: Type -> UniqSM (Bool, CoreArg) wildCardPat :: Type -> UniqSM (Bool, CoreArg)
wildCardPat ty = do { uniq <- getUniqueUs wildCardPat ty
; let id = mkSysLocal (fsLit "sc") uniq ty = do { uniq <- getUniqueUs
; return (False, Var id) } ; let id = mkSysLocal (fsLit "sc") uniq ty
; return (False, Var id) }
argsToPats :: ScEnv -> InScopeSet -> ValueEnv argsToPats :: ScEnv -> InScopeSet -> ValueEnv
-> [(CoreArg, ArgOcc)] -> [CoreArg] -> [ArgOcc] -- Should be same length
-> UniqSM [(Bool, CoreArg)] -> UniqSM (Bool, [CoreArg])
argsToPats env in_scope val_env args argsToPats env in_scope val_env args occs
= mapM do_one args = do { stuff <- zipWithM (argToPat env in_scope val_env) args occs
where ; let (interesting_s, args') = unzip stuff
do_one (arg,occ) = argToPat env in_scope val_env arg occ ; return (or interesting_s, args') }
\end{code} \end{code}
...@@ -1716,11 +1707,6 @@ isValue _env expr -- Maybe it's a constructor application ...@@ -1716,11 +1707,6 @@ isValue _env expr -- Maybe it's a constructor application
isValue _env _expr = Nothing isValue _env _expr = Nothing
mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
mk_con_app (LitAlt lit) [] = Lit lit
mk_con_app (DataAlt con) args = mkConApp con args
mk_con_app _other _args = panic "SpecConstr.mk_con_app"
samePat :: CallPat -> CallPat -> Bool samePat :: CallPat -> CallPat -> Bool
samePat (vs1, as1) (vs2, as2) samePat (vs1, as1) (vs2, as2)
= all2 same as1 as2 = all2 same as1 as2
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment