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
ad522e9
..
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 )
@@
-50,11
+51,7
@@
import UniqFM
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}
-----------------------------------------------------
@@
-675,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
@@
-939,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]
@@
-1176,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
@@
-1282,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
@@
-1317,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
@@
-1327,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]
~~~~~~~~~~~~~~~~~~~~~~~~~~
@@
-1394,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
@@
-1440,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
@@
-1561,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