From: simonpj Date: Fri, 17 Jan 1997 00:33:30 +0000 (+0000) Subject: [project @ 1997-01-17 00:32:23 by simonpj] X-Git-Tag: Approximately_1000_patches_recorded~849 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=fa44695e06cf83d8bcef2c826cb6b39d6ffc49c0;p=ghc-hetmet.git [project @ 1997-01-17 00:32:23 by simonpj] Cross module worker-wrappers --- diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index f0b7b2f..dcf0681 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 21c22d4..738ea2f 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 5641107..76e5ab3 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 5d06570..dff94d2 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 a15f703..215f25b 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 1e1cc3e..486a188 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 dc60530..425ee72 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 aaafe10..536ebb5 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 930f6d5..5212226 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 valrhs1 altrest %type 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 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 9fac62b..457dbd8 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 45c89be..2d840a4 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 fec0ae8..5091453 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 bd2f8e4..776ccfc 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 2d10052..9dd7017 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 18eeace..5e1b2c5 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 db49db2..fab6dd1 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 2a36802..b6f4521 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 15acf55..588619b 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 edfe71a..fc95fff 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 75537f0..1be67d8 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 a88ad05..7aaefe6 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 0478a6d..db1310c 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 457cab2..1b133b1 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 8e65398..318a6d2 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# -> <> x# ys +\begin{code} +mAX_WORKER_ARGS :: Int -- ToDo: set via flag +mAX_WORKER_ARGS = 6 -\ x# ys -> -- worker - let - x = I# x# - in - <> -\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 ac0a5ad..102af84 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 7f3e1ab..71c7dd1 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 f426434..39ecb69 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 afaf13e..359e29c 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 f184f52..19c5755 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 fde7412..7c6d016 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 fde3b4d..71124c0 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 cdfd5c6..040802b 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 086fdc4..601500a 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 0b081fd..bf16dc0 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