diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile
index f0b7b2f29acefda89f2f07da6bb6185d681370fe..dcf06812d84ac72e73f04c077c5e2f47f1cb3162 100644
--- a/ghc/compiler/Makefile
+++ b/ghc/compiler/Makefile
@@ -1,5 +1,5 @@
# -----------------------------------------------------------------------------
-# $Id: Makefile,v 1.6 1997/01/06 21:08:42 simonpj Exp $
+# $Id: Makefile,v 1.7 1997/01/17 00:32:23 simonpj Exp $
TOP = ../..
FlexSuffixRules = YES
@@ -23,7 +23,7 @@ include $(TOP)/mk/rules.mk
#-----------------------------------------------------------------------------
# make libhsp.a
-YFLAGS = -d
+YFLAGS = -d -v
CFLAGS = -Iparser -I. -IcodeGen
ARCHIVE = libhsp.a
DESTDIR = $(INSTLIBDIR_GHC)
diff --git a/ghc/compiler/basicTypes/Demand.lhs b/ghc/compiler/basicTypes/Demand.lhs
index 21c22d46061fbe50d42397fdd3a5d67f5cc82598..738ea2fb383c4f2e54d0be1989fae036d291f2c3 100644
--- a/ghc/compiler/basicTypes/Demand.lhs
+++ b/ghc/compiler/basicTypes/Demand.lhs
@@ -34,6 +34,7 @@ data Demand
-- calling-convention magic)
| WwUnpack -- Argument is strict & a single-constructor
+ Bool -- True <=> wrapper unpacks it; False <=> doesn't
[Demand] -- type; its constituent parts (whose StrictInfos
-- are in the list) should be passed
-- as arguments to the worker.
@@ -53,7 +54,7 @@ type MaybeAbsent = Bool -- True <=> not even used
-- versions that don't worry about Absence:
wwLazy = WwLazy False
wwStrict = WwStrict
-wwUnpack xs = WwUnpack xs
+wwUnpack xs = WwUnpack False xs
wwPrim = WwPrim
wwEnum = WwEnum
\end{code}
@@ -69,7 +70,7 @@ wwEnum = WwEnum
isStrict :: Demand -> Bool
isStrict WwStrict = True
-isStrict (WwUnpack _) = True
+isStrict (WwUnpack _ _) = True
isStrict WwPrim = True
isStrict WwEnum = True
isStrict _ = False
@@ -97,24 +98,30 @@ instance Text Demand where
read_em acc ('E' : xs) = read_em (WwEnum : acc) xs
read_em acc (')' : xs) = [(reverse acc, xs)]
- read_em acc ( 'U' : '(' : xs)
+ read_em acc ( 'U' : '(' : xs) = do_unpack True acc xs
+ read_em acc ( 'u' : '(' : xs) = do_unpack False acc xs
+
+ read_em acc rest = [(reverse acc, rest)]
+
+ do_unpack wrapper_unpacks acc xs
= case (read_em [] xs) of
- [(stuff, rest)] -> read_em (WwUnpack stuff : acc) rest
+ [(stuff, rest)] -> read_em (WwUnpack wrapper_unpacks stuff : acc) rest
_ -> panic ("Text.Demand:"++str++"::"++xs)
- read_em acc rest = [(reverse acc, rest)]
#ifdef REALLY_HASKELL_1_3
instance Show Demand where
#endif
showList wrap_args rest = foldr show1 rest wrap_args
where
- show1 (WwLazy False) rest = 'L' : rest
- show1 (WwLazy True) rest = 'A' : rest
- show1 WwStrict rest = 'S' : rest
- show1 WwPrim rest = 'P' : rest
- show1 WwEnum rest = 'E' : rest
- show1 (WwUnpack args) rest = "U(" ++ showList args (')' : rest)
+ show1 (WwLazy False) rest = 'L' : rest
+ show1 (WwLazy True) rest = 'A' : rest
+ show1 WwStrict rest = 'S' : rest
+ show1 WwPrim rest = 'P' : rest
+ show1 WwEnum rest = 'E' : rest
+ show1 (WwUnpack wu args) rest = ch ++ "(" ++ showList args (')' : rest)
+ where
+ ch = if wu then "U" else "u"
instance Outputable Demand where
ppr sty si = ppStr (showList [si] "")
diff --git a/ghc/compiler/basicTypes/UniqSupply.lhs b/ghc/compiler/basicTypes/UniqSupply.lhs
index 564110750bdc7588e18b6671c6c96d125c03de53..76e5ab3e80f5f4b772b95e28bccac0bfdc099404 100644
--- a/ghc/compiler/basicTypes/UniqSupply.lhs
+++ b/ghc/compiler/basicTypes/UniqSupply.lhs
@@ -134,11 +134,9 @@ type UniqSM result = UniqSupply -> result
-- the initUs function also returns the final UniqSupply
-initUs :: UniqSupply -> UniqSM a -> (UniqSupply, a)
+initUs :: UniqSupply -> UniqSM a -> a
-initUs init_us m
- = case (splitUniqSupply init_us) of { (s1, s2) ->
- (s2, m s1) }
+initUs init_us m = m init_us
{-# INLINE thenUs #-}
{-# INLINE returnUs #-}
diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs
index 5d06570679b4d11a65679f3de05c949f7bd60527..dff94d21854c34c13cca5976ceda43d0694a1812 100644
--- a/ghc/compiler/codeGen/CgClosure.lhs
+++ b/ghc/compiler/codeGen/CgClosure.lhs
@@ -980,7 +980,7 @@ mkWrapperArgTypeCategories wrapper_ty wrap_info
do_one (WwPrim, _) = 'P'
do_one (WwEnum, _) = 'E'
do_one (WwStrict, arg_ty_char) = arg_ty_char
- do_one (WwUnpack _, arg_ty_char)
+ do_one (WwUnpack _ _, arg_ty_char)
= if arg_ty_char `elem` "CIJFDTS"
then toLower arg_ty_char
else if arg_ty_char == '+' then 't'
diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index a15f703453f25104d7fecafc7d11a7ebd2e39f69..215f25b30e7b47a8eb92adc6c5e90bea443addf2 100644
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -52,7 +52,7 @@ import RdrHsSyn ( RdrName )
import OccurAnal ( occurAnalyseGlobalExpr )
import CoreUtils ( coreExprType )
import CostCentre ( ccMentionsId )
-import Id ( idType, getIdArity, isBottomingId,
+import Id ( idType, getIdArity, isBottomingId, isDataCon, isPrimitiveId_maybe,
SYN_IE(IdSet), GenId{-instances-} )
import PrimOp ( primOpCanTriggerGC, fragilePrimOp, PrimOp(..) )
import IdInfo ( ArityInfo(..), bottomIsGuaranteed )
@@ -64,6 +64,7 @@ import UniqSet ( emptyUniqSet, unitUniqSet, mkUniqSet,
addOneToUniqSet, unionUniqSets
)
import Usage ( SYN_IE(UVar) )
+import Maybes ( maybeToBool )
import Util ( isIn, panic, assertPanic )
\end{code}
@@ -179,6 +180,7 @@ mkFormSummary expr
go n (App fun other_arg) = go n fun
go n (Var f) | isBottomingId f = BottomForm
+ | isDataCon f = ValueForm -- Can happen inside imported unfoldings
go 0 (Var f) = VarForm
go n (Var f) = case getIdArity f of
ArityExactly a | n < a -> ValueForm
@@ -235,39 +237,31 @@ calcUnfoldingGuidance
calcUnfoldingGuidance True bOMB_OUT_SIZE expr = UnfoldAlways -- Always inline if the INLINE pragma says so
-calcUnfoldingGuidance False any_size (Con _ _ ) = UnfoldAlways -- We are very gung ho about inlining
-calcUnfoldingGuidance False any_size (Lit _) = UnfoldAlways -- constructors and literals
-
calcUnfoldingGuidance False bOMB_OUT_SIZE expr
= let
(use_binders, ty_binders, val_binders, body) = collectBinders expr
in
case (sizeExpr bOMB_OUT_SIZE val_binders body) of
- Nothing -> UnfoldNever
+ Nothing -> UnfoldNever
Just (size, cased_args)
- -> let
- uf = UnfoldIfGoodArgs
+ -> UnfoldIfGoodArgs
(length ty_binders)
(length val_binders)
(map discount_for val_binders)
size
-
- discount_for b
+ where
+ discount_for b
| is_data && b `is_elem` cased_args = tyConFamilySize tycon
| otherwise = 0
where
(is_data, tycon)
- = --trace "CoreUnfold.getAppDataTyConExpandingDicts:1" $
- case (maybeAppDataTyConExpandingDicts (idType b)) of
+ = case (maybeAppDataTyConExpandingDicts (idType b)) of
Nothing -> (False, panic "discount")
Just (tc,_,_) -> (True, tc)
- in
- -- pprTrace "calcUnfold:" (ppAbove (ppr PprDebug uf) (ppr PprDebug expr))
- uf
- where
- is_elem = isIn "calcUnfoldingGuidance"
+
+ is_elem = isIn "calcUnfoldingGuidance"
\end{code}
\begin{code}
@@ -280,13 +274,31 @@ sizeExpr :: Int -- Bomb out if it gets bigger than this
)
sizeExpr bOMB_OUT_SIZE args expr
+
+ | data_or_prim fun
+-- We are very keen to inline literals, constructors, or primitives
+-- including their slightly-disguised forms as applications (the latter
+-- can show up in the bodies of things imported from interfaces).
+ = Just (0, [])
+
+ | otherwise
= size_up expr
where
- size_up (Var v) = sizeOne
- size_up (App fun arg) = size_up fun `addSize` size_up_arg arg
+ (fun, _) = splitCoreApps expr
+ data_or_prim (Var v) = maybeToBool (isPrimitiveId_maybe v) ||
+ isDataCon v
+ data_or_prim (Con _ _) = True
+ data_or_prim (Prim _ _) = True
+ data_or_prim (Lit _) = True
+ data_or_prim other = False
+
+ size_up (Var v) = sizeZero
+ size_up (App fun arg) = size_up fun `addSize` size_up_arg arg `addSizeN` 1
+ -- 1 for application node
+
size_up (Lit lit) = if isNoRepLit lit
then sizeN uNFOLDING_NOREP_LIT_COST
- else sizeOne
+ else sizeZero
-- I don't understand this hack so I'm removing it! SLPJ Nov 96
-- size_up (SCC _ (Con _ _)) = Nothing -- **** HACK *****
@@ -294,8 +306,10 @@ sizeExpr bOMB_OUT_SIZE args expr
size_up (SCC lbl body) = size_up body -- SCCs cost nothing
size_up (Coerce _ _ body) = size_up body -- Coercions cost nothing
- size_up (Con con args) = -- 1 + # of val args
- sizeN (1 + numValArgs args)
+ size_up (Con con args) = sizeN (numValArgs args)
+ -- We don't count 1 for the constructor because we're
+ -- quite keen to get constructors into the open
+
size_up (Prim op args) = sizeN op_cost -- NB: no charge for PrimOp args
where
op_cost = if primOpCanTriggerGC op
@@ -331,16 +345,23 @@ sizeExpr bOMB_OUT_SIZE args expr
-- We charge for the "case" itself in "size_up_alts"
------------
- size_up_arg arg = if isValArg arg then sizeOne else sizeZero{-it's free-}
+ size_up_arg (LitArg lit) | isNoRepLit lit = sizeN uNFOLDING_NOREP_LIT_COST
+ size_up_arg other = sizeZero
------------
size_up_alts scrut_ty (AlgAlts alts deflt)
- = foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts
- `addSizeN` (if is_data then tyConFamilySize tycon else 1{-??-})
+ = foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts `addSizeN` 1
+ -- "1" for the case itself
+
+ -- `addSizeN` (if is_data then tyConFamilySize tycon else 1)
+ --
+ -- OLD COMMENT: looks unfair to me! So I've nuked this extra charge
+ -- SLPJ Jan 97
-- NB: we charge N for an alg. "case", where N is
-- the number of constructors in the thing being eval'd.
-- (You'll eventually get a "discount" of N if you
-- think the "case" is likely to go away.)
+
where
size_alg_alt (con,args,rhs) = size_up rhs
-- Don't charge for args, so that wrappers look cheap
@@ -367,8 +388,8 @@ sizeExpr bOMB_OUT_SIZE args expr
-- Second, we want to charge nothing for the srutinee if it's just
-- a variable. That way wrapper-like things look cheap.
size_up_scrut (Var v) | v `is_elem` args = Just (0, [v])
- | otherwise = Just (0, [])
- size_up_scrut other = size_up other
+ | otherwise = Just (0, [])
+ size_up_scrut other = size_up other
is_elem :: Id -> [Id] -> Bool
is_elem = isIn "size_up_scrut"
@@ -393,6 +414,12 @@ sizeExpr bOMB_OUT_SIZE args expr
where
tot = n+m
xys = xs ++ ys
+
+splitCoreApps e
+ = go e []
+ where
+ go (App fun arg) args = go fun (arg:args)
+ go fun args = (fun,args)
\end{code}
%************************************************************************
diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index 1e1cc3e17cca47790a7416639b54afd7aeaf3a22..486a1889beb680a6e46019180eef03fbeb195f11 100644
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -249,7 +249,8 @@ instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where
ppCurlies (ppInterleave pp'SP (map pp_field fields))
]
where
- pp_field (n, ty) = ppCat [ppr sty n, ppPStr SLIT("::"), ppr_bang sty ty]
+ pp_field (ns, ty) = ppCat [ppCat (map (ppr sty . getOccName) ns),
+ ppPStr SLIT("::"), ppr_bang sty ty]
ppr_bang sty (Banged ty) = ppBeside (ppChar '!') (pprParendHsType sty ty)
ppr_bang sty (Unbanged ty) = pprParendHsType sty ty
diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs
index dc60530da2ff3728d140e01f7876cba2457affff..425ee72ab265cf9ccad1618a62e02d4eede20fe5 100644
--- a/ghc/compiler/hsSyn/HsTypes.lhs
+++ b/ghc/compiler/hsSyn/HsTypes.lhs
@@ -56,11 +56,8 @@ data HsType name
| MonoTyVar name -- Type variable
- | MonoTyApp name -- Type constructor or variable
- [HsType name]
-
- -- We *could* have a "MonoTyCon name" equiv to "MonoTyApp name []"
- -- (for efficiency, what?) WDP 96/02/18
+ | MonoTyApp (HsType name)
+ (HsType name)
| MonoFunTy (HsType name) -- function type
(HsType name)
@@ -167,13 +164,9 @@ ppr_mono_ty sty ctxt_prec (MonoTupleTy _ tys)
ppr_mono_ty sty ctxt_prec (MonoListTy _ ty)
= ppBesides [ppLbrack, ppr_mono_ty sty pREC_TOP ty, ppRbrack]
-ppr_mono_ty sty ctxt_prec (MonoTyApp tycon tys)
- = let pp_tycon = ppr_hs_tyname sty tycon in
- if null tys then
- pp_tycon
- else
- maybeParen (ctxt_prec >= pREC_CON)
- (ppCat [pp_tycon, ppInterleave ppNil (map (ppr_mono_ty sty pREC_CON) tys)])
+ppr_mono_ty sty ctxt_prec (MonoTyApp fun_ty arg_ty)
+ = maybeParen (ctxt_prec >= pREC_CON)
+ (ppCat [ppr_mono_ty sty pREC_FUN fun_ty, ppr_mono_ty sty pREC_CON arg_ty])
ppr_mono_ty sty ctxt_prec (MonoDictTy clas ty)
= ppCurlies (ppCat [ppr sty clas, ppr_mono_ty sty pREC_CON ty])
@@ -221,9 +214,8 @@ cmpHsType cmp (MonoTupleTy _ tys1) (MonoTupleTy _ tys2)
cmpHsType cmp (MonoListTy _ ty1) (MonoListTy _ ty2)
= cmpHsType cmp ty1 ty2
-cmpHsType cmp (MonoTyApp tc1 tys1) (MonoTyApp tc2 tys2)
- = cmp tc1 tc2 `thenCmp`
- cmpList (cmpHsType cmp) tys1 tys2
+cmpHsType cmp (MonoTyApp fun_ty1 arg_ty1) (MonoTyApp fun_ty2 arg_ty2)
+ = cmpHsType cmp fun_ty1 fun_ty2 `thenCmp` cmpHsType cmp arg_ty1 arg_ty2
cmpHsType cmp (MonoFunTy a1 b1) (MonoFunTy a2 b2)
= cmpHsType cmp a1 a2 `thenCmp` cmpHsType cmp b1 b2
diff --git a/ghc/compiler/main/Constants.lhs b/ghc/compiler/main/Constants.lhs
index aaafe10d2b344b0b0eb63991d0c51f34806cb395..536ebb5706eeda5dca3d99362350dbdeaad15b77 100644
--- a/ghc/compiler/main/Constants.lhs
+++ b/ghc/compiler/main/Constants.lhs
@@ -83,7 +83,7 @@ import Util
All pretty arbitrary:
\begin{code}
-uNFOLDING_USE_THRESHOLD = ( 3 :: Int)
+uNFOLDING_USE_THRESHOLD = ( 8 :: Int)
uNFOLDING_CREATION_THRESHOLD = (30 :: Int)
iNTERFACE_UNFOLD_THRESHOLD = (30 :: Int)
lIBERATE_CASE_THRESHOLD = (10 :: Int)
@@ -91,7 +91,7 @@ lIBERATE_CASE_THRESHOLD = (10 :: Int)
uNFOLDING_CHEAP_OP_COST = ( 1 :: Int)
uNFOLDING_DEAR_OP_COST = ( 4 :: Int)
-uNFOLDING_NOREP_LIT_COST = ( 4 :: Int)
+uNFOLDING_NOREP_LIT_COST = ( 20 :: Int) -- Strings can be pretty big
uNFOLDING_CON_DISCOUNT_WEIGHT = ( 1 :: Int)
\end{code}
diff --git a/ghc/compiler/parser/hsparser.y b/ghc/compiler/parser/hsparser.y
index 930f6d50d06944c0bbdf5900f7c20d380ba63cea..5212226d0a412787c61043db9a4a6707c0a6549b 100644
--- a/ghc/compiler/parser/hsparser.y
+++ b/ghc/compiler/parser/hsparser.y
@@ -228,7 +228,7 @@ BOOLEAN inpat;
constrs constr1 fields
types atypes batypes
types_and_maybe_ids
- pats context context_list tyvar_list
+ pats context context_list /* tyvar_list */
export_list enames
import_list inames
impdecls maybeimpdecls impdecl
@@ -269,9 +269,11 @@ BOOLEAN inpat;
%type <upbinding> valrhs1 altrest
%type <uttype> simple ctype type atype btype
- gtyconapp ntyconapp ntycon gtyconvars
- bbtype batype btyconapp
- class restrict_inst general_inst tyvar
+ gtyconvars
+ bbtype batype
+ class tyvar
+/* gtyconapp0 gtyconapp1 ntyconapp0 ntyconapp1 btyconapp */
+/* restrict_inst general_inst */
%type <uconstr> constr field
@@ -513,9 +515,9 @@ cbody : /* empty */ { $$ = mknullbind(); }
| WHERE vocurly decls vccurly { checkorder($3); $$ = $3; }
;
-instd : instkey context DARROW gtycon restrict_inst rinst
+instd : instkey context DARROW gtycon atype rinst
{ $$ = mkibind($2,$4,$5,$6,startlineno); }
- | instkey gtycon general_inst rinst
+ | instkey gtycon atype rinst
{ $$ = mkibind(Lnil,$2,$3,$4,startlineno); }
;
@@ -524,6 +526,13 @@ rinst : /* empty */ { $$ = mknullbind(); }
| WHERE vocurly instdefs vccurly { $$ = $3; }
;
+/* I now allow a general type in instance declarations, relying
+ on the type checker to reject instance decls which are ill-formed.
+ Some (non-standard) extensions of Haskell may allow more general
+ types than the Report syntax permits, and in any case not all things
+ can be checked in the syntax (eg repeated type variables).
+ SLPJ Jan 97
+
restrict_inst : gtycon { $$ = mktname($1); }
| OPAREN gtyconvars CPAREN { $$ = $2; }
| OPAREN tyvar COMMA tyvar_list CPAREN { $$ = mkttuple(mklcons($2,$4)); }
@@ -532,11 +541,12 @@ restrict_inst : gtycon { $$ = mktname($1); }
;
general_inst : gtycon { $$ = mktname($1); }
- | OPAREN gtyconapp CPAREN { $$ = $2; }
+ | OPAREN gtyconapp1 CPAREN { $$ = $2; }
| OPAREN type COMMA types CPAREN { $$ = mkttuple(mklcons($2,$4)); }
| OBRACK type CBRACK { $$ = mktllist($2); }
| OPAREN btype RARROW type CPAREN { $$ = mktfun($2,$4); }
;
+*/
defaultd: defaultkey OPAREN types CPAREN { $$ = mkdbind($3,startlineno); }
| defaultkey OPAREN CPAREN { $$ = mkdbind(Lnil,startlineno); }
@@ -579,7 +589,7 @@ decl : qvarsk DCOLON ctype
PREVPATT = NULL; FN = NULL; SAMEFN = 0;
}
- | SPECIALISE_UPRAGMA INSTANCE gtycon general_inst END_UPRAGMA
+ | SPECIALISE_UPRAGMA INSTANCE gtycon atype END_UPRAGMA
{
$$ = mkispec_uprag($3, $4, startlineno);
PREVPATT = NULL; FN = NULL; SAMEFN = 0;
@@ -663,25 +673,12 @@ type : btype { $$ = $1; }
| btype RARROW type { $$ = mktfun($1,$3); }
;
-/* btype is split so we can parse gtyconapp without S/R conflicts */
-btype : gtyconapp { $$ = $1; }
- | ntyconapp { $$ = $1; }
- ;
-
-ntyconapp: ntycon { $$ = $1; }
- | ntyconapp atype { $$ = mktapp($1,$2); }
- ;
-
-gtyconapp: gtycon { $$ = mktname($1); }
- | gtyconapp atype { $$ = mktapp($1,$2); }
+btype : atype { $$ = $1; }
+ | btype atype { $$ = mktapp($1,$2); }
;
-
atype : gtycon { $$ = mktname($1); }
- | ntycon { $$ = $1; }
- ;
-
-ntycon : tyvar { $$ = $1; }
+ | tyvar { $$ = $1; }
| OPAREN type COMMA types CPAREN { $$ = mkttuple(mklcons($2,$4)); }
| OBRACK type CBRACK { $$ = mktllist($2); }
| OPAREN type CPAREN { $$ = $2; }
@@ -737,23 +734,47 @@ constrs : constr { $$ = lsing($1); }
| constrs VBAR constr { $$ = lapp($1,$3); }
;
-constr : btyconapp { qid tyc; list tys;
+constr :
+/* This stuff looks really baroque. I've replaced it with simpler stuff.
+ SLPJ Jan 97
+
+ btyconapp { qid tyc; list tys;
splittyconapp($1, &tyc, &tys);
$$ = mkconstrpre(tyc,tys,hsplineno); }
- | OPAREN qconsym CPAREN { $$ = mkconstrpre($2,Lnil,hsplineno); }
- | OPAREN qconsym CPAREN batypes { $$ = mkconstrpre($2,$4,hsplineno); }
- | btyconapp qconop bbtype { checknobangs($1);
+ | btyconapp qconop bbtype { checknobangs($1);
$$ = mkconstrinf($1,$2,$3,hsplineno); }
- | ntyconapp qconop bbtype { $$ = mkconstrinf($1,$2,$3,hsplineno); }
+ | ntyconapp0 qconop bbtype { $$ = mkconstrinf($1,$2,$3,hsplineno); }
+
| BANG atype qconop bbtype { $$ = mkconstrinf(mktbang($2),$3,$4,hsplineno); }
+ | OPAREN qconsym CPAREN { $$ = mkconstrpre($2,Lnil,hsplineno); }
+*/
- /* 1 S/R conflict on OCURLY -> shift */
+ btype { qid tyc; list tys;
+ splittyconapp($1, &tyc, &tys);
+ $$ = mkconstrpre(tyc,tys,hsplineno); }
+ /* We have to parse the constructor application as a *type*, else we get
+ into terrible ambiguity problems. Consider the difference between
+
+ data T = S Int Int Int `R` Int
+ and
+ data T = S Int Int Int
+
+ It isn't till we get to the operator that we discover that the "S" is
+ part of a type in the first, but part of a constructor application in the
+ second.
+ */
+
+ | OPAREN qconsym CPAREN batypes { $$ = mkconstrpre($2,$4,hsplineno); }
+ | bbtype qconop bbtype { $$ = mkconstrinf($1,$2,$3,hsplineno); }
| gtycon OCURLY fields CCURLY { $$ = mkconstrrec($1,$3,hsplineno); }
+ /* 1 S/R conflict on OCURLY -> shift */
;
+/*
btyconapp: gtycon { $$ = mktname($1); }
| btyconapp batype { $$ = mktapp($1,$2); }
;
+*/
bbtype : btype { $$ = $1; }
| BANG atype { $$ = mktbang($2); }
@@ -763,7 +784,7 @@ batype : atype { $$ = $1; }
| BANG atype { $$ = mktbang($2); }
;
-batypes : batype { $$ = lsing($1); }
+batypes : { $$ = Lnil; }
| batypes batype { $$ = lapp($1,$2); }
;
@@ -1452,9 +1473,11 @@ tycon : CONID
modid : CONID
;
+/*
tyvar_list: tyvar { $$ = lsing($1); }
| tyvar_list COMMA tyvar { $$ = lapp($1,$3); }
;
+*/
/**********************************************************************
* *
diff --git a/ghc/compiler/parser/id.c b/ghc/compiler/parser/id.c
index 9fac62b0b51f39badf149dda79a12132633cadca..457dbd812a9a1c12522aad6edc87619f29925c2f 100644
--- a/ghc/compiler/parser/id.c
+++ b/ghc/compiler/parser/id.c
@@ -279,7 +279,7 @@ creategid(i)
{
switch(i) {
case -2:
- return(mkgid(i,install_literal("(->)")));
+ return(mkgid(i,install_literal("->")));
case -1:
return(mkgid(i,install_literal("[]")));
case 0:
diff --git a/ghc/compiler/parser/printtree.c b/ghc/compiler/parser/printtree.c
index 45c89be0ada659d4af2493b09f07841ed734707c..2d840a46b49f289f2678a2323587b4f1af94526a 100644
--- a/ghc/compiler/parser/printtree.c
+++ b/ghc/compiler/parser/printtree.c
@@ -19,7 +19,7 @@
/* fwd decls, necessary and otherwise */
static void pbool PROTO( (BOOLEAN) );
static void pconstr PROTO( (constr) );
-static void pcoresyn PROTO((coresyn));
+/* static void pcoresyn PROTO((coresyn)); */
static void pentid PROTO( (entidt) );
static void pgrhses PROTO( (list) );
static void pid PROTO( (id) );
@@ -27,12 +27,13 @@ static void plist PROTO( (void (*)(/*NOT WORTH IT: void * */), list) );
static void pmaybe PROTO( (void (*)(), maybe) );
static void pmaybe_list PROTO( (void (*)(), maybe) );
static void ppbinding PROTO((pbinding));
-static void ppragma PROTO( (hpragma) );
+/* static void ppragma PROTO( (hpragma) ); */
static void pqid PROTO( (qid) );
static void prbind PROTO( (binding) );
static void pstr PROTO( (char *) );
static void ptree PROTO( (tree) );
static void pttype PROTO( (ttype) );
+static void plineno PROTO( (long) );
extern char *input_filename;
extern BOOLEAN hashIds;
@@ -91,6 +92,15 @@ print_string(hstring str)
putchar('\t');
}
+static void
+plineno (l)
+long l;
+{
+ printf("#%lu\t",l);
+ return;
+}
+
+
static int
get_character(hstring str)
{
@@ -153,21 +163,7 @@ pliteral(literal t)
case clitlit:
PUTTAG('Y');
pstr(gclitlit(t));
- pstr(gclitlit_kind(t));
- break;
-
- case norepi:
- PUTTAG('I');
- pstr(gnorepi(t));
- break;
- case norepr:
- PUTTAG('R');
- pstr(gnorepr_n(t));
- pstr(gnorepr_d(t));
- break;
- case noreps:
- PUTTAG('s');
- print_string(gnoreps(t));
+ /* pstr(gclitlit_kind(t)); */
break;
default:
error("Bad pliteral");
@@ -180,17 +176,22 @@ ptree(t)
{
again:
switch(ttree(t)) {
- case par: t = gpare(t); goto again;
case hmodule:
PUTTAG('M');
- printf("#%lu\t",ghmodline(t));
+ plineno(ghmodline(t));
pid(ghname(t));
+ printf("#%lu\t",ghversion(t));
pstr(input_filename);
prbind(ghmodlist(t));
/* pfixes(); */
plist(prbind, ghimplist(t));
pmaybe_list(pentid, ghexplist(t));
break;
+ case fixop:
+ PUTTAG('I');
+ pqid(gfixop(t));
+ printf("%lu\t%lu",gfixinfx(t),gfixprec(t));
+ break;
case ident:
PUTTAG('i');
pqid(gident(t));
@@ -211,9 +212,13 @@ again:
ptree(ginfarg1(t));
ptree(ginfarg2(t));
break;
+ case negate:
+ PUTTAG('-');
+ ptree(gnexp(t));
+ break;
case lambda:
PUTTAG('l');
- printf("#%lu\t",glamline(t));
+ plineno(glamline(t));
plist(ptree,glampats(t));
ptree(glamexpr(t));
break;
@@ -225,6 +230,7 @@ again:
break;
case casee:
PUTTAG('c');
+ plineno(gcaseline(t));
ptree(gcaseexpr(t));
plist(ppbinding, gcasebody(t));
break;
@@ -234,13 +240,45 @@ again:
ptree(gifthen(t));
ptree(gifelse(t));
break;
- /* case doe: */
- /* case dobind: */
- /* case doexp: */
- /* case seqlet: */
- /* case record: */
- /* case rupdate: */
- /* case rbind: */
+ case doe:
+ PUTTAG('O');
+ plineno(gdoline(t));
+ plist(ptree, gdo(t));
+ break;
+ case dobind:
+ PUTTAG('Q');
+ plineno(gdobindline(t));
+ ptree(gdobindpat(t));
+ ptree(gdobindexp(t));
+ break;
+ case doexp:
+ PUTTAG('R');
+ plineno(gdoexpline(t));
+ ptree(gdoexp(t));
+ break;
+ case seqlet:
+ PUTTAG('U');
+ prbind(gseqlet(t));
+ break;
+ case record:
+ PUTTAG('d');
+ pqid(grcon(t));
+ plist(prbind,grbinds(t));
+ break;
+
+ case rupdate:
+ PUTTAG('h');
+ ptree(gupdexp(t));
+ plist(prbind,gupdbinds(t));
+ break;
+
+ case rbind:
+ PUTTAG('o');
+ pqid(grbindvar(t));
+ pmaybe(ptree,grbindexp(t));
+ break;
+
+ case par: t = gpare(t); goto again;
case as:
PUTTAG('s');
@@ -309,10 +347,6 @@ again:
print_string(gsccid(t));
ptree(gsccexp(t));
break;
- case negate:
- PUTTAG('-');
- ptree(gnexp(t));
- break;
default:
error("Bad ptree");
}
@@ -392,28 +426,34 @@ prbind(b)
switch(tbinding(b)) {
case tbind:
PUTTAG('t');
- printf("#%lu\t",gtline(b));
+ plineno(gtline(b));
plist(pttype, gtbindc(b));
pmaybe_list(pid, gtbindd(b));
pttype(gtbindid(b));
plist(pconstr, gtbindl(b));
- ppragma(gtpragma(b));
break;
- /* case ntbind: */
+ case ntbind:
+ PUTTAG('q');
+ plineno(gntline(b));
+ plist(pttype,gntbindcty(b));
+ pmaybe_list(pid, gntbindd(b));
+ pttype(gntbindid(b));
+ plist(pconstr, gntbindcty(b));
+ break;
case nbind :
PUTTAG('n');
- printf("#%lu\t",gnline(b));
+ plineno(gnline(b));
pttype(gnbindid(b));
pttype(gnbindas(b));
break;
case pbind :
PUTTAG('p');
- printf("#%lu\t",gpline(b));
+ plineno(gpline(b));
plist(ppbinding, gpbindl(b));
break;
case fbind :
PUTTAG('f');
- printf("#%lu\t",gfline(b));
+ plineno(gfline(b));
plist(ppbinding, gfbindl(b));
break;
case abind :
@@ -421,92 +461,105 @@ prbind(b)
prbind(gabindfst(b));
prbind(gabindsnd(b));
break;
- case cbind :
- PUTTAG('$');
- printf("#%lu\t",gcline(b));
- plist(pttype,gcbindc(b));
- pttype(gcbindid(b));
- prbind(gcbindw(b));
- ppragma(gcpragma(b));
- break;
case ibind :
PUTTAG('%');
- printf("#%lu\t",giline(b));
+ plineno(giline(b));
plist(pttype,gibindc(b));
pqid(gibindid(b));
pttype(gibindi(b));
prbind(gibindw(b));
- ppragma(gipragma(b));
+ /* ppragma(gipragma(b)); */
break;
case dbind :
PUTTAG('D');
- printf("#%lu\t",gdline(b));
+ plineno(gdline(b));
plist(pttype,gdbindts(b));
break;
+ case cbind :
+ PUTTAG('$');
+ plineno(gcline(b));
+ plist(pttype,gcbindc(b));
+ pttype(gcbindid(b));
+ prbind(gcbindw(b));
+ break;
+
/* signature(-like) things, including user pragmas */
case sbind :
- PUTTAGSTR("St");
- printf("#%lu\t",gsline(b));
+ PUTTAG('r');
+ plineno(gsline(b));
plist(pqid,gsbindids(b));
pttype(gsbindid(b));
- ppragma(gspragma(b));
break;
+ case nullbind :
+ PUTTAG('B');
+ break;
+
+ case import:
+ PUTTAG('e');
+ plineno(gibindline(b));
+ /* pid(gibindfile(b)); */
+ pid(gibindimod(b));
+ printf("#%lu\t",gibindqual(b)); /* 1 -- qualified */
+ pmaybe(pid, gibindas(b));
+ pmaybe(pconstr, gibindspec(b));
+ /* plist(pentid,giebindexp(b)); ??? */
+ /* prbind(giebinddef(b)); ???? */
+ break;
+
+ /* User pragmas till the end */
+
case vspec_uprag:
PUTTAGSTR("Ss");
- printf("#%lu\t",gvspec_line(b));
+ plineno(gvspec_line(b));
pqid(gvspec_id(b));
plist(pttype,gvspec_tys(b));
break;
+ case vspec_ty_and_id:
+ PUTTAGSTR("St");
+ pttype(gvspec_ty(b));
+ pmaybe(pttype,gvspec_tyid(b));
+ break;
+
case ispec_uprag:
PUTTAGSTR("SS");
- printf("#%lu\t",gispec_line(b));
+ plineno(gispec_line(b));
pqid(gispec_clas(b));
pttype(gispec_ty(b));
break;
case inline_uprag:
PUTTAGSTR("Si");
- printf("#%lu\t",ginline_line(b));
+ plineno(ginline_line(b));
pqid(ginline_id(b));
break;
case deforest_uprag:
PUTTAGSTR("Sd");
- printf("#%lu\t",gdeforest_line(b));
+ plineno(gdeforest_line(b));
pqid(gdeforest_id(b));
break;
case magicuf_uprag:
PUTTAGSTR("Su");
- printf("#%lu\t",gmagicuf_line(b));
+ plineno(gmagicuf_line(b));
pqid(gmagicuf_id(b));
pid(gmagicuf_str(b));
break;
case dspec_uprag:
PUTTAGSTR("Sd");
- printf("#%lu\t",gdspec_line(b));
+ plineno(gdspec_line(b));
pqid(gdspec_id(b));
plist(pttype,gdspec_tys(b));
break;
/* end of signature(-like) things */
-
+/* not used:
case mbind:
PUTTAG('7');
- printf("#%lu\t",gmline(b));
+ plineno(gmline(b));
pid(gmbindmodn(b));
plist(pentid,gmbindimp(b));
break;
- case import:
- PUTTAG('e');
- printf("#%lu\t",gibindline(b));
- pid(gibindfile(b));
- pid(gibindimod(b));
- /* plist(pentid,giebindexp(b)); ??? */
- /* prbind(giebinddef(b)); ???? */
- break;
- case nullbind :
- PUTTAG('B');
- break;
+*/
default : error("Bad prbind");
break;
}
@@ -521,7 +574,7 @@ pttype(t)
pqid(gtypeid(t));
break;
case namedtvar : PUTTAG('y');
- pid(gnamedtvar(t));
+ pqid(gnamedtvar(t));
break;
case tllist : PUTTAG(':');
pttype(gtlist(t));
@@ -544,19 +597,6 @@ pttype(t)
plist(pttype,gtcontextl(t));
pttype(gtcontextt(t));
break;
-
- case unidict : PUTTAGSTR("2A");
- pqid(gunidict_clas(t));
- pttype(gunidict_ty(t));
- break;
- case unityvartemplate : PUTTAGSTR("2B");
- pid(gunityvartemplate(t));
- break;
- case uniforall : PUTTAGSTR("2C");
- plist(pid,guniforall_tv(t));
- pttype(guniforall_ty(t));
- break;
-
default : error("bad pttype");
}
}
@@ -568,18 +608,35 @@ pconstr(a)
switch (tconstr(a)) {
case constrpre :
PUTTAG('1');
- printf("#%lu\t",gconcline(a));
+ plineno(gconcline(a));
pqid(gconcid(a));
plist(pttype, gconctypel(a));
break;
case constrinf :
PUTTAG('2');
- printf("#%lu\t",gconiline(a));
+ plineno(gconiline(a));
pqid(gconiop(a));
pttype(gconity1(a));
pttype(gconity2(a));
break;
+ case constrrec :
+ PUTTAG('u');
+ plineno(gconrline(a));
+ pqid(gconrid(a));
+ plist(pqid,gconrfieldl(a));
+ break;
+ case constrnew :
+ PUTTAG('v');
+ plineno(gconnline(a));
+ pqid(gconnid(a));
+ pttype(gconnty(a));
+ break;
+ case field :
+ PUTTAG('5');
+ plist(pqid,gfieldn(a));
+ pttype(gfieldt(a));
+ break;
default : fprintf(stderr, "Bad tag in abstree %d\n", tconstr(a));
exit(1);
}
@@ -619,12 +676,25 @@ ppbinding(p)
{
switch(tpbinding(p)) {
case pgrhs : PUTTAG('W');
- printf("#%lu\t",ggline(p));
+ plineno(ggline(p));
pqid(ggfuncname(p));
ptree(ggpat(p));
- plist(pgrhses,ggdexprs(p));
+ ppbinding(ggdexprs(p));
prbind(ggbind(p));
break;
+ case pnoguards :
+ PUTTAG('6');
+ ptree(gpnoguard(p));
+ break;
+ case pguards :
+ PUTTAG('9');
+ plist(ptree, gpguards(p));
+ break;
+ case pgdexp :
+ PUTTAG('&');
+ ptree(gpguard(p));
+ ptree(gpexp(p));
+ break;
default :
error("Bad pbinding");
}
@@ -638,7 +708,7 @@ pgrhses(l)
ptree(lhd(l)); /* Guard */
ptree(lhd(ltl(l))); /* Expression */
}
-
+/*
static void
ppragma(p)
hpragma p;
@@ -661,12 +731,12 @@ ppragma(p)
break;
case iinst_simpl_pragma: PUTTAGSTR("Pis");
-/* pid(gprag_imod_simpl(p));
-*/ ppragma(gprag_dfun_simpl(p));
+/ * pid(gprag_imod_simpl(p));
+* / ppragma(gprag_dfun_simpl(p));
break;
case iinst_const_pragma: PUTTAGSTR("Pic");
-/* pid(gprag_imod_const(p));
-*/ ppragma(gprag_dfun_const(p));
+/ * pid(gprag_imod_const(p));
+* / ppragma(gprag_dfun_const(p));
plist(ppragma, gprag_constms(p));
break;
@@ -725,6 +795,7 @@ ppragma(p)
default: error("Bad Pragma");
}
}
+*/
static void
pbool(b)
@@ -737,198 +808,3 @@ pbool(b)
}
}
-static void
-pcoresyn(p)
- coresyn p;
-{
- switch(tcoresyn(p)) {
- case cobinder: PUTTAGSTR("Fa");
- pid(gcobinder_v(p));
- pttype(gcobinder_ty(p));
- break;
-
- case colit: PUTTAGSTR("Fb");
- pliteral(gcolit(p));
- break;
- case colocal: PUTTAGSTR("Fc");
- pcoresyn(gcolocal_v(p));
- break;
-
- case cononrec: PUTTAGSTR("Fd");
- pcoresyn(gcononrec_b(p));
- pcoresyn(gcononrec_rhs(p));
- break;
- case corec: PUTTAGSTR("Fe");
- plist(pcoresyn,gcorec(p));
- break;
- case corec_pair: PUTTAGSTR("Ff");
- pcoresyn(gcorec_b(p));
- pcoresyn(gcorec_rhs(p));
- break;
-
- case covar: PUTTAGSTR("Fg");
- pcoresyn(gcovar(p));
- break;
- case coliteral: PUTTAGSTR("Fh");
- pliteral(gcoliteral(p));
- break;
- case cocon: PUTTAGSTR("Fi");
- pcoresyn(gcocon_con(p));
- plist(pttype, gcocon_tys(p));
- plist(pcoresyn, gcocon_args(p));
- break;
- case coprim: PUTTAGSTR("Fj");
- pcoresyn(gcoprim_op(p));
- plist(pttype, gcoprim_tys(p));
- plist(pcoresyn, gcoprim_args(p));
- break;
- case colam: PUTTAGSTR("Fk");
- plist(pcoresyn, gcolam_vars(p));
- pcoresyn(gcolam_body(p));
- break;
- case cotylam: PUTTAGSTR("Fl");
- plist(pid, gcotylam_tvs(p));
- pcoresyn(gcotylam_body(p));
- break;
- case coapp: PUTTAGSTR("Fm");
- pcoresyn(gcoapp_fun(p));
- plist(pcoresyn, gcoapp_args(p));
- break;
- case cotyapp: PUTTAGSTR("Fn");
- pcoresyn(gcotyapp_e(p));
- pttype(gcotyapp_t(p));
- break;
- case cocase: PUTTAGSTR("Fo");
- pcoresyn(gcocase_s(p));
- pcoresyn(gcocase_alts(p));
- break;
- case colet: PUTTAGSTR("Fp");
- pcoresyn(gcolet_bind(p));
- pcoresyn(gcolet_body(p));
- break;
- case coscc: PUTTAGSTR("Fz"); /* out of order! */
- pcoresyn(gcoscc_scc(p));
- pcoresyn(gcoscc_body(p));
- break;
-
- case coalg_alts: PUTTAGSTR("Fq");
- plist(pcoresyn, gcoalg_alts(p));
- pcoresyn(gcoalg_deflt(p));
- break;
- case coalg_alt: PUTTAGSTR("Fr");
- pcoresyn(gcoalg_con(p));
- plist(pcoresyn, gcoalg_bs(p));
- pcoresyn(gcoalg_rhs(p));
- break;
- case coprim_alts: PUTTAGSTR("Fs");
- plist(pcoresyn, gcoprim_alts(p));
- pcoresyn(gcoprim_deflt(p));
- break;
- case coprim_alt: PUTTAGSTR("Ft");
- pliteral(gcoprim_lit(p));
- pcoresyn(gcoprim_rhs(p));
- break;
- case conodeflt: PUTTAGSTR("Fu");
- break;
- case cobinddeflt: PUTTAGSTR("Fv");
- pcoresyn(gcobinddeflt_v(p));
- pcoresyn(gcobinddeflt_rhs(p));
- break;
-
- case co_primop: PUTTAGSTR("Fw");
- pid(gco_primop(p));
- break;
- case co_ccall: PUTTAGSTR("Fx");
- pbool(gco_ccall_may_gc(p));
- pid(gco_ccall(p));
- plist(pttype, gco_ccall_arg_tys(p));
- pttype(gco_ccall_res_ty(p));
- break;
- case co_casm: PUTTAGSTR("Fy");
- pbool(gco_casm_may_gc(p));
- pliteral(gco_casm(p));
- plist(pttype, gco_casm_arg_tys(p));
- pttype(gco_casm_res_ty(p));
- break;
-
- /* Cost-centre stuff */
- case co_preludedictscc: PUTTAGSTR("F?a");
- pcoresyn(gco_preludedictscc_dupd(p));
- break;
- case co_alldictscc: PUTTAGSTR("F?b");
- print_string(gco_alldictscc_m(p));
- print_string(gco_alldictscc_g(p));
- pcoresyn(gco_alldictscc_dupd(p));
- break;
- case co_usercc: PUTTAGSTR("F?c");
- print_string(gco_usercc_n(p));
- print_string(gco_usercc_m(p));
- print_string(gco_usercc_g(p));
- pcoresyn(gco_usercc_dupd(p));
- pcoresyn(gco_usercc_cafd(p));
- break;
- case co_autocc: PUTTAGSTR("F?d");
- pcoresyn(gco_autocc_i(p));
- print_string(gco_autocc_m(p));
- print_string(gco_autocc_g(p));
- pcoresyn(gco_autocc_dupd(p));
- pcoresyn(gco_autocc_cafd(p));
- break;
- case co_dictcc: PUTTAGSTR("F?e");
- pcoresyn(gco_dictcc_i(p));
- print_string(gco_dictcc_m(p));
- print_string(gco_dictcc_g(p));
- pcoresyn(gco_dictcc_dupd(p));
- pcoresyn(gco_dictcc_cafd(p));
- break;
-
- case co_scc_noncaf: PUTTAGSTR("F?f");
- break;
- case co_scc_caf: PUTTAGSTR("F?g");
- break;
- case co_scc_nondupd: PUTTAGSTR("F?h");
- break;
- case co_scc_dupd: PUTTAGSTR("F?i");
- break;
-
- /* Id stuff */
- case co_id: PUTTAGSTR("F1");
- pid(gco_id(p));
- break;
- case co_orig_id: PUTTAGSTR("F9");
- pid(gco_orig_id_m(p));
- pid(gco_orig_id_n(p));
- break;
- case co_sdselid: PUTTAGSTR("F2");
- pid(gco_sdselid_c(p));
- pid(gco_sdselid_sc(p));
- break;
- case co_classopid: PUTTAGSTR("F3");
- pid(gco_classopid_c(p));
- pid(gco_classopid_o(p));
- break;
- case co_defmid: PUTTAGSTR("F4");
- pid(gco_defmid_c(p));
- pid(gco_defmid_op(p));
- break;
- case co_dfunid: PUTTAGSTR("F5");
- pid(gco_dfunid_c(p));
- pttype(gco_dfunid_ty(p));
- break;
- case co_constmid: PUTTAGSTR("F6");
- pid(gco_constmid_c(p));
- pid(gco_constmid_op(p));
- pttype(gco_constmid_ty(p));
- break;
- case co_specid: PUTTAGSTR("F7");
- pcoresyn(gco_specid_un(p));
- plist(pttype,gco_specid_tys(p));
- break;
- case co_wrkrid: PUTTAGSTR("F8");
- pcoresyn(gco_wrkrid_un(p));
- break;
- /* more to come?? */
-
- default : error("Bad Core syntax");
- }
-}
diff --git a/ghc/compiler/parser/syntax.c b/ghc/compiler/parser/syntax.c
index fec0ae8278633941f2f368bc8a24ea550f726e4d..509145360aeb0478b07c7cec4e85f468344ed1ab 100644
--- a/ghc/compiler/parser/syntax.c
+++ b/ghc/compiler/parser/syntax.c
@@ -543,18 +543,19 @@ splittyconapp(app, tyc, tys)
qid *tyc;
list *tys;
{
- if(tttype(app) == tapp)
- {
+ switch (tttype(app)) {
+ case tapp:
splittyconapp(gtapp((struct Stapp *)app), tyc, tys);
*tys = lapp(*tys, gtarg((struct Stapp *)app));
- }
- else if(tttype(app) == tname)
- {
+ break;
+
+ case tname:
+ case namedtvar:
*tyc = gtypeid((struct Stname *)app);
*tys = Lnil;
- }
- else
- {
+ break;
+
+ default:
hsperror("panic: splittyconap: bad tycon application (no tycon)");
}
}
diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs
index bd2f8e4a06506783493be73ae6b55a12b358c289..776ccfc7f143a2359ea227bf4db13d0edd10cbdb 100644
--- a/ghc/compiler/reader/RdrHsSyn.lhs
+++ b/ghc/compiler/reader/RdrHsSyn.lhs
@@ -114,7 +114,7 @@ extractHsTyVars :: HsType RdrName -> [RdrName]
extractHsTyVars ty
= get ty []
where
- get (MonoTyApp con tys) acc = foldr get (insert con acc) tys
+ get (MonoTyApp ty1 ty2) acc = get ty1 (get ty2 acc)
get (MonoListTy tc ty) acc = get ty acc
get (MonoTupleTy tc tys) acc = foldr get acc tys
get (MonoFunTy ty1 ty2) acc = get ty1 (get ty2 acc)
diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs
index 2d10052b0b72562afd652e396bb569c256a8fe9d..9dd701776b1fc1b7114efe14b2f82afc0aa20e22 100644
--- a/ghc/compiler/reader/ReadPrefix.lhs
+++ b/ghc/compiler/reader/ReadPrefix.lhs
@@ -154,7 +154,7 @@ rdModule
add_sig (BindWith b ss) s = BindWith b (s:ss)
add_sig _ _ = panic "rdModule:add_sig"
- io_ty t = MonoTyApp (Unqual (TCOcc t)) [MonoTupleTy dummyRdrTcName []]
+ io_ty t = MonoTyApp (MonoTyVar (Unqual (TCOcc t))) (MonoTupleTy dummyRdrTcName [])
\end{code}
%************************************************************************
@@ -661,7 +661,7 @@ wlk_sig_thing (U_dspec_uprag itycon dspec_tys srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
wlkTCId itycon `thenUgn` \ tycon ->
wlkList rdMonoType dspec_tys `thenUgn` \ tys ->
- returnUgn (RdrSpecDataSig (SpecDataSig tycon (MonoTyApp tycon tys) src_loc))
+ returnUgn (RdrSpecDataSig (SpecDataSig tycon (foldl MonoTyApp (MonoTyVar tycon) tys) src_loc))
-- value inlining user-pragma
wlk_sig_thing (U_inline_uprag ivar srcline)
@@ -717,27 +717,12 @@ wlkMonoType ttype
U_tname tcon -> -- type constructor
wlkTCId tcon `thenUgn` \ tycon ->
- returnUgn (MonoTyApp tycon [])
+ returnUgn (MonoTyVar tycon)
U_tapp t1 t2 ->
+ wlkMonoType t1 `thenUgn` \ ty1 ->
wlkMonoType t2 `thenUgn` \ ty2 ->
- collect t1 [ty2] `thenUgn` \ (tycon, tys) ->
- returnUgn (MonoTyApp tycon tys)
- where
- collect t acc
- = case t of
- U_tapp t1 t2 -> wlkMonoType t2 `thenUgn` \ ty2 ->
- collect t1 (ty2:acc)
- U_tname tcon -> wlkTCId tcon `thenUgn` \ tycon ->
- returnUgn (tycon, acc)
- U_namedtvar tv -> wlkTvId tv `thenUgn` \ tyvar ->
- returnUgn (tyvar, acc)
- U_tllist _ -> panic "tlist"
- U_ttuple _ -> panic "ttuple"
- U_tfun _ _ -> panic "tfun"
- U_tbang _ -> panic "tbang"
- U_context _ _ -> panic "context"
- _ -> panic "something else"
+ returnUgn (MonoTyApp ty1 ty2)
U_tllist tlist -> -- list type
wlkMonoType tlist `thenUgn` \ ty ->
@@ -760,11 +745,12 @@ wlkContext :: U_list -> UgnM RdrNameContext
wlkClassAssertTy :: U_ttype -> UgnM (RdrName, HsTyVar RdrName)
wlkTyConAndTyVars ttype
- = wlkMonoType ttype `thenUgn` \ (MonoTyApp tycon ty_args) ->
+ = wlkMonoType ttype `thenUgn` \ ty ->
let
- args = [ UserTyVar a | (MonoTyVar a) <- ty_args ]
+ split (MonoTyApp fun (MonoTyVar arg)) args = split fun (UserTyVar arg : args)
+ split (MonoTyVar tycon) args = (tycon,args)
in
- returnUgn (tycon, args)
+ returnUgn (split ty [])
wlkContext list
= wlkList rdMonoType list `thenUgn` \ tys ->
@@ -778,7 +764,7 @@ wlkClassAssertTy xs
mk_class_assertion :: RdrNameHsType -> (RdrName, RdrNameHsType)
-mk_class_assertion (MonoTyApp name [ty@(MonoTyVar tyname)]) = (name, ty)
+mk_class_assertion (MonoTyApp (MonoTyVar name) ty@(MonoTyVar tyname)) = (name, ty)
mk_class_assertion other
= pprError "ERROR: malformed type context: " (ppr PprForUser other)
-- regrettably, the parser does let some junk past
diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index 18eeace7f31a0b6f3ddff5382aef1cee50c4cdc6..5e1b2c5427d1c03816671d07dbf4aadb02307d87 100644
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -271,8 +271,8 @@ fields1 : field { [$1] }
| field COMMA fields1 { $1 : $3 }
field :: { ([RdrName], RdrNameBangType) }
-field : var_name DCOLON type { ([$1], Unbanged $3) }
- | var_name DCOLON BANG type { ([$1], Banged $4)
+field : var_names1 DCOLON type { ($1, Unbanged $3) }
+ | var_names1 DCOLON BANG type { ($1, Banged $4)
--------------------------------------------------------------------------
}
@@ -304,11 +304,10 @@ types2 : type COMMA type { [$1,$3] }
btype :: { RdrNameHsType }
btype : atype { $1 }
- | qtc_name atype atypes { MonoTyApp $1 ($2:$3) }
- | tv_name atype atypes { MonoTyApp $1 ($2:$3) }
+ | btype atype { MonoTyApp $1 $2 }
atype :: { RdrNameHsType }
-atype : qtc_name { MonoTyApp $1 [] }
+atype : qtc_name { MonoTyVar $1 }
| tv_name { MonoTyVar $1 }
| OPAREN types2 CPAREN { MonoTupleTy dummyRdrTcName $2 }
| OBRACK type CBRACK { MonoListTy dummyRdrTcName $2 }
@@ -329,10 +328,15 @@ var_occ : VARID { VarOcc $1 }
| VARSYM { VarOcc $1 }
| BANG { VarOcc SLIT("!") {-sigh, double-sigh-} }
+tc_occ :: { OccName }
+tc_occ : CONID { TCOcc $1 }
+ | CONSYM { TCOcc $1 }
+ | OPAREN RARROW CPAREN { TCOcc SLIT("->") }
+
entity_occ :: { OccName }
entity_occ : var_occ { $1 }
- | CONID { TCOcc $1 }
- | CONSYM { TCOcc $1 }
+ | tc_occ { $1 }
+ | RARROW { TCOcc SLIT("->") {- Allow un-paren'd arrow -} }
val_occ :: { OccName }
val_occ : var_occ { $1 }
@@ -351,6 +355,10 @@ qvar_name :: { RdrName }
var_name :: { RdrName }
var_name : var_occ { Unqual $1 }
+var_names1 :: { [RdrName] }
+var_names1 : var_name { [$1] }
+ | var_name var_names1 { $1 : $2 }
+
any_var_name :: {RdrName}
any_var_name : var_name { $1 }
| qvar_name { $1 }
@@ -372,8 +380,7 @@ qtc_names1 :: { [RdrName] }
| qtc_name COMMA qtc_names1 { $1 : $3 }
tc_name :: { RdrName }
-tc_name : CONID { Unqual (TCOcc $1) }
-
+tc_name : tc_occ { Unqual $1 }
tv_name :: { RdrName }
tv_name : VARID { Unqual (TvOcc $1) }
diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs
index db49db2daa1038c4333424896db27d7d98bc2ebd..fab6dd1119710480493f643a831d36d830791c80 100644
--- a/ghc/compiler/rename/RnHsSyn.lhs
+++ b/ghc/compiler/rename/RnHsSyn.lhs
@@ -75,7 +75,7 @@ extractHsTyNames :: RenamedHsType -> NameSet
extractHsTyNames ty
= get ty
where
- get (MonoTyApp con tys) = foldr (unionNameSets . get) (unitNameSet con) tys
+ get (MonoTyApp ty1 ty2) = get ty1 `unionNameSets` get ty2
get (MonoListTy tc ty) = unitNameSet tc `unionNameSets` get ty
get (MonoTupleTy tc tys) = foldr (unionNameSets . get) (unitNameSet tc) tys
get (MonoFunTy ty1 ty2) = get ty1 `unionNameSets` get ty2
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index 2a36802206efe1903e6090d70f0a51f417940a6a..b6f45211e9c943ab0a81588e95ef8654f1337380 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -287,8 +287,13 @@ getWiredInDecl :: Name -> RnMG AvailInfo
getWiredInDecl name
= -- Force in the home module in case it has instance decls for
-- the thing we are interested in
- (if mod == gHC__ then
- returnRn () -- Mini hack; GHC is guaranteed not to have
+ (if not is_tycon || mod == gHC__ then
+ returnRn () -- Mini hack 1: no point for non-tycons; and if we
+ -- do this we find PrelNum trying to import PackedString,
+ -- because PrelBase's .hi file mentions PackedString.unpackString
+ -- But PackedString.hi isn't built by that point!
+ --
+ -- Mini hack 2; GHC is guaranteed not to have
-- instance decls, so it's a waste of time
-- to read it
else
@@ -296,7 +301,7 @@ getWiredInDecl name
returnRn ()
) `thenRn_`
- if (maybeToBool maybe_wired_in_tycon) then
+ if is_tycon then
get_wired_tycon the_tycon
else -- Must be a wired-in-Id
if (isDataCon the_id) then -- ... a wired-in data constructor
@@ -307,6 +312,7 @@ getWiredInDecl name
doc_str = ppSep [ppStr "Need home module for wired in thing", ppr PprDebug name]
(mod,_) = modAndOcc name
maybe_wired_in_tycon = maybeWiredInTyConName name
+ is_tycon = maybeToBool maybe_wired_in_tycon
maybe_wired_in_id = maybeWiredInIdName name
Just the_tycon = maybe_wired_in_tycon
Just the_id = maybe_wired_in_id
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 15acf550336f66d2c5e3fa47a95c99266bd295a5..588619b2c07803ca82d46cc802c102767165c898 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -18,6 +18,7 @@ import HsTypes ( getTyVarName )
import RdrHsSyn
import RnHsSyn
import HsCore
+import CmdLineOpts ( opt_IgnoreIfacePragmas )
import RnBinds ( rnTopBinds, rnMethodBinds )
import RnEnv ( bindTyVarsRn, lookupRn, lookupOccRn, lookupImplicitOccRn, bindLocalsRn,
@@ -25,7 +26,7 @@ import RnEnv ( bindTyVarsRn, lookupRn, lookupOccRn, lookupImplicitOccRn, bindLo
listType_RDR, tupleType_RDR )
import RnMonad
-import Name ( Name, isLocallyDefined, isTvOcc, pprNonSym,
+import Name ( Name, isLocallyDefined, occNameString,
Provenance,
SYN_IE(NameSet), unionNameSets, emptyNameSet, mkNameSet, unitNameSet,
elemNameSet
@@ -35,6 +36,7 @@ import FiniteMap ( emptyFM, lookupFM, addListToFM_C )
import Id ( GenId{-instance NamedThing-} )
import IdInfo ( IdInfo, StrictnessInfo(..), FBTypeInfo, DemandInfo, ArgUsageInfo )
import SpecEnv ( SpecEnv )
+import Lex ( isLexCon )
import CoreUnfold ( Unfolding(..), SimpleUnfolding )
import MagicUFs ( MagicUnfoldingFun )
import PrelInfo ( derivingOccurrences, evalClass_RDR, numClass_RDR )
@@ -84,7 +86,14 @@ rnDecl (SigD (IfaceSig name ty id_infos loc))
= pushSrcLocRn loc $
lookupRn name `thenRn` \ name' ->
rnHsType ty `thenRn` \ ty' ->
- mapRn rnIdInfo id_infos `thenRn` \ id_infos' ->
+
+ -- Get the pragma info, unless we should ignore it
+ (if opt_IgnoreIfacePragmas then
+ returnRn []
+ else
+ mapRn rnIdInfo id_infos
+ ) `thenRn` \ id_infos' ->
+
returnRn (SigD (IfaceSig name' ty' id_infos' loc))
\end{code}
@@ -284,6 +293,7 @@ rnConDecl :: RdrNameConDecl -> RnMS s RenamedConDecl
rnConDecl (ConDecl name tys src_loc)
= pushSrcLocRn src_loc $
+ checkConName name `thenRn_`
lookupRn name `thenRn` \ new_name ->
mapRn rnBangTy tys `thenRn` \ new_tys ->
returnRn (ConDecl new_name new_tys src_loc)
@@ -297,6 +307,7 @@ rnConDecl (ConOpDecl ty1 op ty2 src_loc)
rnConDecl (NewConDecl name ty src_loc)
= pushSrcLocRn src_loc $
+ checkConName name `thenRn_`
lookupRn name `thenRn` \ new_name ->
rnHsType ty `thenRn` \ new_ty ->
returnRn (NewConDecl new_name new_ty src_loc)
@@ -319,6 +330,20 @@ rnBangTy (Banged ty)
rnBangTy (Unbanged ty)
= rnHsType ty `thenRn` \ new_ty ->
returnRn (Unbanged new_ty)
+
+-- This data decl will parse OK
+-- data T = a Int
+-- treating "a" as the constructor.
+-- It is really hard to make the parser spot this malformation.
+-- So the renamer has to check that the constructor is legal
+--
+-- We can get an operator as the constructor, even in the prefix form:
+-- data T = :% Int Int
+-- from interface files, which always print in prefix form
+
+checkConName name
+ = checkRn (isLexCon (occNameString (rdrNameOcc name)))
+ (badDataCon name)
\end{code}
@@ -362,10 +387,10 @@ rnHsType (MonoTupleTy _ tys)
mapRn rnHsType tys `thenRn` \ tys' ->
returnRn (MonoTupleTy tycon_name tys')
-rnHsType (MonoTyApp name tys)
- = lookupOccRn name `thenRn` \ name' ->
- mapRn rnHsType tys `thenRn` \ tys' ->
- returnRn (MonoTyApp name' tys')
+rnHsType (MonoTyApp ty1 ty2)
+ = rnHsType ty1 `thenRn` \ ty1' ->
+ rnHsType ty2 `thenRn` \ ty2' ->
+ returnRn (MonoTyApp ty1' ty2')
rnHsType (MonoDictTy clas ty)
= lookupOccRn clas `thenRn` \ clas' ->
@@ -583,6 +608,9 @@ classTyVarInOpCtxtErr clas_tyvar sig sty
dupClassAssertWarn ctxt dups sty
= ppHang (ppBesides [ppStr "Duplicate class assertion `", ppr sty dups, ppStr "' in context:"])
4 (ppr sty ctxt)
+
+badDataCon name sty
+ = ppCat [ppStr "Illegal data constructor name:", ppr sty name]
\end{code}
diff --git a/ghc/compiler/simplCore/SimplPgm.lhs b/ghc/compiler/simplCore/SimplPgm.lhs
index edfe71a173ecd1679603eec778162db0fd988863..fc95fffee298325919750f3a14fabfda5455a8c5 100644
--- a/ghc/compiler/simplCore/SimplPgm.lhs
+++ b/ghc/compiler/simplCore/SimplPgm.lhs
@@ -71,7 +71,7 @@ simplifyPgm binds s_sw_chkr simpl_stats us
show_status = pprTrace "NewSimpl: " (ppAboves [
ppBesides [ppInt iterations, ppChar '/', ppInt max_simpl_iterations],
ppStr (showSimplCount dr)
---DEBUG: , ppAboves (map (pprCoreBinding PprDebug) new_pgm)
+-- DEBUG , ppAboves (map (pprCoreBinding PprDebug) new_pgm)
])
in
diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 75537f05dfb827da803b1febee686b192d5ce8ff..1be67d8e18e3c4f745ab54abe27e6bddecfc3891 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -700,7 +700,7 @@ ToDo: check this is OK with andy
simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
| idWantsToBeINLINEd id
- = complete_bind env rhs -- Don't messa bout with floating or let-to-case on
+ = complete_bind env rhs -- Don't mess about with floating or let-to-case on
-- INLINE things
| otherwise
= simpl_bind env rhs
@@ -728,8 +728,7 @@ simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
(\env -> simpl_bind env rhs) body_ty
-- Try case-from-let; this deals with a strict let of error too
- simpl_bind env (Case scrut alts) | will_be_demanded ||
- (float_primops && is_cheap_prim_app scrut)
+ simpl_bind env (Case scrut alts) | case_floating_ok scrut
= tick CaseFloatFromLet `thenSmpl_`
-- First, bind large let-body if necessary
@@ -773,11 +772,31 @@ simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
ValueForm -> True
other -> False
+ float_exposes_hnf = floatExposesHNF float_lets float_primops ok_to_dup rhs
+
let_floating_ok = (will_be_demanded && not no_float) ||
always_float_let_from_let ||
- floatExposesHNF float_lets float_primops ok_to_dup rhs
+ float_exposes_hnf
+
+ case_floating_ok scrut = (will_be_demanded && not no_float) ||
+ (float_exposes_hnf && is_cheap_prim_app scrut && float_primops)
+ -- See note below
\end{code}
+Float switches
+~~~~~~~~~~~~~~
+The booleans controlling floating have to be set with a little care.
+Here's one performance bug I found:
+
+ let x = let y = let z = case a# +# 1 of {b# -> E1}
+ in E2
+ in E3
+ in E4
+
+Now, if E2, E3 aren't HNFs we won't float the y-binding or the z-binding.
+Before case_floating_ok included float_exposes_hnf, the case expression was floated
+*one level per simplifier iteration* outwards. So it made th s
+
Let to case
~~~~~~~~~~~
It's important to try let-to-case before floating. Consider
@@ -801,7 +820,7 @@ Now watch what happens if we do let-to-case first:
let k = \a# -> let a*=I# a# in b
in case v of
p1 -> case e1 of I# a# -> k a#
- p1 -> case e1 of I# a# -> k a#
+ p1 -> case e2 of I# a# -> k a#
The latter is clearly better. (Remember the reboxing let-decl for a
is likely to go away, because after all b is strict in a.)
diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index a88ad0540860942ddb525388f7b11f1d7b2198f3..7aaefe6c227661ee8e8157cc2c93f8b49d72dadc 100644
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -110,8 +110,7 @@ topCoreBindsToStg :: UniqSupply -- name supply
-> [StgBinding] -- output
topCoreBindsToStg us core_binds
- = case (initUs us (coreBindsToStg nullIdEnv core_binds)) of
- (_, stuff) -> stuff
+ = initUs us (coreBindsToStg nullIdEnv core_binds)
where
coreBindsToStg :: StgEnv -> [CoreBinding] -> UniqSM [StgBinding]
diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs
index 0478a6d3891526712d563b698beb451405d88bdc..db1310cd724d78525594c62233fcb34c31385553 100644
--- a/ghc/compiler/stranal/SaAbsInt.lhs
+++ b/ghc/compiler/stranal/SaAbsInt.lhs
@@ -343,7 +343,7 @@ evalStrictness (WwLazy _) _ = False
evalStrictness WwStrict val = isBot val
evalStrictness WwEnum val = isBot val
-evalStrictness (WwUnpack demand_info) val
+evalStrictness (WwUnpack _ demand_info) val
= case val of
AbsTop -> False
AbsBot -> True
@@ -368,7 +368,7 @@ possibly} hit poison.
evalAbsence (WwLazy True) _ = False -- Can't possibly hit poison
-- with Absent demand
-evalAbsence (WwUnpack demand_info) val
+evalAbsence (WwUnpack _ demand_info) val
= case val of
AbsTop -> False -- No poison in here
AbsBot -> True -- Pure poison
diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs
index 457cab22def0221cf39427b9d111478de73d0290..1b133b1f20e3b0d04c1c52be6b6f23c4191b8bdf 100644
--- a/ghc/compiler/stranal/WorkWrap.lhs
+++ b/ghc/compiler/stranal/WorkWrap.lhs
@@ -175,8 +175,8 @@ reason), then we don't w-w it.
The only reason this is monadised is for the unique supply.
\begin{code}
-tryWW :: Id -- the fn binder
- -> CoreExpr -- the bound rhs; its innards
+tryWW :: Id -- The fn binder
+ -> CoreExpr -- The bound rhs; its innards
-- are already ww'd
-> UniqSM [(Id, CoreExpr)] -- either *one* or *two* pairs;
-- if one, then no worker (only
@@ -184,60 +184,49 @@ tryWW :: Id -- the fn binder
-- if two, then a worker and a
-- wrapper.
tryWW fn_id rhs
- | certainlySmallEnoughToInline $
- calcUnfoldingGuidance (idWantsToBeINLINEd fn_id)
+ | (certainlySmallEnoughToInline $
+ calcUnfoldingGuidance (idWantsToBeINLINEd fn_id)
opt_UnfoldingCreationThreshold
- rhs
- -- No point in worker/wrappering something that is going to be
- -- INLINEd wholesale anyway. If the strictness analyser is run
- -- twice, this test also prevents wrappers (which are INLINEd)
- -- from being re-done.
- = do_nothing
-
- | otherwise
- = case (getIdStrictness fn_id) of
-
- NoStrictnessInfo -> do_nothing
- BottomGuaranteed -> do_nothing
-
- StrictnessInfo args_info _ ->
- let
- (uvars, tyvars, args, body) = collectBinders rhs
- body_ty = coreExprType body
- in
- mkWwBodies body_ty tyvars args args_info `thenUs` \ result ->
- case result of
-
- Nothing -> -- We've hit the all-args-absent-and-the-body-is-unboxed case,
- -- or there are too many args for a w/w split,
- -- or there's no benefit from w/w (e.g. SSS)
- do_nothing
-
- Just (wrapper_w_hole, worker_w_hole, worker_strictness, worker_ty_w_hole) ->
-
- -- Terrific! It worked!
- getUnique `thenUs` \ worker_uniq ->
- let
- worker_ty = worker_ty_w_hole body_ty
-
- worker_id = mkWorkerId worker_uniq fn_id worker_ty
- (noIdInfo `addStrictnessInfo` worker_strictness)
-
- wrapper_rhs = wrapper_w_hole worker_id
- worker_rhs = worker_w_hole body
-
- revised_strictness_info
- = -- We know the basic strictness info already, but
- -- we need to slam in the exact identity of the
- -- worker Id:
- mkStrictnessInfo args_info (Just worker_id)
-
- wrapper_id = addInlinePragma (fn_id `addIdStrictness`
- revised_strictness_info)
- -- NB the "addInlinePragma" part; we want to inline wrappers everywhere
- in
- returnUs [ (worker_id, worker_rhs), -- worker comes first
- (wrapper_id, wrapper_rhs) ] -- because wrapper mentions it
+ rhs)
+ -- No point in worker/wrappering something that is going to be
+ -- INLINEd wholesale anyway. If the strictness analyser is run
+ -- twice, this test also prevents wrappers (which are INLINEd)
+ -- from being re-done.
+
+ || not has_strictness_info
+ || not (worthSplitting revised_wrap_args_info)
+ = returnUs [ (fn_id, rhs) ]
+
+ | otherwise -- Do w/w split
+ = let
+ (uvars, tyvars, wrap_args, body) = collectBinders rhs
+ in
+ mkWwBodies tyvars wrap_args
+ (coreExprType body)
+ revised_wrap_args_info `thenUs` \ (wrap_fn, work_fn, work_demands) ->
+ getUnique `thenUs` \ work_uniq ->
+ let
+ work_rhs = work_fn body
+ work_id = mkWorkerId work_uniq fn_id (coreExprType work_rhs) work_info
+ work_info = noIdInfo `addStrictnessInfo` mkStrictnessInfo work_demands Nothing
+
+ wrap_rhs = wrap_fn work_id
+ wrap_id = addInlinePragma (fn_id `addIdStrictness`
+ mkStrictnessInfo revised_wrap_args_info (Just work_id))
+ -- Add info to the wrapper:
+ -- (a) we want to inline it everywhere
+ -- (b) we want to pin on its revised stricteness info
+ -- (c) we pin on its worker id
+ in
+ returnUs ([(work_id, work_rhs), (wrap_id, wrap_rhs)])
+ -- Worker first, because wrapper mentions it
where
- do_nothing = returnUs [ (fn_id, rhs) ]
+ strictness_info = getIdStrictness fn_id
+ has_strictness_info = case strictness_info of
+ StrictnessInfo _ _ -> True
+ other -> False
+
+ wrap_args_info = case strictness_info of
+ StrictnessInfo args_info _ -> args_info
+ revised_wrap_args_info = setUnpackStrategy wrap_args_info
\end{code}
diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs
index 8e653984160bdd88d3b586c72346421c81abdf63..318a6d2a1a832d556b51ffffd370f42dcb4d20e4 100644
--- a/ghc/compiler/stranal/WwLib.lhs
+++ b/ghc/compiler/stranal/WwLib.lhs
@@ -9,7 +9,8 @@
module WwLib (
WwBinding(..),
- mkWwBodies, mAX_WORKER_ARGS
+ worthSplitting, setUnpackStrategy,
+ mkWwBodies, mkWrapper
) where
IMP_Ubiq(){-uitous-}
@@ -17,15 +18,17 @@ IMP_Ubiq(){-uitous-}
import CoreSyn
import Id ( idType, mkSysLocal, dataConArgTys )
import IdInfo ( mkStrictnessInfo, nonAbsentArgs, Demand(..) )
-import PrelVals ( aBSENT_ERROR_ID )
+import PrelVals ( aBSENT_ERROR_ID, voidId )
+import TysPrim ( voidTy )
import SrcLoc ( noSrcLoc )
import Type ( isPrimType, mkTyVarTys, mkForAllTys, mkFunTys,
+ splitForAllTy, splitFunTyExpandingDicts,
maybeAppDataTyConExpandingDicts
)
import UniqSupply ( returnUs, thenUs, thenMaybeUs,
- getUniques, SYN_IE(UniqSM)
+ getUniques, getUnique, SYN_IE(UniqSM)
)
-import Util ( zipWithEqual, assertPanic, panic )
+import Util ( zipWithEqual, zipEqual, assertPanic, panic )
\end{code}
%************************************************************************
@@ -155,256 +158,214 @@ probably slightly paranoid, but OK in practice.) If it isn't the
same, we ``revise'' the strictness info, so that we won't propagate
the unusable strictness-info into the interfaces.
-==========================
-Here's the real fun... The wrapper's ``deconstructing'' of arguments
-and the worker's putting them back together again are ``duals'' in
-some sense.
+%************************************************************************
+%* *
+\subsection{Functions over Demands}
+%* *
+%************************************************************************
-What we do is walk along the @Demand@ list, producing two
-expressions (one for wrapper, one for worker...), each with a ``hole''
-in it, where we will later plug in more information. For our previous
-example, the expressions-with-HOLES are:
-\begin{verbatim}
-\ x ys -> -- wrapper
- case x of
- I# x# -> <<HOLE>> x# ys
+\begin{code}
+mAX_WORKER_ARGS :: Int -- ToDo: set via flag
+mAX_WORKER_ARGS = 6
-\ x# ys -> -- worker
- let
- x = I# x#
- in
- <<HOLE>>
-\end{verbatim}
-(Actually, we add the lambda-bound arguments at the end...) (The big
-Lambdas are added on the front later.)
+setUnpackStrategy :: [Demand] -> [Demand]
+setUnpackStrategy ds
+ = snd (go (mAX_WORKER_ARGS - nonAbsentArgs ds) ds)
+ where
+ go :: Int -- Max number of args available for sub-components of [Demand]
+ -> [Demand]
+ -> (Int, [Demand]) -- Args remaining after subcomponents of [Demand] are unpacked
+
+ go n (WwUnpack _ cs : ds) | n' >= 0
+ = WwUnpack True cs' `cons` go n'' ds
+ | otherwise
+ = WwUnpack False cs `cons` go n ds
+ where
+ n' = n + 1 - nonAbsentArgs cs
+ -- Add one because we don't pass the top-level arg any more
+ -- Delete # of non-absent args to which we'll now be committed
+ (n'',cs') = go n' cs
+
+ go n (d:ds) = d `cons` go n ds
+ go n [] = (n,[])
+
+ cons d (n,ds) = (n, d:ds)
-\begin{code}
-mkWwBodies
- :: Type -- Type of the *body* of the orig
- -- function; i.e. /\ tyvars -> \ vars -> body
- -> [TyVar] -- Type lambda vars of original function
- -> [Id] -- Args of original function
- -> [Demand] -- Strictness info for those args
-
- -> UniqSM (Maybe -- Nothing iff (a) no interesting split possible
- -- (b) any unpack on abstract type
- (Id -> CoreExpr, -- Wrapper expr w/
- -- hole for worker id
- CoreExpr -> CoreExpr, -- Worker expr w/ hole
- -- for original fn body
- StrictnessInfo Id, -- Worker strictness info
- Type -> Type) -- Worker type w/ hole
- ) -- for type of original fn body
-
-
-mkWwBodies body_ty tyvars args arg_infos
- = ASSERT(length args == length arg_infos)
- -- or you can get disastrous user/definer-module mismatches
- if (all_absent_args_and_unboxed_value body_ty arg_infos)
- then returnUs Nothing
-
- else -- the rest...
- mk_ww_arg_processing args arg_infos
- False -- Initialise the "useful-split" flag
- (mAX_WORKER_ARGS - nonAbsentArgs arg_infos)
- `thenMaybeUs` \ (wrap_frag, work_args_info, work_frag) ->
- let
- (work_args, wrkr_demands) = unzip work_args_info
+nonAbsentArgs :: [Demand] -> Int
+nonAbsentArgs [] = 0
+nonAbsentArgs (WwLazy True : ds) = nonAbsentArgs ds
+nonAbsentArgs (d : ds) = 1 + nonAbsentArgs ds
- wrkr_strictness = mkStrictnessInfo wrkr_demands Nothing -- no worker-of-worker...
+worthSplitting :: [Demand] -> Bool -- True <=> the wrapper would not be an identity function
+worthSplitting [] = False
+worthSplitting (WwLazy True : ds) = True -- Absent arg
+worthSplitting (WwUnpack True _ : ds) = True -- Arg to unpack
+worthSplitting (d : ds) = worthSplitting ds
+
+allAbsent :: [Demand] -> Bool
+allAbsent (WwLazy True : ds) = allAbsent ds
+allAbsent (WwUnpack True cs : ds) = allAbsent cs && allAbsent ds
+allAbsent (d : ds) = False
+allAbsent [] = True
+\end{code}
- wrapper_w_hole = \ worker_id ->
- mkLam tyvars args (
- wrap_frag (
- mkTyApp (Var worker_id) (mkTyVarTys tyvars)
- ))
- worker_w_hole = \ orig_body ->
- mkLam tyvars work_args (
- work_frag orig_body
- )
+%************************************************************************
+%* *
+\subsection{The worker wrapper core}
+%* *
+%************************************************************************
- worker_ty_w_hole = \ body_ty ->
- mkForAllTys tyvars $
- mkFunTys (map idType work_args) body_ty
+@mkWrapper@ is called when importing a function. We have the type of
+the function and the name of its worker, and we want to make its body (the wrapper).
+
+\begin{code}
+mkWrapper :: Type -- Wrapper type
+ -> [Demand] -- Wrapper strictness info
+ -> UniqSM (Id -> CoreExpr) -- Wrapper body, missing worker Id
+
+mkWrapper fun_ty demands
+ = let
+ n_wrap_args = length demands
in
- returnUs (Just (wrapper_w_hole, worker_w_hole, wrkr_strictness, worker_ty_w_hole))
- where
- -- "all_absent_args_and_unboxed_value":
- -- check for the obscure case of "\ x y z ... -> body" where
- -- (a) *all* of the args x, y, z,... are absent, and
- -- (b) the type of body is unboxed
- -- If these conditions are true, we must *not* play worker/wrapper games!
-
- all_absent_args_and_unboxed_value body_ty arg_infos
- = not (null arg_infos)
- && all is_absent_arg arg_infos
- && isPrimType body_ty
-
- is_absent_arg (WwLazy True) = True
- is_absent_arg _ = False
+ getUniques n_wrap_args `thenUs` \ wrap_uniqs ->
+ let
+ (tyvars, tau_ty) = splitForAllTy fun_ty
+ (arg_tys, body_ty) = splitFunTyExpandingDicts tau_ty
+ wrap_args = zipWith mk_ww_local wrap_uniqs arg_tys
+ leftover_arg_tys = drop n_wrap_args arg_tys
+ final_body_ty = mkFunTys leftover_arg_tys body_ty
+ in
+ mkWwBodies tyvars wrap_args final_body_ty demands `thenUs` \ (wrap_fn, _, _) ->
+ returnUs wrap_fn
\end{code}
-Important: mk_ww_arg_processing doesn't check
-for an "interesting" split. It just races ahead and makes the
-split, even if there's no unpacking at all. This is important for
-when it calls itself recursively.
-
-It returns Nothing only if it encounters an abstract type in mid-flight.
+@mkWwBodies@ is called when doing the worker/wrapper split inside a module.
\begin{code}
-mAX_WORKER_ARGS :: Int -- ToDo: set via flag
-mAX_WORKER_ARGS = 6 -- Hmm... but this is an everything-must-
- -- be-compiled-with-the-same-val thing...
-
-mk_ww_arg_processing
- :: [Id] -- Args of original function
- -> [Demand] -- Strictness info for those args
- -- must be at least as long as args
-
- -> Bool -- False <=> we've done nothing useful in an enclosing call
- -- If this is False when we hit the end of the arg list, we
- -- don't want to do a w/w split... the wrapper would be the identity fn!
- -- So we return Nothing
-
- -> Int -- Number of extra args we are prepared to add.
- -- This prevents over-eager unpacking, leading
- -- to huge-arity functions.
-
- -> UniqSM (Maybe -- Nothing iff any unpack on abstract type
- -- or if the wrapper would be the identity fn (can happen if we unpack
- -- a huge structure, and decide not to do it)
-
- (CoreExpr -> CoreExpr, -- Wrapper expr w/
- -- hole for worker id
- -- applied to types
- [(Id,Demand)], -- Worker's args
- -- and their strictness info
- CoreExpr -> CoreExpr) -- Worker body expr w/ hole
- ) -- for original fn body
-
-mk_ww_arg_processing [] _ useful_split _ = if useful_split then
- returnUs (Just (id, [], id))
- else
- returnUs Nothing
-
-mk_ww_arg_processing (arg : args) (WwLazy True : infos) useful_split max_extra_args
- = -- Absent argument
- -- So, finish args to the right...
- --pprTrace "Absent; num_wrkr_args=" (ppInt num_wrkr_args) (
+mkWwBodies :: [TyVar] -> [Id] -> Type -- Original fn args and body type
+ -> [Demand] -- Strictness info for original fn; corresp 1-1 with args
+ -> UniqSM (Id -> CoreExpr, -- Wrapper body, lacking only the worker Id
+ CoreExpr -> CoreExpr, -- Worker body, lacking the original function body
+ [Demand]) -- Strictness info for worker
+
+mkWwBodies tyvars args body_ty demands
+ | allAbsent demands &&
+ isPrimType body_ty
+ = -- Horrid special case. If the worker would have no arguments, and the
+ -- function returns a primitive type value, that would make the worker into
+ -- an unboxed value. We box it by passing a dummy void argument, thus:
+ --
+ -- f = /\abc. \xyz. fw abc void
+ -- fw = /\abc. \v. body
+ --
+ getUnique `thenUs` \ void_arg_uniq ->
let
- arg_ty = idType arg
+ void_arg = mk_ww_local void_arg_uniq voidTy
in
- mk_ww_arg_processing args infos True {- useful split -} max_extra_args
- -- We've already discounted for absent args,
- -- so we don't change max_extra_args
- `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
-
- -- wrapper doesn't pass this arg to worker:
- returnUs (Just (
- -- wrapper:
- \ hole -> wrap_rest hole,
-
- -- worker:
- work_args_info, -- NB: no argument added
- \ hole -> mk_absent_let arg arg_ty (work_rest hole)
- ))
- --)
- where
- mk_absent_let arg arg_ty body
- = if not (isPrimType arg_ty) then
- Let (NonRec arg (mkTyApp (Var aBSENT_ERROR_ID) [arg_ty])) body
- else -- quite horrible
- panic "WwLib: haven't done mk_absent_let for primitives yet"
+ returnUs (\ work_id -> mkLam tyvars args (App (mkTyApp (Var work_id) (mkTyVarTys tyvars)) (VarArg voidId)),
+ \ body -> mkLam tyvars [void_arg] body,
+ [WwLazy True])
+mkWwBodies tyvars args body_ty demands
+ | otherwise
+ = let
+ args_w_demands = zipEqual "mkWwBodies" args demands
+ in
+ mkWW args_w_demands `thenUs` \ (wrap_fn, work_args_w_demands, work_fn) ->
+ let
+ (work_args, work_demands) = unzip work_args_w_demands
+ in
+ returnUs (\ work_id -> mkLam tyvars args (wrap_fn (mkTyApp (Var work_id) (mkTyVarTys tyvars))),
+ \ body -> mkLam tyvars work_args (work_fn body),
+ work_demands)
+\end{code}
-mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) useful_split max_extra_args
- | new_max_extra_args > 0 -- Check that we are prepared to add arguments
- = -- this is the complicated one.
- --pprTrace "Unpack; num_wrkr_args=" (ppCat [ppInt num_wrkr_args, ppStr "; new_max=", ppInt new_num_wrkr_args, ppStr "; arg=", ppr PprDebug arg, ppr PprDebug (WwUnpack cmpnt_infos)]) $
- case (maybeAppDataTyConExpandingDicts arg_ty) of
+\begin{code}
+mkWW :: [(Id,Demand)]
+ -> UniqSM (CoreExpr -> CoreExpr, -- Wrapper body, lacking the inner call to the worker
+ -- and without its lambdas
+ [(Id,Demand)], -- Worker args and their demand infos
+ CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function
- Nothing -> -- Not a data type
- panic "mk_ww_arg_processing: not datatype"
- Just (arg_tycon, tycon_arg_tys, [data_con]) ->
- -- The main event: a single-constructor data type
- do_single_constr arg_tycon tycon_arg_tys data_con
+ -- Empty case
+mkWW []
+ = returnUs (\ wrapper_body -> wrapper_body,
+ [],
+ \ worker_body -> worker_body)
- Just (_, _, data_cons) -> -- Zero, or two or more constructors; that's odd
- panic "mk_ww_arg_processing: not one constr"
+ -- Absent case
+mkWW ((arg,WwLazy True) : ds)
+ = mkWW ds `thenUs` \ (wrap_fn, worker_args, work_fn) ->
+ returnUs (\ wrapper_body -> wrap_fn wrapper_body,
+ worker_args,
+ \ worker_body -> mk_absent_let arg (work_fn worker_body))
+
+
+ -- Unpack case
+mkWW ((arg,WwUnpack True cs) : ds)
+ = getUniques (length inst_con_arg_tys) `thenUs` \ uniqs ->
+ let
+ unpk_args = zipWith mk_ww_local uniqs inst_con_arg_tys
+ unpk_args_w_ds = zipEqual "mkWW" unpk_args cs
+ in
+ mkWW (unpk_args_w_ds ++ ds) `thenUs` \ (wrap_fn, worker_args, work_fn) ->
+ returnUs (\ wrapper_body -> mk_unpk_case arg unpk_args data_con arg_tycon (wrap_fn wrapper_body),
+ worker_args,
+ \ worker_body -> work_fn (mk_pk_let arg data_con tycon_arg_tys unpk_args worker_body))
where
- arg_ty = idType arg
+ inst_con_arg_tys = dataConArgTys data_con tycon_arg_tys
+ (arg_tycon, tycon_arg_tys, data_con)
+ = case (maybeAppDataTyConExpandingDicts (idType arg)) of
- new_max_extra_args
- = max_extra_args
- + 1 -- We won't pass the original arg now
- - nonAbsentArgs cmpnt_infos -- But we will pass an arg for each cmpt
+ Just (arg_tycon, tycon_arg_tys, [data_con]) ->
+ -- The main event: a single-constructor data type
+ (arg_tycon, tycon_arg_tys, data_con)
- do_single_constr arg_tycon tycon_arg_tys data_con
- = let
- inst_con_arg_tys = dataConArgTys data_con tycon_arg_tys
- in
- getUniques (length inst_con_arg_tys) `thenUs` \ uniqs ->
-
- let
- unpk_args = zipWithEqual "mk_ww_arg_processing"
- (\ u t -> mkSysLocal SLIT("upk") u t noSrcLoc)
- uniqs inst_con_arg_tys
- in
- -- In processing the rest, push the sub-component args
- -- and infos on the front of the current bunch
- mk_ww_arg_processing (unpk_args ++ args) (cmpnt_infos ++ infos) True {- useful split -} new_max_extra_args
- `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
-
- returnUs (Just (
- -- wrapper: unpack the value
- \ hole -> mk_unpk_case arg unpk_args
- data_con arg_tycon
- (wrap_rest hole),
-
- -- worker: expect the unpacked value;
- -- reconstruct the orig value with a "let"
- work_args_info,
- \ hole -> work_rest (mk_pk_let arg data_con tycon_arg_tys unpk_args hole)
- ))
-
- mk_unpk_case arg unpk_args boxing_con boxing_tycon body
- = Case (Var arg) (
- AlgAlts [(boxing_con, unpk_args, body)]
- NoDefault
- )
-
- mk_pk_let arg boxing_con con_tys unpk_args body
- = Let (NonRec arg (Con boxing_con
- (map TyArg con_tys ++ map VarArg unpk_args)))
- body
-
-mk_ww_arg_processing (arg : args) (arg_demand : infos) useful_split max_extra_args
- | otherwise
- = -- For all others at the moment, we just
- -- pass them to the worker unchanged.
- --pprTrace "Other; num_wrkr_args=" (ppCat [ppInt num_wrkr_args, ppStr ";arg=", ppr PprDebug arg, ppr PprDebug arg_demand]) (
+ Just (_, _, data_cons) -> panic "mk_ww_arg_processing: not one constr"
+ Nothing -> panic "mk_ww_arg_processing: not datatype"
- -- Finish args to the right...
- mk_ww_arg_processing args infos useful_split max_extra_args
- `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
- returnUs (Just (
- -- wrapper:
- \ hole -> wrap_rest (App hole (VarArg arg)),
+ -- Other cases
+mkWW ((arg,other_demand) : ds)
+ = mkWW ds `thenUs` \ (wrap_fn, worker_args, work_fn) ->
+ returnUs (\ wrapper_body -> wrap_fn (App wrapper_body (VarArg arg)),
+ (arg,other_demand) : worker_args,
+ work_fn)
+\end{code}
- -- worker:
- (arg, arg_demand) : work_args_info,
- \ hole -> work_rest hole
- ))
- --)
-nonAbsentArgs :: [Demand] -> Int
-nonAbsentArgs [] = 0
-nonAbsentArgs (WwLazy True : ds) = nonAbsentArgs ds
-nonAbsentArgs (d : ds) = 1 + nonAbsentArgs ds
+%************************************************************************
+%* *
+\subsection{Utilities}
+%* *
+%************************************************************************
+
+
+\begin{code}
+mk_absent_let arg body
+ | not (isPrimType arg_ty)
+ = Let (NonRec arg (mkTyApp (Var aBSENT_ERROR_ID) [arg_ty])) body
+ | otherwise
+ = panic "WwLib: haven't done mk_absent_let for primitives yet"
+ where
+ arg_ty = idType arg
+
+mk_unpk_case arg unpk_args boxing_con boxing_tycon body
+ = Case (Var arg)
+ (AlgAlts [(boxing_con, unpk_args, body)]
+ NoDefault
+ )
+
+mk_pk_let arg boxing_con con_tys unpk_args body
+ = Let (NonRec arg (Con boxing_con con_args)) body
+ where
+ con_args = map TyArg con_tys ++ map VarArg unpk_args
+
+mk_ww_local uniq ty
+ = mkSysLocal SLIT("ww") uniq ty noSrcLoc
\end{code}
diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index ac0a5ad51ef1fa4dc0012253afe8a3ce5e0e3c8a..102af84a1674553613da4fd95c9cd3bbae156d59 100644
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -26,6 +26,7 @@ import Literal ( Literal(..) )
import CoreSyn
import CoreUnfold
import MagicUFs ( MagicUnfoldingFun )
+import WwLib ( mkWrapper )
import SpecEnv ( SpecEnv )
import PrimOp ( PrimOp(..) )
@@ -58,8 +59,8 @@ tcInterfaceSigs :: [RenamedHsDecl] -> TcM s [Id]
tcInterfaceSigs (SigD (IfaceSig name ty id_infos src_loc) : rest)
= tcAddSrcLoc src_loc $
- tcHsType ty `thenTc` \ sigma_ty ->
- tcIdInfo name noIdInfo id_infos `thenTc` \ id_info' ->
+ tcHsType ty `thenTc` \ sigma_ty ->
+ tcIdInfo name sigma_ty noIdInfo id_infos `thenTc` \ id_info' ->
let
sig_id = mkImported name sigma_ty id_info'
in
@@ -72,55 +73,63 @@ tcInterfaceSigs [] = returnTc []
\end{code}
\begin{code}
-tcIdInfo name info [] = returnTc info
+tcIdInfo name ty info [] = returnTc info
-tcIdInfo name info (HsArity arity : rest)
- = tcIdInfo name (info `addArityInfo` arity) rest
+tcIdInfo name ty info (HsArity arity : rest)
+ = tcIdInfo name ty (info `addArityInfo` arity) rest
-tcIdInfo name info (HsUpdate upd : rest)
- = tcIdInfo name (info `addUpdateInfo` upd) rest
+tcIdInfo name ty info (HsUpdate upd : rest)
+ = tcIdInfo name ty (info `addUpdateInfo` upd) rest
-tcIdInfo name info (HsFBType fb : rest)
- = tcIdInfo name (info `addFBTypeInfo` fb) rest
+tcIdInfo name ty info (HsFBType fb : rest)
+ = tcIdInfo name ty (info `addFBTypeInfo` fb) rest
-tcIdInfo name info (HsArgUsage au : rest)
- = tcIdInfo name (info `addArgUsageInfo` au) rest
+tcIdInfo name ty info (HsArgUsage au : rest)
+ = tcIdInfo name ty (info `addArgUsageInfo` au) rest
-tcIdInfo name info (HsDeforest df : rest)
- = tcIdInfo name (info `addDeforestInfo` df) rest
+tcIdInfo name ty info (HsDeforest df : rest)
+ = tcIdInfo name ty (info `addDeforestInfo` df) rest
-tcIdInfo name info (HsUnfold expr : rest)
+tcIdInfo name ty info (HsUnfold expr : rest)
= tcUnfolding name expr `thenNF_Tc` \ unfold_info ->
- tcIdInfo name (info `addUnfoldInfo` unfold_info) rest
+ tcIdInfo name ty (info `addUnfoldInfo` unfold_info) rest
-tcIdInfo name info (HsStrictness strict : rest)
- = tcStrictness strict `thenTc` \ strict_info ->
- tcIdInfo name (info `addStrictnessInfo` strict_info) rest
+tcIdInfo name ty info (HsStrictness strict : rest)
+ = tcStrictness ty info strict `thenTc` \ info' ->
+ tcIdInfo name ty info' rest
\end{code}
\begin{code}
-tcStrictness (StrictnessInfo demands (Just worker))
- = tcWorker worker `thenNF_Tc` \ maybe_worker_id ->
- returnTc (StrictnessInfo demands maybe_worker_id)
-
--- Boring to write these out, but the result type differe from the arg type...
-tcStrictness (StrictnessInfo demands Nothing) = returnTc (StrictnessInfo demands Nothing)
-tcStrictness NoStrictnessInfo = returnTc NoStrictnessInfo
-tcStrictness BottomGuaranteed = returnTc BottomGuaranteed
+tcStrictness ty info (StrictnessInfo demands maybe_worker)
+ = tcWorker maybe_worker `thenNF_Tc` \ maybe_worker_id ->
+ uniqSMToTcM (mkWrapper ty demands) `thenNF_Tc` \ wrap_fn ->
+ let
+ -- Watch out! We can't pull on maybe_worker_id too eagerly!
+ info' = case maybe_worker_id of
+ Just worker_id -> info `addUnfoldInfo` mkUnfolding False (wrap_fn worker_id)
+ Nothing -> info
+ in
+ returnTc (info' `addStrictnessInfo` StrictnessInfo demands maybe_worker_id)
+
+-- Boring to write these out, but the result type differs from the arg type...
+tcStrictness ty info BottomGuaranteed
+ = returnTc (info `addStrictnessInfo` BottomGuaranteed)
+tcStrictness ty info NoStrictnessInfo
+ = returnTc info
\end{code}
\begin{code}
-tcWorker worker
- = tcLookupGlobalValueMaybe worker `thenNF_Tc` \ maybe_worker_id ->
+tcWorker Nothing = returnNF_Tc Nothing
+
+tcWorker (Just worker_name)
+ = tcLookupGlobalValueMaybe worker_name `thenNF_Tc` \ maybe_worker_id ->
returnNF_Tc (trace_maybe maybe_worker_id)
where
-- The trace is so we can see what's getting dropped
- trace_maybe Nothing = pprTrace "tcWorker failed:" (ppr PprDebug worker) Nothing
+ trace_maybe Nothing = pprTrace "tcWorker failed:" (ppr PprDebug worker_name) Nothing
trace_maybe (Just x) = Just x
\end{code}
-tcLookupGlobalValue worker
-
For unfoldings we try to do the job lazily, so that we never type check
an unfolding that isn't going to be looked at.
@@ -317,3 +326,4 @@ tcCorePrim (UfCCallOp str casm gc arg_tys res_ty)
returnTc (CCallOp str casm gc arg_tys' res_ty')
\end{code}
+
diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs
index 7f3e1ab6a80169545256130ee29dbf19167fb61f..71c7dd1ae20905b2ee409b57ee1268273aa45d85 100644
--- a/ghc/compiler/typecheck/TcMonad.lhs
+++ b/ghc/compiler/typecheck/TcMonad.lhs
@@ -10,6 +10,8 @@ module TcMonad(
foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
mapBagTc, fixTc, tryTc, getErrsTc,
+ uniqSMToTcM,
+
returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, fixNF_Tc, forkNF_Tc,
listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
@@ -55,7 +57,8 @@ import FiniteMap ( FiniteMap, emptyFM, isEmptyFM{-, keysFM ToDo:rm-} )
import Maybes ( MaybeErr(..) )
import SrcLoc ( SrcLoc, noSrcLoc )
import UniqFM ( UniqFM, emptyUFM )
-import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply )
+import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply,
+ SYN_IE(UniqSM), initUs )
import Unique ( Unique )
import Util
import Pretty
@@ -412,6 +415,17 @@ tcGetUniques n down env
returnSST uniqs
where
u_var = getUniqSupplyVar down
+
+uniqSMToTcM :: UniqSM a -> NF_TcM s a
+uniqSMToTcM m down env
+ = readMutVarSST u_var `thenSST` \ uniq_supply ->
+ let
+ (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
+ in
+ writeMutVarSST u_var new_uniq_supply `thenSST_`
+ returnSST (initUs uniq_s m)
+ where
+ u_var = getUniqSupplyVar down
\end{code}
diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index f426434d28823b5cfd88b40b67d9d04e2e8c61d3..39ecb691a6d13018cd5ca6aeeb0da1f669438305 100644
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -54,11 +54,16 @@ tcHsTypeKind does the real work. It returns a kind and a type.
\begin{code}
tcHsTypeKind :: RenamedHsType -> TcM s (TcKind s, Type)
+ -- This equation isn't needed (the next one would handle it fine)
+ -- but it's rather a common case, so we handle it directly
tcHsTypeKind (MonoTyVar name)
- = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
+ | isTvOcc (getOccName name)
+ = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
returnTc (kind, mkTyVarTy tyvar)
-
+tcHsTypeKind ty@(MonoTyVar name)
+ = tcFunType ty []
+
tcHsTypeKind (MonoListTy _ ty)
= tcHsType ty `thenTc` \ tau_ty ->
returnTc (mkTcTypeKind, mkListTy tau_ty)
@@ -72,16 +77,8 @@ tcHsTypeKind (MonoFunTy ty1 ty2)
tcHsType ty2 `thenTc` \ tau_ty2 ->
returnTc (mkTcTypeKind, mkFunTy tau_ty1 tau_ty2)
-tcHsTypeKind (MonoTyApp name tys)
- | isTvOcc (getOccName name) -- Must be a type variable
- = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
- tcMonoTyApp kind (mkTyVarTy tyvar) tys
-
- | otherwise -- Must be a type constructor
- = tcLookupTyCon name `thenTc` \ (kind,maybe_arity,tycon) ->
- case maybe_arity of
- Just arity -> tcSynApp name kind arity tycon tys -- synonum
- Nothing -> tcMonoTyApp kind (mkTyConTy tycon) tys -- newtype or data
+tcHsTypeKind (MonoTyApp ty1 ty2)
+ = tcTyApp ty1 [ty2]
tcHsTypeKind (HsForAllTy tv_names context ty)
= tcTyVarScope tv_names $ \ tyvars ->
@@ -101,23 +98,41 @@ tcHsTypeKind (MonoDictTy class_name ty)
Help functions for type applications
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-tcMonoTyApp fun_kind fun_ty tys
- = mapAndUnzipTc tcHsTypeKind tys `thenTc` \ (arg_kinds, arg_tys) ->
- newKindVar `thenNF_Tc` \ result_kind ->
- unifyKind fun_kind (foldr mkTcArrowKind result_kind arg_kinds) `thenTc_`
- returnTc (result_kind, foldl mkAppTy fun_ty arg_tys)
+tcTyApp (MonoTyApp ty1 ty2) tys
+ = tcTyApp ty1 (ty2:tys)
+
+tcTyApp ty tys
+ | null tys
+ = tcFunType ty []
-tcSynApp name syn_kind arity tycon tys
+ | otherwise
= mapAndUnzipTc tcHsTypeKind tys `thenTc` \ (arg_kinds, arg_tys) ->
+ tcFunType ty arg_tys `thenTc` \ (fun_kind, result_ty) ->
+
+ -- Check argument compatibility; special ca
newKindVar `thenNF_Tc` \ result_kind ->
- unifyKind syn_kind (foldr mkTcArrowKind result_kind arg_kinds) `thenTc_`
+ unifyKind fun_kind (foldr mkTcArrowKind result_kind arg_kinds)
+ `thenTc_`
+ returnTc (result_kind, result_ty)
+
+tcFunType (MonoTyVar name) arg_tys
+ | isTvOcc (getOccName name) -- Must be a type variable
+ = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
+ returnTc (kind, foldl mkAppTy (mkTyVarTy tyvar) arg_tys)
- -- Check that it's applied to the right number of arguments
- checkTc (arity == n_args) (err arity) `thenTc_`
- returnTc (result_kind, mkSynTy tycon arg_tys)
+ | otherwise -- Must be a type constructor
+ = tcLookupTyCon name `thenTc` \ (kind,maybe_arity,tycon) ->
+ case maybe_arity of
+ Nothing -> returnTc (kind, foldl mkAppTy (mkTyConTy tycon) arg_tys)
+ Just arity -> checkTc (arity == n_args) (err arity) `thenTc_`
+ returnTc (kind, mkSynTy tycon arg_tys)
where
err arity = arityErr "Type synonym constructor" name arity n_args
- n_args = length tys
+ n_args = length arg_tys
+
+tcFunType ty arg_tys
+ = tcHsTypeKind ty `thenTc` \ (fun_kind, fun_ty) ->
+ returnTc (fun_kind, foldl mkAppTy fun_ty arg_tys)
\end{code}
diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index afaf13efdcff888ef8f92508b694f8ff6bd408d3..359e29c67e3cb1524db476d59b4a6bef2ebbb3c9 100644
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -228,11 +228,10 @@ get_con (RecConDecl _ nbtys _)
get_bty (Banged ty) = get_ty ty
get_bty (Unbanged ty) = get_ty ty
-get_ty (MonoTyVar tv)
- = emptyUniqSet
-get_ty (MonoTyApp name tys)
- = (if isTvOcc (nameOccName name) then emptyUniqSet else set_name name)
- `unionUniqSets` get_tys tys
+get_ty (MonoTyVar name)
+ = if isTvOcc (nameOccName name) then emptyUniqSet else set_name name
+get_ty (MonoTyApp ty1 ty2)
+ = unionUniqSets (get_ty ty1) (get_ty ty2)
get_ty (MonoFunTy ty1 ty2)
= unionUniqSets (get_ty ty1) (get_ty ty2)
get_ty (MonoListTy tc ty)
diff --git a/ghc/docs/install_guide/installing.lit b/ghc/docs/install_guide/installing.lit
index f184f52b616bf7eb1be696d6ee160f9c97600ee2..19c5755153f7f19f4b384a9c4d16c168a54b485e 100644
--- a/ghc/docs/install_guide/installing.lit
+++ b/ghc/docs/install_guide/installing.lit
@@ -1,5 +1,5 @@
%
-% $Header: /srv/cvs/cvs.haskell.org/fptools/ghc/docs/install_guide/Attic/installing.lit,v 1.4 1996/07/25 20:47:34 partain Exp $
+% $Header: /srv/cvs/cvs.haskell.org/fptools/ghc/docs/install_guide/Attic/installing.lit,v 1.5 1997/01/17 00:33:19 simonpj Exp $
%
\begin{onlystandalone}
\documentstyle[11pt,literate]{article}
@@ -12,7 +12,7 @@ University of Glasgow\\
Glasgow, Scotland\\
G12 8QQ\\
\\
-Email: glasgow-haskell-\{users,bugs\}-request\@dcs.gla.ac.uk}
+Email: glasgow-haskell-\{users,bugs\}\@dcs.gla.ac.uk}
\maketitle
\begin{rawlatex}
\tableofcontents
diff --git a/ghc/driver/ghc-iface.lprl b/ghc/driver/ghc-iface.lprl
index fde7412f41d249ad847b24cdf59b9ac0547e2af9..7c6d01690745ff8de7e7233bb790cfb7355bc8cf 100644
--- a/ghc/driver/ghc-iface.lprl
+++ b/ghc/driver/ghc-iface.lprl
@@ -23,8 +23,8 @@ sub postprocessHiFile {
local($new_hi) = "$Tmp_prefix.hi-new";
- print STDERR "*** New hi file follows...\n"
- print STDERR `$Cat $hsc_hi`;
+# print STDERR "*** New hi file follows...\n";
+# print STDERR `$Cat $hsc_hi`;
&constructNewHiFile($hsc_hi, $hifile_target, $new_hi);
diff --git a/ghc/driver/ghc.lprl b/ghc/driver/ghc.lprl
index fde3b4d89a259a788bb26ff5c0b08253d001bebb..71124c037880628470e3f7787817acb1ad85ec33 100644
--- a/ghc/driver/ghc.lprl
+++ b/ghc/driver/ghc.lprl
@@ -206,7 +206,7 @@ These variables represent parts of the -O/-O2/etc ``templates,''
which are filled in later, using these.
These are the default values, which may be changed by user flags.
\begin{code}
-$Oopt_UnfoldingUseThreshold = '-funfolding-use-threshold3';
+$Oopt_UnfoldingUseThreshold = '-funfolding-use-threshold8';
$Oopt_MaxSimplifierIterations = '-fmax-simplifier-iterations4';
$Oopt_PedanticBottoms = '-fpedantic-bottoms'; # ON by default
$Oopt_MonadEtaExpansion = '';
diff --git a/ghc/lib/ghc/GHC.hi b/ghc/lib/ghc/GHC.hi
index cdfd5c6bdad3f251d6c24e70bd2e74285be6cd06..040802b5c613739440b6c50da53142e1108f048e 100644
--- a/ghc/lib/ghc/GHC.hi
+++ b/ghc/lib/ghc/GHC.hi
@@ -8,6 +8,8 @@
_interface_ GHC 2
_exports_
GHC
+ ->
+
Void
void
diff --git a/ghc/lib/ghc/PrelBase.lhs b/ghc/lib/ghc/PrelBase.lhs
index 086fdc455f53a2b133a18db59cbec43a1bb97a52..601500af7a1e4f8658ffb67644b14fddd8677f09 100644
--- a/ghc/lib/ghc/PrelBase.lhs
+++ b/ghc/lib/ghc/PrelBase.lhs
@@ -488,7 +488,22 @@ asciiTab = -- Using an array drags in the array module. listArray ('\NUL', ' ')
%*********************************************************
\begin{code}
-data Int = I# Int# deriving (Eq,Ord)
+data Int = I# Int#
+
+instance Eq Int where
+ (I# x) == (I# y) = x ==# y
+
+instance Ord Int where
+ (I# x) `compare` (I# y) | x <# y = LT
+ | x ==# y = EQ
+ | otherwise = GT
+
+ (I# x) < (I# y) = x <# y
+ (I# x) <= (I# y) = x <=# y
+ (I# x) >= (I# y) = x >=# y
+ (I# x) > (I# y) = x ># y
+
+
instance Enum Int where
toEnum x = x
@@ -546,8 +561,8 @@ rather not link the @Integer@ module at all; and the default-decl stuff
in the renamer tends to slurp in @Double@ regardless.
\begin{code}
-data Float = F# Float# deriving (Eq, Ord)
-data Double = D# Double# deriving (Eq, Ord)
+data Float = F# Float#
+data Double = D# Double#
data Integer = J# Int# Int# ByteArray#
\end{code}
diff --git a/ghc/lib/ghc/PrelNum.lhs b/ghc/lib/ghc/PrelNum.lhs
index 0b081fdeda847d622fb738891d84a9e72810b903..bf16dc0824fde96c2559e4f1b86876369f1074fd 100644
--- a/ghc/lib/ghc/PrelNum.lhs
+++ b/ghc/lib/ghc/PrelNum.lhs
@@ -350,6 +350,19 @@ integer_0 = 0; integer_1 = 1; integer_2 = 2; integer_m1 = -1
%*********************************************************
\begin{code}
+instance Eq Float where
+ (F# x) == (F# y) = x `eqFloat#` y
+
+instance Ord Float where
+ (F# x) `compare` (F# y) | x `ltFloat#` y = LT
+ | x `eqFloat#` y = EQ
+ | otherwise = GT
+
+ (F# x) < (F# y) = x `ltFloat#` y
+ (F# x) <= (F# y) = x `leFloat#` y
+ (F# x) >= (F# y) = x `geFloat#` y
+ (F# x) > (F# y) = x `geFloat#` y
+
instance Num Float where
(+) x y = plusFloat x y
(-) x y = minusFloat x y
@@ -472,6 +485,19 @@ instance Show Float where
%*********************************************************
\begin{code}
+instance Eq Double where
+ (D# x) == (D# y) = x ==## y
+
+instance Ord Double where
+ (D# x) `compare` (D# y) | x <## y = LT
+ | x ==## y = EQ
+ | otherwise = GT
+
+ (D# x) < (D# y) = x <## y
+ (D# x) <= (D# y) = x <=## y
+ (D# x) >= (D# y) = x >=## y
+ (D# x) > (D# y) = x >## y
+
instance Num Double where
(+) x y = plusDouble x y
(-) x y = minusDouble x y