Commit cfcebde7 authored by simonpj's avatar simonpj
Browse files

[project @ 1999-06-08 16:46:44 by simonpj]

Small fixes, including a significant full-laziness bug in OccurAnal
parent 7dd11ebc
cvs remove TcGRHSs.hi-boot TcGRHSs.hi-boot-5 TcGRHSs.lhs
cvs remove pbinding.ugn
cvs add grhsb.ugn gdexp.ugn
cvs add basicTypes/OccName.lhs
Notes June 99
~~~~~~~~~~~~~
* In nofib/spectral/mandel2/Main.check_radius, there's a call to (fromIntegral m), where
m is defined at top level. The full-laziness pass doesn't catch this because by
the time it runs, enough inlining has happened that it looks like
case ccall ... of (# a,b #) -> ...
and the full laziness pass doesn't float unboxed things.
* The same function is an excellent example of where liberate-case would be a win.
New in 4.02
* Scoped type variables
* Warnings for unused variables should work now (they didn't before)
* Simplifier improvements:
- Much better treatment of strict arguments
- Better treatment of bottoming Ids
- No need for w/w split for fns that are merely strict
- Fewer iterations needed, I hope
* Less gratuitous renaming in interface files and abs C
* OccName is a separate module, and is an abstract data type
-----------------------
* CHECK that the things seek_liftable found are done in Core
* CHECK that there aren't too many indirections in STG
local = ...
global = local Int
* Don't forget to try CSE
Interface files
~~~~~~~~~~~~~~~
......@@ -37,115 +23,3 @@ Interface files
We can't say T(T,A,B) and T(A,B) to export or not-export T respectively,
because the type T might have a constructor T.
===========================================================================
Nofib failures
~~~~~~~~~~~~~~
* spectral/hartel/wave4main, wang, spectral/simple, real/symalg
Bus error
* real/anna
expected stdout not matched by reality
*** big.sum.out Thu Aug 22 14:37:05 1996
--- /tmp/runtest21900.1 Mon Jan 20 17:57:49 1997
***************
*** 1 ****
! 12796 49
--- 1 ----
! 63325 97
* /real/compress2
expected stderr not matched by reality
Warning: missing newline at end of file /tmp/runtest14691.2
*** /tmp/no_stderr14691 Thu Jan 23 14:33:29 1997
--- /tmp/runtest14691.2 Thu Jan 23 14:33:29 1997
***************
*** 0 ****
--- 1,2 ----
+
+ Fail: Prelude.Enum.Char.toEnum:out of range
* real/ebnf2ps
IOSupplement.hs: 43: value not in scope: getEnv
...and...
HappyParser.hs: 127: Couldn't match the type
[HappyParser.Token'] against PrelBase.Int
Expected: HappyParser.HappyReduction
Inferred: PrelBase.Int -> HappyParser.Token' -> HappyParser.HappyState HappyParser.Token' ([HappyParser.HappyAbsSyn] -> [AbstractSyntax.Production]) -> PrelBase.Int -> PrelBase.Int -> o{-a1yN-} -> o{-a1yO-} -> [HappyParser.Token'] -> a{-a1yP-}
In an equation for function HappyParser.action_1:
HappyParser.action_1 _ = HappyParser.happyFail
* GHC_ONLY/bugs/andy_cherry
DataTypes.lhs: 3: Could not find valid interface file for `GenUtils'
Need "make depend"
* GHC_ONLY/bugs/lex
Pattern match fail in lex; must be producing empty or multi-valued result
Aggravated by dreadful error messages:
+
+ Fail: In irrefutable pattern
+ Fail: In pattern-matching
+ Fail: In pattern-matching
+ Fail: In pattern-matching
+ Fail: In pattern-matching
+ Fail: In pattern-matching
+ Fail: In pattern-matching
+ Fail: In pattern-matching
+ Fail: In pattern-matching
+ Fail: In pattern-matching
+ Fail: In pattern-matching
+ Fail: In pattern-matching
+ Fail: In pattern-matching
+ Fail: In pattern-matching
+ Fail: In pattern-matching
+ Fail: In pattern-matchingtoo many nested calls to `error'
* GHC_ONLY/bugs/jtod_circint
Main.hs: 12: No instance for: Signal.Signal (Signal.Stream Bit.Bit)
Main.hs: 12: at a use of an overloaded identifier: `Signal.one'
instance-decl slurping is WRONG
* GHC_ONLY/arith005
ceiling doesn't work properly
--- 1,3 ----
+ [1, 1, 2, 3, 4, 5, 0, -2, -3, -4, 1000013, 124, 101, 103, 1, 0, 17001, 0, 1, 4]
+ [1, 1, 2, 3, 4, 5, 0, -2, -3, -4, 1000013, 124, 101, 103, 1, 0, 17001, 0, 1, 4]
[0, 0, 2, 3, 4, 5, -1, -2, -3, -4, 1000012, 124, 101, 103, 1, 0, 17000, 0, 1, 4]
***************
*** 2,5 ****
[0, 0, 2, 3, 4, 5, -1, -2, -3, -4, 1000012, 124, 101, 103, 1, 0, 17000, 0, 1, 4]
- [0, 0, 2, 3, 4, 5, -1, -2, -3, -4, 1000012, 124, 101, 103, 1, 0, 17000, 0, 1, 4]
- [0, 0, 2, 3, 4, 5, -1, -2, -3, -4, 1000012, 124, 101, 103, 1, 0, 17000, 0, 1, 4]
[0, 0, 1, 2, 3, 4, -1, -3, -4, -5, 1000012, 123, 100, 102, 0, -1, 17000, -1, 0, 3]
--- 4,5 ----
* GHC_ONLY/bugs/lennart_array
Wrong array semantics (but who cares?)
* GHC_ONLY/bugs/life_space_leak
-n *** sum I got:
0 0
-n *** sum I expected:
02845 1350
This diff is collapsed.
......@@ -149,10 +149,13 @@ mkFormSummary expr
-- We want selectors to look like values
-- e.g. case x of { (a,b) -> a }
-- should give a ValueForm, so that it will be inlined
-- vigorously
go n expr@(Case _ _ _) | exprIsCheap expr = ValueForm
| otherwise = OtherForm
-- should give a ValueForm, so that it will be inlined vigorously
-- [June 99. I can't remember why this is a good idea. It means that
-- all overloading selectors get inlined at their usage sites, which is
-- not at all necessarily a good thing. So I'm rescinding this decision for now.]
-- go n expr@(Case _ _ _) | exprIsCheap expr = ValueForm
go n expr@(Case _ _ _) = OtherForm
go 0 (Lam x e) | isId x = ValueForm -- NB: \x.bottom /= bottom!
| otherwise = go 0 e
......
......@@ -194,7 +194,7 @@ ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
= sep [ptext SLIT("AbsBinds"),
brackets (interpp'SP tyvars),
brackets (interpp'SP dictvars),
brackets (interpp'SP exports),
brackets (sep (punctuate comma (map ppr exports))),
brackets (interpp'SP (nameSetToList inlines))]
$$
nest 4 (ppr val_binds)
......
This diff is collapsed.
......@@ -13,7 +13,7 @@ module RnIfaces (
checkUpToDate,
getDeclBinders
getDeclBinders, getDeclSysBinders
) where
#include "HsVersions.h"
......
This diff is collapsed.
......@@ -142,6 +142,11 @@ fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop )
Type ty
fiExpr to_drop (_, AnnCon c args)
| isDataCon c -- Don't float into the args of a data construtor;
-- the simplifier will float straight back out
= mkCoLets' to_drop (Con c (map (fiExpr []) args))
| otherwise
= mkCoLets' drop_here (Con c args')
where
(drop_here : arg_drops) = sepBindsByDropPoint (map freeVarsOf args) to_drop
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[FoldrBuildWW]{Spliting suitable functions into Workers and Wrappers}
\begin{code}
module FoldrBuildWW ( mkFoldrBuildWW ) where
#include "HsVersions.h"
-- Just a stub for now
import CoreSyn ( CoreBind )
import UniqSupply ( UniqSupply )
import Panic ( panic )
--import Type ( cloneTyVarFromTemplate, mkTyVarTy,
-- splitFunTyExpandingDicts, eqTyCon, mkForallTy )
--import TysPrim ( alphaTy )
--import TyVar ( alphaTyVar )
--
--import Type ( Type ) -- **** CAN SEE THE CONSTRUCTORS ****
--import UniqSupply ( runBuiltinUs )
--import WwLib -- share the same monad (is this eticit ?)
--import PrelInfo ( listTyCon, mkListTy, nilDataCon, consDataCon,
-- foldrId, buildId
-- )
--import Id ( getIdFBTypeInfo, mkWorkerId, getIdInfo,
-- mkSysLocal, idType
-- )
--import IdInfo
--import Maybes
--import SrcLoc ( noSrcLoc, SrcLoc )
--import Util
\end{code}
\begin{code}
mkFoldrBuildWW
:: UniqSupply
-> [CoreBind]
-> [CoreBind]
mkFoldrBuildWW = panic "mkFoldrBuildWW (ToDo)"
{- LATER:
mkFoldrBuildWW us top_binds =
(mapWw wwBind top_binds `thenWw` \ top_binds2 ->
returnWw (concat top_binds2)) us
\end{code}
\begin{code}
wwBind :: CoreBinding -> WwM [CoreBinding]
wwBind (NonRec bndr expr)
= try_split_bind bndr expr `thenWw` \ re ->
returnWw [NonRec bnds expr | (bnds,expr) <- re]
wwBind (Rec binds)
= mapWw (\ (bndr,expr) -> try_split_bind bndr expr) binds `thenWw` \ res ->
returnWw [Rec (concat res)]
wwExpr :: CoreExpr -> WwM CoreExpr
wwExpr e@(Var _) = returnWw e
wwExpr e@(Lit _) = returnWw e
wwExpr e@(Con _ _ _) = returnWw e
wwExpr e@(Prim _ _ _) = returnWw e
wwExpr (Lam ids e) =
wwExpr e `thenWw` \ e' ->
returnWw (Lam ids e')
wwExpr (CoTyLam tyvar e) =
wwExpr e `thenWw` \ e' ->
returnWw (CoTyLam tyvar e')
wwExpr (App f atom) =
wwExpr f `thenWw` \ f' ->
returnWw (App f atom)
wwExpr (CoTyApp f ty) =
wwExpr f `thenWw` \ f' ->
returnWw (CoTyApp f' ty)
wwExpr (Note note e) =
wwExpr e `thenWw` \ e' ->
returnWw (Note note e')
wwExpr (Let bnds e) =
wwExpr e `thenWw` \ e' ->
wwBind bnds `thenWw` \ bnds' ->
returnWw (foldr Let e' bnds')
wwExpr (Case e alts) =
wwExpr e `thenWw` \ e' ->
wwAlts alts `thenWw` \ alts' ->
returnWw (Case e' alts')
wwAlts (AlgAlts alts deflt) =
mapWw (\(con,binders,e) ->
wwExpr e `thenWw` \ e' ->
returnWw (con,binders,e')) alts `thenWw` \ alts' ->
wwDef deflt `thenWw` \ deflt' ->
returnWw (AlgAlts alts' deflt)
wwAlts (PrimAlts alts deflt) =
mapWw (\(lit,e) ->
wwExpr e `thenWw` \ e' ->
returnWw (lit,e')) alts `thenWw` \ alts' ->
wwDef deflt `thenWw` \ deflt' ->
returnWw (PrimAlts alts' deflt)
wwDef e@NoDefault = returnWw e
wwDef (BindDefault v e) =
wwExpr e `thenWw` \ e' ->
returnWw (BindDefault v e')
\end{code}
\begin{code}
try_split_bind :: Id -> CoreExpr -> WwM [(Id,CoreExpr)]
try_split_bind id expr =
wwExpr expr `thenWw` \ expr' ->
case getFBType (getIdFBTypeInfo id) of
Just (FBType consum prod)
| FBGoodProd == prod ->
{- || any (== FBGoodConsum) consum -}
let
(big_args,args,body) = collectBinders expr'
in
if length args /= length consum -- funny number of arguments
then returnWw [(id,expr')]
else
-- f /\ t1 .. tn \ v1 .. vn -> e
-- ===>
-- f_wrk /\ t1 .. tn t_new \ v1 .. vn c n -> foldr <exprTy> <nTy> c n e
-- f /\ t1 .. tn \ v1 .. vn
-- -> build exprTy (\ c n -> f_wrk t1 .. tn t_new v1 .. vn c n)
pprTrace "WW:" (ppr id) (returnWw ())
`thenWw` \ () ->
getUniqueWw `thenWw` \ ty_new_uq ->
getUniqueWw `thenWw` \ worker_new_uq ->
getUniqueWw `thenWw` \ c_new_uq ->
getUniqueWw `thenWw` \ n_new_uq ->
let
-- The *new* type
n_ty = alphaTy
n_ty_templ = alphaTy
(templ,arg_tys,res) = splitFunTyExpandingDicts (idType id)
expr_ty = getListTy res
getListTy res = panic "FoldrBuildWW:getListTy:ToDo" {-LATER:case res of
UniData lty [ty] | lty `eqTyCon` listTyCon -> ty
_ -> panic "Trying to split a non List datatype into Worker/Wrapper"-}
c_ty = expr_ty `mkFunTy` (n_ty `mkFunTy` n_ty)
c_ty_templ = expr_ty `mkFunTy` (n_ty_templ `mkFunTy` n_ty_templ)
worker_ty = mkForallTy (templ ++ [alphaTyVar])
(foldr mkFunTy n_ty_templ (arg_tys++[c_ty_templ,n_ty_templ]))
wrapper_id = setInlinePragma id IWantToBeINLINEd
worker_id = mkWorkerId worker_new_uq id worker_ty
-- TODO : CHECK if mkWorkerId is thr
-- right function to use ..
-- Now the bodies
c_id = mkSysLocal SLIT("fbww") c_new_uq c_ty
n_id = mkSysLocal SLIT("fbww") n_new_uq n_ty
worker_rhs
= mkTyLam [] (big_args ++ [alphaTyVar]) (args++[c_id,n_id]) worker_body
worker_body = runBuiltinUs (
mkCoApps
(Var foldrId `CoTyApp` expr_ty `CoTyApp` n_ty `App`
VarArg c_id `App` VarArg n_id)
[body])
wrapper_rhs = mkLam big_args args wrapper_body
wrapper_body = runBuiltinUs (
mkCoApps (CoTyApp (Var buildId) expr_ty)
[mkLam [alphaTyVar] [c_id,n_id]
(foldl App
(mkCoTyApps (Var worker_id)
[mkTyVarTy t | t <- big_args ++ [alphaTyVar]])
(map VarArg (args++[c_id,n_id])))])
in
if length args /= length arg_tys ||
length big_args /= length templ
then panic "LEN PROBLEM"
else
returnWw [(worker_id,worker_rhs),(wrapper_id,wrapper_rhs)]
_ -> returnWw [(id,expr')]
-}
\end{code}
_interface_ MagicUFs 1
_exports_
MagicUFs MagicUnfoldingFun mkMagicUnfoldingFun;
_declarations_
1 data MagicUnfoldingFun;
1 mkMagicUnfoldingFun _:_ Unique.Unique -> MagicUnfoldingFun ;;
__interface MagicUFs 1 0 where
__export MagicUFs MagicUnfoldingFun mkMagicUnfoldingFun;
1 data MagicUnfoldingFun;
1 mkMagicUnfoldingFun :: Unique.Unique -> MagicUnfoldingFun ;
......@@ -285,12 +285,12 @@ occAnalBind env (Rec pairs) body_usage
pp_item (_, bndr, _) = ppr bndr
binders = map fst pairs
new_env = env `addNewCands` binders
rhs_env = env `addNewCands` binders
analysed_pairs :: [Details1]
analysed_pairs = [ (bndr, rhs_usage, rhs')
| (bndr, rhs) <- pairs,
let (rhs_usage, rhs') = occAnalRhs new_env bndr rhs
let (rhs_usage, rhs') = occAnalRhs rhs_env bndr rhs
]
sccs :: [SCC (Node Details1)]
......@@ -497,7 +497,7 @@ occAnalRhs :: OccEnv
occAnalRhs env id rhs
= (final_usage, rhs')
where
(rhs_usage, rhs') = occAnal env rhs
(rhs_usage, rhs') = occAnal (zapCtxt env) rhs
-- [March 98] A new wrinkle is that if the binder has specialisations inside
-- it then we count the specialised Ids as "extra rhs's". That way
......@@ -639,7 +639,7 @@ occAnal env expr@(Lam _ _)
occAnal env (Case scrut bndr alts)
= case mapAndUnzip (occAnalAlt alt_env) alts of { (alts_usage_s, alts') ->
case occAnal env scrut of { (scrut_usage, scrut') ->
case occAnal (zapCtxt env) scrut of { (scrut_usage, scrut') ->
let
alts_usage = foldr1 combineAltsUsageDetails alts_usage_s
(alts_usage1, tagged_bndr) = tagBinder alts_usage bndr
......@@ -657,8 +657,10 @@ occAnal env (Let bind body)
new_env = env `addNewCands` (bindersOf bind)
occAnalArgs env args
= case mapAndUnzip (occAnal env) args of { (arg_uds_s, args') ->
= case mapAndUnzip (occAnal arg_env) args of { (arg_uds_s, args') ->
(foldr combineUsageDetails emptyDetails arg_uds_s, args')}
where
arg_env = zapCtxt env
\end{code}
Applications are dealt with specially because we want
......@@ -685,8 +687,8 @@ occAnalApp env (Var fun, args)
| otherwise = occAnalArgs env args
occAnalApp env (fun, args)
= case occAnal env fun of { (fun_uds, fun') ->
case occAnalArgs env args of { (args_uds, args') ->
= case occAnal (zapCtxt env) fun of { (fun_uds, fun') ->
case occAnalArgs env args of { (args_uds, args') ->
let
final_uds = fun_uds `combineUsageDetails` args_uds
in
......@@ -768,6 +770,9 @@ getCtxt env@(OccEnv ifun cands []) n = (False, env)
getCtxt (OccEnv ifun cands ctxt) n = (and (take n ctxt), OccEnv ifun cands (drop n ctxt))
-- Only return True if *all* the lambdas are linear
zapCtxt env@(OccEnv ifun cands []) = env
zapCtxt (OccEnv ifun cands _ ) = OccEnv ifun cands []
type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage
combineUsageDetails, combineAltsUsageDetails
......
......@@ -688,7 +688,7 @@ simplVar var cont
#ifdef DEBUG
if isLocallyDefined var && not (idMustBeINLINEd var)
-- The idMustBeINLINEd test accouunts for the fact
-- that class method selectors don't have top level
-- that class dictionary constructors don't have top level
-- bindings and hence aren't in scope.
then
-- Not in scope
......
......@@ -21,7 +21,7 @@ import CoreUnfold ( Unfolding(..) )
import CoreUtils ( whnfOrBottom, eqExpr )
import PprCore ( pprCoreRule )
import Subst ( Subst, InScopeSet, substBndr, lookupSubst, extendSubst,
mkSubst, substEnv, setSubstEnv,
mkSubst, substEnv, setSubstEnv, emptySubst, isInScope,
unBindSubst, bindSubstList, unBindSubstList,
)
import Id ( Id, getIdUnfolding,
......@@ -122,10 +122,30 @@ matchRule :: InScopeSet -> CoreRule -> [CoreExpr] -> Maybe (FAST_STRING, CoreExp
-- of the output.
--
-- ASSUMPTION (A):
-- No variable free in the template is bound in the target
-- A1. No top-level variable is bound in the target
-- A2. No template variable is bound in the target
-- A3. No lambda bound template variable is free in any subexpression of the target
--
-- To see why A1 is necessary, consider matching
-- \x->f against \f->f
-- When we meet the lambdas we substitute [f/x] in the template (a no-op),
-- and then erroneously succeed in matching f against f.
--
-- To see why A2 is needed consider matching
-- forall a. \b->b against \a->3
-- When we meet the lambdas we substitute [a/b] in the template, and then
-- erroneously succeed in matching what looks like the template variable 'a' against 3.
--
-- A3 is needed to validate the rule that says
-- (\x->E) matches F
-- if
-- (\x->E) matches (\x->F x)
matchRule in_scope (Rule rn tpl_vars tpl_args rhs) args
= go tpl_args args (mkSubst in_scope emptySubstEnv)
= go tpl_args args emptySubst
-- We used to use the in_scope set, but I don't think that's necessary
-- After all, the result is going to be simplified again with that in_scope set
where
tpl_var_set = mkVarSet tpl_vars
......@@ -188,11 +208,10 @@ type Matcher result = IdOrTyVarSet -- Template variables
-> Subst -> Maybe result -- Substitution so far -> result
-- The *SubstEnv* in these Substs apply to the TEMPLATE only
-- The *InScopeSet* in these Substs gives a superset of the free vars
-- in the term being matched. This set can get augmented, for example
-- when matching against a lambda:
-- (\x.M) ~ N iff M ~ N x
-- but we must clone x if it's already free in N
-- The *InScopeSet* in these Substs gives variables bound so far in the
-- target term. So when matching forall a. (\x. a x) against (\y. y y)
-- while processing the body of the lambdas, the in-scope set will be {y}.
-- That lets us do the occurs-check when matching 'a' against 'y'
match :: CoreExpr -- Template
-> CoreExpr -- Target
......@@ -202,8 +221,13 @@ match_fail = Nothing
match (Var v1) e2 tpl_vars kont subst
= case lookupSubst subst v1 of
Nothing | v1 `elemVarSet` tpl_vars -> kont (extendSubst subst v1 (DoneEx e2))
-- v1 is a template variables
Nothing | v1 `elemVarSet` tpl_vars -- v1 is a template variable
-> if (any (`isInScope` subst) (varSetElems (exprFreeVars e2))) then
match_fail -- Occurs check failure
-- e.g. match forall a. (\x-> a x) against (\y. y y)
else
kont (extendSubst subst v1 (DoneEx e2))
| eqExpr (Var v1) e2 -> kont subst
-- v1 is not a template variable, so it must be a global constant
......@@ -222,23 +246,18 @@ match (App f1 a1) (App f2 a2) tpl_vars kont subst
match (Lam x1 e1) (Lam x2 e2) tpl_vars kont subst
= bind [x1] [x2] (match e1 e2) tpl_vars kont subst
{- THESE EQUATIONS ARE BOGUS. SLPJ 19 May 99
-- This rule does eta expansion
-- (\x.M) ~ N iff M ~ N x
-- We must clone the binder in case it's already in scope in N
-- See assumption A3
match (Lam x1 e1) e2 tpl_vars kont subst
= match e1 (App e2 (mkVarArg x1')) tpl_vars kont' subst'
where
(subst', x1') = substBndr subst x1
kont' subst = kont (unBindSubst subst x1 x1')
= bind [x1] [x1] (match e1 (App e2 (mkVarArg x1))) tpl_vars kont subst
-- Eta expansion the other way
-- M ~ (\y.N) iff \y.M y ~ \y.N
-- iff M y ~ N
-- Remembering that by (A), y can't be free in M, we get this
match e1 (Lam x2 e2) tpl_vars kont subst
= match (App e1 (mkVarArg x2)) e2 tpl_vars kont subst
-}
= bind [x2] [x2] (match (App e1 (mkVarArg x2)) e2) tpl_vars kont subst
match (Case e1 x1 alts1) (Case e2 x2 alts2) tpl_vars kont subst
= match e1 e2 tpl_vars case_kont subst
......
......@@ -632,9 +632,7 @@ findStrictness tys str_val abs_val
where
tys_w_index = tys `zip` [(1::Int) ..]
find_str (ty,n) = -- let res =
-- in pprTrace "findStr" (ppr ty <+> int n <+> ppr res) res
findRecDemand str_fn abs_fn ty
find_str (ty,n) = findRecDemand str_fn abs_fn ty
where
str_fn val = foldl (absApply StrAnal) str_val
(map (mk_arg val n) tys_w_index)
......
......@@ -328,8 +328,7 @@ addStrictnessInfoToId str_val abs_val binder body
-- We could use 'collectBindersIgnoringNotes', but then the
-- strictness info may have more items than the visible binders
-- used by WorkWrap.tryWW
(binders, rhs) -> -- pprTrace "addStr" (ppr binder $$ ppr strictness) $
binder `setIdStrictness`
(binders, rhs) -> binder `setIdStrictness`
mkStrictnessInfo strictness
where
tys = [idType id | id <- binders, isId id]
......
......@@ -24,7 +24,7 @@ import RnHsSyn ( RenamedTyClDecl, RenamedClassPragmas,
)
import TcHsSyn ( TcMonoBinds )
import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, newDicts, newMethod )
import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs, newDicts, newMethod )
import TcEnv ( TcId, ValueEnv, TcTyThing(..), tcAddImportedIdInfo,
tcLookupClass, tcLookupTy, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars,
tcExtendLocalValEnv
......@@ -44,9 +44,7 @@ import Class ( mkClass, classBigSig, Class )
import CmdLineOpts ( opt_GlasgowExts, opt_WarnMissingMethods )
import MkId ( mkDictSelId, mkDataConId, mkDefaultMethodId )
import DataCon ( mkDataCon, notMarkedStrict )
import Id ( Id,
getIdUnfolding, idType, idName
)
import Id ( Id, setInlinePragma, getIdUnfolding, idType, idName )
import CoreUnfold ( getUnfoldingTemplate )
import IdInfo
import Name ( Name, nameOccName, isLocallyDefined, NamedThing(..) )
......@@ -180,7 +178,11 @@ tcClassDecl1 rec_env rec_inst_mapper rec_vrcs
[{-No existential tyvars-}] [{-Or context-}]
dict_component_tys
tycon dict_con_id
-- In general, constructors don't have to be inlined, but this one
-- does, because we don't make a top level binding for it.
dict_con_id = mkDataConId dict_con
`setInlinePragma` IMustBeINLINEd
argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcClassDecl1: argvrcs:" $
ppr tycon_name)
......@@ -378,23 +380,11 @@ we get the default methods:
defm.Foo.op1 :: forall a. Foo a => a -> Bool
defm.Foo.op1 = /\a -> \dfoo -> \x -> True
====================== OLD ==================
\begin{verbatim}
defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
if (op1 a dfoo x) && (< b dord y z) then y else z
\end{verbatim}
Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.