projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Remove (most of) the FiniteMap wrapper
[ghc-hetmet.git]
/
compiler
/
specialise
/
SpecConstr.lhs
diff --git
a/compiler/specialise/SpecConstr.lhs
b/compiler/specialise/SpecConstr.lhs
index
219e758
..
f214f0c
100644
(file)
--- a/
compiler/specialise/SpecConstr.lhs
+++ b/
compiler/specialise/SpecConstr.lhs
@@
-31,11
+31,12
@@
import Coercion
import Rules
import Type hiding( substTy )
import Id
import Rules
import Type hiding( substTy )
import Id
-import MkId ( mkImpossibleExpr )
+import MkCore ( mkImpossibleExpr )
import Var
import VarEnv
import VarSet
import Name
import Var
import VarEnv
import VarSet
import Name
+import BasicTypes
import DynFlags ( DynFlags(..) )
import StaticFlags ( opt_PprStyle_Debug )
import Maybes ( orElse, catMaybes, isJust, isNothing )
import DynFlags ( DynFlags(..) )
import StaticFlags ( opt_PprStyle_Debug )
import Maybes ( orElse, catMaybes, isJust, isNothing )
@@
-47,15
+48,10
@@
import UniqSupply
import Outputable
import FastString
import UniqFM
import Outputable
import FastString
import UniqFM
-import qualified LazyUniqFM as L
import MonadUtils
import Control.Monad ( zipWithM )
import Data.List
import MonadUtils
import Control.Monad ( zipWithM )
import Data.List
-#if __GLASGOW_HASKELL__ > 609
import Data.Data ( Data, Typeable )
import Data.Data ( Data, Typeable )
-#else
-import Data.Generics ( Data, Typeable )
-#endif
\end{code}
-----------------------------------------------------
\end{code}
-----------------------------------------------------
@@
-555,7
+551,7
@@
data ScEnv = SCE { sc_size :: Maybe Int, -- Size threshold
-- Domain is OutIds (*after* applying the substitution)
-- Used even for top-level bindings (but not imported ones)
-- Domain is OutIds (*after* applying the substitution)
-- Used even for top-level bindings (but not imported ones)
- sc_annotations :: L.UniqFM SpecConstrAnnotation
+ sc_annotations :: UniqFM SpecConstrAnnotation
}
---------------------
}
---------------------
@@
-580,7
+576,7
@@
instance Outputable Value where
ppr LambdaVal = ptext (sLit "<Lambda>")
---------------------
ppr LambdaVal = ptext (sLit "<Lambda>")
---------------------
-initScEnv :: DynFlags -> L.UniqFM SpecConstrAnnotation -> ScEnv
+initScEnv :: DynFlags -> UniqFM SpecConstrAnnotation -> ScEnv
initScEnv dflags anns
= SCE { sc_size = specConstrThreshold dflags,
sc_count = specConstrCount dflags,
initScEnv dflags anns
= SCE { sc_size = specConstrThreshold dflags,
sc_count = specConstrCount dflags,
@@
-676,7
+672,7
@@
extendCaseBndrs env case_bndr con alt_bndrs
-- Var v -> extendValEnv env1 v cval
-- _other -> env1
where
-- Var v -> extendValEnv env1 v cval
-- _other -> env1
where
- zap v | isTyVar v = v -- See NB2 above
+ zap v | isTyCoVar v = v -- See NB2 above
| otherwise = zapIdOccInfo v
env1 = extendValEnv env case_bndr cval
cval = case con of
| otherwise = zapIdOccInfo v
env1 = extendValEnv env case_bndr cval
cval = case con of
@@
-689,7
+685,7
@@
extendCaseBndrs env case_bndr con alt_bndrs
ignoreTyCon :: ScEnv -> TyCon -> Bool
ignoreTyCon env tycon
ignoreTyCon :: ScEnv -> TyCon -> Bool
ignoreTyCon env tycon
- = L.lookupUFM (sc_annotations env) tycon == Just NoSpecConstr
+ = lookupUFM (sc_annotations env) tycon == Just NoSpecConstr
ignoreType :: ScEnv -> Type -> Bool
ignoreType env ty
ignoreType :: ScEnv -> Type -> Bool
ignoreType env ty
@@
-715,7
+711,7
@@
forceSpecArgTy env ty
forceSpecArgTy env ty
| Just (tycon, tys) <- splitTyConApp_maybe ty
, tycon /= funTyCon
forceSpecArgTy env ty
| Just (tycon, tys) <- splitTyConApp_maybe ty
, tycon /= funTyCon
- = L.lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr
+ = lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr
|| any (forceSpecArgTy env) tys
forceSpecArgTy _ _ = False
|| any (forceSpecArgTy env) tys
forceSpecArgTy _ _ = False
@@
-940,7
+936,7
@@
scExpr' env (Case scrut b ty alts)
; return (usg', scrut_occ, (con, bs2, rhs')) }
scExpr' env (Let (NonRec bndr rhs) body)
; return (usg', scrut_occ, (con, bs2, rhs')) }
scExpr' env (Let (NonRec bndr rhs) body)
- | isTyVar bndr -- Type-lets may be created by doBeta
+ | isTyCoVar bndr -- Type-lets may be created by doBeta
= scExpr' (extendScSubst env bndr rhs) body
| otherwise -- Note [Local let bindings]
= scExpr' (extendScSubst env bndr rhs) body
| otherwise -- Note [Local let bindings]
@@
-1177,6
+1173,7
@@
specialise
specialise env force_spec bind_calls (RI fn _ arg_bndrs body arg_occs)
spec_info@(SI specs spec_count mb_unspec)
| not (isBottomingId fn) -- Note [Do not specialise diverging functions]
specialise env force_spec bind_calls (RI fn _ arg_bndrs body arg_occs)
spec_info@(SI specs spec_count mb_unspec)
| not (isBottomingId fn) -- Note [Do not specialise diverging functions]
+ , not (isNeverActive (idInlineActivation fn)) -- See Note [Transfer activation]
, notNull arg_bndrs -- Only specialise functions
, Just all_calls <- lookupVarEnv bind_calls fn
= do { (boring_call, pats) <- callsToPats env specs arg_occs all_calls
, notNull arg_bndrs -- Only specialise functions
, Just all_calls <- lookupVarEnv bind_calls fn
= do { (boring_call, pats) <- callsToPats env specs arg_occs all_calls
@@
-1283,6
+1280,7
@@
spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
rule_rhs = mkVarApps (Var spec_id) spec_call_args
inline_act = idInlineActivation fn
rule = mkLocalRule rule_name inline_act fn_name qvars pats rule_rhs
rule_rhs = mkVarApps (Var spec_id) spec_call_args
inline_act = idInlineActivation fn
rule = mkLocalRule rule_name inline_act fn_name qvars pats rule_rhs
+ -- See Note [Transfer activation]
; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
calcSpecStrictness :: Id -- The original function
; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
calcSpecStrictness :: Id -- The original function
@@
-1318,6
+1316,10
@@
specialised RHS, and that can lead directly to exponential behaviour.
Note [Transfer activation]
~~~~~~~~~~~~~~~~~~~~~~~~~~
Note [Transfer activation]
~~~~~~~~~~~~~~~~~~~~~~~~~~
+ This note is for SpecConstr, but exactly the same thing
+ happens in the overloading specialiser; see
+ Note [Auto-specialisation and RULES] in Specialise.
+
In which phase should the specialise-constructor rules be active?
Originally I made them always-active, but Manuel found that this
defeated some clever user-written rules. Then I made them active only
In which phase should the specialise-constructor rules be active?
Originally I made them always-active, but Manuel found that this
defeated some clever user-written rules. Then I made them active only
@@
-1328,8
+1330,9
@@
simplCore/should_compile/spec-inline.
So now I just use the inline-activation of the parent Id, as the
activation for the specialiation RULE, just like the main specialiser;
So now I just use the inline-activation of the parent Id, as the
activation for the specialiation RULE, just like the main specialiser;
-see Note [Auto-specialisation and RULES] in Specialise.
+This in turn means there is no point in specialising NOINLINE things,
+so we test for that.
Note [Transfer strictness]
~~~~~~~~~~~~~~~~~~~~~~~~~~
Note [Transfer strictness]
~~~~~~~~~~~~~~~~~~~~~~~~~~
@@
-1395,7
+1398,7
@@
callToPats env bndr_occs (con_env, args)
-- at the call site
-- See Note [Shadowing] at the top
-- at the call site
-- See Note [Shadowing] at the top
- (tvs, ids) = partition isTyVar qvars
+ (tvs, ids) = partition isTyCoVar qvars
qvars' = tvs ++ ids
-- Put the type variables first; the type of a term
-- variable may mention a type variable
qvars' = tvs ++ ids
-- Put the type variables first; the type of a term
-- variable may mention a type variable
@@
-1441,11
+1444,18
@@
argToPat env in_scope val_env (Note _ arg) arg_occ
argToPat env in_scope val_env (Let _ arg) arg_occ
= argToPat env in_scope val_env arg arg_occ
argToPat env in_scope val_env (Let _ arg) arg_occ
= argToPat env in_scope val_env arg arg_occ
+ -- See Note [Matching lets] in Rule.lhs
-- Look through let expressions
-- Look through let expressions
- -- e.g. f (let v = rhs in \y -> ...v...)
- -- Here we can specialise for f (\y -> ...)
+ -- e.g. f (let v = rhs in (v,w))
+ -- Here we can specialise for f (v,w)
-- because the rule-matcher will look through the let.
-- because the rule-matcher will look through the let.
+{- Disabled; see Note [Matching cases] in Rule.lhs
+argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ
+ | exprOkForSpeculation scrut -- See Note [Matching cases] in Rule.hhs
+ = argToPat env in_scope val_env rhs arg_occ
+-}
+
argToPat env in_scope val_env (Cast arg co) arg_occ
| not (ignoreType env ty2)
= do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ
argToPat env in_scope val_env (Cast arg co) arg_occ
| not (ignoreType env ty2)
= do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ
@@
-1562,7
+1572,7
@@
isValue env (Var v)
-- as well, for let-bound constructors!
isValue env (Lam b e)
-- as well, for let-bound constructors!
isValue env (Lam b e)
- | isTyVar b = case isValue env e of
+ | isTyCoVar b = case isValue env e of
Just _ -> Just LambdaVal
Nothing -> Nothing
| otherwise = Just LambdaVal
Just _ -> Just LambdaVal
Nothing -> Nothing
| otherwise = Just LambdaVal