diff options
| author | simonpj <unknown> | 1997-01-06 21:10:27 +0000 |
|---|---|---|
| committer | simonpj <unknown> | 1997-01-06 21:10:27 +0000 |
| commit | 8f7ac3fe40d3d55743b824deab655d0797a1c55f (patch) | |
| tree | 874eef228e0257539f87caefec7bbc471e08fdd0 /ghc/compiler | |
| parent | b437dc065099e891083dde8549e06d824461e2d2 (diff) | |
| download | haskell-8f7ac3fe40d3d55743b824deab655d0797a1c55f.tar.gz | |
[project @ 1997-01-06 21:08:42 by simonpj]
Pragmas in interface files added
Diffstat (limited to 'ghc/compiler')
61 files changed, 936 insertions, 1130 deletions
diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index b59469cde4..f0b7b2f29a 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Makefile,v 1.5 1996/12/19 09:10:03 simonpj Exp $ +# $Id: Makefile,v 1.6 1997/01/06 21:08:42 simonpj Exp $ TOP = ../.. FlexSuffixRules = YES @@ -155,9 +155,9 @@ endif all :: hsc libhsp.a hsc : $(OBJS) -# $(HC) -no-link-chk "-pgml time /projects/pacsoft/ghc/src/pureatria/purelink-1.2.2-solaris2/purelink gcc" $(HC_OPTS) -o $@ $^ - $(HC) -no-link-chk "-pgml time gcc -B/projects/unsupported/gnu/sparc-sunos5/bin/g" $(HC_OPTS) -o $@ $^ -# $(HC) -no-link-chk "-pgml time gcc" $(HC_OPTS) -o $@ $^ +# $(HC) -no-link-chk "-pgml time /projects/pacsoft/ghc/src/pureatria/purelink-1.2.2-solaris2/purelink gcc" $(HC_OPTS) $(EXTRA_HC_OPTS) -o $@ $^ + $(HC) -no-link-chk "-pgml time gcc -B/projects/unsupported/gnu/sparc-sunos5/bin/g" $(HC_OPTS) $(EXTRA_HC_OPTS) -o $@ $^ +# $(HC) -no-link-chk "-pgml time gcc" $(HC_OPTS) $(EXTRA_HC_OPTS) -o $@ $^ parser/hschooks.o : parser/hschooks.c @$(RM) $@ @@ -165,7 +165,7 @@ parser/hschooks.o : parser/hschooks.c rename/ParseIface.hs : rename/ParseIface.y @$(RM) rename/ParseIface.hs rename/ParseIface.hinfo - happy +RTS -K2m -RTS -g rename/ParseIface.y + happy +RTS -K2m -H10m -RTS -g rename/ParseIface.y @chmod 444 rename/ParseIface.hs # ---------------------------------------------------------------------------- diff --git a/ghc/compiler/absCSyn/CStrings.lhs b/ghc/compiler/absCSyn/CStrings.lhs index 720e143fa9..ea5e3d199a 100644 --- a/ghc/compiler/absCSyn/CStrings.lhs +++ b/ghc/compiler/absCSyn/CStrings.lhs @@ -92,7 +92,7 @@ charToEasyHaskell c || (c >= '0' && c <= '9') then [c] else case c of - _ -> '\\' : 'o' : (octify (ord c)) + _ -> '\\' : show (ord c) octify :: Int -> String octify n diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 201c4ac5a3..2a7e85bd88 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -53,7 +53,7 @@ module Id ( recordSelectorFieldLabel, -- PREDICATES - wantIdSigInIface, + omitIfaceSigForId, cmpEqDataCon, cmpId, cmpId_withSpecDataCon, @@ -153,7 +153,7 @@ import Class ( classOpString, SYN_IE(Class), GenClass, SYN_IE(ClassOp), GenClas import IdInfo import Maybes ( maybeToBool ) import Name ( nameUnique, mkLocalName, mkSysLocalName, isLocalName, - mkCompoundName, mkInstDeclName, mkWiredInIdName, mkGlobalName, + mkCompoundName, mkInstDeclName, isLocallyDefinedName, occNameString, modAndOcc, isLocallyDefined, changeUnique, isWiredInName, nameString, getOccString, setNameVisibility, @@ -551,44 +551,35 @@ idHasNoFreeTyVars (Id _ _ _ details _ info) chk (SpecPragmaId _ no_free_tvs) = no_free_tvs chk (PrimitiveId _) = True --- wantIdSigInIface decides whether to put an Id's type signature and --- IdInfo in an interface file -wantIdSigInIface - :: Bool -- True <=> the thing is mentioned somewhere else in the - -- interface file - -> Bool -- True <=> omit anything that doesn't *have* to go - -> Id +-- omitIfaceSigForId tells whether an Id's info is implied by other declarations, +-- so we don't need to put its signature in an interface file, even if it's mentioned +-- in some other interface unfolding. + +omitIfaceSigForId + :: Id -> Bool -wantIdSigInIface mentioned_already omit_iface_prags (Id _ name _ details _ _) - = chk details - where - chk (LocalId _) = isExported name && - not (isWiredInName name) -- User-declared thing! - chk ImportedId = False -- Never put imports in interface file - chk (PrimitiveId _) = False -- Ditto, for primitives +omitIfaceSigForId (Id _ name _ details _ _) + | isWiredInName name + = True + + | otherwise + = case details of + ImportedId -> True -- Never put imports in interface file + (PrimitiveId _) -> True -- Ditto, for primitives -- This group is Ids that are implied by their type or class decl; - -- remember that all type and class decls appear in the interface file - chk (DataConId _ _ _ _ _ _ _) = False - chk (TupleConId _) = False -- Ditto - chk (RecordSelId _) = False -- Ditto - chk (SuperDictSelId _ _) = False -- Ditto - chk (MethodSelId _ _) = False -- Ditto - chk (ConstMethodId _ _ _ _) = False -- Scheduled for nuking - chk (DefaultMethodId _ _ _) = False -- Hmm. No, for now - - -- DictFunIds are more interesting, they may have IdInfo we can't - -- get from the instance declaration. We emit them if we're gung ho. - -- No need to check the export flag; instance decls are always exposed - chk (DictFunId _ _) = not omit_iface_prags - - -- This group are only called out by being mentioned somewhere else - chk (WorkerId unwrkr) = mentioned_already - chk (SpecId _ _ _) = mentioned_already - chk (InstId _) = mentioned_already - chk (SysLocalId _) = mentioned_already - chk (SpecPragmaId _ _) = mentioned_already + -- remember that all type and class decls appear in the interface file. + -- The dfun id must *not* be omitted, because it carries version info for + -- the instance decl + (DataConId _ _ _ _ _ _ _) -> True + (TupleConId _) -> True + (RecordSelId _) -> True + (SuperDictSelId _ _) -> True + (MethodSelId _ _) -> True + + other -> False -- Don't omit! + -- NB DefaultMethodIds are not omitted \end{code} \begin{code} diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 40b3c1ff7d..3c8270b3c8 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -354,7 +354,7 @@ addStrictnessInfo id_info NoStrictnessInfo = id_info addStrictnessInfo (IdInfo a b d _ e f g h i) strict = IdInfo a b d strict e f g h i ppStrictnessInfo sty NoStrictnessInfo = ppNil -ppStrictnessInfo sty BottomGuaranteed = ppPStr SLIT("_S_ _!_") +ppStrictnessInfo sty BottomGuaranteed = ppPStr SLIT("_bot_") ppStrictnessInfo sty (StrictnessInfo wrapper_args wrkr_maybe) = ppCat [ppPStr SLIT("_S_"), ppStr (showList wrapper_args ""), pp_wrkr] diff --git a/ghc/compiler/basicTypes/Literal.lhs b/ghc/compiler/basicTypes/Literal.lhs index 5caf003760..b94f150229 100644 --- a/ghc/compiler/basicTypes/Literal.lhs +++ b/ghc/compiler/basicTypes/Literal.lhs @@ -28,8 +28,8 @@ import TysPrim ( getPrimRepInfo, import CStrings ( stringToC, charToC, charToEasyHaskell ) import TysWiredIn ( stringTy ) import Pretty -- pretty-printing stuff -import PprStyle ( PprStyle(..), codeStyle ) -import Util ( thenCmp, panic ) +import PprStyle ( PprStyle(..), codeStyle, ifaceStyle ) +import Util ( thenCmp, panic, pprPanic ) \end{code} So-called @Literals@ are {\em either}: @@ -48,17 +48,24 @@ function applications, etc., etc., has not yet been done. data Literal = MachChar Char | MachStr FAST_STRING + | MachAddr Integer -- whatever this machine thinks is a "pointer" + | MachInt Integer -- for the numeric types, these are Bool -- True <=> signed (Int#); False <=> unsigned (Word#) + | MachFloat Rational | MachDouble Rational + | MachLitLit FAST_STRING PrimRep - | NoRepStr FAST_STRING -- the uncommitted ones - | NoRepInteger Integer Type{-save what we learned in the typechecker-} - | NoRepRational Rational Type{-ditto-} + | NoRepStr FAST_STRING + | NoRepInteger Integer Type -- This Type is always Integer + | NoRepRational Rational Type -- This Type is always Rational + -- We keep these Types in the literal because Rational isn't + -- (currently) wired in, so we can't conjure up its type out of + -- thin air. Integer is, so the type here is really redundant. -- deriving (Eq, Ord): no, don't want to compare Types -- The Ord is needed for the FiniteMap used in the lookForConstructor @@ -164,6 +171,11 @@ ppCast :: PprStyle -> FAST_STRING -> Pretty ppCast PprForC cast = ppPStr cast ppCast _ _ = ppNil +-- MachX (i.e. unboxed) things are printed unadornded (e.g. 3, 'a', "foo") +-- exceptions: MachFloat and MachAddr get an initial keyword prefix +-- +-- NoRep things get an initial keyword prefix (e.g. _integer_ 3) + instance Outputable Literal where ppr sty (MachChar ch) = let @@ -171,64 +183,54 @@ instance Outputable Literal where = case sty of PprForC -> charToC ch PprForAsm _ _ -> charToC ch - PprUnfolding -> charToEasyHaskell ch + PprInterface -> charToEasyHaskell ch _ -> [ch] in - ppBeside (ppBesides [ppCast sty SLIT("(C_)"), ppChar '\'', ppStr char_encoding, ppChar '\'']) - (if_ubxd sty) + ppBesides [ppCast sty SLIT("(C_)"), ppChar '\'', ppStr char_encoding, ppChar '\''] ppr sty (MachStr s) - = ppBeside (if codeStyle sty - then ppBesides [ppChar '"', ppStr (stringToC (_UNPK_ s)), ppChar '"'] - else ppStr (show (_UNPK_ s))) - (if_ubxd sty) + | codeStyle sty = ppBesides [ppChar '"', ppStr (stringToC (_UNPK_ s)), ppChar '"'] + | otherwise = ppStr (show (_UNPK_ s)) + + ppr sty lit@(NoRepStr s) + | codeStyle sty = pprPanic "NoRep in code style" (ppr PprDebug lit) + | otherwise = ppBesides [ppStr "_string_", ppStr (show (_UNPK_ s))] - ppr sty (MachAddr p) = ppBesides [ppCast sty SLIT("(void*)"), ppInteger p, if_ubxd sty] ppr sty (MachInt i signed) - | codeStyle sty - && ((signed && (i >= toInteger minInt && i <= toInteger maxInt)) - || (not signed && (i >= toInteger 0 && i <= toInteger maxInt))) - -- ToDo: Think about these ranges! - = ppBesides [ppInteger i, if_ubxd sty] - - | not (codeStyle sty) -- we'd prefer the code to the error message - = ppBesides [ppInteger i, if_ubxd sty] - - | otherwise - = error ("ERROR: Int " ++ show i ++ " out of range [" ++ - show range_min ++ " .. " ++ show maxInt ++ "]\n") + | codeStyle sty && out_of_range + = panic ("ERROR: Int " ++ show i ++ " out of range [" ++ + show range_min ++ " .. " ++ show range_max ++ "]\n") + + | otherwise = ppInteger i + where range_min = if signed then minInt else 0 + range_max = maxInt + out_of_range = not (i >= toInteger range_min && i <= toInteger range_max) - ppr sty (MachFloat f) = ppBesides [ppCast sty SLIT("(StgFloat)"), ppRational f, if_ubxd sty] - ppr sty (MachDouble d) = ppBesides [ppRational d, if_ubxd sty, if_ubxd sty] - - ppr sty (NoRepInteger i _) - | codeStyle sty = ppInteger i - | ufStyle sty = ppCat [ppStr "_NOREP_I_", ppInteger i] - | otherwise = ppBesides [ppInteger i, ppChar 'I'] + ppr sty (MachFloat f) + | codeStyle sty = ppBesides [ppCast sty SLIT("(StgFloat)"), ppRational f] + | otherwise = ppBesides [ppStr "_float_", ppRational f] - ppr sty (NoRepRational r _) - | ufStyle sty = ppCat [ppStr "_NOREP_R_", ppInteger (numerator r), ppInteger (denominator r)] - | codeStyle sty = panic "ppr.ForC.NoRepRational" - | otherwise = ppBesides [ppRational r, ppChar 'R'] + ppr sty (MachDouble d) = ppRational d - ppr sty (NoRepStr s) - | codeStyle sty = ppBesides [ppStr (show (_UNPK_ s))] - | ufStyle sty = ppCat [ppStr "_NOREP_S_", ppStr (show (_UNPK_ s))] - | otherwise = ppBesides [ppStr (show (_UNPK_ s)), ppChar 'S'] + ppr sty (MachAddr p) + | codeStyle sty = ppBesides [ppCast sty SLIT("(void*)"), ppInteger p] + | otherwise = ppBesides [ppStr "_addr_", ppInteger p] - ppr sty (MachLitLit s k) - | codeStyle sty = ppPStr s - | ufStyle sty = ppBesides [ppStr "``", ppPStr s, ppStr "'' _K_ ", ppr sty k] - | otherwise = ppBesides [ppStr "``", ppPStr s, ppStr "''"] + ppr sty lit@(NoRepInteger i _) + | codeStyle sty = pprPanic "NoRep in code style" (ppr PprDebug lit) + | otherwise = ppCat [ppStr "_integer_", ppInteger i] -ufStyle PprUnfolding = True -ufStyle _ = False + ppr sty lit@(NoRepRational r _) + | codeStyle sty = pprPanic "NoRep in code style" (ppr PprDebug lit) + | otherwise = ppCat [ppStr "_rational_", ppInteger (numerator r), ppInteger (denominator r)] -if_ubxd sty = if codeStyle sty then ppNil else ppChar '#' + ppr sty (MachLitLit s k) + | codeStyle sty = ppPStr s + | otherwise = ppBesides [ppStr "_litlit_", ppStr (show (_UNPK_ s))] showLiteral :: PprStyle -> Literal -> String - showLiteral sty lit = ppShow 80 (ppr sty lit) \end{code} + diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index 684e2bc944..452466bff4 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -33,7 +33,7 @@ import AbsCSyn import CgMonad import CgUsages ( getHpRelOffset, getSpARelOffset, getSpBRelOffset ) -import CLabel ( mkClosureLabel ) +import CLabel ( mkStaticClosureLabel, mkClosureLabel ) import ClosureInfo ( mkLFImported, mkConLFInfo, mkLFArgument, LambdaFormInfo ) import HeapOffs ( SYN_IE(VirtualHeapOffset), SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset) @@ -291,7 +291,42 @@ getArgAmodes (atom:atoms) getArgAmode :: StgArg -> FCode CAddrMode -getArgAmode (StgVarArg var) = getCAddrMode var +getArgAmode (StgConArg var) + {- Why does this case differ from StgVarArg? + Because the program might look like this: + data Foo a = Empty | Baz a + f a x = let c = Empty! a + in h c + Now, when we go Core->Stg, we drop the type applications, + so we can inline c, giving + f x = h Empty + Now we are referring to Empty as an argument (rather than in an STGCon), + so we'll look it up with getCAddrMode. We want to return an amode for + the static closure that we make for nullary constructors. But if we blindly + go ahead with getCAddrMode we end up looking in the environment, and it ain't there! + + This special case used to be in getCAddrModeAndInfo, but it doesn't work there. + Consider: + f a x = Baz a x + If the constructor Baz isn't inlined we simply want to treat it like any other + identifier, with a top level definition. We don't want to spot that it's a constructor. + + In short + StgApp con args + and + StgCon con args + are treated differently; the former is a call to a bog standard function while the + latter uses the specially-labelled, pre-defined info tables etc for the constructor. + + The way to think of this case in getArgAmode is that + SApp f Empty + is really + App f (StgCon Empty []) + -} + = returnFC (CLbl (mkStaticClosureLabel var) (idPrimRep var)) + +getArgAmode (StgVarArg var) = getCAddrMode var -- The common case + getArgAmode (StgLitArg lit) = returnFC (CLit lit) \end{code} diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs index 4cc7b301f9..136814ab26 100644 --- a/ghc/compiler/codeGen/CgTailCall.lhs +++ b/ghc/compiler/codeGen/CgTailCall.lhs @@ -80,6 +80,11 @@ Things to be careful about: \item Adjust the stack high water mark appropriately. \end{itemize} +\begin{code} +cgTailCall (StgConArg con) args live_vars + = panic "cgTailCall StgConArg" -- Only occur in argument positions +\end{code} + Literals are similar to constructors; they return by putting themselves in an appropriate register and returning to the address on top of the B stack. diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index 186209fd85..1486ff24d4 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -68,7 +68,7 @@ import CgRetConv ( assignRegs, dataReturnConvAlg, ) import CLabel ( mkStdEntryLabel, mkFastEntryLabel, mkPhantomInfoTableLabel, mkInfoTableLabel, - mkConInfoTableLabel, + mkConInfoTableLabel, mkStaticClosureLabel, mkBlackHoleInfoTableLabel, mkVapInfoTableLabel, mkStaticInfoTableLabel, mkStaticConEntryLabel, mkConEntryLabel, mkClosureLabel, mkVapEntryLabel @@ -1177,7 +1177,12 @@ mkConEntryPtr con rep _ -> mkConEntryLabel con -closureLabelFromCI (MkClosureInfo id _ _) = mkClosureLabel id +closureLabelFromCI (MkClosureInfo id _ rep) + | isConstantRep rep + = mkStaticClosureLabel id + -- This case catches those pesky static closures for nullary constructors + +closureLabelFromCI (MkClosureInfo id _ other_rep) = mkClosureLabel id entryLabelFromCI :: ClosureInfo -> CLabel entryLabelFromCI (MkClosureInfo id lf_info rep) diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 386ef41fbc..a15f703453 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -235,6 +235,9 @@ 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 @@ -460,24 +463,19 @@ okToInline -> Bool -- True => it's small enough to inline -> Bool -- True => yes, inline it --- Always inline bottoms -okToInline BottomForm occ_info small_enough - = True -- Unless one of the type args is unboxed?? - -- This used to be checked for, but I can't - -- see why so I've left it out. - --- A WHNF can be inlined if it occurs once, or is small +-- If there's no danger of duplicating work, we can inline if it occurs once, or is small okToInline form occ_info small_enough - | is_whnf_form form + | no_dup_danger form = small_enough || one_occ where one_occ = case occ_info of OneOcc _ _ _ n_alts _ -> n_alts <= 1 other -> False - is_whnf_form VarForm = True - is_whnf_form ValueForm = True - is_whnf_form other = False + no_dup_danger VarForm = True + no_dup_danger ValueForm = True + no_dup_danger BottomForm = True + no_dup_danger other = False -- A non-WHNF can be inlined if it doesn't occur inside a lambda, -- and occurs exactly once or diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index f4cbb536de..7211966765 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -55,7 +55,9 @@ import UniqSupply ( initUs, returnUs, thenUs, SYN_IE(UniqSM), UniqSupply ) import Usage ( SYN_IE(UVar) ) -import Util ( zipEqual, panic, pprPanic, assertPanic ) +import Util ( zipEqual, panic, pprTrace, pprPanic, assertPanic ) +import Pretty +import Outputable ( Outputable(..) ) type TypeEnv = TyVarEnv Type applyUsage = panic "CoreUtils.applyUsage:ToDo" @@ -82,7 +84,14 @@ coreExprType (Coerce _ ty _) = ty -- that's the whole point! -- a Con is a fully-saturated application of a data constructor -- a Prim is <ditto> of a PrimOp -coreExprType (Con con args) = applyTypeToArgs (dataConRepType con) args +coreExprType (Con con args) = +-- pprTrace "appTyArgs" (ppCat [ppr PprDebug con, ppSemi, +-- ppr PprDebug con_ty, ppSemi, +-- ppr PprDebug args]) $ + applyTypeToArgs con_ty args + where + con_ty = dataConRepType con + coreExprType (Prim op args) = applyTypeToArgs (primOpType op) args coreExprType (Lam (ValBinder binder) expr) @@ -95,7 +104,11 @@ coreExprType (Lam (UsageBinder uvar) expr) = mkForAllUsageTy uvar (panic "coreExprType:Lam UsageBinder") (coreExprType expr) coreExprType (App expr (TyArg ty)) - = applyTy (coreExprType expr) ty + = +-- pprTrace "appTy1" (ppCat [ppr PprDebug fun_ty, ppSP, ppr PprDebug ty]) $ + applyTy fun_ty ty + where + fun_ty = coreExprType expr coreExprType (App expr (UsageArg use)) = applyUsage (coreExprType expr) use diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 6c5ea90673..55bf40b542 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -36,7 +36,7 @@ import Name ( OccName, parenInCode ) import Outputable -- quite a few things import PprEnv import PprType ( pprParendGenType, pprTyVarBndr, GenType{-instances-}, GenTyVar{-instance-} ) -import PprStyle ( PprStyle(..) ) +import PprStyle ( PprStyle(..), ifaceStyle ) import Pretty import PrimOp ( PrimOp{-instances-} ) import TyVar ( GenTyVar{-instances-} ) @@ -85,15 +85,27 @@ pprGenCoreBinding sty pbdr1 pbdr2 pocc bind init_ppr_env sty tvbndr pbdr1 pbdr2 pocc = initPprEnv sty (Just (ppr sty)) -- literals - (Just (ppr sty)) -- data cons - (Just (ppr sty)) -- primops + (Just ppr_con) -- data cons + (Just ppr_prim) -- primops (Just (\ cc -> ppStr (showCostCentre sty True cc))) - (Just tvbndr) -- tyvar binders - (Just (ppr sty)) -- tyvar occs - (Just (ppr sty)) -- usage vars + (Just tvbndr) -- tyvar binders + (Just (ppr sty)) -- tyvar occs + (Just (ppr sty)) -- usage vars (Just pbdr1) (Just pbdr2) (Just pocc) -- value vars (Just (pprParendGenType sty)) -- types - (Just (ppr sty)) -- usages + (Just (ppr sty)) -- usages + where + -- ppr_con is used when printing Con expressions; we add a "!" + -- to distinguish them from ordinary applications. But not when + -- printing for interfaces, where they are treated as ordinary applications + ppr_con con | ifaceStyle sty = ppr sty con + | otherwise = ppr sty con `ppBeside` ppChar '!' + + -- We add a "!" to distinguish Primitive applications from ordinary applications. + -- But not when printing for interfaces, where they are treated + -- as ordinary applications + ppr_prim prim | ifaceStyle sty = ppr sty prim + | otherwise = ppr sty prim `ppBeside` ppChar '!' -------------- pprCoreBinding sty (NonRec binder expr) @@ -243,11 +255,11 @@ ppr_expr pe (Lit lit) = pLit pe lit ppr_expr pe (Con con []) = pCon pe con ppr_expr pe (Con con args) - = ppHang (ppBesides [pCon pe con, ppChar '!']) + = ppHang (pCon pe con) 4 (ppSep (map (ppr_arg pe) args)) ppr_expr pe (Prim prim args) - = ppHang (ppBesides [pPrim pe prim, ppChar '!']) + = ppHang (pPrim pe prim) 4 (ppSep (map (ppr_arg pe) args)) ppr_expr pe expr@(Lam _ _) @@ -263,15 +275,13 @@ ppr_expr pe expr@(Lam _ _) pp_vars lam pp vs = ppCat [ppPStr lam, ppInterleave ppSP (map pp vs), ppStr "->"] -ppr_expr pe expr@(App _ _) +ppr_expr pe expr@(App fun arg) = let - (fun, uargs, targs, vargs) = collectArgs expr + (final_fun, final_args) = go fun [arg] + go (App fun arg) args_so_far = go fun (arg:args_so_far) + go fun args_so_far = (fun, args_so_far) in - ppHang (ppr_parend_expr pe fun) - 4 (ppSep [ ppInterleave ppNil (map (pUse pe) uargs) - , ppInterleave ppNil (map (pTy pe) targs) - , ppInterleave ppNil (map (ppr_arg pe) vargs) - ]) + ppHang (ppr_parend_expr pe final_fun) 4 (ppSep (map (ppr_arg pe) final_args)) ppr_expr pe (Case expr alts) | only_one_alt alts @@ -282,7 +292,7 @@ ppr_expr pe (Case expr alts) ppr_alt (PrimAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) (ppStr " ->") ppr_alt (PrimAlts ((l, _):[]) NoDefault)= ppBeside (pLit pe l) (ppStr " ->") ppr_alt (AlgAlts ((con, params, _):[]) NoDefault) - = ppCat [ppr_alt_con con (pCon pe con), + = ppCat [pCon pe con, ppInterleave ppSP (map (pMinBndr pe) params), ppStr "->"] @@ -292,14 +302,18 @@ ppr_expr pe (Case expr alts) ppr_rhs (PrimAlts ((_,expr):[]) NoDefault) = ppr_expr pe expr in ppSep - [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_expr pe expr), ppStr "of {", ppr_alt alts], - ppBeside (ppr_rhs alts) (ppStr ";}")] + [ppSep [pp_keyword, ppNest 4 (ppr_expr pe expr), ppStr "of {", ppr_alt alts], + ppBeside (ppr_rhs alts) (ppStr ";}")] | otherwise -- default "case" printing = ppSep - [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_expr pe expr), ppStr "of {"], + [ppSep [pp_keyword, ppNest 4 (ppr_expr pe expr), ppStr "of {"], ppNest 2 (ppr_alts pe alts), ppStr "}"] + where + pp_keyword = case alts of + AlgAlts _ _ -> ppPStr SLIT("case") + PrimAlts _ _ -> ppPStr SLIT("case#") -- special cases: let ... in let ... -- ("disgusting" SLPJ) @@ -333,18 +347,16 @@ ppr_expr pe (SCC cc expr) ppr_parend_expr pe expr ] ppr_expr pe (Coerce c ty expr) - = ppSep [pp_coerce c, pTy pe ty, ppr_parend_expr pe expr ] + = ppSep [pp_coerce c, pTy pe ty, ppr_expr pe expr] where - pp_coerce (CoerceIn v) = ppBeside (ppStr "_coerce_in_") (ppr (pStyle pe) v) - pp_coerce (CoerceOut v) = ppBeside (ppStr "_coerce_out_") (ppr (pStyle pe) v) + pp_coerce (CoerceIn v) = ppBeside (ppStr "_coerce_in_ ") (ppr (pStyle pe) v) + pp_coerce (CoerceOut v) = ppBeside (ppStr "_coerce_out_ ") (ppr (pStyle pe) v) only_one_alt (AlgAlts [] (BindDefault _ _)) = True only_one_alt (AlgAlts (_:[]) NoDefault) = True only_one_alt (PrimAlts [] (BindDefault _ _)) = True only_one_alt (PrimAlts (_:[]) NoDefault) = True only_one_alt _ = False - -ppr_alt_con con pp_con = if parenInCode (getOccName con) then ppParens pp_con else pp_con \end{code} \begin{code} @@ -356,7 +368,7 @@ ppr_alts pe (AlgAlts alts deflt) ppCat [ppParens (ppInterleave ppComma (map (pMinBndr pe) params)), ppStr "->"] else - ppCat [ppr_alt_con con (pCon pe con), + ppCat [pCon pe con, ppInterleave ppSP (map (pMinBndr pe) params), ppStr "->"] ) @@ -381,7 +393,7 @@ ppr_default pe (BindDefault val_bdr expr) \begin{code} ppr_arg pe (LitArg lit) = pLit pe lit ppr_arg pe (VarArg v) = pOcc pe v -ppr_arg pe (TyArg ty) = pTy pe ty +ppr_arg pe (TyArg ty) = ppStr "@ " `ppBeside` pTy pe ty ppr_arg pe (UsageArg use) = pUse pe use \end{code} diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index e8f20fa4de..a50bdc4360 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -98,7 +98,7 @@ dsCCall label args may_gc is_asm result_ty \begin{code} unboxArg :: CoreExpr -- The supplied argument - -> DsM (CoreExpr, -- To pass as the actual argument + -> DsM (CoreExpr, -- To pass as the actual argument CoreExpr -> CoreExpr -- Wrapper to unbox the arg ) unboxArg arg @@ -106,6 +106,13 @@ unboxArg arg -- Primitive types -- ADR Question: can this ever be used? None of the PrimTypes are -- instances of the CCallable class. + -- + -- SOF response: + -- Oh yes they are, I've just added them :-) Having _ccall_ and _casm_ + -- that accept unboxed arguments is a Good Thing if you have a stub generator + -- which generates the boiler-plate box-unbox code for you, i.e., it may help + -- us nuke this very module :-) + -- | isPrimType arg_ty = returnDs (arg, \body -> body) diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 169fd50d9c..0afd0bc839 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -310,23 +310,6 @@ dsExpr (ExplicitTuple expr_list) mkConDs (tupleCon (length expr_list)) (map (TyArg . coreExprType) core_exprs ++ map VarArg core_exprs) --- Two cases, one for ordinary constructors and one for newtype constructors -dsExpr (HsCon con tys args) - | isDataTyCon tycon -- The usual datatype case - = mapDs dsExpr args `thenDs` \ args_exprs -> - mkConDs con (map TyArg tys ++ map VarArg args_exprs) - - | otherwise -- The newtype case - = ASSERT( isNewTyCon tycon ) - ASSERT( null rest_args ) - dsExpr first_arg `thenDs` \ arg_expr -> - returnDs (Coerce (CoerceIn con) result_ty arg_expr) - - where - (first_arg:rest_args) = args - (args_tys, result_ty) = splitFunTy (foldl applyTy (idType con) tys) - (tycon,_) = getAppTyCon result_ty - dsExpr (ArithSeqOut expr (From from)) = dsExpr expr `thenDs` \ expr2 -> dsExpr from `thenDs` \ from2 -> diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index 6f51268640..2a396ea7eb 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -213,7 +213,10 @@ dfListComp expr expr_ty c_ty c_id n_ty n_id (FilterQual filt : quals) returnDs (mkCoreIfThenElse core_filt core_rest (Var n_id)) dfListComp expr expr_ty c_ty c_id n_ty n_id (LetQual binds : quals) - = panic "dfListComp:LetQual" + -- new in 1.3, local bindings + = dsBinds False binds `thenDs` \ core_binds -> + dfListComp expr expr_ty c_ty c_id n_ty n_id quals `thenDs` \ core_rest -> + returnDs ( mkCoLetsAny core_binds core_rest ) dfListComp expr expr_ty c_ty c_id n_ty n_id (GeneratorQual pat list1 : quals) -- evaluate the two lists diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index 0154c84d6d..3a240733fc 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -153,7 +153,7 @@ instance Outputable name => Outputable (UfPrimOp name) where after = if is_casm then ppStr "'' " else ppSP in ppBesides [before, ppPStr str, after, - ppLbrack, ppr sty arg_tys, ppRbrack, ppSP, ppr sty result_ty] + ppLbrack, ppr sty arg_tys, ppRbrack, ppSP, ppr sty result_ty] ppr sty (UfOtherOp op) = ppr sty op diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 42fd9268d8..a993d6c2c6 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -173,11 +173,6 @@ Everything from here on appears only in typechecker output. | SingleDict -- a simple special case of Dictionary id -- local dictionary name - | HsCon -- TRANSLATION; a constructor application - Id -- used only in the RHS of constructor definitions - [GenType tyvar uvar] - [HsExpr tyvar uvar id pat] - type HsRecordBinds tyvar uvar id pat = [(id, HsExpr tyvar uvar id pat, Bool)] -- True <=> source code used "punning", @@ -364,8 +359,6 @@ pprExpr sty (Dictionary dicts methods) pprExpr sty (SingleDict dname) = ppCat [ppPStr SLIT("{-singleDict-}"), ppr sty dname] -pprExpr sty (HsCon con tys exprs) - = ppCat [ppPStr SLIT("{-HsCon-}"), ppr sty con, interppSP sty tys, interppSP sty exprs] \end{code} Parenthesize unless very simple: diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 001cd61b94..183c3990c7 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -46,6 +46,7 @@ module CmdLineOpts ( opt_D_verbose_stg2stg, opt_DoCoreLinting, opt_DoSemiTagging, + opt_DoEtaReduction, opt_DoTickyProfiling, opt_EnsureSplittableC, opt_FoldrBuildOn, @@ -60,6 +61,7 @@ module CmdLineOpts ( opt_IrrefutableEverything, opt_IrrefutableTuples, opt_LiberateCaseThreshold, + opt_NoImplicitPrelude, opt_NumbersStrict, opt_OmitBlackHoling, opt_OmitDefaultInstanceMethods, @@ -188,7 +190,6 @@ data SimplifierSwitch | IgnoreINLINEPragma | SimplDoLambdaEtaExpansion - | SimplDoEtaReduction | EssentialUnfoldingsOnly -- never mind the thresholds, only -- do unfoldings that *must* be done @@ -279,6 +280,7 @@ opt_D_verbose_stg2stg = lookUp SLIT("-dverbose-stg") opt_DoCoreLinting = lookUp SLIT("-dcore-lint") opt_DoSemiTagging = lookUp SLIT("-fsemi-tagging") opt_DoTickyProfiling = lookUp SLIT("-fticky-ticky") +opt_DoEtaReduction = lookUp SLIT("-fdo-eta-reduction") opt_EnsureSplittableC = lookUp SLIT("-fglobalise-toplev-names") opt_FoldrBuildOn = lookUp SLIT("-ffoldr-build-on") opt_FoldrBuildTrace = lookUp SLIT("-ffoldr-build-trace") @@ -291,6 +293,7 @@ opt_IgnoreIfacePragmas = lookUp SLIT("-fignore-interface-pragmas") opt_IgnoreStrictnessPragmas = lookUp SLIT("-fignore-strictness-pragmas") opt_IrrefutableEverything = lookUp SLIT("-firrefutable-everything") opt_IrrefutableTuples = lookUp SLIT("-firrefutable-tuples") +opt_NoImplicitPrelude = lookUp SLIT("-fno-implicit-prelude") opt_NumbersStrict = lookUp SLIT("-fnumbers-strict") opt_OmitBlackHoling = lookUp SLIT("-dno-black-holing") opt_OmitDefaultInstanceMethods = lookUp SLIT("-fomit-default-instance-methods") @@ -411,7 +414,6 @@ classifyOpts = sep argv [] [] -- accumulators... "-ffloat-primops-ok" -> SIMPL_SW(SimplOkToFloatPrimOps) "-falways-float-lets-from-lets" -> SIMPL_SW(SimplAlwaysFloatLetsFromLets) "-fdo-case-elim" -> SIMPL_SW(SimplDoCaseElim) - "-fdo-eta-reduction" -> SIMPL_SW(SimplDoEtaReduction) "-fdo-lambda-eta-expansion" -> SIMPL_SW(SimplDoLambdaEtaExpansion) "-fdo-foldr-build" -> SIMPL_SW(SimplDoFoldrBuild) "-fdo-not-fold-back-append" -> SIMPL_SW(SimplDontFoldBackAppend) @@ -473,7 +475,6 @@ tagOf_SimplSwitch SimplDoFoldrBuild = ILIT(12) tagOf_SimplSwitch SimplDoInlineFoldrBuild = ILIT(14) tagOf_SimplSwitch IgnoreINLINEPragma = ILIT(15) tagOf_SimplSwitch SimplDoLambdaEtaExpansion = ILIT(16) -tagOf_SimplSwitch SimplDoEtaReduction = ILIT(18) tagOf_SimplSwitch EssentialUnfoldingsOnly = ILIT(19) tagOf_SimplSwitch ShowSimplifierProgress = ILIT(20) tagOf_SimplSwitch (MaxSimplifierIterations _) = ILIT(21) diff --git a/ghc/compiler/main/LoopHack.lhc b/ghc/compiler/main/LoopHack.lhc index 382df1486f..7f46936977 100644 --- a/ghc/compiler/main/LoopHack.lhc +++ b/ghc/compiler/main/LoopHack.lhc @@ -14,11 +14,14 @@ STGFUN(_regNcgLoop){} STGFUN(_regDsLoop){} STGFUN(_regIdLoop){} STGFUN(_regPrelLoop){} +STGFUN(_regSmplLoop){} STGFUN(_regTyLoop){} STGFUN(_regHsLoop){} STGFUN(_regSpecLoop){} STGFUN(_regTcMLoop){} STGFUN(_regTcLoop){} STGFUN(_regRnLoop){} +STGFUN(_regCgLoop1){} +STGFUN(_regCgLoop2){} \end{code} diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index cb893f76dc..27bbe1e52d 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -150,10 +150,6 @@ doIt (core_cmds, stg_cmds) input_pgm doDump opt_D_dump_deriv "Derived instances:" (pp_show (ddump_deriv pprStyle)) >> - -- Now (and alas only now) we have the derived-instance information - -- so we can put instance information in the interface file - ifaceInstances if_handle inst_info >> - -- ******* DESUGARER show_pass "DeSugar " >> _scc_ "DeSugar" @@ -207,12 +203,12 @@ doIt (core_cmds, stg_cmds) input_pgm (pp_show (ppAboves (map (pprPlainStgBinding pprStyle) stg_binds2))) >> - -- Dump type signatures into the interface file + -- Dump instance decls and type signatures into the interface file let final_ids = collectFinalStgBinders stg_binds2 in - ifaceDecls if_handle rn_mod final_ids simplified >> - endIface if_handle >> + ifaceDecls if_handle rn_mod inst_info final_ids simplified >> + endIface if_handle >> -- We are definitely done w/ interface-file stuff at this point: -- (See comments near call to "startIface".) diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 3129d80a6c..59c32a05e8 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -8,7 +8,7 @@ module MkIface ( startIface, endIface, - ifaceMain, ifaceInstances, + ifaceMain, ifaceDecls ) where @@ -24,7 +24,7 @@ import TcInstUtil ( InstInfo(..) ) import CmdLineOpts import Id ( idType, dataConRawArgTys, dataConFieldLabels, isDataCon, - getIdInfo, idWantsToBeINLINEd, wantIdSigInIface, + getIdInfo, idWantsToBeINLINEd, omitIfaceSigForId, dataConStrictMarks, StrictnessMark(..), SYN_IE(IdSet), idSetToList, unionIdSets, unitIdSet, minusIdSet, isEmptyIdSet, elementOfIdSet, emptyIdSet, mkIdSet, @@ -58,7 +58,7 @@ import Unpretty -- ditto import Bag ( bagToList ) import Maybes ( catMaybes, maybeToBool ) -import FiniteMap ( emptyFM, addToFM, lookupFM, fmToList, eltsFM, FiniteMap ) +import FiniteMap ( emptyFM, addToFM, addToFM_C, lookupFM, fmToList, eltsFM, FiniteMap ) import UniqFM ( UniqFM, lookupUFM, listToUFM ) import Util ( sortLt, zipWithEqual, zipWith3Equal, mapAccumL, assertPanic, panic{-ToDo:rm-}, pprTrace ) @@ -81,10 +81,10 @@ ifaceMain :: Maybe Handle -> InterfaceDetails -> IO () -ifaceInstances :: Maybe Handle -> Bag InstInfo -> IO () ifaceDecls :: Maybe Handle -> RenamedHsModule + -> Bag InstInfo -> [Id] -- Ids used at code-gen time; they have better pragma info! -> [CoreBinding] -- In dependency order, later depend on earlier -> IO () @@ -117,16 +117,18 @@ ifaceMain (Just if_hdl) ifaceFixities if_hdl fixities >> return () -ifaceDecls Nothing rn_mod final_ids simplified = return () -ifaceDecls (Just hdl) +ifaceDecls Nothing rn_mod inst_info final_ids simplified = return () +ifaceDecls (Just hdl) (HsModule _ _ _ _ _ decls _) + inst_infos final_ids binds | null decls = return () -- You could have a module with just (re-)exports/instances in it | otherwise - = hPutStr hdl "_declarations_\n" >> - ifaceTCDecls hdl decls >> - ifaceBinds hdl final_ids binds >> + = ifaceInstances hdl inst_infos >>= \ needed_ids -> + hPutStr hdl "_declarations_\n" >> + ifaceTCDecls hdl decls >> + ifaceBinds hdl needed_ids final_ids binds >> return () \end{code} @@ -153,7 +155,21 @@ ifaceInstanceModules if_hdl imods ifaceExports if_hdl [] = return () ifaceExports if_hdl avails = hPutStr if_hdl "_exports_\n" >> - hPutCol if_hdl upp_avail (sortLt lt_avail avails) + hPutCol if_hdl do_one_module (fmToList export_fm) + where + -- Sort them into groups by module + export_fm :: FiniteMap Module [AvailInfo] + export_fm = foldr insert emptyFM avails + insert avail@(Avail name _) efm = addToFM_C (++) efm mod [avail] + where + (mod,_) = modAndOcc name + insert NotAvailable efm = efm + + -- Print one module's worth of stuff + do_one_module (mod_name, avails) + = uppBesides [upp_module mod_name, uppSP, + uppCat (map upp_avail (sortLt lt_avail avails)), + uppSemi] ifaceFixities if_hdl [] = return () ifaceFixities if_hdl fixities @@ -182,14 +198,15 @@ ifaceTCDecls if_hdl decls \begin{code} -ifaceInstances Nothing{-no iface handle-} _ = return () - -ifaceInstances (Just if_hdl) inst_infos - | null togo_insts = return () +ifaceInstances :: Handle -> Bag InstInfo -> IO IdSet -- The IdSet is the needed dfuns +ifaceInstances if_hdl inst_infos + | null togo_insts = return emptyIdSet | otherwise = hPutStr if_hdl "_instances_\n" >> - hPutCol if_hdl pp_inst (sortLt lt_inst togo_insts) + hPutCol if_hdl pp_inst (sortLt lt_inst togo_insts) >> + return needed_ids where togo_insts = filter is_togo_inst (bagToList inst_infos) + needed_ids = mkIdSet [dfun_id | InstInfo _ _ _ _ _ dfun_id _ _ _ <- togo_insts] is_togo_inst (InstInfo _ _ _ _ _ dfun_id _ _ _) = isLocallyDefined dfun_id ------- @@ -223,20 +240,22 @@ ifaceId :: (Id -> IdInfo) -- This function "knows" the extra info added -> IdSet -- Set of Ids that are needed by earlier interface -- file emissions. If the Id isn't in this set, and isn't -- exported, there's no need to emit anything + -> Bool -- True <=> recursive, so don't print unfolding -> Id -> CoreExpr -- The Id's right hand side -> Maybe (Pretty, IdSet) -- The emitted stuff, plus a possibly-augmented set of needed Ids -ifaceId get_idinfo needed_ids id rhs - | not (wantIdSigInIface (id `elementOfIdSet` needed_ids) - opt_OmitInterfacePragmas - id) +ifaceId get_idinfo needed_ids is_rec id rhs + | not (id `elementOfIdSet` needed_ids || -- Needed [no id in needed_ids has omitIfaceSigForId] + (isExported id && not (omitIfaceSigForId id))) -- or exported and not to be omitted = Nothing -- Well, that was easy! -ifaceId get_idinfo needed_ids id rhs +ifaceId get_idinfo needed_ids is_rec id rhs = Just (ppCat [sig_pretty, prag_pretty, ppSemi], new_needed_ids) where - idinfo = get_idinfo id + idinfo = get_idinfo id + inline_pragma = idWantsToBeINLINEd id + ty_pretty = pprType PprInterface (initNmbr (nmbrType (idType id))) sig_pretty = ppBesides [ppr PprInterface (getOccName id), ppPStr SLIT(" :: "), ty_pretty] @@ -255,13 +274,18 @@ ifaceId get_idinfo needed_ids id rhs unfold_pretty | show_unfold = ppCat [ppStr "_U_", pprIfaceUnfolding rhs] | otherwise = ppNil - show_unfold = not (maybeToBool maybe_worker) && -- Unfolding is implicit - not (bottomIsGuaranteed strict_info) && -- Ditto - case guidance of -- Small enough to show - UnfoldNever -> False - other -> True + show_unfold = not implicit_unfolding && -- Unnecessary + (inline_pragma || not dodgy_unfolding) -- Dangerous - guidance = calcUnfoldingGuidance (idWantsToBeINLINEd id) + implicit_unfolding = maybeToBool maybe_worker || + bottomIsGuaranteed strict_info + + dodgy_unfolding = is_rec || -- No recursive unfoldings please! + case guidance of -- Too big to show + UnfoldNever -> True + other -> False + + guidance = calcUnfoldingGuidance inline_pragma opt_InterfaceUnfoldThreshold rhs @@ -282,19 +306,19 @@ ifaceId get_idinfo needed_ids id rhs | otherwise = emptyIdSet where (_,free_vars) = addExprFVs interesting emptyIdSet rhs - interesting bound id = not (id `elementOfIdSet` bound) && - not (isDataCon id) && - not (isWiredInName (getName id)) && - isLocallyDefined id + interesting bound id = isLocallyDefined id && + not (id `elementOfIdSet` bound) && + not (omitIfaceSigForId id) \end{code} \begin{code} ifaceBinds :: Handle + -> IdSet -- These Ids are needed already -> [Id] -- Ids used at code-gen time; they have better pragma info! -> [CoreBinding] -- In dependency order, later depend on earlier -> IO () -ifaceBinds hdl final_ids binds +ifaceBinds hdl needed_ids final_ids binds = hPutStr hdl (uppShow 0 (prettyToUn (ppAboves pretties))) >> hPutStr hdl "\n" where @@ -304,7 +328,7 @@ ifaceBinds hdl final_ids binds Nothing -> pprTrace "ifaceBinds not found:" (ppr PprDebug id) $ getIdInfo id - pretties = go emptyIdSet (reverse binds) -- Reverse so that later things will + pretties = go needed_ids (reverse binds) -- Reverse so that later things will -- provoke earlier ones to be emitted go needed [] = if not (isEmptyIdSet needed) then pprTrace "ifaceBinds: free vars:" @@ -314,7 +338,7 @@ ifaceBinds hdl final_ids binds [] go needed (NonRec id rhs : binds) - = case ifaceId get_idinfo needed id rhs of + = case ifaceId get_idinfo needed False id rhs of Nothing -> go needed binds Just (pretty, needed') -> pretty : go needed' binds @@ -338,7 +362,7 @@ ifaceBinds hdl final_ids binds (needed', maybes) = mapAccumL do_one needed pairs (final_needed, more_pretties) = go_rec needed' reduced_pairs - do_one needed (id,rhs) = case ifaceId get_idinfo needed id rhs of + do_one needed (id,rhs) = case ifaceId get_idinfo needed True id rhs of Nothing -> (needed, Nothing) Just (pretty, needed') -> (needed', Just pretty) \end{code} @@ -352,11 +376,7 @@ ifaceBinds hdl final_ids binds \begin{code} upp_avail NotAvailable = uppNil -upp_avail (Avail name ns) = uppBesides [upp_module mod, uppSP, - upp_occname occ, uppSP, - upp_export ns] - where - (mod,occ) = modAndOcc name +upp_avail (Avail name ns) = uppBesides [upp_occname (getOccName name), upp_export ns] upp_export [] = uppNil upp_export names = uppBesides [uppStr "(", diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs index c743362c54..741911b592 100644 --- a/ghc/compiler/prelude/PrelVals.lhs +++ b/ghc/compiler/prelude/PrelVals.lhs @@ -571,7 +571,7 @@ realWorldPrimId \end{code} \begin{code} -voidId = pcMiscPrelId voidIdKey gHC__ SLIT("void") voidTy noIdInfo +voidId = pc_bottoming_Id voidIdKey gHC__ SLIT("void") voidTy \end{code} %************************************************************************ diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 0e522a4366..7af6822120 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -38,7 +38,7 @@ import TysWiredIn import CStrings ( identToC ) import Constants ( mIN_MP_INT_SIZE, mP_STRUCT_SIZE ) import HeapOffs ( addOff, intOff, totHdrSize, HeapOffset ) -import PprStyle ( codeStyle{-, PprStyle(..) ToDo:rm-} ) +import PprStyle ( codeStyle, ifaceStyle ) import PprType ( pprParendGenType, GenTyVar{-instance Outputable-} ) import Pretty import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) ) @@ -1742,26 +1742,31 @@ pprPrimOp sty (CCallOp fun is_casm may_gc arg_tys res_ty) = let before = if is_casm then - if may_gc then "(_casm_GC_ ``" else "(_casm_ ``" + if may_gc then "_casm_GC_ ``" else "_casm_ ``" else - if may_gc then "(_ccall_GC_ " else "(_ccall_ " + if may_gc then "_ccall_GC_ " else "_ccall_ " after = if is_casm then ppStr "''" else ppNil pp_tys - = ppBesides [ppStr " { [", - ppIntersperse pp'SP{-'-} (map (pprParendGenType sty) arg_tys), - ppRbrack, ppSP, pprParendGenType sty res_ty, ppStr " })"] - + = ppCat (map (pprParendGenType sty) (res_ty:arg_tys)) in - ppBesides [ppStr before, ppPStr fun, after, pp_tys] + ppBesides [ppStr before, ppPStr fun, after, ppSP, ppLbrack, pp_tys, ppRbrack] pprPrimOp sty other_op - = let - str = primOp_str other_op - in - (if codeStyle sty then identToC else ppPStr) str + | codeStyle sty -- For C just print the primop itself + = identToC str + + | ifaceStyle sty -- For interfaces Print it qualified with GHC. + = ppPStr SLIT("GHC.") `ppBeside` ppPStr str + + | otherwise -- Unqualified is good enough + = ppPStr str + where + str = primOp_str other_op + + instance Outputable PrimOp where ppr sty op = pprPrimOp sty op diff --git a/ghc/compiler/reader/Lex.lhs b/ghc/compiler/reader/Lex.lhs index a353f79eca..b5e035a066 100644 --- a/ghc/compiler/reader/Lex.lhs +++ b/ghc/compiler/reader/Lex.lhs @@ -152,7 +152,6 @@ data IfaceToken | ITcbrack | ITcparen | ITsemi - | ITinteger Integer -- numbers and names | ITvarid FAST_STRING | ITconid FAST_STRING | ITvarsym FAST_STRING @@ -165,9 +164,13 @@ data IfaceToken -- Stuff for reading unfoldings | ITarity | ITstrict | ITunfold | ITdemand [Demand] | ITbottom - | ITlam | ITbiglam | ITcase | ITlet | ITletrec | ITin | ITof - | ITcoerce_in | ITcoerce_out + | ITlam | ITbiglam | ITcase | ITprim_case | ITlet | ITletrec | ITin | ITof + | ITcoerce_in | ITcoerce_out | ITatsign + | ITccall (Bool,Bool) -- (is_casm, may_gc) + | ITchar Char | ITstring FAST_STRING + | ITinteger Integer | ITdouble Double + | ITinteger_lit | ITfloat_lit | ITrational_lit | ITaddr_lit | ITlit_lit | ITstring_lit deriving Text -- debugging \end{code} @@ -207,18 +210,24 @@ lexIface input ',' : cs -> ITcomma : lexIface cs ':' : ':' : cs -> ITdcolon : lexIface cs ';' : cs -> ITsemi : lexIface cs - '\"' : cs -> case read input of - ((str, rest) : _) -> ITstring (_PK_ (str::String)) : lexIface rest - '\'' : cs -> case read input of - ((ch, rest) : _) -> ITchar ch : lexIface rest + '@' : cs -> ITatsign : lexIface cs + '\"' : cs -> case reads input of + [(str, rest)] -> ITstring (_PK_ (str::String)) : lexIface rest + '\'' : cs -> case reads input of + [(ch, rest)] -> ITchar ch : lexIface rest + +-- ``thingy'' form for casm + '`' : '`' : cs -> lex_cstring "" cs +-- Keywords '_' : 'S' : '_' : cs -> ITstrict : lex_demand cs '_' : cs -> lex_keyword cs - c : cs | isDigit c -> lex_num input - | otherwise -> lex_id input - - other -> error ("lexing:"++other) +-- Numbers + '-' : c : cs | isDigit c -> lex_num "-" (c:cs) + c : cs | isDigit c -> lex_num "" (c:cs) + + other -> lex_id input where lex_comment str = case (span ((/=) '\n') str) of { (junk, rest) -> @@ -228,10 +237,17 @@ lexIface input lex_demand (c:cs) | isSpace c = lex_demand cs | otherwise = case readList (c:cs) of ((demand,rest) : _) -> ITdemand demand : lexIface rest + ----------- - lex_num str + lex_num minus str = case (span isDigit str) of { (num, rest) -> - ITinteger (read num) : lexIface rest } + case rest of + '.' : str2 -> case (span isDigit str2) of { (num2,rest2) -> + ITdouble (read (minus ++ num ++ ('.':num2))) : lexIface rest2 + } + + other -> ITinteger (read (minus ++ num)) : lexIface rest + } ------------ lex_keyword str @@ -245,6 +261,11 @@ lexIface input is_kwd_mod_char c = isAlphanum c ----------- + lex_cstring so_far ('\'' : '\'' : cs) = ITstring (_PK_ (reverse (so_far::String))) : lexIface cs + lex_cstring so_far (c : cs) = lex_cstring (c:so_far) cs + + + ----------- lex_tuple module_dot orig_cs = go 2 orig_cs where go n (',':cs) = go (n+1) cs @@ -253,6 +274,7 @@ lexIface input -- NB: ':' isn't valid inside an identifier, only at the start. -- otherwise we get confused by a::t! + -- Similarly ' itself is ok inside an identifier, but not at the start is_id_char c = isAlphanum c || c `elem` "_'!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic lex_id cs = go [] cs @@ -313,8 +335,17 @@ lexIface input ,("coerce_out_", ITcoerce_out) ,("A_", ITarity) ,("A_", ITarity) - ,("!_", ITbottom) - + ,("bot_", ITbottom) + ,("integer_", ITinteger_lit) + ,("rational_", ITrational_lit) + ,("addr_", ITaddr_lit) + ,("float_", ITfloat_lit) + ,("string_", ITstring_lit) + ,("litlit_", ITlit_lit) + ,("ccall_", ITccall (False, False)) + ,("ccall_GC_", ITccall (False, True)) + ,("casm_", ITccall (True, False)) + ,("casm_GC_", ITccall (True, True)) ] haskellKeywordsFM = listToFM [ @@ -328,6 +359,7 @@ lexIface input ,("infixr", ITinfixr) ,("infix", ITinfix) ,("case", ITcase) + ,("case#", ITprim_case) ,("of", ITof) ,("in", ITin) ,("let", ITlet) diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 1f6e8315a4..1092208b95 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -93,14 +93,24 @@ parseIface = parseIToks . lexIface LAM { ITlam } BIGLAM { ITbiglam } CASE { ITcase } + PRIM_CASE { ITprim_case } OF { ITof } LET { ITlet } LETREC { ITletrec } IN { ITin } + ATSIGN { ITatsign } COERCE_IN { ITcoerce_in } COERCE_OUT { ITcoerce_out } CHAR { ITchar $$ } STRING { ITstring $$ } + DOUBLE { ITdouble $$ } + INTEGER_LIT { ITinteger_lit } + STRING_LIT { ITstring_lit } + FLOAT_LIT { ITfloat_lit } + RATIONAL_LIT { ITrational_lit } + ADDR_LIT { ITaddr_lit } + LIT_LIT { ITlit_lit } + CCALL { ITccall $$ } %% iface :: { ParsedIface } @@ -153,13 +163,17 @@ exports_part : EXPORTS_PART export_items { $2 } export_items :: { [ExportItem] } export_items : { [] } - | export_item export_items { $1 : $2 } + | mod_name entities SEMI export_items { ($1,$2) : $4 } -export_item :: { ExportItem } -export_item : mod_name entity_occ maybe_dotdot { ($1, $2, $3) } +entities :: { [(OccName, [OccName])] } +entities : { [] } + | entity entities { $1 : $2 } -maybe_dotdot :: { [OccName] } -maybe_dotdot : { [] } +entity :: { (OccName, [OccName]) } +entity : entity_occ maybe_inside { ($1, $2) } + +maybe_inside :: { [OccName] } +maybe_inside : { [] } | OPAREN val_occs CPAREN { $2 -------------------------------------------------------------------------- } @@ -209,7 +223,7 @@ topdecl : TYPE tc_name tv_bndrs EQUAL type SEMI { TyD (TyNew $2 $3 $4 $6 $7 noDataPragmas mkIfaceSrcLoc) } | CLASS decl_context tc_name tv_bndr csigs SEMI { ClD (ClassDecl $2 $3 $4 $5 EmptyMonoBinds noClassPragmas mkIfaceSrcLoc) } - | var_name DCOLON ctype id_info SEMI + | var_name DCOLON type id_info SEMI { SigD (IfaceSig $1 $3 $4 mkIfaceSrcLoc) } decl_context :: { RdrNameContext } @@ -225,7 +239,7 @@ csigs1 : csig { [$1] } | csig SEMI csigs1 { $1 : $3 } csig :: { RdrNameSig } -csig : var_name DCOLON ctype { ClassOpSig $1 $3 noClassOpPragmas mkIfaceSrcLoc +csig : var_name DCOLON type { ClassOpSig $1 $3 noClassOpPragmas mkIfaceSrcLoc ---------------------------------------------------------------- } @@ -257,8 +271,8 @@ fields1 : field { [$1] } | field COMMA fields1 { $1 : $3 } field :: { ([RdrName], RdrNameBangType) } -field : var_name DCOLON ctype { ([$1], Unbanged $3) } - | var_name DCOLON BANG ctype { ([$1], Banged $4) +field : var_name DCOLON type { ([$1], Unbanged $3) } + | var_name DCOLON BANG type { ([$1], Banged $4) -------------------------------------------------------------------------- } @@ -276,34 +290,34 @@ context_list1 : class { [$1] } class :: { (RdrName, RdrNameHsType) } class : qtc_name atype { ($1, $2) } -ctype :: { RdrNameHsType } -ctype : FORALL forall context DARROW type { mkHsForAllTy $2 $3 $5 } - | type { $1 } - type :: { RdrNameHsType } -type : btype { $1 } - | btype RARROW type { MonoFunTy $1 $3 } +type : FORALL forall context DARROW tautype { mkHsForAllTy $2 $3 $5 } + | tautype { $1 } + +tautype :: { RdrNameHsType } +tautype : btype { $1 } + | btype RARROW tautype { MonoFunTy $1 $3 } -ctypes2 :: { [RdrNameHsType] {- Two or more -} } -ctypes2 : ctype COMMA ctype { [$1,$3] } - | ctype COMMA ctypes2 { $1 : $3 } +types2 :: { [RdrNameHsType] {- Two or more -} } +types2 : type COMMA type { [$1,$3] } + | type COMMA types2 { $1 : $3 } btype :: { RdrNameHsType } btype : atype { $1 } - | qtc_name atypes1 { MonoTyApp $1 $2 } - | tv_name atypes1 { MonoTyApp $1 $2 } + | qtc_name atype atypes { MonoTyApp $1 ($2:$3) } + | tv_name atype atypes { MonoTyApp $1 ($2:$3) } atype :: { RdrNameHsType } atype : qtc_name { MonoTyApp $1 [] } | tv_name { MonoTyVar $1 } - | OPAREN ctypes2 CPAREN { MonoTupleTy dummyRdrTcName $2 } + | OPAREN types2 CPAREN { MonoTupleTy dummyRdrTcName $2 } | OBRACK type CBRACK { MonoListTy dummyRdrTcName $2 } | OCURLY qtc_name atype CCURLY { MonoDictTy $2 $3 } - | OPAREN ctype CPAREN { $2 } + | OPAREN type CPAREN { $2 } -atypes1 :: { [RdrNameHsType] {- One or more -} } -atypes1 : atype { [$1] } - | atype atypes1 { $1 : $2 +atypes :: { [RdrNameHsType] {- Zero or more -} } +atypes : { [] } + | atype atypes { $1 : $2 --------------------------------------------------------------------- } @@ -337,6 +351,9 @@ qvar_name :: { RdrName } var_name :: { RdrName } var_name : var_occ { Unqual $1 } +any_var_name :: {RdrName} +any_var_name : var_name { $1 } + | qvar_name { $1 } qdata_name :: { RdrName } qdata_name : QCONID { varQual $1 } @@ -393,7 +410,7 @@ instdecls : { [] } | instd instdecls { $1 : $2 } instd :: { RdrNameInstDecl } -instd : INSTANCE ctype EQUAL var_name SEMI +instd : INSTANCE type EQUAL var_name SEMI { InstDecl $2 EmptyMonoBinds {- No bindings -} [] {- No user pragmas -} @@ -404,41 +421,53 @@ instd : INSTANCE ctype EQUAL var_name SEMI id_info :: { [HsIdInfo RdrName] } id_info : { [] } - | ARITY_PART arity_info id_info { HsArity $2 : $3 } - | STRICT_PART strict_info id_info { HsStrictness $2 : $3 } - | UNFOLD_PART core_expr id_info { HsUnfold $2 : $3 } + | id_info_item id_info { $1 : $2 } + +id_info_item :: { HsIdInfo RdrName } +id_info_item : ARITY_PART arity_info { HsArity $2 } + | STRICT_PART strict_info { HsStrictness $2 } + | BOTTOM { HsStrictness mkBottomStrictnessInfo } + | UNFOLD_PART core_expr { HsUnfold $2 } arity_info :: { ArityInfo } arity_info : INTEGER { exactArity (fromInteger $1) } strict_info :: { StrictnessInfo RdrName } -strict_info : DEMAND qvar_name { mkStrictnessInfo $1 (Just $2) } +strict_info : DEMAND any_var_name { mkStrictnessInfo $1 (Just $2) } | DEMAND { mkStrictnessInfo $1 Nothing } - | BOTTOM { mkBottomStrictnessInfo } core_expr :: { UfExpr RdrName } -core_expr : var_name { UfVar $1 } - | qvar_name { UfVar $1 } +core_expr : any_var_name { UfVar $1 } | qdata_name { UfVar $1 } | core_lit { UfLit $1 } + | OPAREN core_expr CPAREN { $2 } + + | core_expr ATSIGN atype { UfApp $1 (UfTyArg $3) } | core_expr core_arg { UfApp $1 $2 } - | LAM core_val_bndr RARROW core_expr { UfLam $2 $4 } + | LAM core_val_bndrs RARROW core_expr { foldr UfLam $4 $2 } | BIGLAM core_tv_bndrs RARROW core_expr { foldr UfLam $4 $2 } | CASE core_expr OF OCURLY alg_alts core_default CCURLY { UfCase $2 (UfAlgAlts $5 $6) } - | CASE BANG core_expr OF - OCURLY prim_alts core_default CCURLY { UfCase $3 (UfPrimAlts $6 $7) } + | PRIM_CASE core_expr OF + OCURLY prim_alts core_default CCURLY { UfCase $2 (UfPrimAlts $5 $6) } + | LET OCURLY core_val_bndr EQUAL core_expr CCURLY IN core_expr { UfLet (UfNonRec $3 $5) $8 } | LETREC OCURLY rec_binds CCURLY IN core_expr { UfLet (UfRec $3) $6 } - | qdata_name BANG core_args { UfCon $1 $3 } - | qvar_name BANG core_args { UfPrim (UfOtherOp $1) $3 } | coerce atype core_expr { UfCoerce $1 $2 $3 } + | CCALL ccall_string + OBRACK atype atypes CBRACK core_args { let + (is_casm, may_gc) = $1 + in + UfPrim (UfCCallOp $2 is_casm may_gc $5 $4) + $7 + } + rec_binds :: { [(UfBinder RdrName, UfExpr RdrName)] } : { [] } | core_val_bndr EQUAL core_expr SEMI rec_binds { ($1,$3) : $5 } @@ -458,23 +487,37 @@ alg_alts :: { [(RdrName, [UfBinder RdrName], UfExpr RdrName)] } core_default :: { UfDefault RdrName } : { UfNoDefault } - | core_val_bndr RARROW core_expr { UfBindDefault $1 $3 } + | core_val_bndr RARROW core_expr SEMI { UfBindDefault $1 $3 } core_arg :: { UfArg RdrName } : var_name { UfVarArg $1 } | qvar_name { UfVarArg $1 } | qdata_name { UfVarArg $1 } | core_lit { UfLitArg $1 } - | OBRACK atype CBRACK { UfTyArg $2 } core_args :: { [UfArg RdrName] } : { [] } | core_arg core_args { $1 : $2 } core_lit :: { Literal } -core_lit : INTEGER { MachInt $1 True } - | CHAR { MachChar $1 } - | STRING { MachStr $1 } +core_lit : INTEGER { MachInt $1 True } + | CHAR { MachChar $1 } + | STRING { MachStr $1 } + | STRING_LIT STRING { NoRepStr $2 } + | DOUBLE { MachDouble (toRational $1) } + | FLOAT_LIT DOUBLE { MachFloat (toRational $2) } + + | INTEGER_LIT INTEGER { NoRepInteger $2 (panic "NoRepInteger type") + -- The type checker will add the types + } + + | RATIONAL_LIT INTEGER INTEGER { NoRepRational ($2 % $3) + (panic "NoRepRational type") + -- The type checker will add the type + } + + | ADDR_LIT INTEGER { MachAddr $2 } + | LIT_LIT STRING { MachLitLit $2 (panic "ParseIface.y: ToDo: need PrimRep on LitLits in ifaces") } core_val_bndr :: { UfBinder RdrName } core_val_bndr : var_name DCOLON atype { UfValBinder $1 $3 } @@ -491,3 +534,7 @@ core_tv_bndrs :: { [UfBinder RdrName] } core_tv_bndrs : { [] } | core_tv_bndr core_tv_bndrs { $1 : $2 } +ccall_string :: { FAST_STRING } + : STRING { $1 } + | VARID { $1 } + | CONID { $1 } diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index cd531b8fc5..5964faa49a 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -84,15 +84,20 @@ renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_ -- SLURP IN ALL THE NEEDED DECLARATIONS -- Notice that the rnEnv starts empty closeDecls rn_local_decls (availsToNameSet local_avails) [] - `thenRn` \ (rn_all_decls, imported_avails) -> + `thenRn` \ (rn_all_decls1, all_names1, imp_avails1) -> -- SLURP IN ALL NEEDED INSTANCE DECLARATIONS - -- We keep the ones that only mention things (type constructors, classes) that are - -- already imported. Ones which don't can't possibly be useful to us. + -- We extract instance decls that only mention things (type constructors, classes) that are + -- already imported. Those that don't can't possibly be useful to us. + -- + -- We do another closeDecls, so that we can slurp info for the dictionary functions + -- for the instance declaration. These are *not* optional because the version number on + -- the dfun acts as the version number for the instance declaration itself; if the + -- instance decl changes, so will it's dfun version number. getImportedInstDecls `thenRn` \ imported_insts -> let all_big_names = mkNameSet [name | Avail name _ <- local_avails] `unionNameSets` - mkNameSet [name | Avail name _ <- imported_avails] + mkNameSet [name | Avail name _ <- imp_avails1] rn_needed_insts = [ initRnMS emptyRnEnv mod_name InterfaceMode (rnDecl (InstD inst_decl)) | (inst_names, mod_name, inst_decl) <- imported_insts, @@ -100,11 +105,11 @@ renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_ ] in sequenceRn rn_needed_insts `thenRn` \ inst_decls -> - -- Maybe we need to do another close-decls? + closeDecls rn_all_decls1 all_names1 imp_avails1 `thenRn` \ (rn_all_decls2, all_names2, imp_avails2) -> -- GENERATE THE VERSION/USAGE INFO - getImportVersions imported_avails `thenRn` \ import_versions -> + getImportVersions imp_avails2 `thenRn` \ import_versions -> getNameSupplyRn `thenRn` \ name_supply -> @@ -129,7 +134,7 @@ renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_ renamed_module = HsModule mod_name vers trashed_exports trashed_imports trashed_fixities - (inst_decls ++ rn_all_decls) + (inst_decls ++ rn_all_decls2) loc in returnRn (Just (renamed_module, @@ -147,8 +152,9 @@ renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_ closeDecls :: [RenamedHsDecl] -- Declarations got so far -> NameSet -- Names bound by those declarations -> [AvailInfo] -- Available stuff generated by closeDecls so far - -> RnMG ([RenamedHsDecl], -- The closed set - [AvailInfo]) -- Available stuff generated by closeDecls + -> RnMG ([RenamedHsDecl], -- input + extra decls slurped + NameSet, -- input + names bound by extra decls + [AvailInfo]) -- input + extra avails from extra decls -- The monad includes a list of possibly-unresolved Names -- This list is empty when closeDecls returns @@ -158,7 +164,7 @@ closeDecls decls decl_names import_avails case maybe_unresolved of -- No more unresolved names; we're done - Nothing -> returnRn (decls, import_avails) + Nothing -> returnRn (decls, decl_names, import_avails) -- An "unresolved" name that we've already dealt with Just (name,_) | name `elemNameSet` decl_names @@ -179,8 +185,10 @@ closeDecls decls decl_names import_avails case decl_avail of -- Can't find the declaration; check that it was optional - NotAvailable -> checkRn (case necessity of { Optional -> True; other -> False}) - (getDeclErr name) `thenRn_` + NotAvailable -> case necessity of { + Optional -> addWarnRn (getDeclWarn name); + other -> addErrRn (getDeclErr name) + } `thenRn_` closeDecls decls decl_names import_avails -- Found it @@ -195,6 +203,9 @@ closeDecls decls decl_names import_avails getDeclErr name sty = ppSep [ppStr "Failed to find interface decl for", ppr sty name] + +getDeclWarn name sty + = ppSep [ppStr "Warning: failed to find (optional) interface decl for", ppr sty name] \end{code} diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index 0ff8016cb6..d4df584c22 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -158,7 +158,7 @@ it expects the global environment to contain bindings for the binders %* * %************************************************************************ -@rnTopBinds@ and @rnTopMonoBinds@ assume that the environment already +@rnTopBinds@ assumes that the environment already contains bindings for the binders of this particular binding. \begin{code} @@ -170,10 +170,6 @@ rnTopBinds (BindWith (RecBind bind) sigs) = rnTopMonoBinds bind sigs -- The parser doesn't produce other forms -rnTopMonoBinds :: RdrNameMonoBinds - -> [RdrNameSig] - -> RnMS s RenamedHsBinds - rnTopMonoBinds EmptyMonoBinds sigs = returnRn EmptyBinds @@ -201,10 +197,6 @@ rnTopMonoBinds mbinds sigs - extends the environment to bind them to new local names - calls @rnMonoBinds@ to do the real work -In contrast, @rnTopMonoBinds@ doesn't extend the environment, because that's -already done in pass3. All it does is call @rnMonoBinds@ and discards -the free var info. - \begin{code} rnBinds :: RdrNameHsBinds -> (RenamedHsBinds -> RnMS s (result, FreeVars)) diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 649391dd4d..2a36802206 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -97,11 +97,11 @@ loadInterface doc_str load_mod Just (ParsedIface _ mod_vers usages exports rd_inst_mods fixs decls insts) -> -- LOAD IT INTO Ifaces - mapRn loadExport exports `thenRn` \ avails -> + mapRn loadExport exports `thenRn` \ avails_s -> foldlRn (loadDecl load_mod) (decls_map,vers_map) decls `thenRn` \ (new_decls_map, new_vers_map) -> foldlRn (loadInstDecl load_mod) inst_map insts `thenRn` \ new_insts_map -> let - export_env = (avails, fixs) + export_env = (concat avails_s, fixs) -- Exclude this module from the "special-inst" modules new_inst_mods = inst_mods `unionLists` (filter (/= this_mod) rd_inst_mods) @@ -118,14 +118,17 @@ loadInterface doc_str load_mod returnRn new_ifaces } -loadExport :: ExportItem -> RnMG AvailInfo -loadExport (mod, occ, occs) - = new_name occ `thenRn` \ name -> - mapRn new_name occs `thenRn` \ names -> - returnRn (Avail name names) +loadExport :: ExportItem -> RnMG [AvailInfo] +loadExport (mod, entities) + = mapRn load_entity entities where new_name occ = newGlobalName mod occ + load_entity (occ, occs) + = new_name occ `thenRn` \ name -> + mapRn new_name occs `thenRn` \ names -> + returnRn (Avail name names) + loadVersion :: Module -> VersionMap -> (OccName,Version) -> RnMG VersionMap loadVersion mod vers_map (occ, version) = newGlobalName mod occ `thenRn` \ name -> diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index f1fd8477c5..a2cc06aece 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -160,7 +160,7 @@ data AvailInfo = NotAvailable | Avail Name [Name] =================================================== \begin{code} -type ExportItem = (Module, OccName, [OccName]) +type ExportItem = (Module, [(OccName, [OccName])]) type VersionInfo name = [ImportVersion name] type ImportVersion name = (Module, Version, [LocalVersion name]) type LocalVersion name = (name, Version) diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 069d7100d2..5db5ead0fb 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -12,7 +12,7 @@ module RnNames ( IMP_Ubiq() -import CmdLineOpts ( opt_SourceUnchanged ) +import CmdLineOpts ( opt_SourceUnchanged, opt_NoImplicitPrelude ) import HsSyn ( HsModule(..), HsDecl(..), FixityDecl(..), Fixity, Fake, InPat, IE(..), HsTyVar, TyDecl, ClassDecl, InstDecl, DefaultDecl, ImportDecl(..), HsBinds, IfaceSig ) @@ -91,8 +91,13 @@ getGlobalNames m@(HsModule this_mod _ exports imports _ _ mod_loc) all_imports = prel_imports ++ imports + -- NB: opt_NoImplicitPrelude is slightly different to import Prelude (); + -- because the former doesn't even look at Prelude.hi for instance declarations, + -- whereas the latter does. prel_imports | this_mod == pRELUDE || - explicit_prelude_import = [] + explicit_prelude_import || + opt_NoImplicitPrelude + = [] | otherwise = [ImportDecl pRELUDE False {- Not qualified -} @@ -125,12 +130,7 @@ checkEarlyExit mod importsFromImportDecl :: RdrNameImportDecl -> RnMG (RnEnv, ModuleAvails) - -- Check for "import M ()", and then don't even look at M. - -- This makes sense, and is actually rather useful for the Prelude. -importsFromImportDecl (ImportDecl mod qual as_mod (Just (False,[])) loc) - = returnRn (emptyRnEnv, emptyModuleAvails) - -importsFromImportDecl (ImportDecl mod qual as_mod import_spec loc) +importsFromImportDecl (ImportDecl mod qual_only as_mod import_spec loc) = pushSrcLocRn loc $ getInterfaceExports mod `thenRn` \ (avails, fixities) -> filterImports mod import_spec avails `thenRn` \ filtered_avails -> @@ -140,7 +140,11 @@ importsFromImportDecl (ImportDecl mod qual as_mod import_spec loc) ] fixities' = [ (occ,fixity,provenance) | (occ,fixity) <- fixities ] in - qualifyImports mod qual as_mod (ExportEnv filtered_avails' fixities') + qualifyImports mod + True -- Want qualified names + (not qual_only) -- Maybe want unqualified names + as_mod + (ExportEnv filtered_avails' fixities') where set_name_prov name = setNameProvenance name provenance provenance = Imported mod loc @@ -152,7 +156,8 @@ importsFromLocalDecls rec_exp_fn (HsModule mod _ _ _ fix_decls decls _) = foldlRn getLocalDeclBinders [] decls `thenRn` \ avails -> mapRn fixityFromFixDecl fix_decls `thenRn` \ fixities -> qualifyImports mod - False -- Not qualified + False -- Don't want qualified names + True -- Want unqualified names Nothing -- No "as M" part (ExportEnv avails fixities) where @@ -250,41 +255,52 @@ right qaulified names. It also turns the @Names@ in the @ExportEnv@ into fully fledged @Names@. \begin{code} -qualifyImports :: Module -- Improrted module - -> Bool -- True <=> qualified import +qualifyImports :: Module -- Imported module + -> Bool -- True <=> want qualified import + -> Bool -- True <=> want unqualified import -> Maybe Module -- Optional "as M" part -> ExportEnv -- What's imported -> RnMG (RnEnv, ModuleAvails) -qualifyImports this_mod qual as_mod (ExportEnv avails fixities) +qualifyImports this_mod qual_imp unqual_imp as_mod (ExportEnv avails fixities) = -- Make the qualified-name environments, checking of course for clashes foldlRn add_name emptyNameEnv avails `thenRn` \ name_env -> foldlRn (add_fixity name_env) emptyFixityEnv fixities `thenRn` \ fixity_env -> - - -- Deal with the "qualified" part; if not qualifies then add unqualfied bindings - if qual then - returnRn (RnEnv name_env fixity_env, mod_avail_env) - else - returnRn (RnEnv (unQualify name_env) (unQualify fixity_env), mod_avail_env) - + returnRn (RnEnv name_env fixity_env, mod_avail_env) where - mod_avail_env = unitFM this_mod avails + qual_mod = case as_mod of + Nothing -> this_mod + Just another_name -> another_name + + mod_avail_env = unitFM qual_mod avails add_name name_env NotAvailable = returnRn name_env add_name name_env (Avail n ns) = foldlRn add_one name_env (n : ns) add_one :: NameEnv -> Name -> RnMG NameEnv - add_one env name = addOneToNameEnvRn env (Qual this_mod occ_name) name + add_one env name = add_to_env addOneToNameEnvRn env occ_name name where occ_name = nameOccName name + add_to_env add_fn env occ thing | qual_imp && unqual_imp = both + | qual_imp = qual_only + | unqual_imp = unqual_only + where + unqual_only = add_fn env (Unqual occ) thing + qual_only = add_fn env (Qual qual_mod occ) thing + both = unqual_only `thenRn` \ env' -> + add_fn env' (Qual qual_mod occ) thing + add_fixity name_env fixity_env (occ_name, fixity, provenance) - | maybeToBool (lookupFM name_env qual_name) -- The name is imported - = addOneToFixityEnvRn fixity_env qual_name (fixity,provenance) - | otherwise -- It ain't imported + | maybeToBool (lookupFM name_env rdr_name) -- It's imported + = add_to_env addOneToFixityEnvRn fixity_env occ_name (fixity,provenance) + | otherwise -- It ain't imported = returnRn fixity_env where - qual_name = Qual this_mod occ_name + -- rdr_name is a name by which the thing is guaranteed to be known, + -- *if it is imported at all* + rdr_name | qual_imp = Qual qual_mod occ_name + | otherwise = Unqual occ_name \end{code} unQualify adds an Unqual binding for every existing Qual binding. diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index e726eb3151..15acf55033 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -201,7 +201,9 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun_name src_loc)) where rn_dfun Nothing = newDfunName src_loc `thenRn` \ n' -> returnRn (Just n') - rn_dfun (Just n) = lookupOptionalOccRn n `thenRn` \ n' -> + rn_dfun (Just n) = lookupOccRn n `thenRn` \ n' -> + -- The dfun is not optional, because we use its version number + -- to identify the version of the instance declaration returnRn (Just n') rn_uprag (SpecSig op ty using locn) diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs index 4a57044521..f571658ec5 100644 --- a/ghc/compiler/simplCore/SimplCase.lhs +++ b/ghc/compiler/simplCore/SimplCase.lhs @@ -30,7 +30,6 @@ import PrelVals ( voidId ) import PrimOp ( primOpOkForSpeculation, PrimOp{-instance Eq-} ) import SimplEnv import SimplMonad -import SimplUtils ( mkValLamTryingEta ) import Type ( isPrimType, getAppDataTyConExpandingDicts, mkFunTy, mkFunTys, eqTy ) import TysPrim ( voidTy ) import Unique ( Unique{-instance Eq-} ) @@ -451,10 +450,7 @@ bindLargeRhs env args rhs_ty rhs_c in rhs_c new_env `thenSmpl` \ rhs' -> let - final_rhs - = (if switchIsSet new_env SimplDoEtaReduction - then mkValLamTryingEta - else mkValLam) used_args' rhs' + final_rhs = mkValLam used_args' rhs' in returnSmpl (NonRec rhs_fun_id final_rhs, foldl App (Var rhs_fun_id) used_arg_atoms) diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 80d9bb3c48..b92e2a7017 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -27,6 +27,7 @@ import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), switchIsOn, import CoreLint ( lintCoreBindings ) import CoreSyn import CoreUtils ( coreExprType ) +import SimplUtils ( etaCoreExpr ) import CoreUnfold import Literal ( Literal(..), literalType, mkMachInt ) import ErrUtils ( ghcExit ) @@ -121,9 +122,13 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds init_specdata = initSpecData local_tycons tycon_specs ------------- - core_linter = if opt_DoCoreLinting - then lintCoreBindings ppr_style - else ( \ whodunnit spec_done binds -> binds ) + core_linter what = if opt_DoCoreLinting + then (if opt_D_show_passes then + trace ("\n*** Core Lint result of " ++ what) + else id + ) + lintCoreBindings ppr_style what + else ( \ spec_done binds -> binds ) -------------- do_core_pass info@(binds, us, spec_data, simpl_stats) to_do @@ -307,6 +312,14 @@ Several tasks are done by @tidyCorePgm@ 6. Eliminate polymorphic case expressions. We can't generate code for them yet. +7. Do eta reduction for lambda abstractions appearing in: + - the RHS of case alternatives + - the body of a let + These will otherwise turn into local bindings during Core->STG; better to + nuke them if possible. (In general the simplifier does eta expansion not + eta reduction, up to this point.) + + Eliminate indirections ~~~~~~~~~~~~~~~~~~~~~~ In @elimIndirections@, we look for things at the top-level of the form... @@ -453,22 +466,22 @@ tidyCoreExpr (Lam bndr body) tidyCoreExpr (Let bind body) = tidyCoreBinding bind `thenTM` \ bind' -> - tidyCoreExpr body `thenTM` \ body' -> + tidyCoreExprEta body `thenTM` \ body' -> returnTM (Let bind' body') tidyCoreExpr (SCC cc body) - = tidyCoreExpr body `thenTM` \ body' -> + = tidyCoreExprEta body `thenTM` \ body' -> returnTM (SCC cc body') tidyCoreExpr (Coerce coercion ty body) - = tidyCoreExpr body `thenTM` \ body' -> + = tidyCoreExprEta body `thenTM` \ body' -> returnTM (Coerce coercion ty body') -- Wierd case for par, seq, fork etc. See notes above. tidyCoreExpr (Case scrut@(Prim op args) (PrimAlts _ (BindDefault binder rhs))) | funnyParallelOp op = tidyCoreExpr scrut `thenTM` \ scrut' -> - tidyCoreExpr rhs `thenTM` \ rhs' -> + tidyCoreExprEta rhs `thenTM` \ rhs' -> returnTM (Case scrut' (PrimAlts [] (BindDefault binder rhs'))) -- Eliminate polymorphic case, for which we can't generate code just yet @@ -494,10 +507,10 @@ tidyCoreExpr (Case scrut alts) tidy_deflt deflt `thenTM` \ deflt' -> returnTM (PrimAlts alts' deflt') - tidy_alg_alt (con,bndrs,rhs) = tidyCoreExpr rhs `thenTM` \ rhs' -> + tidy_alg_alt (con,bndrs,rhs) = tidyCoreExprEta rhs `thenTM` \ rhs' -> returnTM (con,bndrs,rhs') - tidy_prim_alt (lit,rhs) = tidyCoreExpr rhs `thenTM` \ rhs' -> + tidy_prim_alt (lit,rhs) = tidyCoreExprEta rhs `thenTM` \ rhs' -> returnTM (lit,rhs') -- We convert case x of {...; x' -> ...x'...} @@ -510,12 +523,15 @@ tidyCoreExpr (Case scrut alts) tidy_deflt NoDefault = returnTM NoDefault tidy_deflt (BindDefault bndr rhs) - = extend_env (tidyCoreExpr rhs) `thenTM` \ rhs' -> + = extend_env (tidyCoreExprEta rhs) `thenTM` \ rhs' -> returnTM (BindDefault bndr rhs') where extend_env = case scrut of Var v -> extendEnvTM bndr v other -> \x -> x + +tidyCoreExprEta e = tidyCoreExpr e `thenTM` \ e' -> + returnTM (etaCoreExpr e') \end{code} Arguments diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index 26d6029ae2..5653bfa489 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -450,9 +450,14 @@ extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con | otherwise = expr_cc where expr_cc = coreExprCc rhs +\end{code} + -{- We need to be pretty careful when extending - the environment with RHS info in recursive groups. + +Recursive bindings +~~~~~~~~~~~~~~~~~~ +We need to be pretty careful when extending +the environment with RHS info in recursive groups. Here's a nasty example: @@ -480,7 +485,7 @@ Our solution is this: (a) we inline un-simplified RHSs, and then simplify them in a clone-only environment. (b) we inline only variables and values -This means taht +This means that r = f x ==> r = f x @@ -503,8 +508,8 @@ with a clone of y. Instead we'll probably inline y (a small value) to give x = 1:y which is OK if not clever. --} +\begin{code} extendEnvForRecBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) (out_id, ((_,occ_info), old_rhs)) = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 0017880516..4b8f01a36c 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -10,7 +10,7 @@ module SimplUtils ( floatExposesHNF, - mkTyLamTryingEta, mkValLamTryingEta, + etaCoreExpr, etaExpandCount, @@ -25,7 +25,7 @@ IMP_Ubiq(){-uitous-} IMPORT_DELOOPER(SmplLoop) -- paranoia checking import BinderInfo -import CmdLineOpts ( SimplifierSwitch(..) ) +import CmdLineOpts ( opt_DoEtaReduction, SimplifierSwitch(..) ) import CoreSyn import CoreUnfold ( SimpleUnfolding, mkFormSummary, FormSummary(..) ) import Id ( idType, isBottomingId, idWantsToBeINLINEd, dataConArgTys, @@ -37,9 +37,10 @@ import PrelVals ( augmentId, buildId ) import PrimOp ( primOpIsCheap ) import SimplEnv import SimplMonad -import Type ( eqTy, isPrimType, maybeAppDataTyConExpandingDicts, getTyVar_maybe ) +import Type ( tyVarsOfType, isPrimType, maybeAppDataTyConExpandingDicts ) import TysWiredIn ( realWorldStateTy ) -import TyVar ( GenTyVar{-instance Eq-} ) +import TyVar ( elementOfTyVarSet, + GenTyVar{-instance Eq-} ) import Util ( isIn, panic ) \end{code} @@ -102,12 +103,16 @@ floatExposesHNF float_lets float_primops ok_to_dup rhs try_deflt (BindDefault _ rhs) = try rhs \end{code} +Eta reduction +~~~~~~~~~~~~~ +@etaCoreExpr@ trys an eta reduction at the top level of a Core Expr. -Eta reduction on ordinary lambdas -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have a go at doing +e.g. \ x y -> f x y ===> f - \ x y -> f x y ===> f +It is used + a) Before constructing an Unfolding, to + try to make the unfolding smaller; + b) In tidyCoreExpr, which is done just before converting to STG. But we only do this if it gets rid of a whole lambda, not part. The idea is that lambdas are often quite helpful: they indicate @@ -123,43 +128,75 @@ It does arise: gives rise to a recursive function for the list comprehension, and f turns out to be just a single call to this recursive function. -\begin{code} -mkValLamTryingEta :: [Id] -- Args to the lambda - -> CoreExpr -- Lambda body - -> CoreExpr +Doing eta on type lambdas is useful too: -mkValLamTryingEta [] body = body + /\a -> <expr> a ===> <expr> -mkValLamTryingEta orig_ids body - = reduce_it (reverse orig_ids) body - where - bale_out = mkValLam orig_ids body +where <expr> doesn't mention a. +This is sometimes quite useful, because we can get the sequence: + + f ab d = let d1 = ...d... in + letrec f' b x = ...d...(f' b)... in + f' b +specialise ==> + + f.Int b = letrec f' b x = ...dInt...(f' b)... in + f' b + +float ==> + + f' b x = ...dInt...(f' b)... + f.Int b = f' b - reduce_it [] residual - | residual_ok residual = residual - | otherwise = bale_out +Now we really want to simplify to - reduce_it (id:ids) (App fun (VarArg arg)) - | id == arg - && not (idType id `eqTy` realWorldStateTy) - -- *never* eta-reduce away a PrimIO state token! (WDP 94/11) - = reduce_it ids fun + f.Int = f' - reduce_it ids other = bale_out +and then replace all the f's with f.Ints. - is_elem = isIn "mkValLamTryingEta" +N.B. We are careful not to partially eta-reduce a sequence of type +applications since this breaks the specialiser: + + /\ a -> f Char# a =NO=> f Char# + +\begin{code} +etaCoreExpr :: CoreExpr -> CoreExpr + + +etaCoreExpr expr@(Lam bndr body) + | opt_DoEtaReduction + = case etaCoreExpr body of + App fun arg | eta_match bndr arg && + residual_ok fun + -> fun -- Eta + other -> expr -- Can't eliminate it, so do nothing at all + where + eta_match (ValBinder v) (VarArg v') = v == v' + eta_match (TyBinder tv) (TyArg ty) = tv `elementOfTyVarSet` tyVarsOfType ty + eta_match bndr arg = False - ----------- residual_ok :: CoreExpr -> Bool -- Checks for type application -- and function not one of the -- bound vars - residual_ok (Var v) = not (v `is_elem` orig_ids) - -- Fun mustn't be one of the bound ids + residual_ok (Var v) + = not (eta_match bndr (VarArg v)) residual_ok (App fun arg) - | notValArg arg = residual_ok fun - residual_ok other = False + | eta_match bndr arg = False + | otherwise = residual_ok fun + residual_ok (Coerce coercion ty body) + | eta_match bndr (TyArg ty) = False + | otherwise = residual_ok body + + residual_ok other = False -- Safe answer + -- This last clause may seem conservative, but consider: + -- primops, constructors, and literals, are impossible here + -- let and case are unlikely (the argument would have been floated inside) + -- SCCs we probably want to be conservative about (not sure, but it's safe to be) + +etaCoreExpr expr = expr -- The common case \end{code} + Eta expansion ~~~~~~~~~~~~~ @@ -282,69 +319,6 @@ manifestlyCheap other_expr -- look for manifest partial application \end{code} -Eta reduction on type lambdas -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have a go at doing - - /\a -> <expr> a ===> <expr> - -where <expr> doesn't mention a. -This is sometimes quite useful, because we can get the sequence: - - f ab d = let d1 = ...d... in - letrec f' b x = ...d...(f' b)... in - f' b -specialise ==> - - f.Int b = letrec f' b x = ...dInt...(f' b)... in - f' b - -float ==> - - f' b x = ...dInt...(f' b)... - f.Int b = f' b - -Now we really want to simplify to - - f.Int = f' - -and then replace all the f's with f.Ints. - -N.B. We are careful not to partially eta-reduce a sequence of type -applications since this breaks the specialiser: - - /\ a -> f Char# a =NO=> f Char# - -\begin{code} -mkTyLamTryingEta :: [TyVar] -> CoreExpr -> CoreExpr - -mkTyLamTryingEta tyvars tylam_body - = if - tyvars == tyvar_args && -- Same args in same order - check_fun fun -- Function left is ok - then - -- Eta reduction worked - fun - else - -- The vastly common case - mkTyLam tyvars tylam_body - where - (tyvar_args, fun) = strip_tyvar_args [] tylam_body - - strip_tyvar_args args_so_far tyapp@(App fun (TyArg ty)) - = case getTyVar_maybe ty of - Just tyvar_arg -> strip_tyvar_args (tyvar_arg:args_so_far) fun - Nothing -> (args_so_far, tyapp) - - strip_tyvar_args args_so_far (App _ (UsageArg _)) - = panic "SimplUtils.mkTyLamTryingEta: strip_tyvar_args UsageArg" - - strip_tyvar_args args_so_far fun - = (args_so_far, fun) - - check_fun (Var f) = True -- Claim: tyvars not mentioned by type of f - check_fun other = False -\end{code} Let to case ~~~~~~~~~~~ diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs index 80951af6db..0b0cc562b1 100644 --- a/ghc/compiler/simplCore/SimplVar.lhs +++ b/ghc/compiler/simplCore/SimplVar.lhs @@ -69,6 +69,14 @@ completeVar env var args -- wrappers, even thouth the former have an unfold-always guidance. costCentreOk (getEnclosingCC env) (getEnclosingCC unfold_env) = tick UnfoldingDone `thenSmpl_` +#ifdef DEBUG + simplCount `thenSmpl` \ n -> + (if n > 3000 then + pprTrace "Ticks > 3000 and unfolding" (ppr PprDebug var) + else + id + ) +#endif simplExpr unfold_env unf_template args | maybeToBool maybe_specialisation @@ -93,10 +101,17 @@ completeVar env var args ---------- Unfolding stuff maybe_unfolding_info = case (lookupOutIdEnv env var, unfolding_from_id) of + (Just (_, occ_info, OutUnfolding enc_cc unf), _) -> Just (occ_info, setEnclosingCC env enc_cc, unf) + (Just (_, occ_info, InUnfolding env_unf unf), _) - -> Just (occ_info, combineSimplEnv env env_unf, unf) + -> Just (occ_info, env_unf, unf) +-- This combineSimplEnv is WRONG. InUnfoldings are used for +-- recursive decls, and we're relying on using the old unfold enf +-- to avoid getting outselves in a loop! +-- -> Just (occ_info, combineSimplEnv env env_unf, unf) + (_, CoreUnfolding unf) -> Just (noBinderInfo, env, unf) diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 9d44435afc..75537f05df 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -324,23 +324,12 @@ simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args) simplExpr (extendTyEnv env tyvar ty) body args simplExpr env tylam@(Lam (TyBinder tyvar) body) [] - = do_tylambdas env [] tylam - where - do_tylambdas env tyvars' (Lam (TyBinder tyvar) body) - = -- Clone the type variable - cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' -> - let - new_env = extendTyEnv env tyvar (mkTyVarTy tyvar') - in - do_tylambdas new_env (tyvar':tyvars') body - - do_tylambdas env tyvars' body - = simplExpr env body [] `thenSmpl` \ body' -> - returnSmpl ( - (if switchIsSet env SimplDoEtaReduction - then mkTyLamTryingEta - else mkTyLam) (reverse tyvars') body' - ) + = cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' -> + let + new_env = extendTyEnv env tyvar (mkTyVarTy tyvar') + in + simplExpr new_env body [] `thenSmpl` \ body' -> + returnSmpl (Lam (TyBinder tyvar') body') #ifdef DEBUG simplExpr env (Lam (TyBinder _) _) (_ : _) @@ -493,11 +482,6 @@ simplRhsExpr -> SmplM (OutExpr, ArityInfo) simplRhsExpr env binder@(id,occ_info) rhs - | dont_eta_expand rhs - = simplExpr rhs_env rhs [] `thenSmpl` \ rhs' -> - returnSmpl (rhs', unknownArity) - - | otherwise -- Have a go at eta expansion = -- Deal with the big lambda part ASSERT( null uvars ) -- For now @@ -511,12 +495,7 @@ simplRhsExpr env binder@(id,occ_info) rhs simplValLam lam_env body (getBinderInfoArity occ_info) `thenSmpl` \ (lambda', arity) -> -- Put it back together - returnSmpl ( - (if switchIsSet env SimplDoEtaReduction - then mkTyLamTryingEta - else mkTyLam) tyvars' lambda', - arity - ) + returnSmpl (mkTyLam tyvars' lambda', arity) where rhs_env | -- not (switchIsSet env IgnoreINLINEPragma) && @@ -552,25 +531,6 @@ simplRhsExpr env binder@(id,occ_info) rhs -- We havn't solved this problem yet! (uvars, tyvars, body) = collectUsageAndTyBinders rhs - - -- dont_eta_expand prevents eta expansion in silly situations. - -- For example, consider the defn - -- x = y - -- It would be silly to eta expand the "y", because it would just - -- get eta-reduced back to y. Furthermore, if this was a top level defn, - -- and x was exported, then the defn won't be eliminated, so this - -- silly expand/reduce cycle will happen every time, which makes the - -- simplifier loop!. - -- The solution is to not even try eta expansion unless the rhs looks - -- non-trivial. - dont_eta_expand (Lit _) = True - dont_eta_expand (Var _) = True - dont_eta_expand (Con _ _) = True - dont_eta_expand (App f a) - | notValArg a = dont_eta_expand f - dont_eta_expand (Lam x b) - | notValBinder x = dont_eta_expand b - dont_eta_expand _ = False \end{code} @@ -597,12 +557,7 @@ simplValLam env expr min_no_of_args new_env = extendIdEnvWithClones env binders binders' in simplExpr new_env body [] `thenSmpl` \ body' -> - returnSmpl ( - (if switchIsSet new_env SimplDoEtaReduction - then mkValLamTryingEta - else mkValLam) binders' body', - atLeastArity no_of_binders - ) + returnSmpl (mkValLam binders' body', atLeastArity no_of_binders) | otherwise -- Eta expansion possible = tick EtaExpansion `thenSmpl_` @@ -613,9 +568,7 @@ simplValLam env expr min_no_of_args newIds extra_binder_tys `thenSmpl` \ extra_binders' -> simplExpr new_env body (map VarArg extra_binders') `thenSmpl` \ body' -> returnSmpl ( - (if switchIsSet new_env SimplDoEtaReduction - then mkValLamTryingEta - else mkValLam) (binders' ++ extra_binders') body', + mkValLam (binders' ++ extra_binders') body', atLeastArity (no_of_binders + no_of_extra_binders) ) @@ -1122,22 +1075,7 @@ completeNonRec env binder new_id (Coerce coercion ty rhs) (Coerce coercion ty atomic_rhs) `thenSmpl` \ (env2, binds2) -> returnSmpl (env2, binds1 ++ binds2) - where - is_atomic (Var v) = True - is_atomic (Lit l) = not (isNoRepLit l) - is_atomic other = False - -- Atomic right-hand sides. - -- We used to have a "tick AtomicRhs" in here, but it causes more trouble - -- than it's worth. For a top-level binding a = b, where a is exported, - -- we can't drop the binding, so we get repeated AtomicRhs ticks -completeNonRec env binder new_id rhs@(Var v) - = returnSmpl (extendIdEnvWithAtom env binder (VarArg v), [NonRec new_id rhs]) - -completeNonRec env binder new_id rhs@(Lit lit) - | not (isNoRepLit lit) - = returnSmpl (extendIdEnvWithAtom env binder (LitArg lit), [NonRec new_id rhs]) - -- Right hand sides that are constructors -- let v = C args -- in @@ -1156,12 +1094,26 @@ completeNonRec env binder new_id rhs@(Con con con_args) maybe_existing_con = lookForConstructor env con con_args Just it = maybe_existing_con + -- Default case -completeNonRec env binder@(id,occ_info) new_id rhs - = returnSmpl (new_env, [NonRec new_id rhs]) + -- Check for atomic right-hand sides. + -- We used to have a "tick AtomicRhs" in here, but it causes more trouble + -- than it's worth. For a top-level binding a = b, where a is exported, + -- we can't drop the binding, so we get repeated AtomicRhs ticks +completeNonRec env binder@(id,occ_info) new_id new_rhs + = returnSmpl (new_env , [NonRec new_id new_rhs]) where - env1 = extendIdEnvWithClone env binder new_id - new_env = extendEnvGivenBinding env1 occ_info new_id rhs + new_env | is_atomic eta'd_rhs -- If rhs (after eta reduction) is atomic + = extendIdEnvWithAtom env binder the_arg + + | otherwise -- Non-atomic + = extendEnvGivenBinding (extendIdEnvWithClone env binder new_id) + occ_info new_id new_rhs -- Don't eta if it doesn't eliminate the binding + + eta'd_rhs = etaCoreExpr new_rhs + the_arg = case eta'd_rhs of + Var v -> VarArg v + Lit l -> LitArg l \end{code} %************************************************************************ @@ -1215,5 +1167,9 @@ computeResultType env expr args var `withArity` UnknownArity = var var `withArity` arity = var `addIdArity` arity + +is_atomic (Var v) = True +is_atomic (Lit l) = not (isNoRepLit l) +is_atomic other = False \end{code} diff --git a/ghc/compiler/simplStg/LambdaLift.lhs b/ghc/compiler/simplStg/LambdaLift.lhs index 29ed3952b6..367577ef13 100644 --- a/ghc/compiler/simplStg/LambdaLift.lhs +++ b/ghc/compiler/simplStg/LambdaLift.lhs @@ -148,6 +148,7 @@ liftExpr expr@(StgCon con args lvs) = returnLM (expr, emptyLiftInfo) liftExpr expr@(StgPrim op args lvs) = returnLM (expr, emptyLiftInfo) liftExpr expr@(StgApp (StgLitArg lit) args lvs) = returnLM (expr, emptyLiftInfo) +liftExpr expr@(StgApp (StgConArg con) args lvs) = returnLM (expr, emptyLiftInfo) liftExpr expr@(StgApp (StgVarArg v) args lvs) = lookUp v `thenLM` \ ~(sc, sc_args) -> -- NB the ~. We don't want to -- poke these bindings too early! diff --git a/ghc/compiler/simplStg/SatStgRhs.lhs b/ghc/compiler/simplStg/SatStgRhs.lhs deleted file mode 100644 index a61c2c3017..0000000000 --- a/ghc/compiler/simplStg/SatStgRhs.lhs +++ /dev/null @@ -1,314 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 -% -\section[SatStgRhs]{Saturates RHSs when they are partial applications} - -96/03: This is actually an essential module, as it sets arity info -for the code generator. - -\begin{display} -Subject: arg satis check -Date: Wed, 29 Apr 92 13:33:58 +0100 -From: Simon L Peyton Jones <simonpj> - -Andre - -Another transformation to consider. We'd like to avoid -argument-satisfaction checks wherever possible. So, whenever we have an -STG binding application - - f = vs \ xs -> g e1 ... en - -where xs has one or more elements -and -where g is a known function with arity m+n, - -then: change it to - - f = vs \ xs++{x1...xm} -> g e1 ... en x1 .. xm - -Now g has enough args. One arg-satisfaction check disappears; -the one for the closure incorporates the one for g. - -You might like to consider variants, applying the transformation more -widely. I concluded that this was the only instance which made -sense, but I could be wrong. - -Simon -\end{display} - -The algorithm proceeds as follows: -\begin{enumerate} -\item -Gather the arity information of the functions defined in this module -(as @getIdArity@ only knows about the arity of @ImportedIds@). - -\item -for every definition of the form -\begin{verbatim} - v = /\ts -> \vs -> f args -\end{verbatim} -we try to match the arity of \tr{f} with the number of arguments. -If they do not match we insert extra lambdas to make that application -saturated. -\end{enumerate} - -This is done for local definitions as well. - -\begin{code} -#include "HsVersions.h" - -module SatStgRhs ( satStgRhs ) where - -IMP_Ubiq(){-uitous-} - -import StgSyn - -import CostCentre ( isCafCC, subsumedCosts, useCurrentCostCentre ) -import Id ( idType, getIdArity, addIdArity, mkSysLocal, - nullIdEnv, addOneToIdEnv, growIdEnvList, - lookupIdEnv, SYN_IE(IdEnv) - ) -import SrcLoc ( noSrcLoc ) -import Type ( splitSigmaTy, splitForAllTy, splitFunTyExpandingDicts ) -import UniqSupply ( returnUs, thenUs, mapUs, getUnique, SYN_IE(UniqSM) ) -import Util ( panic, assertPanic ) - -type Count = Int - -type ExprArityInfo = Maybe Int -- Just n => This expression has a guaranteed - -- arity of n - -- Nothing => Don't know how many args it needs - -type Id_w_Arity = Id -- An Id with correct arity info pinned on it -type SatEnv = IdEnv Id_w_Arity -- Binds only local, let(rec)-bound things -\end{code} - -This pass -\begin{itemize} -\item adds extra args where necessary; -\item pins the correct arity on everything. -\end{itemize} - -%************************************************************************ -%* * -\subsection{Top-level list of bindings (a ``program'')} -%* * -%************************************************************************ - -\begin{code} -satStgRhs :: [StgBinding] -> UniqSM [StgBinding] -satStgRhs = panic "satStgRhs" - -{- NUKED FOR NOW SLPJ Dec 96 - - -satStgRhs p = satProgram nullIdEnv p - -satProgram :: SatEnv -> [StgBinding] -> UniqSM [StgBinding] -satProgram env [] = returnUs [] - -satProgram env (bind:binds) - = satBinding True{-toplevel-} env bind `thenUs` \ (env2, bind2) -> - satProgram env2 binds `thenUs` \ binds2 -> - returnUs (bind2 : binds2) -\end{code} - -%************************************************************************ -%* * -\subsection{Bindings} -%* * -%************************************************************************ - -\begin{code} -satBinding :: Bool -- True <=> top-level - -> SatEnv - -> StgBinding - -> UniqSM (SatEnv, StgBinding) - -satBinding top env (StgNonRec b rhs) - = satRhs top env (b, rhs) `thenUs` \ (b2, rhs2) -> - let - env2 = addOneToIdEnv env b b2 - in - returnUs (env2, StgNonRec b2 rhs2) - -satBinding top env (StgRec pairs) - = -- Do it once to get the arities right... - mapUs (satRhs top env) pairs `thenUs` \ pairs2 -> - let - env2 = growIdEnvList env (map fst pairs `zip` map fst pairs2) - in - -- Do it again to *use* those arities: - mapUs (satRhs top env2) pairs `thenUs` \ pairs3 -> - - returnUs (env2, StgRec pairs3) - -satRhs :: Bool -> SatEnv -> (Id, StgRhs) -> UniqSM (Id_w_Arity, StgRhs) - -satRhs top env (b, StgRhsCon cc con args) -- Nothing much to do here - = let - b2 = b `addIdArity` 0 -- bound to a saturated constructor; hence zero. - in - returnUs (b2, StgRhsCon cc con (lookupArgs env args)) - -satRhs top env (b, StgRhsClosure cc bi fv u args body) - = satExpr env body `thenUs` \ (arity_info, body2) -> - let - num_args = length args - in - (case arity_info of - Nothing -> - returnUs (num_args, StgRhsClosure cc bi fv u args body2) - - Just needed_args -> - ASSERT(needed_args >= 1) - - let -- the arity we're aiming for is: what we already have ("args") - -- plus the ones requested in "arity_info" - new_arity = num_args + needed_args - - -- get type info for this function: - (_, rho_ty) = splitForAllTy (idType b) - (all_arg_tys, _) = splitFunTyExpandingDicts rho_ty - - -- now, we already have "args"; we drop that many types - args_we_dont_have_tys = drop num_args all_arg_tys - - -- finally, we take some of those (up to maybe all of them), - -- depending on how many "needed_args" - args_to_add_tys = take needed_args args_we_dont_have_tys - in - -- make up names for them - mapUs newName args_to_add_tys `thenUs` \ nns -> - - -- and do the business - let - body3 = saturate body2 (map StgVarArg nns) - - new_cc -- if we're adding args, we'd better not - -- keep calling something a CAF! (what about DICTs? ToDo: WDP 95/02) - = if not (isCafCC cc) - then cc -- unchanged - else if top then subsumedCosts else useCurrentCostCentre - in - returnUs (new_arity, StgRhsClosure new_cc bi fv ReEntrant (args++nns) body3) - ) - `thenUs` \ (arity, rhs2) -> - let - b2 = b `addIdArity` arity - in - returnUs (b2, rhs2) -\end{code} - -%************************************************************************ -%* * -\subsection{Expressions} -%* * -%************************************************************************ - -\begin{code} -satExpr :: SatEnv -> StgExpr -> UniqSM (ExprArityInfo, StgExpr) - -satExpr env app@(StgApp (StgLitArg lit) [] lvs) = returnUs (Nothing, app) - -satExpr env app@(StgApp (StgVarArg f) as lvs) - = returnUs (arity_to_return, StgApp (StgVarArg f2) as2 lvs) - where - as2 = lookupArgs env as - f2 = lookupVar env f - arity_to_return = case arityMaybe (getIdArity f2) of - Nothing -> Nothing - - Just f_arity -> if remaining_arity > 0 - then Just remaining_arity - else Nothing - where - remaining_arity = f_arity - length as - -satExpr env app@(StgCon con as lvs) - = returnUs (Nothing, StgCon con (lookupArgs env as) lvs) - -satExpr env app@(StgPrim op as lvs) - = returnUs (Nothing, StgPrim op (lookupArgs env as) lvs) - -satExpr env (StgSCC ty l e) - = satExpr env e `thenUs` \ (_, e2) -> - returnUs (Nothing, StgSCC ty l e2) - -{- OMITTED: Let-no-escapery should come *after* saturation - -satExpr (StgLetNoEscape lvs_whole lvs_rhss binds body) - = satBinding binds `thenUs` \ (binds2, c) -> - satExpr body `thenUs` \ (_, body2, c2) -> - returnUs (Nothing, StgLetNoEscape lvs_whole lvs_rhss binds2 body2, c + c2) --} - -satExpr env (StgLet binds body) - = satBinding False{-not top-level-} env binds `thenUs` \ (env2, binds2) -> - satExpr env2 body `thenUs` \ (_, body2) -> - returnUs (Nothing, StgLet binds2 body2) - -satExpr env (StgCase expr lve lva uniq alts) - = satExpr env expr `thenUs` \ (_, expr2) -> - sat_alts alts `thenUs` \ alts2 -> - returnUs (Nothing, StgCase expr2 lve lva uniq alts2) - where - sat_alts (StgAlgAlts ty alts def) - = mapUs sat_alg_alt alts `thenUs` \ alts2 -> - sat_deflt def `thenUs` \ def2 -> - returnUs (StgAlgAlts ty alts2 def2) - where - sat_alg_alt (id, bs, use_mask, e) - = satExpr env e `thenUs` \ (_, e2) -> - returnUs (id, bs, use_mask, e2) - - sat_alts (StgPrimAlts ty alts def) - = mapUs sat_prim_alt alts `thenUs` \ alts2 -> - sat_deflt def `thenUs` \ def2 -> - returnUs (StgPrimAlts ty alts2 def2) - where - sat_prim_alt (l, e) - = satExpr env e `thenUs` \ (_, e2) -> - returnUs (l, e2) - - sat_deflt StgNoDefault - = returnUs StgNoDefault - - sat_deflt (StgBindDefault b u expr) - = satExpr env expr `thenUs` \ (_,expr2) -> - returnUs (StgBindDefault b u expr2) -\end{code} - -%************************************************************************ -%* * -\subsection{Utility functions} -%* * -%************************************************************************ - -\begin{code} -saturate :: StgExpr -> [StgArg] -> StgExpr - -saturate (StgApp f as lvs) ids = StgApp f (as ++ ids) lvs -saturate other _ = panic "SatStgRhs: saturate" -\end{code} - -\begin{code} -lookupArgs :: SatEnv -> [StgArg] -> [StgArg] -lookupArgs env args = map doo args - where - doo (StgVarArg v) = StgVarArg (lookupVar env v) - doo a@(StgLitArg lit) = a - -lookupVar :: SatEnv -> Id -> Id -lookupVar env v = case lookupIdEnv env v of - Nothing -> v - Just v2 -> v2 - -newName :: Type -> UniqSM Id -newName ut - = getUnique `thenUs` \ uniq -> - returnUs (mkSysLocal SLIT("sat") uniq ut noSrcLoc) - --} -\end{code} diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index 2718501e6a..efa56793c8 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -12,12 +12,10 @@ IMP_Ubiq(){-uitous-} IMPORT_1_3(IO(hPutStr,stderr)) import StgSyn -import StgUtils import LambdaLift ( liftProgram ) import Name ( isLocallyDefined ) import SCCfinal ( stgMassageForProfiling ) -import SatStgRhs ( satStgRhs ) import StgLint ( lintStgBindings ) import StgStats ( showStgStats ) import StgVarInfo ( setStgVarInfo ) diff --git a/ghc/compiler/simplStg/StgVarInfo.lhs b/ghc/compiler/simplStg/StgVarInfo.lhs index 76403afa21..0142dcda9d 100644 --- a/ghc/compiler/simplStg/StgVarInfo.lhs +++ b/ghc/compiler/simplStg/StgVarInfo.lhs @@ -192,7 +192,8 @@ varsAtoms atoms = mapLne var_atom atoms `thenLne` \ fvs_lists -> returnLne (unionFVInfos fvs_lists) where - var_atom a@(StgLitArg _) = returnLne emptyFVInfo + var_atom a@(StgLitArg _) = returnLne emptyFVInfo + var_atom a@(StgConArg _) = returnLne emptyFVInfo var_atom a@(StgVarArg v) = lookupVarEnv v `thenLne` \ how_bound -> returnLne (singletonFVInfo v how_bound stgArgOcc) @@ -235,6 +236,9 @@ decisions. Hence no black holes. varsExpr (StgApp lit@(StgLitArg _) args _) = returnLne (StgApp lit [] emptyIdSet, emptyFVInfo, emptyIdSet) +varsExpr (StgApp lit@(StgConArg _) args _) + = panic "varsExpr StgConArg" -- Only occur in argument positions + varsExpr (StgApp fun@(StgVarArg f) args _) = varsApp Nothing f args varsExpr (StgCon con args _) diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index a6385c1558..a88ad05408 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -138,8 +138,9 @@ coreBindToStg env (NonRec binder rhs) = coreRhsToStg env rhs `thenUs` \ stg_rhs -> let -- Binds to return if RHS is trivial - triv_binds | externallyVisibleId binder = [StgNonRec binder stg_rhs] -- Retain it - | otherwise = [] -- Discard it + binder_w_arity = binder `addIdArity` (rhsArity stg_rhs) + triv_binds | externallyVisibleId binder = [StgNonRec binder_w_arity stg_rhs] -- Retain it + | otherwise = [] -- Discard it in case stg_rhs of StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) -> @@ -152,12 +153,11 @@ coreBindToStg env (NonRec binder rhs) -- Trivial RHS, so augment envt, and ditch the binding returnUs (triv_binds, new_env) where - new_env = addOneToIdEnv env binder (StgVarArg con_id) + new_env = addOneToIdEnv env binder (StgConArg con_id) other -> -- Non-trivial RHS, so don't augment envt returnUs ([StgNonRec binder_w_arity stg_rhs], new_env) where - binder_w_arity = binder `addIdArity` (rhsArity stg_rhs) new_env = addOneToIdEnv env binder (StgVarArg binder_w_arity) -- new_env propagates the arity @@ -246,7 +246,7 @@ coreExprToStg env (Lit lit) = returnUs (StgApp (StgLitArg lit) [] bOGUS_LVs) coreExprToStg env (Var var) - = returnUs (StgApp (stgLookup env var) [] bOGUS_LVs) + = returnUs (mk_app (stgLookup env var) []) coreExprToStg env (Con con args) = let @@ -306,7 +306,7 @@ coreExprToStg env expr@(App _ _) case (fun, args) of (Var fun_id, _) -> -- A function Id, so do an StgApp; it's ok if -- there are no arguments. - returnUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs) + returnUs (mk_app (stgLookup env fun_id) stg_args) (non_var_fun, []) -> -- No value args, so recurse into the function coreExprToStg env non_var_fun @@ -444,4 +444,10 @@ mkStgLets :: [StgBinding] -> StgExpr mkStgLets binds body = foldr StgLet body binds + +-- mk_app spots an StgCon in a function position, +-- and turns it into an StgCon. See notes with +-- getArgAmode in CgBindery. +mk_app (StgConArg con) args = StgCon con args bOGUS_LVs +mk_app other_fun args = StgApp other_fun args bOGUS_LVs \end{code} diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs index 6d0c4e949d..4ef43a4a93 100644 --- a/ghc/compiler/stgSyn/StgLint.lhs +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -78,6 +78,7 @@ lintStgBindings sty whodunnit binds lintStgArg :: StgArg -> LintM (Maybe Type) lintStgArg (StgLitArg lit) = returnL (Just (literalType lit)) +lintStgArg (StgConArg con) = returnL (Just (idType con)) lintStgArg a@(StgVarArg v) = checkInScope v `thenL_` returnL (Just (idType v)) diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index 6de6376cfc..1e86a91005 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -40,7 +40,7 @@ module StgSyn ( IMP_Ubiq(){-uitous-} import CostCentre ( showCostCentre ) -import Id ( idPrimRep, GenId{-instance NamedThing-} ) +import Id ( idPrimRep, SYN_IE(DataCon), GenId{-instance NamedThing-} ) import Literal ( literalPrimRep, isLitLitLit, Literal{-instance Outputable-} ) import Name ( pprNonSym ) import Outputable ( ifPprDebug, interppSP, interpp'SP, @@ -83,10 +83,12 @@ data GenStgBinding bndr occ data GenStgArg occ = StgVarArg occ | StgLitArg Literal + | StgConArg DataCon -- A nullary data constructor \end{code} \begin{code} getArgPrimRep (StgVarArg local) = idPrimRep local +getArgPrimRep (StgConArg con) = idPrimRep con getArgPrimRep (StgLitArg lit) = literalPrimRep lit isLitLitArg (StgLitArg x) = isLitLitLit x @@ -539,6 +541,7 @@ instance (Outputable bndr, Outputable bdee, Ord bdee) pprStgArg :: (Outputable bdee) => PprStyle -> GenStgArg bdee -> Pretty pprStgArg sty (StgVarArg var) = ppr sty var +pprStgArg sty (StgConArg con) = ppr sty con pprStgArg sty (StgLitArg lit) = ppr sty lit \end{code} diff --git a/ghc/compiler/stgSyn/StgUtils.lhs b/ghc/compiler/stgSyn/StgUtils.lhs deleted file mode 100644 index 2448e1284f..0000000000 --- a/ghc/compiler/stgSyn/StgUtils.lhs +++ /dev/null @@ -1,96 +0,0 @@ -x% -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996 -% -\section[StgUtils]{Utility functions for @STG@ programs} - -\begin{code} -#include "HsVersions.h" - -module StgUtils - -- ( mapStgBindeesRhs ) Dead code SLPJ Nov 96 - where -{- DEAD CODE SLPJ Nov 96 - -IMP_Ubiq(){-uitous-} - -import Id ( GenId{-instanced NamedThing-} ) -import StgSyn -import UniqSet -\end{code} - -This utility function simply applies the given function to every -bindee in the program. - -\begin{code} - -mapStgBindeesBind :: (Id -> Id) -> StgBinding -> StgBinding - -mapStgBindeesBind fn (StgNonRec b rhs) = StgNonRec b (mapStgBindeesRhs fn rhs) -mapStgBindeesBind fn (StgRec pairs) = StgRec [ (b, mapStgBindeesRhs fn r) | (b, r) <- pairs ] - ------------------- -mapStgBindeesRhs :: (Id -> Id) -> StgRhs -> StgRhs - -mapStgBindeesRhs fn (StgRhsClosure cc bi fvs u args expr) - = StgRhsClosure - cc bi - (map fn fvs) - u - (map fn args) - (mapStgBindeesExpr fn expr) - -mapStgBindeesRhs fn (StgRhsCon cc con atoms) - = StgRhsCon cc con (map (mapStgBindeesArg fn) atoms) - ------------------- -mapStgBindeesExpr :: (Id -> Id) -> StgExpr -> StgExpr - -mapStgBindeesExpr fn (StgApp f args lvs) - = StgApp (mapStgBindeesArg fn f) - (map (mapStgBindeesArg fn) args) - (mapUniqSet fn lvs) - -mapStgBindeesExpr fn (StgCon con atoms lvs) - = StgCon con (map (mapStgBindeesArg fn) atoms) (mapUniqSet fn lvs) - -mapStgBindeesExpr fn (StgPrim op atoms lvs) - = StgPrim op (map (mapStgBindeesArg fn) atoms) (mapUniqSet fn lvs) - -mapStgBindeesExpr fn (StgLet bind expr) - = StgLet (mapStgBindeesBind fn bind) (mapStgBindeesExpr fn expr) - -mapStgBindeesExpr fn (StgLetNoEscape lvs rhss_lvs bind body) - = StgLetNoEscape (mapUniqSet fn lvs) (mapUniqSet fn rhss_lvs) - (mapStgBindeesBind fn bind) (mapStgBindeesExpr fn body) - -mapStgBindeesExpr fn (StgSCC ty label expr) - = StgSCC ty label (mapStgBindeesExpr fn expr) - -mapStgBindeesExpr fn (StgCase expr lvs1 lvs2 uniq alts) - = StgCase (mapStgBindeesExpr fn expr) - (mapUniqSet fn lvs1) - (mapUniqSet fn lvs2) - uniq - (mapStgBindeesAlts alts) - where - mapStgBindeesAlts (StgAlgAlts ty alts deflt) - = StgAlgAlts ty (map mapStgBindeesBoxed_alt alts) (mapStgBindeesDeflt deflt) - where - mapStgBindeesBoxed_alt (c,ps,use_mask,expr) = (c,ps,use_mask,mapStgBindeesExpr fn expr) - - mapStgBindeesAlts (StgPrimAlts ty alts deflt) - = StgPrimAlts ty (map mapStgBindeesunboxed_alt alts) (mapStgBindeesDeflt deflt) - where - mapStgBindeesunboxed_alt (l,expr) = (l,mapStgBindeesExpr fn expr) - - mapStgBindeesDeflt StgNoDefault = StgNoDefault - mapStgBindeesDeflt (StgBindDefault b used expr) = StgBindDefault b used (mapStgBindeesExpr fn expr) - ------------------- -mapStgBindeesArg :: (Id -> Id) -> StgArg -> StgArg - -mapStgBindeesArg fn a@(StgLitArg _) = a -mapStgBindeesArg fn a@(StgVarArg id) = StgVarArg (fn id) - --} -\end{code} diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs index fff2a5d29c..0478a6d389 100644 --- a/ghc/compiler/stranal/SaAbsInt.lhs +++ b/ghc/compiler/stranal/SaAbsInt.lhs @@ -114,9 +114,9 @@ glb v1 v2 else AbsBot where - is_fun (AbsFun _ _ _) = True - is_fun (AbsApproxFun _) = True -- Not used, but the glb works ok - is_fun other = False + is_fun (AbsFun _ _ _) = True + is_fun (AbsApproxFun _ _) = True -- Not used, but the glb works ok + is_fun other = False -- The non-functional cases are quite straightforward @@ -198,11 +198,11 @@ Used only in strictness analysis: \begin{code} isBot :: AbsVal -> Bool -isBot AbsBot = True -isBot (AbsFun args body env) = isBot (absEval StrAnal body env) +isBot AbsBot = True +isBot (AbsFun arg body env) = isBot (absEval StrAnal body env) -- Don't bother to extend the envt because -- unbound variables default to AbsTop anyway -isBot other = False +isBot other = False \end{code} Used only in absence analysis: @@ -212,8 +212,8 @@ anyBot :: AbsVal -> Bool anyBot AbsBot = True -- poisoned! anyBot AbsTop = False anyBot (AbsProd vals) = any anyBot vals -anyBot (AbsFun args body env) = anyBot (absEval AbsAnal body env) -anyBot (AbsApproxFun demands) = False +anyBot (AbsFun arg body env) = anyBot (absEval AbsAnal body env) +anyBot (AbsApproxFun _ _) = False -- AbsApproxFun can only arise in absence analysis from the Demand -- info of an imported value; whatever it is we're looking for is @@ -227,12 +227,17 @@ it, so it can be compared for equality by @sameVal@. \begin{code} widen :: AnalysisKind -> AbsVal -> AbsVal -widen StrAnal (AbsFun args body env) - | isBot (absEval StrAnal body env) = AbsBot - | otherwise - = ASSERT (not (null args)) - AbsApproxFun (map (findDemandStrOnly env body) args) +widen StrAnal (AbsFun arg body env) + = AbsApproxFun (findDemandStrOnly env body arg) + (widen StrAnal abs_body) + where + abs_body = absEval StrAnal body env + +{- OLD comment... + This stuff is now instead handled neatly by the fact that AbsApproxFun + contains an AbsVal inside it. SLPJ Jan 97 + | isBot abs_body = AbsBot -- It's worth checking for a function which is unconditionally -- bottom. Consider -- @@ -248,20 +253,23 @@ widen StrAnal (AbsFun args body env) -- alternative here would be to bind g to its exact abstract -- value, but that entails lots of potential re-computation, at -- every application of g.) +-} widen StrAnal (AbsProd vals) = AbsProd (map (widen StrAnal) vals) widen StrAnal other_val = other_val -widen AbsAnal (AbsFun args body env) - | anyBot (absEval AbsAnal body env) = AbsBot +widen AbsAnal (AbsFun arg body env) + | anyBot abs_body = AbsBot -- In the absence-analysis case it's *essential* to check -- that the function has no poison in its body. If it does, -- anywhere, then the whole function is poisonous. | otherwise - = ASSERT (not (null args)) - AbsApproxFun (map (findDemandAbsOnly env body) args) + = AbsApproxFun (findDemandAbsOnly env body arg) + (widen AbsAnal abs_body) + where + abs_body = absEval AbsAnal body env widen AbsAnal (AbsProd vals) = AbsProd (map (widen AbsAnal) vals) @@ -313,9 +321,9 @@ sameVal (AbsProd vals1) (AbsProd vals2) = and (zipWithEqual "sameVal" sameVal va sameVal (AbsProd _) AbsTop = False sameVal (AbsProd _) AbsBot = False -sameVal (AbsApproxFun str1) (AbsApproxFun str2) = str1 == str2 -sameVal (AbsApproxFun _) AbsTop = False -sameVal (AbsApproxFun _) AbsBot = False +sameVal (AbsApproxFun str1 v1) (AbsApproxFun str2 v2) = str1 == str2 && sameVal v1 v1 +sameVal (AbsApproxFun _ _) AbsTop = False +sameVal (AbsApproxFun _ _) AbsBot = False sameVal val1 val2 = panic "sameVal: type mismatch or AbsFun encountered" \end{code} @@ -394,7 +402,7 @@ absId anal var env (Just abs_val, _, _) -> abs_val -- Bound in the environment - (Nothing, noStrictnessInfo, CoreUnfolding (SimpleUnfolding _ _ unfolding)) -> + (Nothing, NoStrictnessInfo, CoreUnfolding (SimpleUnfolding _ _ unfolding)) -> -- We have an unfolding for the expr -- Assume the unfolding has no free variables since it -- came from inside the Id @@ -512,7 +520,7 @@ absEval anal (Con con as) env \begin{code} absEval anal (Lam (ValBinder binder) body) env - = AbsFun [binder] body env + = AbsFun binder body env absEval anal (Lam other_binder expr) env = absEval anal expr env absEval anal (App f a) env | isValArg a @@ -670,31 +678,22 @@ result. A @Lam@ with two or more args: return another @AbsFun@ with an augmented environment. \begin{code} -absApply anal (AbsFun [binder] body env) arg +absApply anal (AbsFun binder body env) arg = absEval anal body (addOneToAbsValEnv env binder arg) - -absApply anal (AbsFun (binder:bs) body env) arg - = AbsFun bs body (addOneToAbsValEnv env binder arg) \end{code} \begin{code} -absApply StrAnal (AbsApproxFun (arg1_demand:ds)) arg - = if evalStrictness arg1_demand arg +absApply StrAnal (AbsApproxFun demand val) arg + = if evalStrictness demand arg then AbsBot - else case ds of - [] -> AbsTop - other -> AbsApproxFun ds + else val -absApply AbsAnal (AbsApproxFun (arg1_demand:ds)) arg - = if evalAbsence arg1_demand arg +absApply AbsAnal (AbsApproxFun demand val) arg + = if evalAbsence demand arg then AbsBot - else case ds of - [] -> AbsTop - other -> AbsApproxFun ds + else val #ifdef DEBUG -absApply anal (AbsApproxFun []) arg = panic ("absApply: Duff function: AbsApproxFun." ++ show anal) -absApply anal (AbsFun [] _ _) arg = panic ("absApply: Duff function: AbsFun." ++ show anal) absApply anal (AbsProd _) arg = panic ("absApply: Duff function: AbsProd." ++ show anal) #endif \end{code} diff --git a/ghc/compiler/stranal/SaLib.lhs b/ghc/compiler/stranal/SaLib.lhs index e3fd7abc05..786333aad0 100644 --- a/ghc/compiler/stranal/SaLib.lhs +++ b/ghc/compiler/stranal/SaLib.lhs @@ -64,28 +64,25 @@ data AbsVal -- AbsProd [AbsBot, ..., AbsBot] | AbsFun -- An abstract function, with the given: - [Id] -- arguments - CoreExpr -- body + Id -- argument + CoreExpr -- body AbsValEnv -- and environment | AbsApproxFun -- This is used to represent a coarse - [Demand] -- approximation to a function value. It's an - -- abstract function which is strict in its i'th - -- argument if the i'th element of the Demand - -- list so indicates. - -- The list of arguments is always non-empty. - -- In effect, AbsApproxFun [] = AbsTop + Demand -- approximation to a function value. It's an + AbsVal -- abstract function which is strict in its + -- argument if the Demand so indicates. instance Outputable AbsVal where ppr sty AbsTop = ppStr "AbsTop" ppr sty AbsBot = ppStr "AbsBot" ppr sty (AbsProd prod) = ppCat [ppStr "AbsProd", ppr sty prod] - ppr sty (AbsFun args body env) - = ppCat [ppStr "AbsFun{", ppr sty args, + ppr sty (AbsFun arg body env) + = ppCat [ppStr "AbsFun{", ppr sty arg, ppStr "???", -- ppStr "}{env:", ppr sty (keysFM env `zip` eltsFM env), ppStr "}" ] - ppr sty (AbsApproxFun demands) - = ppCat [ppStr "AbsApprox{", ppr sty demands, ppStr "}" ] + ppr sty (AbsApproxFun demand val) + = ppCat [ppStr "AbsApprox ", ppr sty demand, ppStr "", ppr sty val ] \end{code} %----------- @@ -124,6 +121,5 @@ absValFromStrictness anal NoStrictnessInfo = AbsTop absValFromStrictness StrAnal BottomGuaranteed = AbsBot -- Guaranteed bottom absValFromStrictness AbsAnal BottomGuaranteed = AbsTop -- Check for poison in -- arguments (if any) -absValFromStrictness anal (StrictnessInfo [] _) = AbsTop -absValFromStrictness anal (StrictnessInfo args_info _) = AbsApproxFun args_info +absValFromStrictness anal (StrictnessInfo args_info _) = foldr AbsApproxFun AbsTop args_info \end{code} diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs index 9f38eadd09..f3946f8661 100644 --- a/ghc/compiler/stranal/StrictAnal.lhs +++ b/ghc/compiler/stranal/StrictAnal.lhs @@ -408,13 +408,13 @@ addStrictnessInfoToId strflags str_val abs_val binder body = binder `addIdStrictness` mkBottomStrictnessInfo | otherwise - = case (collectBinders body) of { (_, _, lambda_bounds, rhs) -> - let - tys = map idType lambda_bounds - strictness = findStrictness strflags tys str_val abs_val - in - binder `addIdStrictness` mkStrictnessInfo strictness Nothing - } + = case (collectBinders body) of + (_, _, [], rhs) -> binder + (_, _, lambda_bounds, rhs) -> binder `addIdStrictness` + mkStrictnessInfo strictness Nothing + where + tys = map idType lambda_bounds + strictness = findStrictness strflags tys str_val abs_val \end{code} \begin{code} diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index 82227725db..8e65398416 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -326,45 +326,16 @@ mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) useful_split ma case (maybeAppDataTyConExpandingDicts arg_ty) of - Nothing -> -- Not a data type - panic "mk_ww_arg_processing: not datatype" - - Just (_, _, []) -> -- An abstract type - -- We have to give up on the whole idea - returnUs Nothing - - Just (_, _, (_:_:_)) -> -- Two or more constructors; that's odd - panic "mk_ww_arg_processing: multi-constr" + 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 - - 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) -> + -- The main event: a single-constructor data type + do_single_constr arg_tycon tycon_arg_tys data_con + + Just (_, _, data_cons) -> -- Zero, or two or more constructors; that's odd + panic "mk_ww_arg_processing: not one constr" - 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) - )) where arg_ty = idType arg @@ -373,6 +344,34 @@ mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) useful_split ma + 1 -- We won't pass the original arg now - nonAbsentArgs cmpnt_infos -- But we will pass an arg for each cmpt + 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)] @@ -405,5 +404,7 @@ mk_ww_arg_processing (arg : args) (arg_demand : infos) useful_split max_extra_ar --) nonAbsentArgs :: [Demand] -> Int -nonAbsentArgs cmpts = length [() | WwLazy True <- cmpts] +nonAbsentArgs [] = 0 +nonAbsentArgs (WwLazy True : ds) = nonAbsentArgs ds +nonAbsentArgs (d : ds) = 1 + nonAbsentArgs ds \end{code} diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index fa9dba3344..74e5bfa1a7 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -162,21 +162,30 @@ newDicts :: InstOrigin s -> NF_TcM s (LIE s, [TcIdOcc s]) newDicts orig theta = tcGetSrcLoc `thenNF_Tc` \ loc -> + newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, ids) -> + returnNF_Tc (listToBag dicts, ids) +{- tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs -> let mk_dict u (clas, ty) = Dict u clas ty orig loc dicts = zipWithEqual "newDicts" mk_dict new_uniqs theta in returnNF_Tc (listToBag dicts, map instToId dicts) - -newDictsAtLoc orig loc theta -- Local function, similar to newDicts, - -- but with slightly different interface - = tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs -> - let - mk_dict u (clas, ty) = Dict u clas ty orig loc - dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta - in - returnNF_Tc (dicts, map instToId dicts) +-} + +-- Local function, similar to newDicts, +-- but with slightly different interface +newDictsAtLoc :: InstOrigin s + -> SrcLoc + -> [(Class, TcType s)] + -> NF_TcM s ([Inst s], [TcIdOcc s]) +newDictsAtLoc orig loc theta = + tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs -> + let + mk_dict u (clas, ty) = Dict u clas ty orig loc + dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta + in + returnNF_Tc (dicts, map instToId dicts) newMethod :: InstOrigin s -> TcIdOcc s diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index fee38f4a5b..079bd72d3e 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -15,7 +15,8 @@ IMP_Ubiq() import HsSyn ( HsDecl, FixityDecl, Fixity, InstDecl, Sig, HsBinds(..), Bind(..), MonoBinds(..), GRHSsAndBinds, Match, HsExpr, HsLit, InPat, - ArithSeqInfo, Fake, HsType + ArithSeqInfo, Fake, HsType, + collectMonoBinders ) import HsPragmas ( InstancePragmas(..) ) import RdrHsSyn ( RdrName, SYN_IE(RdrNameMonoBinds) ) @@ -32,7 +33,7 @@ import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs ) import TcSimplify ( tcSimplifyThetas ) import RnBinds ( rnMethodBinds, rnTopMonoBinds ) -import RnEnv ( newDfunName ) +import RnEnv ( newDfunName, bindLocatedLocalsRn ) import RnMonad ( SYN_IE(RnM), RnDown, GDown, SDown, RnNameSupply(..), setNameSupplyRn, renameSourceCode, thenRn, mapRn, returnRn ) @@ -64,6 +65,7 @@ import TysPrim ( voidTy ) import TyVar ( GenTyVar ) import UniqFM ( emptyUFM ) import Unique -- Keys stuff +import Bag ( bagToList ) import Util ( zipWithEqual, zipEqual, sortLt, removeDups, assoc, thenCmp, cmpList, panic, panic#, pprPanic, pprPanic#, assertPanic-- , pprTrace{-ToDo:rm-} @@ -228,18 +230,20 @@ tcDeriving modname rn_name_supply inst_decl_infos_in extra_mbind_list = map gen_tag_n_con_monobind nm_alist_etc extra_mbinds = foldr AndMonoBinds EmptyMonoBinds extra_mbind_list method_binds_s = map gen_bind new_inst_infos + mbinders = bagToList (collectMonoBinders extra_mbinds) -- Rename to get RenamedBinds. -- The only tricky bit is that the extra_binds must scope over the -- method bindings for the instances. (dfun_names_w_method_binds, rn_extra_binds) = renameSourceCode modname rn_name_supply ( + bindLocatedLocalsRn "deriving" mbinders $ \ _ -> rnTopMonoBinds extra_mbinds [] `thenRn` \ rn_extra_binds -> mapRn rn_one method_binds_s `thenRn` \ dfun_names_w_method_binds -> returnRn (dfun_names_w_method_binds, rn_extra_binds) ) rn_one meth_binds = newDfunName mkGeneratedSrcLoc `thenRn` \ dfun_name -> - rnMethodBinds meth_binds `thenRn` \ rn_meth_binds -> + rnMethodBinds meth_binds `thenRn` \ rn_meth_binds -> returnRn (dfun_name, rn_meth_binds) in diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 3215394f4d..70f8070831 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -269,8 +269,9 @@ tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) mapNF_Tc new_arg_dict (zipEqual "tcExpr:CCall" args arg_tys) `thenNF_Tc` \ ccarg_dicts_s -> newDicts result_origin [(cReturnableClass, result_ty)] `thenNF_Tc` \ (ccres_dict, _) -> - returnTc (HsCon stDataCon [realWorldTy, result_ty] [CCall lbl args' may_gc is_asm result_ty], - -- do the wrapping in the newtype constructor here + returnTc (HsApp (HsVar (RealId stDataCon) `TyApp` [realWorldTy, result_ty]) + (CCall lbl args' may_gc is_asm result_ty), + -- do the wrapping in the newtype constructor here foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie, mkPrimIoTy result_ty) \end{code} diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 3bc2b6953e..d6c7513f9b 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -42,7 +42,7 @@ import Id ( GenId, dataConNumFields, isNullaryDataCon, dataConTag, dataConRawArgTys, fIRST_TAG, isDataCon, SYN_IE(DataCon), SYN_IE(ConTag) ) import Maybes ( maybeToBool ) -import Name ( getOccString, getSrcLoc, occNameString, modAndOcc, OccName, Name ) +import Name ( getOccString, getOccName, getSrcLoc, occNameString, modAndOcc, OccName, Name ) import PrimOp ( PrimOp(..) ) import PrelInfo -- Lots of RdrNames @@ -1047,6 +1047,13 @@ d_Pat = VarPatIn d_RDR con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName +con2tag_RDR tycon = varUnqual (SLIT("con2tag_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#")) +tag2con_RDR tycon = varUnqual (SLIT("tag2con_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#")) +maxtag_RDR tycon = varUnqual (SLIT("maxtag_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#")) + + +{- OLD, and wrong; the renamer doesn't like qualified names for locals. + con2tag_RDR tycon = let (mod, nm) = modAndOcc tycon con2tag = SLIT("con2tag_") _APPEND_ occNameString nm _APPEND_ SLIT("#") @@ -1064,4 +1071,5 @@ maxtag_RDR tycon maxtag = SLIT("maxtag_") _APPEND_ occNameString nm _APPEND_ SLIT("#") in varQual (mod, maxtag) +-} \end{code} diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 9b0be49aa4..6768120494 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -505,10 +505,6 @@ zonkExpr te ve (Dictionary dicts methods) zonkExpr te ve (SingleDict name) = returnNF_Tc (SingleDict (zonkIdOcc ve name)) -zonkExpr te ve (HsCon con tys vargs) - = mapNF_Tc (zonkTcTypeToType te) tys `thenNF_Tc` \ new_tys -> - mapNF_Tc (zonkExpr te ve) vargs `thenNF_Tc` \ new_vargs -> - returnNF_Tc (HsCon con new_tys new_vargs) ------------------------------------------------------------------------- zonkArithSeq :: TyVarEnv Type -> IdEnv Id diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 656a1e29b2..ac0a5ad51e 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -12,7 +12,9 @@ IMP_Ubiq() import TcMonad import TcMonoType ( tcHsType ) -import TcEnv ( tcLookupGlobalValue, tcExtendTyVarEnv, tcExtendGlobalValEnv ) +import TcEnv ( tcLookupGlobalValue, tcExtendTyVarEnv, tcExtendGlobalValEnv, + tcLookupTyConByKey, tcLookupGlobalValueMaybe, tcLookupLocalValue + ) import TcKind ( TcKind, kindToTcKind ) import HsSyn ( IfaceSig(..), HsDecl(..), TyDecl, ClassDecl, InstDecl, DefaultDecl, HsBinds, @@ -20,6 +22,7 @@ import HsSyn ( IfaceSig(..), HsDecl(..), TyDecl, ClassDecl, InstDecl, DefaultDe import RnHsSyn ( RenamedHsDecl(..) ) import HsCore import HsDecls ( HsIdInfo(..) ) +import Literal ( Literal(..) ) import CoreSyn import CoreUnfold import MagicUFs ( MagicUnfoldingFun ) @@ -27,9 +30,13 @@ import SpecEnv ( SpecEnv ) import PrimOp ( PrimOp(..) ) import Id ( GenId, mkImported, mkUserId, isPrimitiveId_maybe ) +import Type ( mkSynTy ) import TyVar ( mkTyVar ) import Name ( Name ) +import Unique ( rationalTyConKey ) +import TysWiredIn ( integerTy ) import PragmaInfo ( PragmaInfo(..) ) +import ErrUtils ( pprBagOfErrors ) import Maybes ( maybeToBool ) import Pretty import PprStyle ( PprStyle(..) ) @@ -64,9 +71,6 @@ tcInterfaceSigs (other_decl : rest) = tcInterfaceSigs rest tcInterfaceSigs [] = returnTc [] \end{code} -Inside here we use only the Global environment, even for locally bound variables. -Why? Because we know all the types and want to bind them to real Ids. - \begin{code} tcIdInfo name info [] = returnTc info @@ -96,8 +100,8 @@ tcIdInfo name info (HsStrictness strict : rest) \begin{code} tcStrictness (StrictnessInfo demands (Just worker)) - = tcLookupGlobalValue worker `thenNF_Tc` \ worker_id -> - returnTc (StrictnessInfo demands (Just worker_id)) + = 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) @@ -105,18 +109,53 @@ tcStrictness NoStrictnessInfo = returnTc NoStrictnessInfo tcStrictness BottomGuaranteed = returnTc BottomGuaranteed \end{code} +\begin{code} +tcWorker worker + = tcLookupGlobalValueMaybe worker `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 (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. \begin{code} tcUnfolding name core_expr = forkNF_Tc ( - recoverNF_Tc (returnNF_Tc no_unfolding) ( + recoverNF_Tc no_unfolding ( tcCoreExpr core_expr `thenTc` \ core_expr' -> returnTc (mkUnfolding False core_expr') )) where - no_unfolding = pprTrace "tcUnfolding failed:" (ppr PprDebug name) NoUnfolding + -- The trace tells what wasn't available, for the benefit of + -- compiler hackers who want to improve it! + no_unfolding = getErrsTc `thenNF_Tc` \ (warns,errs) -> + returnNF_Tc (pprTrace "tcUnfolding failed with:" + (ppHang (ppr PprDebug name) 4 (pprBagOfErrors PprDebug errs)) + NoUnfolding) +\end{code} + + +Variables in unfoldings +~~~~~~~~~~~~~~~~~~~~~~~ +****** Inside here we use only the Global environment, even for locally bound variables. +****** Why? Because we know all the types and want to bind them to real Ids. + +\begin{code} +tcVar :: Name -> TcM s Id +tcVar name + = tcLookupGlobalValueMaybe name `thenNF_Tc` \ maybe_id -> + case maybe_id of { + Just id -> returnTc id; + Nothing -> failTc (noDecl name) + } + +noDecl name sty = ppCat [ppStr "Warning: no binding for", ppr sty name] \end{code} UfCore expressions. @@ -125,13 +164,27 @@ UfCore expressions. tcCoreExpr :: UfExpr Name -> TcM s CoreExpr tcCoreExpr (UfVar name) - = tcLookupGlobalValue name `thenNF_Tc` \ id -> + = tcVar name `thenTc` \ id -> returnTc (Var id) -tcCoreExpr (UfLit lit) = returnTc (Lit lit) +-- rationalTy isn't built in so we have to construct it +-- (the "ty" part of the incoming literal is simply bottom) +tcCoreExpr (UfLit (NoRepRational lit _)) + = tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon -> + let + rational_ty = mkSynTy rational_tycon [] + in + returnTc (Lit (NoRepRational lit rational_ty)) + +-- Similarly for integers, except that it is wired in +tcCoreExpr (UfLit (NoRepInteger lit _)) + = returnTc (Lit (NoRepInteger lit integerTy)) + +tcCoreExpr (UfLit other_lit) + = returnTc (Lit other_lit) tcCoreExpr (UfCon con args) - = tcLookupGlobalValue con `thenNF_Tc` \ con_id -> + = tcVar con `thenTc` \ con_id -> mapTc tcCoreArg args `thenTc` \ args' -> returnTc (Con con_id args') @@ -221,8 +274,8 @@ tcCoreValBndrs bndrs thing_inside -- Expect them all to be ValBinders \end{code} \begin{code} -tcCoreArg (UfVarArg v) = tcLookupGlobalValue v `thenNF_Tc` \ v' -> returnTc (VarArg v') -tcCoreArg (UfTyArg ty) = tcHsType ty `thenTc` \ ty' -> returnTc (TyArg ty') +tcCoreArg (UfVarArg v) = tcVar v `thenTc` \ v' -> returnTc (VarArg v') +tcCoreArg (UfTyArg ty) = tcHsType ty `thenTc` \ ty' -> returnTc (TyArg ty') tcCoreArg (UfLitArg lit) = returnTc (LitArg lit) tcCoreArg (UfUsageArg u) = error "tcCoreArg: usage" @@ -231,7 +284,7 @@ tcCoreAlts (UfAlgAlts alts deflt) tcCoreDefault deflt `thenTc` \ deflt' -> returnTc (AlgAlts alts' deflt') where - tc_alt (con, bndrs, rhs) = tcLookupGlobalValue con `thenNF_Tc` \ con' -> + tc_alt (con, bndrs, rhs) = tcVar con `thenTc` \ con' -> tcCoreValBndrs bndrs $ \ bndrs' -> tcCoreExpr rhs `thenTc` \ rhs' -> returnTc (con', bndrs', rhs') @@ -249,11 +302,11 @@ tcCoreDefault (UfBindDefault bndr rhs) = tcCoreValBndr bndr $ \ bndr' -> tcCoreExpr rhs `thenTc` \ rhs' -> returnTc (BindDefault bndr' rhs') -tcCoercion (UfIn n) = tcLookupGlobalValue n `thenNF_Tc` \ n' -> returnTc (CoerceIn n') -tcCoercion (UfOut n) = tcLookupGlobalValue n `thenNF_Tc` \ n' -> returnTc (CoerceOut n') +tcCoercion (UfIn n) = tcVar n `thenTc` \ n' -> returnTc (CoerceIn n') +tcCoercion (UfOut n) = tcVar n `thenTc` \ n' -> returnTc (CoerceOut n') tcCorePrim (UfOtherOp op) - = tcLookupGlobalValue op `thenNF_Tc` \ op_id -> + = tcVar op `thenTc` \ op_id -> case isPrimitiveId_maybe op_id of Just prim_op -> returnTc prim_op Nothing -> pprPanic "tcCorePrim" (ppr PprDebug op_id) diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 030ab8079b..63b280d8c3 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -76,7 +76,7 @@ import PprStyle import SrcLoc ( SrcLoc ) import Pretty import TyCon ( isSynTyCon, derivedFor ) -import Type ( GenType(..), SYN_IE(ThetaType), mkTyVarTys, +import Type ( GenType(..), SYN_IE(ThetaType), mkTyVarTys, isPrimType, splitSigmaTy, splitAppTy, isTyVarTy, matchTy, mkSigmaTy, getTyCon_maybe, maybeAppTyCon, maybeBoxedPrimType, maybeAppDataTyCon, splitRhoTy, eqTy @@ -850,7 +850,8 @@ scrutiniseInstanceType dfun_name clas inst_tau -- These conditions come directly from what the DsCCall is capable of. -- Totally grotesque. Green card should solve this. -ccallable_type ty = maybeToBool (maybeBoxedPrimType ty) || +ccallable_type ty = isPrimType ty || -- Allow CCallable Int# etc + maybeToBool (maybeBoxedPrimType ty) || -- Ditto Int etc ty `eqTy` stringTy || byte_arr_thing where diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index 5bd270cc3e..7f3e1ab6a8 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -8,7 +8,7 @@ module TcMonad( initTc, returnTc, thenTc, thenTc_, mapTc, listTc, foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc, - mapBagTc, fixTc, tryTc, + mapBagTc, fixTc, tryTc, getErrsTc, returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, fixNF_Tc, forkNF_Tc, @@ -259,6 +259,12 @@ forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env Error handling ~~~~~~~~~~~~~~ \begin{code} +getErrsTc :: NF_TcM s (Bag Error, Bag Warning) +getErrsTc down env + = readMutVarSST errs_var + where + errs_var = getTcErrs down + failTc :: Message -> TcM s a failTc err_msg down env = readMutVarSST errs_var `thenSST` \ (warns,errs) -> diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 7bb3928d63..aef320822a 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -87,6 +87,27 @@ instance Outputable {-TyVar, i.e.:-}(GenTyVar Usage) where %* * %************************************************************************ +Precedence +~~~~~~~~~~ +@ppr_ty@ takes an @Int@ that is the precedence of the context. +The precedence levels are: +\begin{description} +\item[tOP_PREC] No parens required. +\item[fUN_PREC] Left hand argument of a function arrow. +\item[tYCON_PREC] Argument of a type constructor. +\end{description} + + +\begin{code} +tOP_PREC = (0 :: Int) +fUN_PREC = (1 :: Int) +tYCON_PREC = (2 :: Int) + +maybeParen ctxt_prec inner_prec pretty + | ctxt_prec < inner_prec = pretty + | otherwise = ppParens pretty +\end{code} + @pprGenType@ is the std @Type@ printer; the overloaded @ppr@ function is defined to use this. @pprParendGenType@ is the same, except it puts parens around the type, except for the atomic cases. @pprParendGenType@ @@ -121,11 +142,13 @@ ppr_ty env ctxt_prec (TyConTy tycon usage) = ppr_tycon env tycon ppr_ty env ctxt_prec ty@(ForAllTy _ _) - | show_forall = ppSep [ ppPStr SLIT("_forall_"), pp_tyvars, + | show_forall = maybeParen ctxt_prec fUN_PREC $ + ppSep [ ppPStr SLIT("_forall_"), pp_tyvars, pp_theta, ppPStr SLIT("=>"), pp_body ] - | null theta = pp_body - | otherwise = ppSep [pp_theta, ppPStr SLIT("=>"), pp_body] + | null theta = ppr_ty env ctxt_prec body_ty + | otherwise = maybeParen ctxt_prec fUN_PREC $ + ppSep [pp_theta, ppPStr SLIT("=>"), pp_body] where (tyvars, rho_ty) = splitForAllTy ty (theta, body_ty) | show_context = splitRhoTy rho_ty @@ -134,7 +157,7 @@ ppr_ty env ctxt_prec ty@(ForAllTy _ _) pp_tyvars = ppBracket (ppIntersperse ppSP (map (pTyVarB env) tyvars)) pp_theta | null theta = ppNil | otherwise = ppCurlies (ppInterleave ppComma (map (ppr_dict env tOP_PREC) theta)) - pp_body = ppr_ty env ctxt_prec body_ty + pp_body = ppr_ty env tOP_PREC body_ty sty = pStyle env show_forall = case sty of @@ -238,25 +261,6 @@ ppr_tycon env tycon = ppr (pStyle env) tycon ppr_class env clas = ppr (pStyle env) clas \end{code} -@ppr_ty@ takes an @Int@ that is the precedence of the context. -The precedence levels are: -\begin{description} -\item[0:] What we start with. -\item[1:] Function application (@FunTys@). -\item[2:] Type constructors. -\end{description} - - -\begin{code} -tOP_PREC = (0 :: Int) -fUN_PREC = (1 :: Int) -tYCON_PREC = (2 :: Int) - -maybeParen ctxt_prec inner_prec pretty - | ctxt_prec < inner_prec = pretty - | otherwise = ppParens pretty -\end{code} - %************************************************************************ %* * \subsection[TyVar]{@TyVar@} diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index daee1722ff..5888c27bca 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -567,13 +567,16 @@ namesOfType (ForAllUsageTy _ _ ty) = panic "forall usage" Instantiating a type ~~~~~~~~~~~~~~~~~~~~ \begin{code} -applyTy :: GenType (GenTyVar flexi) uvar - -> GenType (GenTyVar flexi) uvar - -> GenType (GenTyVar flexi) uvar +-- applyTy :: GenType (GenTyVar flexi) uvar +-- -> GenType (GenTyVar flexi) uvar +-- -> GenType (GenTyVar flexi) uvar -applyTy (SynTy _ _ fun) arg = applyTy fun arg -applyTy (ForAllTy tv ty) arg = instantiateTy [(tv,arg)] ty -applyTy other arg = panic "applyTy" +applyTy :: Type -> Type -> Type + +applyTy (SynTy _ _ fun) arg = applyTy fun arg +applyTy (ForAllTy tv ty) arg = instantiateTy [(tv,arg)] ty +applyTy ty@(DictTy _ _ _) arg = applyTy (expandTy ty) arg +applyTy other arg = panic "applyTy" \end{code} \begin{code} diff --git a/ghc/compiler/utils/FiniteMap.lhs b/ghc/compiler/utils/FiniteMap.lhs index f28185638f..2f5324e556 100644 --- a/ghc/compiler/utils/FiniteMap.lhs +++ b/ghc/compiler/utils/FiniteMap.lhs @@ -73,11 +73,8 @@ IMPORT_DELOOPER(SpecLoop) import Maybes import Bag ( Bag, foldBag ) import Outputable ( Outputable(..) ) - -# ifdef DEBUG import PprStyle ( PprStyle ) import Pretty ( SYN_IE(Pretty), PrettyRep ) -# endif #ifdef COMPILING_GHC @@ -777,12 +774,10 @@ When the FiniteMap module is used in GHC, we specialise it for , FiniteMap FAST_STRING elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt , FiniteMap (FAST_STRING, FAST_STRING) elt -> (FAST_STRING, FAST_STRING) -> elt -> FiniteMap (FAST_STRING, FAST_STRING) elt , FiniteMap RdrName elt -> RdrName -> elt -> FiniteMap RdrName elt - , FiniteMap OrigName elt -> OrigName -> elt -> FiniteMap OrigName elt IF_NCG(COMMA FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt) #-} {-# SPECIALIZE addToFM_C :: (elt -> elt -> elt) -> FiniteMap (RdrName, RdrName) elt -> (RdrName, RdrName) -> elt -> FiniteMap (RdrName, RdrName) elt - , (elt -> elt -> elt) -> FiniteMap (OrigName, OrigName) elt -> (OrigName, OrigName) -> elt -> FiniteMap (OrigName, OrigName) elt , (elt -> elt -> elt) -> FiniteMap FAST_STRING elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt) #-} @@ -791,7 +786,6 @@ When the FiniteMap module is used in GHC, we specialise it for #-} {-# SPECIALIZE delListFromFM :: FiniteMap RdrName elt -> [RdrName] -> FiniteMap RdrName elt - , FiniteMap OrigName elt -> [OrigName] -> FiniteMap OrigName elt , FiniteMap FAST_STRING elt -> [FAST_STRING] -> FiniteMap FAST_STRING elt IF_NCG(COMMA FiniteMap Reg elt -> [Reg] -> FiniteMap Reg elt) #-} @@ -799,7 +793,6 @@ When the FiniteMap module is used in GHC, we specialise it for :: [([Char],elt)] -> FiniteMap [Char] elt , [(FAST_STRING,elt)] -> FiniteMap FAST_STRING elt , [((FAST_STRING,FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt - , [(OrigName,elt)] -> FiniteMap OrigName elt IF_NCG(COMMA [(Reg COMMA elt)] -> FiniteMap Reg elt) #-} {-# SPECIALIZE lookupFM @@ -807,8 +800,6 @@ When the FiniteMap module is used in GHC, we specialise it for , FiniteMap [Char] elt -> [Char] -> Maybe elt , FiniteMap FAST_STRING elt -> FAST_STRING -> Maybe elt , FiniteMap (FAST_STRING,FAST_STRING) elt -> (FAST_STRING,FAST_STRING) -> Maybe elt - , FiniteMap OrigName elt -> OrigName -> Maybe elt - , FiniteMap (OrigName,OrigName) elt -> (OrigName,OrigName) -> Maybe elt , FiniteMap RdrName elt -> RdrName -> Maybe elt , FiniteMap (RdrName,RdrName) elt -> (RdrName,RdrName) -> Maybe elt IF_NCG(COMMA FiniteMap Reg elt -> Reg -> Maybe elt) @@ -819,7 +810,6 @@ When the FiniteMap module is used in GHC, we specialise it for #-} {-# SPECIALIZE plusFM :: FiniteMap RdrName elt -> FiniteMap RdrName elt -> FiniteMap RdrName elt - , FiniteMap OrigName elt -> FiniteMap OrigName elt -> FiniteMap OrigName elt , FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt IF_NCG(COMMA FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt) #-} diff --git a/ghc/compiler/utils/SpecLoop.lhi b/ghc/compiler/utils/SpecLoop.lhi index 74e3f2cb7b..f05cdefd62 100644 --- a/ghc/compiler/utils/SpecLoop.lhi +++ b/ghc/compiler/utils/SpecLoop.lhi @@ -5,7 +5,7 @@ SPECIALIZE pragmas. interface SpecLoop where import RdrHsSyn ( RdrName ) -import Name ( Name, OrigName, OccName ) +import Name ( Name, OccName ) import TyVar ( GenTyVar ) import TyCon ( TyCon ) import Class ( GenClass, GenClassOp ) @@ -21,7 +21,6 @@ data GenClassOp a data GenId a -- NB: fails the optimisation criterion data GenTyVar a -- NB: fails the optimisation criterion data Name -data OrigName data OccName data TyCon data Unique @@ -37,7 +36,6 @@ instance Eq Reg instance Eq CLabel instance Eq OccName instance Eq RdrName -instance Eq OrigName instance Eq (GenId a) instance Eq TyCon instance Eq (GenClass a b) @@ -48,7 +46,6 @@ instance Ord Reg instance Ord CLabel instance Ord OccName instance Ord RdrName -instance Ord OrigName instance Ord (GenId a) instance Ord TyCon instance Ord (GenClass a b) @@ -56,7 +53,6 @@ instance Ord Unique instance Ord Name -- SPECIALIZing in UniqFM, UniqSet -instance Uniquable OrigName instance Uniquable (GenId a) instance Uniquable TyCon instance Uniquable (GenClass a b) diff --git a/ghc/compiler/utils/Ubiq_1_3.lhi b/ghc/compiler/utils/Ubiq_1_3.lhi index 77ce05a469..8cb031eb68 100644 --- a/ghc/compiler/utils/Ubiq_1_3.lhi +++ b/ghc/compiler/utils/Ubiq_1_3.lhi @@ -46,7 +46,6 @@ Name ExportFlag Name Module Name Name Name NamedThing (..) -Name OrigName (..) Name RdrName (..) Outputable Outputable (..) PprStyle PprStyle |