eq_btype env (Banged t1) (Banged t2) = eq_hsType env t1 t2
eq_btype env (Unbanged t1) (Unbanged t2) = eq_hsType env t1 t2
eq_btype env (Unpacked t1) (Unpacked t2) = eq_hsType env t1 t2
-eq_btype env _ _ = False
+eq_btype env _ _ = False
\end{code}
\begin{code}
| otherwise = hsep [ppr name, dcolon, pprParendKind kind]
pprHsForAll [] [] = empty
-pprHsForAll tvs cxt = ptext SLIT("__forall") <+> interppSP tvs <+> ppr_context cxt <+> ptext SLIT("=>")
+pprHsForAll tvs cxt
+ -- This printer is used for both interface files and
+ -- printing user types in error messages; and alas the
+ -- two use slightly different syntax. Ah well.
+ = getPprStyle $ \ sty ->
+ if userStyle sty then
+ ptext SLIT("forall") <+> interppSP tvs <> dot <+>
+ (if null cxt then
+ empty
+ else
+ ppr_context cxt <+> ptext SLIT("=>")
+ )
+ else -- Used in interfaces
+ ptext SLIT("__forall") <+> interppSP tvs <+>
+ ppr_context cxt <+> ptext SLIT("=>")
pprHsContext :: (Outputable name) => HsContext name -> SDoc
pprHsContext [] = empty
import TcModule ( TcResults(..), typecheckModule )
import Desugar ( deSugar )
import SimplCore ( core2core )
+import OccurAnal ( occurAnalyseBinds )
import CoreLint ( endPass )
import CoreUtils ( coreBindsSize )
import CoreTidy ( tidyCorePgm )
tidyCorePgm tidy_uniqs this_mod
simplified orphan_rules >>= \ (tidy_binds, tidy_orphan_rules) ->
- coreBindsSize tidy_binds `seq`
+ -- Run the occurrence analyser one last time, so that
+ -- dead binders get dead-binder info. This is exploited by
+ -- code generators to avoid spitting out redundant bindings.
+ -- The occurrence-zapping in Simplify.simplCaseBinder means
+ -- that the Simplifier nukes useful dead-var stuff especially
+ -- in case patterns.
+ let occ_anal_tidy_binds = occurAnalyseBinds tidy_binds in
+
+ coreBindsSize occ_anal_tidy_binds `seq`
-- TEMP: the above call zaps some space usage allocated by the
-- simplifier, which for reasons I don't understand, persists
-- thoroughout code generation
show_pass "Core2Stg" >>
_scc_ "Core2Stg"
let
- stg_binds = topCoreBindsToStg c2s_uniqs tidy_binds
+ stg_binds = topCoreBindsToStg c2s_uniqs occ_anal_tidy_binds
in
-------------------------- Simplify STG code -------------------------------
in
writeIface this_mod old_iface new_iface
local_tycons local_classes inst_info
- final_ids tidy_binds tidy_orphan_rules >>
+ final_ids occ_anal_tidy_binds tidy_orphan_rules >>
-------------------------- Code generation -------------------------------
show_pass "CodeOutput" >>
_scc_ "CodeOutput"
codeOutput this_mod local_tycons local_classes
- tidy_binds stg_binds2
+ occ_anal_tidy_binds stg_binds2
c_code h_code abstractC
ncg_uniqs >>
-- (using funResultTy) in mkDupableCont.
\end{code}
-simplCaseBinder checks whether the scrutinee is a variable, v.
-If so, try to eliminate uses of v in the RHSs in favour of case_bndr;
-that way, there's a chance that v will now only be used once, and hence inlined.
-
-There is a time we *don't* want to do that, namely when -fno-case-of-case
-is on. This happens in the first simplifier pass, and enhances full laziness.
-Here's the bad case:
+simplCaseBinder checks whether the scrutinee is a variable, v. If so,
+try to eliminate uses of v in the RHSs in favour of case_bndr; that
+way, there's a chance that v will now only be used once, and hence
+inlined.
+
+There is a time we *don't* want to do that, namely when
+-fno-case-of-case is on. This happens in the first simplifier pass,
+and enhances full laziness. Here's the bad case:
f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )
If we eliminate the inner case, we trap it inside the I# v -> arm,
which might prevent some full laziness happening. I've seen this
)
import PprType ( {- instance Outputable Type -} )
import Subst ( Subst, mkSubst, substTy, mkSubst, substBndrs, extendSubstList,
- substId, substAndCloneId, substAndCloneIds, lookupIdSubst
+ substId, substAndCloneId, substAndCloneIds, lookupIdSubst, substInScope
)
import Var ( TyVar, mkSysTyVar, setVarUnique )
import VarSet
import CoreFVs ( exprFreeVars, exprsFreeVars )
import CoreLint ( beginPass, endPass )
import PprCore ( pprCoreRules )
-import Rules ( addIdSpecialisations )
+import Rules ( addIdSpecialisations, lookupRule )
import UniqSupply ( UniqSupply,
UniqSM, initUs_, thenUs, thenUs_, returnUs, getUniqueUs,
)
import Name ( nameOccName, mkSpecOcc, getSrcLoc )
import FiniteMap
-import Maybes ( MaybeErr(..), catMaybes )
+import Maybes ( MaybeErr(..), catMaybes, maybeToBool )
import ErrUtils ( dumpIfSet )
import Bag
import List ( partition )
returnSM (App fun' arg', uds_arg `plusUDs` uds_app)
go (Var f) args = case specVar subst f of
- Var f' -> returnSM (Var f', mkCallUDs f' args)
+ Var f' -> returnSM (Var f', mkCallUDs subst f' args)
e' -> returnSM (e', emptyUDs) -- I don't expect this!
go other args = specExpr subst other
unionCalls :: CallDetails -> CallDetails -> CallDetails
unionCalls c1 c2 = plusFM_C plusFM c1 c2
-singleCall :: (Id, [Maybe Type], [DictExpr]) -> CallDetails
-singleCall (id, tys, dicts)
+singleCall :: Id -> [Maybe Type] -> [DictExpr] -> CallDetails
+singleCall id tys dicts
= unitFM id (unitFM tys (dicts, call_fvs))
where
call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs
(tys,dicts) <- fmToList fm
]
-mkCallUDs f args
+mkCallUDs subst f args
| null theta
|| length spec_tys /= n_tyvars
|| length dicts /= n_dicts
- = emptyUDs -- Not overloaded
+ || maybeToBool (lookupRule (substInScope subst) f args)
+ -- There's already a rule covering this call. A typical case
+ -- is where there's an explicit user-provided rule. Then
+ -- we don't want to create a specialised version
+ -- of the function that overlaps.
+ = emptyUDs -- Not overloaded, or no specialisation wanted
| otherwise
= MkUD {dict_binds = emptyBag,
- calls = singleCall (f, spec_tys, dicts)
+ calls = singleCall f spec_tys dicts
}
where
(tyvars, theta, tau) = splitSigmaTy (idType f)
= coreExprToStgFloat env scrut `thenUs` \ (binds, scrut') ->
newLocalId NotTopLevel env bndr `thenUs` \ (env', bndr') ->
alts_to_stg env' (findDefault alts) `thenUs` \ alts' ->
- returnUs (binds, mkStgCase scrut' bndr' alts')
+ mkStgCase scrut' bndr' alts' `thenUs` \ expr' ->
+ returnUs (binds, expr')
where
scrut_ty = idType bndr
prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
#endif
| isUnLiftedType bndr_rep_ty -- Use a case/PrimAlts
= ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
- mkStgBinds floats $
- mkStgCase rhs bndr (StgPrimAlts bndr_rep_ty [] (StgBindDefault body))
+ mkStgCase rhs bndr (StgPrimAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' ->
+ mkStgBinds floats expr'
| is_whnf
= if is_strict then
| otherwise -- Not WHNF
= if is_strict then
-- Strict let with non-WHNF rhs
- mkStgBinds floats $
- mkStgCase rhs bndr (StgAlgAlts bndr_rep_ty [] (StgBindDefault body))
+ mkStgCase rhs bndr (StgAlgAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' ->
+ mkStgBinds floats expr'
else
-- Lazy let with non-WHNF rhs, so keep the floats in the RHS
mkStgBinds floats rhs `thenUs` \ new_rhs ->
-- Discard alernatives in case (par# ..) of
mkStgCase scrut@(StgPrimApp ParOp _ _) bndr
(StgPrimAlts ty _ deflt@(StgBindDefault _))
- = StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT (StgPrimAlts ty [] deflt)
+ = returnUs (StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT (StgPrimAlts ty [] deflt))
mkStgCase (StgPrimApp SeqOp [scrut] _) bndr
(StgPrimAlts _ _ deflt@(StgBindDefault rhs))
- = mkStgCase scrut_expr new_bndr (StgAlgAlts scrut_ty [] (StgBindDefault rhs))
+ = mkStgCase scrut_expr new_bndr new_alts
where
new_alts | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" ) StgPrimAlts scrut_ty [] deflt
| otherwise = StgAlgAlts scrut_ty [] deflt
StgLitArg l -> WARN( True, text "seq on" <+> ppr l ) StgLit l
mkStgCase scrut bndr alts
- = ASSERT( case scrut of { StgLam _ _ _ -> False; other -> True } )
- -- We should never find
- -- case (\x->e) of { ... }
- -- The simplifier eliminates such things
- StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT alts
+ = deStgLam scrut `thenUs` \ scrut' ->
+ -- It is (just) possible to get a lambda as a srutinee here
+ -- Namely: fromDyn (toDyn ((+1)::Int->Int)) False)
+ -- gives: case ...Bool == Int->Int... of
+ -- True -> case coerce Bool (\x -> + 1 x) of
+ -- True -> ...
+ -- False -> ...
+ -- False -> ...
+ -- The True branch of the outer case will never happen, of course.
+
+ returnUs (StgCase scrut' bOGUS_LVs bOGUS_LVs bndr noSRT alts)
\end{code}
returnTc (kind, mkUsForAllTy uv tc_ty)
tc_type_kind (HsForAllTy (Just tv_names) context ty)
- = tcExtendTyVarScope tv_names $ \ tyvars ->
+ = tcExtendTyVarScope tv_names $ \ forall_tyvars ->
tcContext context `thenTc` \ theta ->
tc_type_kind ty `thenTc` \ (kind, tau) ->
- tcGetInScopeTyVars `thenTc` \ in_scope_vars ->
let
body_kind | null theta = kind
| otherwise = boxedTypeKind
-- forall x y. (C x y) => x
-- is not ambiguous because x is mentioned and x determines y
--
- -- In addition, GHC insists that at least one type variable
+ -- NOTE: In addition, GHC insists that at least one type variable
-- in each constraint is in V. So we disallow a type like
-- forall a. Eq b => b -> b
-- even in a scope where b is in scope.
+ -- This is the is_free test below.
- forall_tyvars = map varName tyvars -- was: in_scope_vars. Why???
tau_vars = tyVarsOfType tau
fds = instFunDepsOfTheta theta
tvFundep = tyVarFunDep fds
extended_tau_vars = oclose tvFundep tau_vars
- is_ambig ct_var = (varName ct_var `elem` forall_tyvars) &&
+ is_ambig ct_var = (ct_var `elem` forall_tyvars) &&
not (ct_var `elemUFM` extended_tau_vars)
- is_free ct_var = not (varName ct_var `elem` forall_tyvars)
+ is_free ct_var = not (ct_var `elem` forall_tyvars)
check_pred pred = checkTc (not any_ambig) (ambigErr pred ty) `thenTc_`
checkTc (not all_free) (freeErr pred ty)
where
ct_vars = varSetElems (tyVarsOfPred pred)
- any_ambig = any is_ambig ct_vars
+ any_ambig = is_source_polytype && any is_ambig ct_vars
all_free = all is_free ct_vars
+
+ -- Check ambiguity only for source-program types, not
+ -- for types coming from inteface files. The latter can
+ -- legitimately have ambiguous types. Example
+ -- class S a where s :: a -> (Int,Int)
+ -- instance S Char where s _ = (1,1)
+ -- f:: S a => [a] -> Int -> (Int,Int)
+ -- f (_::[a]) x = (a*x,b)
+ -- where (a,b) = s (undefined::a)
+ -- Here the worker for f gets the type
+ -- fw :: forall a. S a => Int -> (# Int, Int #)
+ --
+ -- If the list of tv_names is empty, we have a monotype,
+ -- and then we don't need to check for ambiguity either,
+ -- because the test can't fail (see is_ambig).
+ is_source_polytype = case tv_names of
+ (UserTyVar _ : _) -> True
+ other -> False
in
- mapTc check_pred theta `thenTc_`
- returnTc (body_kind, mkSigmaTy tyvars theta tau)
+ mapTc check_pred theta `thenTc_`
+ returnTc (body_kind, mkSigmaTy forall_tyvars theta tau)
\end{code}
Help functions for type applications
*** Required superclass : C [a]
\end{pseudocode}
-You might wonder what hugs is complaining about. It's saying that you need to
-add `C [a]' to the context of the `D [a]' instance (as appears in comments).
-But there's that `C [a]' instance decl one line above that says that I can
-reduce the need for a `C [a]' instance to the need for a `C a' instance, and
-in this case, I already have the necessary `C a' instance (since we have `D a'
-explicitly in the context, and `C' is a superclass of `D').
+You might wonder what hugs is complaining about. It's saying that you
+need to add `C [a]' to the context of the `D [a]' instance (as appears
+in comments). But there's that `C [a]' instance decl one line above
+that says that I can reduce the need for a `C [a]' instance to the
+need for a `C a' instance, and in this case, I already have the
+necessary `C a' instance (since we have `D a' explicitly in the
+context, and `C' is a superclass of `D').
Unfortunately, the above reasoning indicates a premature commitment to the
generic `C [a]' instance. I.e., it prematurely rules out the more specific
add the context that hugs suggests (uncomment the `C [a]'), effectively
deferring the decision about which instance to use.
-Now, interestingly enough, 4.04 has this same bug, but it's covered up in this
-case by a little known `optimization' that was disabled in 4.06. Ghc-4.04
-silently inserts any missing superclass context into an instance declaration.
-In this case, it silently inserts the `C [a]', and everything happens to work
-out.
+Now, interestingly enough, 4.04 has this same bug, but it's covered up
+in this case by a little known `optimization' that was disabled in
+4.06. Ghc-4.04 silently inserts any missing superclass context into
+an instance declaration. In this case, it silently inserts the `C
+[a]', and everything happens to work out.
(See `basicTypes/MkId:mkDictFunId' for the code in question. Search for
`Mark Jones', although Mark claims no credit for the `optimization' in
d' :: D a => [a]
d' = c
-Everyone raise their hand who thinks that `d :: [Int]' should give a different
-answer from `d' :: [Int]'. Well, in ghc-4.04, it does. The `optimization'
-only applies to instance decls, not to regular bindings, giving inconsistent
-behavior.
-
-Old hugs had this same bug. Here's how we fixed it: like GHC, the list of
-instances for a given class is ordered, so that more specific instances come
-before more generic ones. For example, the instance list for C might contain:
- ..., C Int, ..., C a, ...
-When we go to look for a `C Int' instance we'll get that one first. But what
-if we go looking for a `C b' (`b' is unconstrained)? We'll pass the `C Int'
-instance, and keep going. But if `b' is unconstrained, then we don't know yet
-if the more specific instance will eventually apply. GHC keeps going, and
-matches on the generic `C a'. The fix is to, at each step, check to see if
-there's a reverse match, and if so, abort the search. This prevents hugs
-from prematurely chosing a generic instance when a more specific one exists.
+Everyone raise their hand who thinks that `d :: [Int]' should give a
+different answer from `d' :: [Int]'. Well, in ghc-4.04, it does. The
+`optimization' only applies to instance decls, not to regular
+bindings, giving inconsistent behavior.
+
+Old hugs had this same bug. Here's how we fixed it: like GHC, the
+list of instances for a given class is ordered, so that more specific
+instances come before more generic ones. For example, the instance
+list for C might contain:
+ ..., C Int, ..., C a, ...
+When we go to look for a `C Int' instance we'll get that one first.
+But what if we go looking for a `C b' (`b' is unconstrained)? We'll
+pass the `C Int' instance, and keep going. But if `b' is
+unconstrained, then we don't know yet if the more specific instance
+will eventually apply. GHC keeps going, and matches on the generic `C
+a'. The fix is to, at each step, check to see if there's a reverse
+match, and if so, abort the search. This prevents hugs from
+prematurely chosing a generic instance when a more specific one
+exists.
--Jeff
projects / ghc-hetmet.git / commitdiff