Commit 91ef36b9 authored by simonpj's avatar simonpj
Browse files

[project @ 2000-06-18 08:37:17 by simonpj]

*** MERGE WITH 4.07 ***

* Fix the ambiguity check in TcMonotype.lhs so that
  it is not carried out for types read from interface 
  files.  Some workers may get ambiguous types but that
  does not matter, and should not make compilation fail.
  More detail in the comments with TcMonoType.tc_type_kind
  (the HsForAll case)

* Don't create specialisations for type applications 
  where there's a matching rule.  The rule should
  clearly take precedence.  (Bug reported by Sven.)
  I havn't tested this fix.

* Run the occurrence analyser after tidyCore, so that
  occurrence info (notably dead-var info) is correct
  for the code generators.  This should fix Erik's problem,
  but again I've not tested the fix.  The extra call 
  is in Main.lhs

* Fix CoreToStg so that it can handle an StgLam in mkStgCase.
  This only shows up in a wierd case, documented in 
  CoreToStg.mkStgCase
parent aa104ab9
......@@ -341,7 +341,7 @@ eq_fld env (ns1,bt1) (ns2, bt2) = ns1==ns2 && eq_btype env bt1 bt2
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}
......
......@@ -165,7 +165,21 @@ pprHsTyVarBndr name kind | kind == boxedTypeKind = ppr name
| 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
......
......@@ -25,6 +25,7 @@ import MkIface ( writeIface )
import TcModule ( TcResults(..), typecheckModule )
import Desugar ( deSugar )
import SimplCore ( core2core )
import OccurAnal ( occurAnalyseBinds )
import CoreLint ( endPass )
import CoreUtils ( coreBindsSize )
import CoreTidy ( tidyCorePgm )
......@@ -156,7 +157,15 @@ doIt (core_cmds, stg_cmds)
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
......@@ -167,7 +176,7 @@ doIt (core_cmds, stg_cmds)
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 -------------------------------
......@@ -184,7 +193,7 @@ doIt (core_cmds, stg_cmds)
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 -------------------------------
......@@ -201,7 +210,7 @@ doIt (core_cmds, stg_cmds)
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 >>
......
......@@ -1269,13 +1269,14 @@ prepareCaseCont alts cont thing_inside = simplType (coreAltsType alts) `thenSm
-- (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
......
......@@ -23,7 +23,7 @@ import Type ( Type, mkTyVarTy, splitSigmaTy, splitFunTysN,
)
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
......@@ -34,7 +34,7 @@ import CoreUnfold ( certainlyWillInline )
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,
......@@ -42,7 +42,7 @@ import UniqSupply ( UniqSupply,
)
import Name ( nameOccName, mkSpecOcc, getSrcLoc )
import FiniteMap
import Maybes ( MaybeErr(..), catMaybes )
import Maybes ( MaybeErr(..), catMaybes, maybeToBool )
import ErrUtils ( dumpIfSet )
import Bag
import List ( partition )
......@@ -648,7 +648,7 @@ specExpr subst expr@(App fun arg)
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
......@@ -943,8 +943,8 @@ type CallInfo = FiniteMap [Maybe Type] -- Nothing => unconstrained type ar
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
......@@ -970,15 +970,20 @@ callDetailsToList calls = [ (id,tys,dicts)
(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)
......
......@@ -543,7 +543,8 @@ coreExprToStgFloat env (Case scrut bndr alts)
= 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)
......@@ -789,8 +790,8 @@ mk_stg_let bndr rhs dem floats body
#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
......@@ -809,8 +810,8 @@ mk_stg_let bndr rhs dem floats body
| 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 ->
......@@ -885,11 +886,11 @@ way to enforce ordering --SDM.
-- 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
......@@ -908,9 +909,15 @@ mkStgCase (StgPrimApp SeqOp [scrut] _) bndr
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}
......@@ -202,10 +202,9 @@ tc_type_kind (HsUsgForAllTy uv_name ty)
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
......@@ -227,29 +226,47 @@ tc_type_kind (HsForAllTy (Just tv_names) context ty)
-- 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
......
......@@ -87,12 +87,13 @@ What hugs complains about is the `D [a]' instance decl.
*** 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
......@@ -100,11 +101,11 @@ instance `C [Int]'. This is the mistake that ghc-4.06 makes. The fix is to
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
......@@ -117,22 +118,25 @@ something else out with ghc-4.04. Let's add the following line:
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
......
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