From: simonpj Date: Sat, 18 Jan 1997 10:04:45 +0000 (+0000) Subject: [project @ 1997-01-18 10:03:27 by simonpj] X-Git-Tag: Approximately_1000_patches_recorded~848 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=8de16184643ea3c2f9f30b5eaed18db6ef247760;p=ghc-hetmet.git [project @ 1997-01-18 10:03:27 by simonpj] More polishing by Simon; to get nofib to run! --- diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index 0d4fb49..a482b68 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -113,6 +113,7 @@ module Unique ( liftTyConKey, listTyConKey, ltDataConKey, + mainKey, mainPrimIoKey, monadClassKey, monadPlusClassKey, monadZeroClassKey, @@ -669,4 +670,7 @@ thenMClassOpKey = mkPreludeMiscIdUnique 63 -- (>>=) unboundKey = mkPreludeMiscIdUnique 64 -- Just a place holder for unbound -- variables produced by the renamer fromEnumClassOpKey = mkPreludeMiscIdUnique 65 + +mainKey = mkPreludeMiscIdUnique 66 +mainPrimIoKey = mkPreludeMiscIdUnique 67 \end{code} diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 55bf40b..d7dd124 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -267,7 +267,7 @@ ppr_expr pe expr@(Lam _ _) (uvars, tyvars, vars, body) = collectBinders expr in ppHang (ppCat [pp_vars SLIT("/u\\") (pUVar pe) uvars, - pp_vars SLIT("/\\") (pTyVarB pe) tyvars, + pp_vars SLIT("_/\\_") (pTyVarB pe) tyvars, pp_vars SLIT("\\") (pMinBndr pe) vars]) 4 (ppr_expr pe body) where @@ -393,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) = ppStr "@ " `ppBeside` pTy pe ty +ppr_arg pe (TyArg ty) = ppStr "_@_ " `ppBeside` pTy pe ty ppr_arg pe (UsageArg use) = pUse pe use \end{code} @@ -405,9 +405,8 @@ pprBigCoreBinder sty binder = ppAboves [sig, pragmas, ppr sty binder] where sig = ifnotPprShowAll sty ( - ppHang (ppCat [ppr sty binder, ppStr "::"]) + ppHang (ppCat [ppr sty binder, ppDcolon]) 4 (ppr sty (idType binder))) - pragmas = ifnotPprForUser sty (ppIdInfo sty False{-no specs, thanks-} (getIdInfo binder)) @@ -424,5 +423,9 @@ pprBabyCoreBinder sty binder -- ppStr ("{- " ++ (showList xx "") ++ " -}") pprTypedCoreBinder sty binder - = ppBesides [ppr sty binder, ppStr "::", pprParendGenType sty (idType binder)] + = ppBesides [ppr sty binder, ppDcolon, pprParendGenType sty (idType binder)] + +ppDcolon = ppStr " :: " + -- The space before the :: is important; it helps the lexer + -- when reading inferfaces. Otherwise it would lex "a::b" as one thing. \end{code} diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 0afd0bc..2efca38 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -13,7 +13,7 @@ IMPORT_DELOOPER(DsLoop) -- partly to get dsBinds, partly to chk dsExpr import HsSyn ( failureFreePat, HsExpr(..), OutPat(..), HsLit(..), ArithSeqInfo(..), - Stmt(..), Match(..), Qualifier, HsBinds, HsType, + Stmt(..), Match(..), Qualifier, HsBinds, HsType, Fixity, GRHSsAndBinds ) import TcHsSyn ( SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedHsBinds), @@ -188,8 +188,8 @@ dsExpr expr@(HsLam a_Match) = matchWrapper LambdaMatch [a_Match] "lambda" `thenDs` \ (binders, matching_code) -> returnDs ( mkValLam binders matching_code ) -dsExpr expr@(HsApp e1 e2) = dsApp expr [] -dsExpr expr@(OpApp e1 op e2) = dsApp expr [] +dsExpr expr@(HsApp e1 e2) = dsApp expr [] +dsExpr expr@(OpApp e1 op _ e2) = dsApp expr [] \end{code} Operator sections. At first it looks as if we can convert @@ -549,7 +549,7 @@ dsApp (HsApp e1 e2) args = dsExpr e2 `thenDs` \ core_e2 -> dsApp e1 (VarArg core_e2 : args) -dsApp (OpApp e1 op e2) args +dsApp (OpApp e1 op _ e2) args = dsExpr e1 `thenDs` \ core_e1 -> dsExpr e2 `thenDs` \ core_e2 -> dsApp op (VarArg core_e1 : VarArg core_e2 : args) diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 3b767bb..ff2ec5f 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -30,7 +30,7 @@ module DsUtils ( IMP_Ubiq() IMPORT_DELOOPER(DsLoop) ( match, matchSimply ) -import HsSyn ( HsExpr(..), OutPat(..), HsLit(..), +import HsSyn ( HsExpr(..), OutPat(..), HsLit(..), Fixity, Match, HsBinds, Stmt, Qualifier, HsType, ArithSeqInfo ) import TcHsSyn ( SYN_IE(TypecheckedPat) ) import DsHsSyn ( outPatType ) diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs index 53ef74d..a4ed52d 100644 --- a/ghc/compiler/deSugar/MatchLit.lhs +++ b/ghc/compiler/deSugar/MatchLit.lhs @@ -11,7 +11,7 @@ module MatchLit ( matchLiterals ) where IMP_Ubiq() IMPORT_DELOOPER(DsLoop) -- break match-ish and dsExpr-ish loops -import HsSyn ( HsLit(..), OutPat(..), HsExpr(..), +import HsSyn ( HsLit(..), OutPat(..), HsExpr(..), Fixity, Match, HsBinds, Stmt, Qualifier, HsType, ArithSeqInfo ) import TcHsSyn ( SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedPat) diff --git a/ghc/compiler/hsSyn/HsLit.lhs b/ghc/compiler/hsSyn/HsBasic.lhs similarity index 61% rename from ghc/compiler/hsSyn/HsLit.lhs rename to ghc/compiler/hsSyn/HsBasic.lhs index e0f7364..114721a 100644 --- a/ghc/compiler/hsSyn/HsLit.lhs +++ b/ghc/compiler/hsSyn/HsBasic.lhs @@ -6,7 +6,7 @@ \begin{code} #include "HsVersions.h" -module HsLit where +module HsBasic where IMP_Ubiq(){-uitous-} IMPORT_1_3(Ratio(Rational)) @@ -14,6 +14,23 @@ IMPORT_1_3(Ratio(Rational)) import Pretty \end{code} +%************************************************************************ +%* * +\subsection[Version]{Module and identifier version numbers} +%* * +%************************************************************************ + +\begin{code} +type Version = Int +\end{code} + +%************************************************************************ +%* * +\subsection[HsLit]{Literals} +%* * +%************************************************************************ + + \begin{code} data HsLit = HsChar Char -- characters @@ -59,3 +76,27 @@ instance Outputable HsLit where ppr sty (HsIntPrim i) = ppBeside (ppInteger i) (ppChar '#') ppr sty (HsLitLit s) = ppBesides [ppStr "``", ppPStr s, ppStr "''"] \end{code} + +%************************************************************************ +%* * +\subsection[Fixity]{Fixity info} +%* * +%************************************************************************ + +\begin{code} +data Fixity = Fixity Int FixityDirection +data FixityDirection = InfixL | InfixR | InfixN + deriving(Eq) + +instance Outputable Fixity where + ppr sty (Fixity prec dir) = ppBesides [ppr sty dir, ppSP, ppInt prec] + +instance Outputable FixityDirection where + ppr sty InfixL = ppStr "infixl" + ppr sty InfixR = ppStr "infixr" + ppr sty InfixN = ppStr "infix" + +instance Eq Fixity where -- Used to determine if two fixities conflict + (Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2 +\end{code} + diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 486a188..9f90735 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -22,6 +22,7 @@ import HsTypes import IdInfo import SpecEnv ( SpecEnv ) import HsCore ( UfExpr ) +import HsBasic ( Fixity ) -- others: import Name ( pprSym, pprNonSym, getOccName, OccName ) @@ -86,26 +87,6 @@ instance Outputable name => Outputable (FixityDecl name) where ppr sty (FixityDecl name fixity loc) = ppSep [ppr sty fixity, ppr sty name] \end{code} -It's convenient to keep the source location in the @Fixity@; it makes error reporting -in the renamer easier. - -\begin{code} -data Fixity = Fixity Int FixityDirection -data FixityDirection = InfixL | InfixR | InfixN - deriving(Eq) - -instance Outputable Fixity where - ppr sty (Fixity prec dir) = ppBesides [ppr sty dir, ppSP, ppInt prec] - -instance Outputable FixityDirection where - ppr sty InfixL = ppStr "infixl" - ppr sty InfixR = ppStr "infixr" - ppr sty InfixN = ppStr "infix" - -instance Eq Fixity where -- Used to determine if two fixities conflict - (Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2 -\end{code} - %************************************************************************ %* * @@ -252,7 +233,10 @@ instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where pp_field (ns, ty) = ppCat [ppCat (map (ppr sty . getOccName) ns), ppPStr SLIT("::"), ppr_bang sty ty] -ppr_bang sty (Banged ty) = ppBeside (ppChar '!') (pprParendHsType sty ty) +ppr_bang sty (Banged ty) = ppBeside (ppStr "! ") (pprParendHsType sty ty) + -- The extra space helps the lexical analyser that lexes + -- interface files; it doesn't make the rigid operator/identifier + -- distinction, so "!a" is a valid identifier so far as it is concerned ppr_bang sty (Unbanged ty) = pprParendHsType sty ty \end{code} diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 8f6b099..b08debd 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -13,7 +13,7 @@ IMPORT_DELOOPER(HsLoop) -- for paranoia checking -- friends: import HsBinds ( HsBinds ) -import HsLit ( HsLit ) +import HsBasic ( HsLit, Fixity(..), FixityDirection(..) ) import HsMatches ( pprMatches, pprMatch, Match ) import HsTypes ( HsType ) @@ -54,6 +54,7 @@ data HsExpr tyvar uvar id pat | OpApp (HsExpr tyvar uvar id pat) -- left operand (HsExpr tyvar uvar id pat) -- operator + Fixity -- Renamer adds fixity; bottom until then (HsExpr tyvar uvar id pat) -- right operand -- We preserve prefix negation and parenthesis for the precedence parser. @@ -208,13 +209,13 @@ pprExpr sty expr@(HsApp e1 e2) collect_args (HsApp fun arg) args = collect_args fun (arg:args) collect_args fun args = (fun, args) -pprExpr sty (OpApp e1 op e2) +pprExpr sty (OpApp e1 op fixity e2) = case op of HsVar v -> pp_infixly v _ -> pp_prefixly where - pp_e1 = pprExpr sty e1 - pp_e2 = pprExpr sty e2 + pp_e1 = pprParendExpr sty e1 -- Add parens to make precedence clear + pp_e2 = pprParendExpr sty e2 pp_prefixly = ppHang (pprExpr sty op) 4 (ppSep [pp_e1, pp_e2]) @@ -374,10 +375,13 @@ pprParendExpr sty expr case expr of HsLit l -> ppr sty l HsLitOut l _ -> ppr sty l + HsVar _ -> pp_as_was ExplicitList _ -> pp_as_was ExplicitListOut _ _ -> pp_as_was ExplicitTuple _ -> pp_as_was + HsPar _ -> pp_as_was + _ -> ppParens pp_as_was \end{code} diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index d90dd1e..da42d1c 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -20,7 +20,7 @@ module HsPat ( IMP_Ubiq() -- friends: -import HsLit ( HsLit ) +import HsBasic ( HsLit, Fixity ) IMPORT_DELOOPER(HsLoop) ( HsExpr ) -- others: @@ -47,6 +47,7 @@ data InPat name [InPat name] | ConOpPatIn (InPat name) name + Fixity -- c.f. OpApp in HsExpr (InPat name) -- We preserve prefix negation and parenthesis for the precedence parser. @@ -127,7 +128,7 @@ pprInPat sty (ConPatIn c pats) else ppCat [ppr sty c, interppSP sty pats] -- ParPats put in the parens -pprInPat sty (ConOpPatIn pat1 op pat2) +pprInPat sty (ConOpPatIn pat1 op fixity pat2) = ppCat [ppr sty pat1, ppr sty op, ppr sty pat2] -- ParPats put in parens -- ToDo: use pprSym to print op (but this involves fiddling various @@ -290,16 +291,16 @@ collected is important; see @HsBinds.lhs@. \begin{code} collectPatBinders :: InPat a -> [a] -collectPatBinders WildPatIn = [] -collectPatBinders (VarPatIn var) = [var] -collectPatBinders (LitPatIn _) = [] -collectPatBinders (LazyPatIn pat) = collectPatBinders pat -collectPatBinders (AsPatIn a pat) = a : collectPatBinders pat -collectPatBinders (ConPatIn c pats) = concat (map collectPatBinders pats) -collectPatBinders (ConOpPatIn p1 c p2)= collectPatBinders p1 ++ collectPatBinders p2 -collectPatBinders (NegPatIn pat) = collectPatBinders pat -collectPatBinders (ParPatIn pat) = collectPatBinders pat -collectPatBinders (ListPatIn pats) = concat (map collectPatBinders pats) -collectPatBinders (TuplePatIn pats) = concat (map collectPatBinders pats) -collectPatBinders (RecPatIn c fields) = concat (map (\ (f,pat,_) -> collectPatBinders pat) fields) +collectPatBinders WildPatIn = [] +collectPatBinders (VarPatIn var) = [var] +collectPatBinders (LitPatIn _) = [] +collectPatBinders (LazyPatIn pat) = collectPatBinders pat +collectPatBinders (AsPatIn a pat) = a : collectPatBinders pat +collectPatBinders (ConPatIn c pats) = concat (map collectPatBinders pats) +collectPatBinders (ConOpPatIn p1 c f p2) = collectPatBinders p1 ++ collectPatBinders p2 +collectPatBinders (NegPatIn pat) = collectPatBinders pat +collectPatBinders (ParPatIn pat) = collectPatBinders pat +collectPatBinders (ListPatIn pats) = concat (map collectPatBinders pats) +collectPatBinders (TuplePatIn pats) = concat (map collectPatBinders pats) +collectPatBinders (RecPatIn c fields) = concat (map (\ (f,pat,_) -> collectPatBinders pat) fields) \end{code} diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index 9e57b8d..2702f8a 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -20,7 +20,7 @@ module HsSyn ( EXP_MODULE(HsDecls) , EXP_MODULE(HsExpr) , EXP_MODULE(HsImpExp) , - EXP_MODULE(HsLit) , + EXP_MODULE(HsBasic) , EXP_MODULE(HsMatches) , EXP_MODULE(HsPat) , EXP_MODULE(HsTypes) @@ -32,14 +32,14 @@ IMP_Ubiq() import HsBinds import HsDecls ( HsDecl(..), TyDecl(..), InstDecl(..), ClassDecl(..), DefaultDecl(..), - FixityDecl(..), Fixity(..), FixityDirection(..), + FixityDecl(..), ConDecl(..), BangType(..), IfaceSig(..), HsIdInfo, SpecDataSig(..), SpecInstSig(..), hsDeclName ) import HsExpr import HsImpExp -import HsLit +import HsBasic import HsMatches import HsPat import HsTypes @@ -63,8 +63,6 @@ instance Outputable Fake All we actually declare here is the top-level structure for a module. \begin{code} -type Version = Int - data HsModule tyvar uvar name pat = HsModule Module -- module name diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 183c399..b695f4c 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -34,6 +34,7 @@ module CmdLineOpts ( opt_D_dump_realC, opt_D_dump_rn, opt_D_dump_simpl, + opt_D_dump_simpl_iterations, opt_D_dump_spec, opt_D_dump_stg, opt_D_dump_stranal, @@ -56,6 +57,7 @@ module CmdLineOpts ( opt_GranMacros, opt_Haskell_1_3, opt_HiMap, + opt_HiSuffix, opt_IgnoreIfacePragmas, opt_IgnoreStrictnessPragmas, opt_IrrefutableEverything, @@ -267,6 +269,7 @@ opt_D_dump_rdr = lookUp SLIT("-ddump-rdr") opt_D_dump_realC = lookUp SLIT("-ddump-realC") opt_D_dump_rn = lookUp SLIT("-ddump-rn") opt_D_dump_simpl = lookUp SLIT("-ddump-simpl") +opt_D_dump_simpl_iterations = lookUp SLIT("-ddump-simpl_iterations") opt_D_dump_spec = lookUp SLIT("-ddump-spec") opt_D_dump_stg = lookUp SLIT("-ddump-stg") opt_D_dump_stranal = lookUp SLIT("-ddump-stranal") @@ -289,6 +292,7 @@ opt_GranMacros = lookUp SLIT("-fgransim") opt_GlasgowExts = lookUp SLIT("-fglasgow-exts") opt_Haskell_1_3 = lookUp SLIT("-fhaskell-1.3") opt_HiMap = lookup_str "-himap=" -- file saying where to look for .hi files +opt_HiSuffix = lookup_str "-hisuf=" opt_IgnoreIfacePragmas = lookUp SLIT("-fignore-interface-pragmas") opt_IgnoreStrictnessPragmas = lookUp SLIT("-fignore-strictness-pragmas") opt_IrrefutableEverything = lookUp SLIT("-firrefutable-everything") diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 59c32a0..5bc488d 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -251,7 +251,7 @@ ifaceId get_idinfo needed_ids is_rec id rhs = Nothing -- Well, that was easy! ifaceId get_idinfo needed_ids is_rec id rhs - = Just (ppCat [sig_pretty, prag_pretty, ppSemi], new_needed_ids) + = Just (ppCat [sig_pretty, prag_pretty, ppStr ";;"], new_needed_ids) where idinfo = get_idinfo id inline_pragma = idWantsToBeINLINEd id @@ -383,9 +383,9 @@ upp_export names = uppBesides [uppStr "(", uppIntersperse uppSP (map (upp_occname . getOccName) names), uppStr ")"] -upp_fixity (occ, Fixity prec dir, prov) = uppBesides [upp_dir dir, uppSP, - uppInt prec, uppSP, - upp_occname occ, uppSemi] +upp_fixity (occ, (Fixity prec dir, prov)) = uppBesides [upp_dir dir, uppSP, + uppInt prec, uppSP, + upp_occname occ, uppSemi] upp_dir InfixR = uppStr "infixr" upp_dir InfixL = uppStr "infixl" upp_dir InfixN = uppStr "infix" diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index ed2bec5..7001a7b 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -8,7 +8,7 @@ module PrelInfo ( -- finite maps for built-in things (for the renamer and typechecker): - builtinNames, builtinKeys, derivingOccurrences, + builtinNames, derivingOccurrences, SYN_IE(BuiltinNames), maybeCharLikeTyCon, maybeIntLikeTyCon, @@ -27,6 +27,8 @@ module PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR, creturnableClass_RDR, monadZeroClass_RDR, enumClass_RDR, evalClass_RDR, ordClass_RDR, + main_NAME, mainPrimIO_NAME, ioTyCon_NAME, primIoTyCon_NAME, + needsDataDeclCtxtClassKeys, cCallishClassKeys, isNoDictClass, isNumericClass, isStandardClass, isCcallishClass ) where @@ -82,7 +84,7 @@ builtinNames listToBag (map (getName.primOpName) allThePrimOps) `unionBags` -- Other names with magic keys - listToBag builtinKeys + listToBag knownKeyNames \end{code} @@ -243,58 +245,62 @@ wired_in_ids Ids, Synonyms, Classes and ClassOps with builtin keys. \begin{code} -getKeyOrig :: (Module, OccName, Unique) -> Name -getKeyOrig (mod, occ, uniq) = mkGlobalName uniq mod occ VanillaDefn Implicit - -builtinKeys :: [Name] -builtinKeys - = map getKeyOrig +mkKnownKeyGlobal :: (RdrName, Unique) -> Name +mkKnownKeyGlobal (Qual mod occ, uniq) = mkGlobalName uniq mod occ VanillaDefn Implicit + +main_NAME = mkKnownKeyGlobal (main_RDR, mainKey) +mainPrimIO_NAME = mkKnownKeyGlobal (mainPrimIO_RDR, mainPrimIoKey) +ioTyCon_NAME = mkKnownKeyGlobal (ioTyCon_RDR, iOTyConKey) +primIoTyCon_NAME = getName primIoTyCon + +knownKeyNames :: [Name] +knownKeyNames + = [main_NAME, mainPrimIO_NAME, ioTyCon_NAME] + ++ + map mkKnownKeyGlobal [ -- Type constructors (synonyms especially) - (iO_BASE, TCOcc SLIT("IO"), iOTyConKey) - , (pREL_BASE, TCOcc SLIT("Ordering"), orderingTyConKey) - , (pREL_NUM, TCOcc SLIT("Rational"), rationalTyConKey) - , (pREL_NUM, TCOcc SLIT("Ratio"), ratioTyConKey) - + (orderingTyCon_RDR, orderingTyConKey) + , (rationalTyCon_RDR, rationalTyConKey) + , (ratioTyCon_RDR, ratioTyConKey) -- Classes. *Must* include: -- classes that are grabbed by key (e.g., eqClassKey) -- classes in "Class.standardClassKeys" (quite a few) - , (pREL_BASE, TCOcc SLIT("Eq"), eqClassKey) -- mentioned, derivable - , (pREL_BASE, TCOcc SLIT("Eval"), evalClassKey) -- mentioned - , (pREL_BASE, TCOcc SLIT("Ord"), ordClassKey) -- derivable - , (pREL_BASE, TCOcc SLIT("Bounded"), boundedClassKey) -- derivable - , (pREL_BASE, TCOcc SLIT("Num"), numClassKey) -- mentioned, numeric - , (pREL_BASE, TCOcc SLIT("Enum"), enumClassKey) -- derivable - , (pREL_BASE, TCOcc SLIT("Monad"), monadClassKey) - , (pREL_BASE, TCOcc SLIT("MonadZero"), monadZeroClassKey) - , (pREL_BASE, TCOcc SLIT("MonadPlus"), monadPlusClassKey) - , (pREL_BASE, TCOcc SLIT("Functor"), functorClassKey) - , (pREL_BASE, TCOcc SLIT("Show"), showClassKey) -- derivable - , (pREL_NUM, TCOcc SLIT("Real"), realClassKey) -- numeric - , (pREL_NUM, TCOcc SLIT("Integral"), integralClassKey) -- numeric - , (pREL_NUM, TCOcc SLIT("Fractional"), fractionalClassKey) -- numeric - , (pREL_NUM, TCOcc SLIT("Floating"), floatingClassKey) -- numeric - , (pREL_NUM, TCOcc SLIT("RealFrac"), realFracClassKey) -- numeric - , (pREL_NUM, TCOcc SLIT("RealFloat"), realFloatClassKey) -- numeric - , (pREL_READ, TCOcc SLIT("Read"), readClassKey) -- derivable - , (iX, TCOcc SLIT("Ix"), ixClassKey) -- derivable (but it isn't Prelude.Ix; hmmm) - , (fOREIGN, TCOcc SLIT("CCallable"), cCallableClassKey) -- mentioned, ccallish - , (fOREIGN, TCOcc SLIT("CReturnable"), cReturnableClassKey) -- mentioned, ccallish - + , (eqClass_RDR, eqClassKey) -- mentioned, derivable + , (ordClass_RDR, ordClassKey) -- derivable + , (evalClass_RDR, evalClassKey) -- mentioned + , (boundedClass_RDR, boundedClassKey) -- derivable + , (numClass_RDR, numClassKey) -- mentioned, numeric + , (enumClass_RDR, enumClassKey) -- derivable + , (monadClass_RDR, monadClassKey) + , (monadZeroClass_RDR, monadZeroClassKey) + , (monadPlusClass_RDR, monadPlusClassKey) + , (functorClass_RDR, functorClassKey) + , (showClass_RDR, showClassKey) -- derivable + , (realClass_RDR, realClassKey) -- numeric + , (integralClass_RDR, integralClassKey) -- numeric + , (fractionalClass_RDR, fractionalClassKey) -- numeric + , (floatingClass_RDR, floatingClassKey) -- numeric + , (realFracClass_RDR, realFracClassKey) -- numeric + , (realFloatClass_RDR, realFloatClassKey) -- numeric + , (readClass_RDR, readClassKey) -- derivable + , (ixClass_RDR, ixClassKey) -- derivable (but it isn't Prelude.Ix; hmmm) + , (ccallableClass_RDR, cCallableClassKey) -- mentioned, ccallish + , (creturnableClass_RDR, cReturnableClassKey) -- mentioned, ccallish -- ClassOps - , (pREL_BASE, VarOcc SLIT("fromInt"), fromIntClassOpKey) - , (pREL_BASE, VarOcc SLIT("fromInteger"), fromIntegerClassOpKey) - , (pREL_BASE, VarOcc SLIT("enumFrom"), enumFromClassOpKey) - , (pREL_BASE, VarOcc SLIT("enumFromThen"), enumFromThenClassOpKey) - , (pREL_BASE, VarOcc SLIT("enumFromTo"), enumFromToClassOpKey) - , (pREL_BASE, VarOcc SLIT("enumFromThenTo"), enumFromThenToClassOpKey) - , (pREL_BASE, VarOcc SLIT("fromEnum"), fromEnumClassOpKey) - , (pREL_BASE, VarOcc SLIT("=="), eqClassOpKey) - , (pREL_BASE, VarOcc SLIT(">>="), thenMClassOpKey) - , (pREL_BASE, VarOcc SLIT("zero"), zeroClassOpKey) - , (pREL_NUM, VarOcc SLIT("fromRational"), fromRationalClassOpKey) + , (fromInt_RDR, fromIntClassOpKey) + , (fromInteger_RDR, fromIntegerClassOpKey) + , (enumFrom_RDR, enumFromClassOpKey) + , (enumFromThen_RDR, enumFromThenClassOpKey) + , (enumFromTo_RDR, enumFromToClassOpKey) + , (enumFromThenTo_RDR, enumFromThenToClassOpKey) + , (fromEnum_RDR, fromEnumClassOpKey) + , (eq_RDR, eqClassOpKey) + , (thenM_RDR, thenMClassOpKey) + , (zeroM_RDR, zeroClassOpKey) + , (fromRational_RDR, fromRationalClassOpKey) ] \end{code} @@ -318,16 +324,46 @@ to write them all down in one place. \begin{code} prelude_primop op = qual (modAndOcc (primOpName op)) +intTyCon_RDR = qual (modAndOcc intTyCon) +ioTyCon_RDR = tcQual (iO_BASE, SLIT("IO")) +orderingTyCon_RDR = tcQual (pREL_BASE, SLIT("Ordering")) +rationalTyCon_RDR = tcQual (pREL_NUM, SLIT("Rational")) +ratioTyCon_RDR = tcQual (pREL_NUM, SLIT("Ratio")) + eqClass_RDR = tcQual (pREL_BASE, SLIT("Eq")) ordClass_RDR = tcQual (pREL_BASE, SLIT("Ord")) evalClass_RDR = tcQual (pREL_BASE, SLIT("Eval")) -monadZeroClass_RDR = tcQual (pREL_BASE, SLIT("MonadZero")) -enumClass_RDR = tcQual (pREL_BASE, SLIT("Enum")) +boundedClass_RDR = tcQual (pREL_BASE, SLIT("Bounded")) numClass_RDR = tcQual (pREL_BASE, SLIT("Num")) +enumClass_RDR = tcQual (pREL_BASE, SLIT("Enum")) +monadClass_RDR = tcQual (pREL_BASE, SLIT("Monad")) +monadZeroClass_RDR = tcQual (pREL_BASE, SLIT("MonadZero")) +monadPlusClass_RDR = tcQual (pREL_BASE, SLIT("MonadPlus")) +functorClass_RDR = tcQual (pREL_BASE, SLIT("Functor")) +showClass_RDR = tcQual (pREL_BASE, SLIT("Show")) +realClass_RDR = tcQual (pREL_NUM, SLIT("Real")) +integralClass_RDR = tcQual (pREL_NUM, SLIT("Integral")) fractionalClass_RDR = tcQual (pREL_NUM, SLIT("Fractional")) +floatingClass_RDR = tcQual (pREL_NUM, SLIT("Floating")) +realFracClass_RDR = tcQual (pREL_NUM, SLIT("RealFrac")) +realFloatClass_RDR = tcQual (pREL_NUM, SLIT("RealFloat")) +readClass_RDR = tcQual (pREL_READ, SLIT("Read")) +ixClass_RDR = tcQual (iX, SLIT("Ix")) ccallableClass_RDR = tcQual (fOREIGN, SLIT("CCallable")) creturnableClass_RDR = tcQual (fOREIGN, SLIT("CReturnable")) +fromInt_RDR = varQual (pREL_BASE, SLIT("fromInt")) +fromInteger_RDR = varQual (pREL_BASE, SLIT("fromInteger")) +fromEnum_RDR = varQual (pREL_BASE, SLIT("fromEnum")) +enumFrom_RDR = varQual (pREL_BASE, SLIT("enumFrom")) +enumFromTo_RDR = varQual (pREL_BASE, SLIT("enumFromTo")) +enumFromThen_RDR = varQual (pREL_BASE, SLIT("enumFromThen")) +enumFromThenTo_RDR = varQual (pREL_BASE, SLIT("enumFromThenTo")) + +thenM_RDR = varQual (pREL_BASE, SLIT(">>=")) +zeroM_RDR = varQual (pREL_BASE, SLIT("zero")) +fromRational_RDR = varQual (pREL_NUM, SLIT("fromRational")) + negate_RDR = varQual (pREL_BASE, SLIT("negate")) eq_RDR = varQual (pREL_BASE, SLIT("==")) ne_RDR = varQual (pREL_BASE, SLIT("/=")) @@ -368,11 +404,6 @@ readParen_RDR = varQual (pREL_READ, SLIT("readParen")) lex_RDR = varQual (pREL_READ, SLIT("lex")) readList___RDR = varQual (pREL_READ, SLIT("readList__")) -fromEnum_RDR = varQual (pREL_BASE, SLIT("fromEnum")) -enumFrom_RDR = varQual (pREL_BASE, SLIT("enumFrom")) -enumFromTo_RDR = varQual (pREL_BASE, SLIT("enumFromTo")) -enumFromThen_RDR = varQual (pREL_BASE, SLIT("enumFromThen")) -enumFromThenTo_RDR = varQual (pREL_BASE, SLIT("enumFromThenTo")) plus_RDR = varQual (pREL_BASE, SLIT("+")) times_RDR = varQual (pREL_BASE, SLIT("*")) mkInt_RDR = varQual (pREL_BASE, SLIT("I#")) @@ -395,7 +426,8 @@ geH_RDR = prelude_primop IntGeOp leH_RDR = prelude_primop IntLeOp minusH_RDR = prelude_primop IntSubOp -intType_RDR = qual (modAndOcc intTyCon) +main_RDR = varQual (mAIN, SLIT("main")) +mainPrimIO_RDR = varQual (gHC_MAIN, SLIT("mainPrimIO")) \end{code} %************************************************************************ @@ -423,18 +455,18 @@ derivingOccurrences = listToUFM deriving_occ_info derivableClassKeys = map fst deriving_occ_info deriving_occ_info - = [ (eqClassKey, [intType_RDR, and_RDR, not_RDR]) - , (ordClassKey, [intType_RDR, compose_RDR]) - , (enumClassKey, [intType_RDR, map_RDR]) - , (evalClassKey, [intType_RDR]) - , (boundedClassKey, [intType_RDR]) - , (showClassKey, [intType_RDR, numClass_RDR, ordClass_RDR, compose_RDR, showString_RDR, + = [ (eqClassKey, [intTyCon_RDR, and_RDR, not_RDR]) + , (ordClassKey, [intTyCon_RDR, compose_RDR]) + , (enumClassKey, [intTyCon_RDR, map_RDR]) + , (evalClassKey, [intTyCon_RDR]) + , (boundedClassKey, [intTyCon_RDR]) + , (showClassKey, [intTyCon_RDR, numClass_RDR, ordClass_RDR, compose_RDR, showString_RDR, showParen_RDR, showSpace_RDR, showList___RDR]) - , (readClassKey, [intType_RDR, numClass_RDR, ordClass_RDR, append_RDR, + , (readClassKey, [intTyCon_RDR, numClass_RDR, ordClass_RDR, append_RDR, lex_RDR, readParen_RDR, readList___RDR]) - , (ixClassKey, [intType_RDR, numClass_RDR, and_RDR, map_RDR]) + , (ixClassKey, [intTyCon_RDR, numClass_RDR, and_RDR, map_RDR]) ] - -- intType: Practically any deriving needs Int, either for index calculations, + -- intTyCon: Practically any deriving needs Int, either for index calculations, -- or for taggery. -- ordClass: really it's the methods that are actually used. -- numClass: for Int literals diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 06c91a3..742510f 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -510,7 +510,7 @@ mkPrimIoTy a = mkStateTransformerTy realWorldTy a primIoTyCon = pcSynTyCon - primIoTyConKey iO_BASE SLIT("PrimIO") + primIoTyConKey sT_BASE SLIT("PrimIO") (mkBoxedTypeKind `mkArrowKind` mkBoxedTypeKind) 1 alpha_tyvar (mkPrimIoTy alphaTy) \end{code} diff --git a/ghc/compiler/reader/Lex.lhs b/ghc/compiler/reader/Lex.lhs index b5e035a..ec761e4 100644 --- a/ghc/compiler/reader/Lex.lhs +++ b/ghc/compiler/reader/Lex.lhs @@ -20,6 +20,7 @@ module Lex ( IMPORT_1_3(Char(isDigit, isAlpha, isAlphanum, isUpper)) +import CmdLineOpts ( opt_IgnoreIfacePragmas ) import Demand ( Demand {- instance Read -} ) import FiniteMap ( FiniteMap, listToFM, lookupFM ) import Maybes ( Maybe(..), MaybeErr(..) ) @@ -210,7 +211,6 @@ lexIface input ',' : cs -> ITcomma : lexIface cs ':' : ':' : cs -> ITdcolon : lexIface cs ';' : cs -> ITsemi : lexIface cs - '@' : cs -> ITatsign : lexIface cs '\"' : cs -> case reads input of [(str, rest)] -> ITstring (_PK_ (str::String)) : lexIface rest '\'' : cs -> case reads input of @@ -254,11 +254,13 @@ lexIface input = case (span is_kwd_mod_char str) of { (kw, rest) -> case (lookupFM ifaceKeywordsFM kw) of Nothing -> panic ("lex_keyword:"++str) - Just xx -> xx : lexIface rest + + Just xx | startDiscard xx && + opt_IgnoreIfacePragmas -> lexIface (doDiscard rest) + | otherwise -> xx : lexIface rest } - is_kwd_mod_char '_' = True - is_kwd_mod_char c = isAlphanum c + is_kwd_mod_char c = isAlphanum c || c `elem` "_@/\\" ----------- lex_cstring so_far ('\'' : '\'' : cs) = ITstring (_PK_ (reverse (so_far::String))) : lexIface cs @@ -272,10 +274,8 @@ lexIface input go n (')':cs) = end_lex_id module_dot (ITconid (mkTupNameStr n)) cs go n other = panic ("lex_tuple" ++ orig_cs) - -- 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 + is_id_char c = isAlphanum c || c `elem` ":_'!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic lex_id cs = go [] cs where @@ -319,7 +319,9 @@ lexIface input ------------ ifaceKeywordsFM :: FiniteMap String IfaceToken ifaceKeywordsFM = listToFM [ - ("interface_", ITinterface) + ("/\\_", ITbiglam) + ,("@_", ITatsign) + ,("interface_", ITinterface) ,("usages_", ITusages) ,("versions_", ITversions) ,("exports_", ITexports) @@ -333,8 +335,6 @@ lexIface input ,("A_", ITarity) ,("coerce_in_", ITcoerce_in) ,("coerce_out_", ITcoerce_out) - ,("A_", ITarity) - ,("A_", ITarity) ,("bot_", ITbottom) ,("integer_", ITinteger_lit) ,("rational_", ITrational_lit) @@ -368,12 +368,22 @@ lexIface input ,("->", ITrarrow) ,("\\", ITlam) - ,("/\\", ITbiglam) ,("|", ITvbar) ,("!", ITbang) ,("=>", ITdarrow) ,("=", ITequal) ] + +startDiscard ITarity = True +startDiscard ITunfold = True +startDiscard ITstrict = True +startDiscard other = False + +-- doDiscard rips along really fast looking for a double semicolon, +-- indicating the end of the pragma we're skipping +doDiscard rest@(';' : ';' : _) = rest +doDiscard ( _ : rest) = doDiscard rest +doDiscard [] = [] \end{code} diff --git a/ghc/compiler/reader/PrefixToHs.lhs b/ghc/compiler/reader/PrefixToHs.lhs index 61da9a2..9b72fa5 100644 --- a/ghc/compiler/reader/PrefixToHs.lhs +++ b/ghc/compiler/reader/PrefixToHs.lhs @@ -150,9 +150,9 @@ cvFunMonoBind sf matches get_mdef (RdrMatch_NoGuard _ sfun pat _ _) = get_pdef pat get_mdef (RdrMatch_Guards _ sfun pat _ _) = get_pdef pat - get_pdef (ConPatIn fn _) = (fn, False) - get_pdef (ConOpPatIn _ op _) = (op, True) - get_pdef (ParPatIn pat) = get_pdef pat + get_pdef (ConPatIn fn _) = (fn, False) + get_pdef (ConOpPatIn _ op _ _) = (op, True) + get_pdef (ParPatIn pat) = get_pdef pat cvMatches :: SrcFile -> Bool -> [RdrMatch] -> [RdrNameMatch] @@ -172,9 +172,9 @@ cvMatch sf is_case rdr_match (if is_case then -- just one pattern: leave it untouched... [pat] else -- function pattern; extract arg patterns... - case pat of ConPatIn fn pats -> pats - ConOpPatIn p1 op p2 -> [p1,p2] - ParPatIn pat -> panic "PrefixToHs.cvMatch:ParPatIn" + case pat of ConPatIn fn pats -> pats + ConOpPatIn p1 op _ p2 -> [p1,p2] + ParPatIn pat -> panic "PrefixToHs.cvMatch:ParPatIn" ) where (pat, binding, guarded_exprs) diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs index 776ccfc..ab07b88 100644 --- a/ghc/compiler/reader/RdrHsSyn.lhs +++ b/ghc/compiler/reader/RdrHsSyn.lhs @@ -52,7 +52,8 @@ module RdrHsSyn ( dummyRdrVarName, dummyRdrTcName, isUnqual, isQual, showRdr, rdrNameOcc, - cmpRdr + cmpRdr, + mkOpApp ) where @@ -132,7 +133,15 @@ extractHsTyVars ty | otherwise = other : acc \end{code} - + +A useful function for building @OpApps@. The operator is always a variable, +and we don't know the fixity yet. + +\begin{code} +mkOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2 +\end{code} + + %************************************************************************ %* * \subsection[RdrName]{The @RdrName@ datatype; names read from files} diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs index 9dd7017..2098692 100644 --- a/ghc/compiler/reader/ReadPrefix.lhs +++ b/ghc/compiler/reader/ReadPrefix.lhs @@ -121,7 +121,7 @@ rdModule wlkBinding hmodlist `thenUgn` \ binding -> let - val_decl = ValD (add_main_sig modname (cvBinds srcfile cvValSig binding)) + val_decl = ValD (cvBinds srcfile cvValSig binding) other_decls = cvOtherDecls binding in returnUgn (modname, @@ -133,28 +133,6 @@ rdModule (val_decl: other_decls) src_loc ) - where - add_main_sig modname binds - = if modname == mAIN then - let - s = Sig (varUnqual SLIT("main")) (io_ty SLIT("IO")) mkGeneratedSrcLoc - in - add_sig binds s - - else if modname == gHC_MAIN then - let - s = Sig (varUnqual SLIT("mainPrimIO")) (io_ty SLIT("PrimIO")) mkGeneratedSrcLoc - in - add_sig binds s - - else -- add nothing - binds - where - add_sig (SingleBind b) s = BindWith b [s] - add_sig (BindWith b ss) s = BindWith b (s:ss) - add_sig _ _ = panic "rdModule:add_sig" - - io_ty t = MonoTyApp (MonoTyVar (Unqual (TCOcc t))) (MonoTupleTy dummyRdrTcName []) \end{code} %************************************************************************ @@ -335,7 +313,7 @@ wlkExpr expr wlkVarId fun `thenUgn` \ op -> wlkExpr arg1 `thenUgn` \ expr1 -> wlkExpr arg2 `thenUgn` \ expr2 -> - returnUgn (OpApp expr1 (HsVar op) expr2) + returnUgn (mkOpApp expr1 op expr2) U_negate nexp -> -- prefix negation wlkExpr nexp `thenUgn` \ expr -> @@ -426,9 +404,9 @@ wlkPat pat wlkPat r `thenUgn` \ rpat -> collect_pats l [rpat] `thenUgn` \ (lpat,lpats) -> (case lpat of - VarPatIn x -> returnUgn (x, lpats) - ConPatIn x [] -> returnUgn (x, lpats) - ConOpPatIn x op y -> returnUgn (op, x:y:lpats) + VarPatIn x -> returnUgn (x, lpats) + ConPatIn x [] -> returnUgn (x, lpats) + ConOpPatIn x op _ y -> returnUgn (op, x:y:lpats) _ -> getSrcLocUgn `thenUgn` \ loc -> let err = addErrLoc loc "Illegal pattern `application'" @@ -460,7 +438,7 @@ wlkPat pat wlkVarId fun `thenUgn` \ op -> wlkPat arg1 `thenUgn` \ pat1 -> wlkPat arg2 `thenUgn` \ pat2 -> - returnUgn (ConOpPatIn pat1 op pat2) + returnUgn (ConOpPatIn pat1 op (error "ConOpPatIn:fixity") pat2) U_negate npat -> -- negated pattern wlkPat npat `thenUgn` \ pat -> diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 5e1b2c5..0faa549 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -5,6 +5,8 @@ module ParseIface ( parseIface ) where IMP_Ubiq(){-uitous-} +import CmdLineOpts ( opt_IgnoreIfacePragmas ) + import HsSyn -- quite a bit of stuff import RdrHsSyn -- oodles of synonyms import HsDecls ( HsIdInfo(..) ) @@ -223,8 +225,12 @@ 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 type id_info SEMI - { SigD (IfaceSig $1 $3 $4 mkIfaceSrcLoc) } + | var_name DCOLON type id_info SEMI SEMI + { {- Double semicolon allows easy pragma discard in lexer -} + let + id_info = if opt_IgnoreIfacePragmas then [] else $4 + in + SigD (IfaceSig $1 $3 id_info mkIfaceSrcLoc) } decl_context :: { RdrNameContext } decl_context : { [] } diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 5964faa..d66596b 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -24,14 +24,17 @@ import RnSource ( rnDecl ) import RnIfaces ( getImportedInstDecls, getDecl, getImportVersions, getSpecialInstModules, mkSearchPath, getWiredInDecl ) -import RnEnv ( availsToNameSet, addAvailToNameSet, addImplicitOccsRn ) +import RnEnv ( availsToNameSet, addAvailToNameSet, + addImplicitOccsRn, lookupImplicitOccRn ) import Id ( GenId {- instance NamedThing -} ) import Name ( Name, Provenance, ExportFlag(..), isLocallyDefined, NameSet(..), elemNameSet, mkNameSet, unionNameSets, nameSetToList, isWiredInName, modAndOcc ) import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon ) +import PrelInfo ( ioTyCon_NAME, primIoTyCon_NAME ) import TyCon ( TyCon ) +import PrelMods ( mAIN, gHC_MAIN ) import ErrUtils ( SYN_IE(Error), SYN_IE(Warning) ) import FiniteMap ( emptyFM, eltsFM, fmToList, addToFM, FiniteMap ) import Pretty @@ -72,14 +75,10 @@ renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_ Just (export_env, rn_env, local_avails) -> -- RENAME THE SOURCE - -- We also add occurrences for Int, Double, and (), because they - -- are the types to which ambigious type variables may be defaulted by - -- the type checker; so they won't every appear explicitly. - -- [The () one is a GHC extension for defaulting CCall results.] - initRnMS rn_env mod_name SourceMode (mapRn rnDecl local_decls) `thenRn` \ rn_local_decls -> - addImplicitOccsRn [getName intTyCon, - getName doubleTyCon, - getName unitTyCon] `thenRn_` + initRnMS rn_env mod_name SourceMode ( + addImplicits mod_name `thenRn_` + mapRn rnDecl local_decls + ) `thenRn` \ rn_local_decls -> -- SLURP IN ALL THE NEEDED DECLARATIONS -- Notice that the rnEnv starts empty @@ -93,7 +92,7 @@ renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_ -- 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. + -- instance decl changes, so will its dfun version number. getImportedInstDecls `thenRn` \ imported_insts -> let all_big_names = mkNameSet [name | Avail name _ <- local_avails] `unionNameSets` @@ -148,6 +147,26 @@ renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_ trashed_fixities = [] \end{code} +@addImplicits@ forces the renamer to slurp in some things which aren't +mentioned explicitly, but which might be needed by the type checker. + +\begin{code} +addImplicits mod_name + = addImplicitOccsRn (implicit_main ++ default_tys) + where + -- Add occurrences for Int, Double, and (), because they + -- are the types to which ambigious type variables may be defaulted by + -- the type checker; so they won't every appear explicitly. + -- [The () one is a GHC extension for defaulting CCall results.] + default_tys = [getName intTyCon, getName doubleTyCon, getName unitTyCon] + + -- Add occurrences for IO or PrimIO + implicit_main | mod_name == mAIN = [ioTyCon_NAME] + | mod_name == gHC_MAIN = [primIoTyCon_NAME] + | otherwise = [] +\end{code} + + \begin{code} closeDecls :: [RenamedHsDecl] -- Declarations got so far -> NameSet -- Names bound by those declarations diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index fa90d3f..da4fed9 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -272,7 +272,6 @@ addImplicitOccRn name = addOccurrenceName Compulsory name addImplicitOccsRn :: [Name] -> RnM s d () addImplicitOccsRn names = addOccurrenceNames Compulsory names -intType_RDR = qual (modAndOcc (getName intTyCon)) listType_RDR = qual (modAndOcc listType_name) tupleType_RDR n = qual (modAndOcc (tupleType_name n)) diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 613b37b..73b1c44 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -41,7 +41,8 @@ import UniqSet ( emptyUniqSet, unitUniqSet, unionUniqSets, unionManyUniqSets, SYN_IE(UniqSet) ) -import Util ( Ord3(..), removeDups, panic ) +import PprStyle ( PprStyle(..) ) +import Util ( Ord3(..), removeDups, panic, pprPanic, assertPanic ) \end{code} @@ -79,8 +80,12 @@ rnPat (ConPatIn con pats) mapRn rnPat pats `thenRn` \ patslist -> returnRn (ConPatIn con' patslist) -rnPat (ConOpPatIn pat1 con pat2) - = rnOpPat pat1 con pat2 +rnPat (ConOpPatIn pat1 con _ pat2) + = rnPat pat1 `thenRn` \ pat1' -> + lookupRn con `thenRn` \ con' -> + lookupFixity con `thenRn` \ fixity -> + rnPat pat2 `thenRn` \ pat2' -> + mkConOpPatRn pat1' con' fixity pat2' -- Negated patters can only be literals, and they are dealt with -- by negating the literal at compile time, not by using the negation @@ -217,9 +222,28 @@ rnExpr (HsApp fun arg) rnExpr arg `thenRn` \ (arg',fvArg) -> returnRn (HsApp fun' arg', fvFun `unionNameSets` fvArg) -rnExpr (OpApp e1 (HsVar op) e2) = rnOpApp e1 op e2 +rnExpr (OpApp e1 op@(HsVar op_name) _ e2) + = rnExpr e1 `thenRn` \ (e1', fv_e1) -> + rnExpr e2 `thenRn` \ (e2', fv_e2) -> + rnExpr op `thenRn` \ (op', fv_op) -> -rnExpr (NegApp e n) = completeNegApp (rnExpr e) + -- Deal wth fixity + lookupFixity op_name `thenRn` \ fixity -> + getModeRn `thenRn` \ mode -> + (case mode of + SourceMode -> mkOpAppRn e1' op' fixity e2' + InterfaceMode -> returnRn (OpApp e1' op' fixity e2') + ) `thenRn` \ final_e -> + + returnRn (final_e, + fv_e1 `unionNameSets` fv_op `unionNameSets` fv_e2) + +rnExpr (NegApp e n) + = rnExpr e `thenRn` \ (e', fv_e) -> + lookupImplicitOccRn negate_RDR `thenRn` \ neg -> + getModeRn `thenRn` \ mode -> + mkNegAppRn mode e' (HsVar neg) `thenRn` \ final_e -> + returnRn (final_e, fv_e) rnExpr (HsPar e) = rnExpr e `thenRn` \ (e', fvs_e) -> @@ -467,85 +491,94 @@ rnStmt (LetStmt binds) thing_inside %* * %************************************************************************ -@rnOpApp@ deals with operator applications. It does some rearrangement of -the expression so that the precedences are right. This must be done on the -expression *before* renaming, because fixity info applies to the things -the programmer actually wrote. +@mkOpAppRn@ deals with operator fixities. The argument expressions +are assumed to be already correctly arranged. It needs the fixities +recorded in the OpApp nodes, because fixity info applies to the things +the programmer actually wrote, so you can't find it out from the Name. + +Furthermore, the second argument is guaranteed not to be another +operator application. Why? Because the parser parses all +operator appications left-associatively. \begin{code} -rnOpApp (NegApp e11 n) op e2 - = lookupFixity op `thenRn` \ (Fixity op_prec op_dir) -> - if op_prec > 6 then - -- negate precedence 6 wired in - -- (-x)*y ==> -(x*y) - completeNegApp (rnOpApp e11 op e2) - else - completeOpApp (completeNegApp (rnExpr e11)) op (rnExpr e2) - -rnOpApp (OpApp e11 (HsVar op1) e12) op e2 - = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) -> - lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) -> - -- pprTrace "rnOpApp:" (ppCat [ppr PprDebug op, ppInt op_prec, ppr PprDebug op1, ppInt op1_prec]) $ - case (op1_prec `cmp` op_prec) of - LT_ -> rearrange - EQ_ -> case (op1_dir, op_dir) of - (InfixR, InfixR) -> rearrange - (InfixL, InfixL) -> dont_rearrange - _ -> addErrRn (precParseErr (op1,op1_fix) (op,op_fix)) `thenRn_` - dont_rearrange - GT__ -> dont_rearrange +mkOpAppRn :: RenamedHsExpr -> RenamedHsExpr -> Fixity -> RenamedHsExpr + -> RnMS s RenamedHsExpr + +mkOpAppRn e1@(OpApp e11 op1 fix1 e12) + op2 fix2 e2 + | nofix_error + = addErrRn (precParseErr (get op1,fix1) (get op2,fix2)) `thenRn_` + returnRn (OpApp e1 op2 fix2 e2) + + | rearrange_me + = mkOpAppRn e12 op2 fix2 e2 `thenRn` \ new_e -> + returnRn (OpApp e11 op1 fix1 new_e) where - rearrange = rnOpApp e11 op1 (OpApp e12 (HsVar op) e2) - dont_rearrange = completeOpApp (rnOpApp e11 op1 e12) op (rnExpr e2) - -rnOpApp e1 op e2 = completeOpApp (rnExpr e1) op (rnExpr e2) + (nofix_error, rearrange_me) = compareFixity fix1 fix2 + get (HsVar n) = n + +mkOpAppRn e1@(NegApp neg_arg neg_id) + op2 + fix2@(Fixity prec2 dir2) + e2 + | prec2 > 6 -- Precedence of unary - is wired in as 6! + = mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e -> + returnRn (NegApp new_e neg_id) + +mkOpAppRn e1 op fix e2 -- Default case, no rearrangment + = ASSERT( right_op_ok fix e2 ) + returnRn (OpApp e1 op fix e2) + +-- Parser left-associates everything, but +-- derived instances may have correctly-associated things to +-- in the right operarand. So we just check that the right operand is OK +right_op_ok fix1 (OpApp _ _ fix2 _) + = not error_please && associate_right + where + (error_please, associate_right) = compareFixity fix1 fix2 +right_op_ok fix1 other + = True -completeOpApp rn_e1 op rn_e2 - = rn_e1 `thenRn` \ (e1', fvs1) -> - rn_e2 `thenRn` \ (e2', fvs2) -> - rnExpr (HsVar op) `thenRn` \ (op', fvs3) -> - returnRn (OpApp e1' op' e2', fvs1 `unionNameSets` fvs2 `unionNameSets` fvs3) +-- Parser initially makes negation bind more tightly than any other operator +mkNegAppRn mode neg_arg neg_id + = ASSERT( not_op_app mode neg_arg ) + returnRn (NegApp neg_arg neg_id) -completeNegApp rn_expr - = rn_expr `thenRn` \ (e', fvs_e) -> - lookupImplicitOccRn negate_RDR `thenRn` \ neg -> - returnRn (NegApp e' (HsVar neg), fvs_e) +not_op_app SourceMode (OpApp _ _ _ _) = False +not_op_app mode other = True \end{code} \begin{code} -rnOpPat p1@(NegPatIn p11) op p2 - = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) -> - if op_prec > 6 then - -- negate precedence 6 wired in - addErrRn (precParseNegPatErr (op,op_fix)) `thenRn_` - rnOpPat p11 op p2 `thenRn` \ op_pat -> - returnRn (NegPatIn op_pat) - else - completeOpPat (rnPat p1) op (rnPat p2) - -rnOpPat (ConOpPatIn p11 op1 p12) op p2 - = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) -> - lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) -> - case (op1_prec `cmp` op_prec) of - LT_ -> rearrange - EQ_ -> case (op1_dir, op_dir) of - (InfixR, InfixR) -> rearrange - (InfixL, InfixL) -> dont_rearrange - _ -> addErrRn (precParseErr (op1,op1_fix) (op,op_fix)) `thenRn_` - dont_rearrange - GT__ -> dont_rearrange - where - rearrange = rnOpPat p11 op1 (ConOpPatIn p12 op p2) - dont_rearrange = completeOpPat (rnOpPat p11 op1 p12) op (rnPat p2) +mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat + -> RnMS s RenamedPat +mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12) + op2 fix2 p2 + | nofix_error + = addErrRn (precParseErr (op1,fix1) (op2,fix2)) `thenRn_` + returnRn (ConOpPatIn p1 op2 fix2 p2) -rnOpPat p1 op p2 = completeOpPat (rnPat p1) op (rnPat p2) + | rearrange_me + = mkConOpPatRn p12 op2 fix2 p2 `thenRn` \ new_p -> + returnRn (ConOpPatIn p11 op1 fix1 new_p) -completeOpPat rn_p1 op rn_p2 - = rn_p1 `thenRn` \ p1' -> - rn_p2 `thenRn` \ p2' -> - lookupRn op `thenRn` \ op' -> - returnRn (ConOpPatIn p1' op' p2') + where + (nofix_error, rearrange_me) = compareFixity fix1 fix2 + +mkConOpPatRn p1@(NegPatIn neg_arg) + op2 + fix2@(Fixity prec2 dir2) + p2 + | prec2 > 6 -- Precedence of unary - is wired in as 6! + = addErrRn (precParseNegPatErr (op2,fix2)) `thenRn_` + returnRn (ConOpPatIn p1 op2 fix2 p2) + +mkConOpPatRn p1 op fix p2 -- Default case, no rearrangment + = ASSERT( not_op_pat p2 ) + returnRn (ConOpPatIn p1 op fix p2) + +not_op_pat (ConOpPatIn _ _ _ _) = False +not_op_pat other = True \end{code} \begin{code} @@ -559,7 +592,7 @@ checkPrecMatch True op (PatMatch p1 (PatMatch p2 (GRHSMatch _))) checkPrecMatch True op _ = panic "checkPrecMatch" -checkPrec op (ConOpPatIn _ op1 _) right +checkPrec op (ConOpPatIn _ op1 _ _) right = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) -> lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) -> let @@ -582,6 +615,30 @@ checkPrec op pat right = returnRn () \end{code} +Consider + a `op1` b `op2` c + +(compareFixity op1 op2) tells which way to arrange appication, or +whether there's an error. + +\begin{code} +compareFixity :: Fixity -> Fixity + -> (Bool, -- Error please + Bool) -- Associate to the right: a op1 (b op2 c) +compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2) + = case prec1 `cmp` prec2 of + GT_ -> left + LT_ -> right + EQ_ -> case (dir1, dir2) of + (InfixR, InfixR) -> right + (InfixL, InfixL) -> left + _ -> error_please + where + right = (False, True) + left = (False, False) + error_please = (True, False) +\end{code} + %************************************************************************ %* * \subsubsection{Literals} diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index b6f4521..8b804f2 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -22,6 +22,7 @@ module RnIfaces ( IMP_Ubiq() +-- import CmdLineOpts ( opt_HiSuffix ) import HsSyn ( HsDecl(..), TyDecl(..), ClassDecl(..), HsTyVar, Bind, HsExpr, Sig(..), HsBinds(..), MonoBinds, DefaultDecl, ConDecl(..), HsType, BangType, IfaceSig(..), FixityDecl(..), Fixity, Fake, InPat, InstDecl(..), SYN_IE(Version), HsIdInfo @@ -572,7 +573,7 @@ mkSearchPath (Just s) \begin{code} noIfaceErr mod sty - = ppBesides [ppStr "Could not find interface for ", ppQuote (pprModule sty mod)] + = ppBesides [ppStr "Could not find valid interface file for ", ppQuote (pprModule sty mod)] -- , ppStr " in"]) 4 (ppAboves (map ppStr dirs)) cannaeReadFile file err sty diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index a2cc06a..62f789d 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -145,7 +145,7 @@ emptyFixityEnv = emptyFM data ExportEnv = ExportEnv Avails Fixities type Avails = [AvailInfo] -type Fixities = [(OccName, Fixity, Provenance)] +type Fixities = [(OccName, (Fixity, Provenance))] -- Can contain duplicates, if one module defines the same fixity, -- or the same type/class/id, more than once. Hence a boring old list. -- This allows us to report duplicates in just one place, namely plusRnEnv. diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 51b8424..754dfd2 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -34,7 +34,7 @@ import Maybes ( maybeToBool, expectJust ) import Name import Pretty import PprStyle ( PprStyle(..) ) -import Util ( panic, pprTrace ) +import Util ( panic, pprTrace, assertPanic ) \end{code} @@ -111,18 +111,19 @@ getGlobalNames m@(HsModule this_mod _ exports imports _ _ mod_loc) \begin{code} checkEarlyExit mod - = if not opt_SourceUnchanged then - -- Source code changed; look no further + = checkErrsRn `thenRn` \ no_errs_so_far -> + if not no_errs_so_far then + -- Found errors already, so exit now + returnRn True + else + if not opt_SourceUnchanged then + -- Source code changed and no errors yet... carry on returnRn False else - -- Unchanged source; look further - -- We check for - -- (a) errors so far. These can arise if a module imports - -- something that's no longer exported by the imported module - -- (b) usage information up to date - checkErrsRn `thenRn` \ no_errs_so_far -> + -- Unchanged source, and no errors yet; see if usage info + -- up to date, and exit if so checkUpToDate mod `thenRn` \ up_to_date -> - returnRn (no_errs_so_far && up_to_date) + returnRn up_to_date \end{code} @@ -138,7 +139,7 @@ importsFromImportDecl (ImportDecl mod qual_only as_mod import_spec loc) filtered_avails' = [ Avail (set_name_prov n) (map set_name_prov ns) | Avail n ns <- filtered_avails ] - fixities' = [ (occ,fixity,provenance) | (occ,fixity) <- fixities ] + fixities' = [ (occ,(fixity,provenance)) | (occ,fixity) <- fixities ] in qualifyImports mod True -- Want qualified names @@ -293,7 +294,7 @@ qualifyImports this_mod qual_imp unqual_imp as_mod (ExportEnv avails fixities) both = unqual_only `thenRn` \ env' -> add_fn env' (Qual qual_mod occ) thing - add_fixity name_env fixity_env (occ_name, fixity, provenance) + add_fixity name_env fixity_env (occ_name, (fixity, provenance)) | maybeToBool (lookupFM name_env rdr_name) -- It's imported = add_to_env addOneToFixityEnvRn fixity_env occ_name (fixity,provenance) | otherwise -- It ain't imported @@ -320,10 +321,10 @@ unQualify fm = addListToFM fm [(Unqual occ, elt) | (Qual _ occ, elt) <- fmToList \begin{code} -fixityFromFixDecl :: RdrNameFixityDecl -> RnMG (OccName, Fixity, Provenance) +fixityFromFixDecl :: RdrNameFixityDecl -> RnMG (OccName, (Fixity, Provenance)) fixityFromFixDecl (FixityDecl rdr_name fixity loc) - = returnRn (rdrNameOcc rdr_name, fixity, LocalDef (panic "export-flag") loc) + = returnRn (rdrNameOcc rdr_name, (fixity, LocalDef (panic "export-flag") loc)) \end{code} @@ -426,12 +427,46 @@ exportsFromAvail this_mod (Just export_items) all_avails (RnEnv name_env fixity_ enough_avail = case export_avail of {NotAvailable -> False; other -> True} -- We export a fixity iff we export a thing with the same (qualified) RdrName - mk_exported_fixities :: NameSet -> [(OccName, Fixity, Provenance)] + mk_exported_fixities :: NameSet -> [(OccName, (Fixity, Provenance))] mk_exported_fixities exports - = [ (rdrNameOcc rdr_name, fixity, prov) - | (rdr_name, (fixity, prov)) <- fmToList fixity_env, - export_fixity name_env exports rdr_name - ] + = fmToList (foldr (perhaps_add_fixity exports) + emptyFM + (fmToList fixity_env)) + + perhaps_add_fixity :: NameSet -> (RdrName, (Fixity, Provenance)) + -> FiniteMap OccName (Fixity,Provenance) + -> FiniteMap OccName (Fixity,Provenance) + perhaps_add_fixity exports (rdr_name, (fixity, prov)) fix_env + = let + do_nothing = fix_env -- The default is to pass on the env unchanged + in + -- Step 1: check whether the rdr_name is in scope; if so find its Name + case lookupFM name_env rdr_name of { + Nothing -> do_nothing; + Just fixity_name -> + + -- Step 2: check whether the fixity thing is exported + if not (fixity_name `elemNameSet` exports) then + do_nothing + else + + -- Step 3: check whether we already have a fixity for the + -- Name's OccName in the fix_env we are building up. This can easily + -- happen. the original fixity_env might contain bindings for + -- M.a and N.a, if a was imported via M and N. + -- If this does happen, we expect the fixity to be the same either way. + let + occ_name = rdrNameOcc rdr_name + in + case lookupFM fix_env occ_name of { + Just (fixity1, prov1) -> -- Got it already + ASSERT( fixity == fixity1 ) + do_nothing; + Nothing -> + + -- Step 3: add it to the outgoing fix_env + addToFM fix_env occ_name (fixity,prov) + }} mk_export_fn :: [AvailInfo] -> (Name -> ExportFlag) mk_export_fn avails @@ -441,14 +476,6 @@ mk_export_fn avails where exported_names :: NameSet exported_names = availsToNameSet avails - -export_fixity :: NameEnv -> NameSet -> RdrName -> Bool -export_fixity name_env exports rdr_name - = case lookupFM name_env rdr_name of - Just fixity_name -> fixity_name `elemNameSet` exports - -- Check whether the exported thing is - -- the one to which the fixity attaches - other -> False -- Not even in scope \end{code} diff --git a/ghc/compiler/simplCore/SimplPgm.lhs b/ghc/compiler/simplCore/SimplPgm.lhs index fc95fff..506ec80 100644 --- a/ghc/compiler/simplCore/SimplPgm.lhs +++ b/ghc/compiler/simplCore/SimplPgm.lhs @@ -10,7 +10,7 @@ module SimplPgm ( simplifyPgm ) where IMP_Ubiq(){-uitous-} -import CmdLineOpts ( opt_D_verbose_core2core, +import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_simpl_iterations, switchIsOn, SimplifierSwitch(..) ) import CoreSyn @@ -68,10 +68,13 @@ simplifyPgm binds s_sw_chkr simpl_stats us simplCount `thenSmpl` \ r -> detailedSimplCount `thenSmpl` \ dr -> let - show_status = pprTrace "NewSimpl: " (ppAboves [ - ppBesides [ppInt iterations, ppChar '/', ppInt max_simpl_iterations], - ppStr (showSimplCount dr) --- DEBUG , ppAboves (map (pprCoreBinding PprDebug) new_pgm) + show_status = pprTrace "Simplifer run: " (ppAboves [ + ppBesides [ppStr "iteration ", ppInt iterations, ppStr " out of ", ppInt max_simpl_iterations], + ppStr (showSimplCount dr), + if opt_D_dump_simpl_iterations then + ppAboves (map (pprCoreBinding PprDebug) new_pgm) + else + ppNil ]) in @@ -81,10 +84,12 @@ simplifyPgm binds s_sw_chkr simpl_stats us else id) (let stop_now = r == n {-nothing happened-} - || (if iterations > max_simpl_iterations then + || (if iterations >= max_simpl_iterations then (if max_simpl_iterations > 1 {-otherwise too boring-} then trace - ("NOTE: Simplifier still going after "++show max_simpl_iterations++" iterations; bailing out.") + ("NOTE: Simplifier still going after " ++ + show max_simpl_iterations ++ + " iterations; baling out.") else id) True else diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index f76ed75..80ecd77 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -57,7 +57,7 @@ import Pretty ( ppHang, ppCat, ppStr, ppAboves, ppBesides, import PrimOp ( PrimOp(..) ) import SpecUtils import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, getAppDataTyConExpandingDicts, - tyVarsOfTypes, applyTypeEnvToTy, isUnboxedType + tyVarsOfTypes, applyTypeEnvToTy, isUnboxedType, isDictTy ) import TyCon ( TyCon{-instance Eq-} ) import TyVar ( cloneTyVar, mkSysTyVar, @@ -82,7 +82,6 @@ addIdSpecialisation = panic "Specialise.addIdSpecialisation (ToDo)" cmpUniTypeMaybeList = panic "Specialise.cmpUniTypeMaybeList (ToDo)" getIdSpecialisation = panic "Specialise.getIdSpecialisation (ToDo)" isClassOpId = panic "Specialise.isClassOpId (ToDo)" -isDictTy = panic "Specialise.isDictTy (ToDo)" isLocalGenTyCon = panic "Specialise.isLocalGenTyCon (ToDo)" isLocalSpecTyCon = panic "Specialise.isLocalSpecTyCon (ToDo)" isSpecId_maybe = panic "Specialise.isSpecId_maybe (ToDo)" diff --git a/ghc/compiler/typecheck/GenSpecEtc.lhs b/ghc/compiler/typecheck/GenSpecEtc.lhs index 08e8367..f231f89 100644 --- a/ghc/compiler/typecheck/GenSpecEtc.lhs +++ b/ghc/compiler/typecheck/GenSpecEtc.lhs @@ -158,7 +158,7 @@ genBinds binder_names mono_ids bind lie sig_infos prag_info_fn resolveOverloading tyvars_to_gen lie bind tysig_vars (head thetas) `thenTc` \ (lie', reduced_tyvars_to_gen, dict_binds, dicts_bound) -> - -- Check for generaliseation over unboxed types, and + -- Check for generalisation over unboxed types, and -- default any TypeKind TyVars to BoxedTypeKind let tyvars = tyVarSetToList reduced_tyvars_to_gen -- Commit to a particular order diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 74e5bfa..0c6d0c5 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -31,7 +31,7 @@ module Inst ( IMP_Ubiq() IMPORT_1_3(Ratio(Rational)) -import HsSyn ( HsLit(..), HsExpr(..), HsBinds, +import HsSyn ( HsLit(..), HsExpr(..), HsBinds, Fixity, InPat, OutPat, Stmt, Qualifier, Match, ArithSeqInfo, HsType, Fake ) import RnHsSyn ( SYN_IE(RenamedArithSeqInfo), SYN_IE(RenamedHsExpr) ) diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 3ce5967..ffafeb7 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -336,7 +336,7 @@ stuff. If we simplify only at the f-binding (not the xs-binding) we'll know that the literals are all Ints, and we can just produce Int literals! -Find all the type variables involved in overloading, the "constrained_tyvars" +Find all the type variables involved in overloading, the "constrained_tyvars". These are the ones we *aren't* going to generalise. We must be careful about doing this: (a) If we fail to generalise a tyvar which is not actually diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 48af28e..da8ea95 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -12,7 +12,7 @@ IMP_Ubiq() import HsSyn ( HsDecl(..), ClassDecl(..), HsBinds(..), Bind(..), MonoBinds(..), Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..), - DefaultDecl, TyDecl, InstDecl, IfaceSig, + DefaultDecl, TyDecl, InstDecl, IfaceSig, Fixity, HsLit(..), OutPat(..), Sig(..), HsType(..), HsTyVar, Stmt, Qualifier, ArithSeqInfo, InPat, Fake ) import HsTypes ( getTyVarName ) diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index a13c8aa..473ce91 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -15,6 +15,7 @@ module TcEnv( tcExtendGlobalValEnv, tcExtendLocalValEnv, tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey, tcLookupGlobalValue, tcLookupGlobalValueByKey, tcLookupGlobalValueMaybe, + tcLookupGlobalValueByKeyMaybe, newMonoIds, newLocalIds, newLocalId, tcGetGlobalTyVars, tcExtendGlobalTyVars @@ -275,6 +276,10 @@ tcLookupGlobalValueByKey uniq def = panic "tcLookupGlobalValueByKey" #endif +tcLookupGlobalValueByKeyMaybe :: Unique -> NF_TcM s (Maybe Id) +tcLookupGlobalValueByKeyMaybe uniq + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> + returnNF_Tc (lookupUFM_Directly gve uniq) \end{code} diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 70f8070..65738ee 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -6,15 +6,15 @@ \begin{code} #include "HsVersions.h" -module TcExpr ( tcExpr ) where +module TcExpr ( tcExpr, tcId ) where IMP_Ubiq() import HsSyn ( HsExpr(..), Qualifier(..), Stmt(..), HsBinds(..), Bind(..), MonoBinds(..), ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds, - Match, Fake, InPat, OutPat, HsType, - failureFreePat, collectPatBinders ) + Match, Fake, InPat, OutPat, HsType, Fixity, + pprParendExpr, failureFreePat, collectPatBinders ) import RnHsSyn ( SYN_IE(RenamedHsExpr), SYN_IE(RenamedQual), SYN_IE(RenamedStmt), SYN_IE(RenamedRecordBinds) ) @@ -187,9 +187,9 @@ tcExpr (HsApp e1 e2) = accum e1 [e2] returnTc (foldl HsApp fun' args', lie, res_ty) -- equivalent to (op e1) e2: -tcExpr (OpApp arg1 op arg2) +tcExpr (OpApp arg1 op fix arg2) = tcApp op [arg1,arg2] `thenTc` \ (op', [arg1', arg2'], lie, res_ty) -> - returnTc (OpApp arg1' op' arg2', lie, res_ty) + returnTc (OpApp arg1' op' fix arg2', lie, res_ty) \end{code} Note that the operators in sections are expected to be binary, and @@ -928,8 +928,9 @@ sectionLAppCtxt expr sty = ppHang (ppStr "In a left section:") 4 (ppr sty expr) funAppCtxt fun arg_no arg sty - = ppHang (ppCat [ ppStr "In the", speakNth arg_no, ppStr "argument of", ppr sty fun]) - 4 (ppCat [ppStr "namely", ppr sty arg]) + = ppHang (ppCat [ ppStr "In the", speakNth arg_no, ppStr "argument of", + ppr sty fun `ppBeside` ppStr ", namely"]) + 4 (pprParendExpr sty arg) qualCtxt qual sty = ppHang (ppStr "In a list-comprehension qualifer:") diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index d6c7513..856ad7c 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -32,8 +32,8 @@ IMPORT_1_3(List(partition)) import HsSyn ( HsBinds(..), Bind(..), MonoBinds(..), Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..), HsLit(..), InPat(..), Qualifier(..), Stmt, - ArithSeqInfo, Sig, HsType, FixityDecl, Fake ) -import RdrHsSyn ( RdrName(..), varQual, varUnqual, + ArithSeqInfo, Sig, HsType, FixityDecl, Fixity, Fake ) +import RdrHsSyn ( RdrName(..), varQual, varUnqual, mkOpApp, SYN_IE(RdrNameMonoBinds), SYN_IE(RdrNameHsExpr), SYN_IE(RdrNamePat) ) -- import RnHsSyn ( RenamedFixityDecl(..) ) @@ -175,7 +175,7 @@ gen_Eq_binds tycon where nested_eq_expr [] [] [] = true_Expr nested_eq_expr tys as bs - = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs) + = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs) where nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b)) \end{code} @@ -553,7 +553,7 @@ gen_Ix_binds tycon grhs = [OtherwiseGRHS (mk_easy_App mkInt_RDR [c_RDR]) tycon_loc] in HsCase - (HsPar (OpApp (HsVar dh_RDR) (HsVar minusH_RDR) (HsVar ah_RDR))) + (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR)) [PatMatch (VarPatIn c_RDR) (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))] tycon_loc @@ -568,8 +568,8 @@ gen_Ix_binds tycon untag_Expr tycon [(a_RDR, ah_RDR)] ( untag_Expr tycon [(b_RDR, bh_RDR)] ( untag_Expr tycon [(c_RDR, ch_RDR)] ( - HsIf (HsPar (OpApp (HsVar ch_RDR) (HsVar geH_RDR) (HsVar ah_RDR))) ( - (OpApp (HsVar ch_RDR) (HsVar leH_RDR) (HsVar bh_RDR)) + HsIf (genOpApp (HsVar ch_RDR) geH_RDR (HsVar ah_RDR)) ( + (genOpApp (HsVar ch_RDR) leH_RDR (HsVar bh_RDR)) ) {-else-} ( false_Expr ) tycon_loc)))) @@ -610,19 +610,19 @@ gen_Ix_binds tycon foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed)) where mk_index multiply_by (l, u, i) - =OpApp ( + = genOpApp ( (HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [HsVar l, HsVar u])) (HsVar i)) - ) (HsVar plus_RDR) ( - OpApp ( + ) plus_RDR ( + genOpApp ( (HsApp (HsVar rangeSize_RDR) (ExplicitTuple [HsVar l, HsVar u])) - ) (HsVar times_RDR) multiply_by + ) times_RDR multiply_by ) range_size = mk_easy_FunMonoBind tycon_loc rangeSize_RDR [TuplePatIn [a_Pat, b_Pat]] [] ( - OpApp ( + genOpApp ( (HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [a_Expr, b_Expr])) b_Expr) - ) (HsVar plus_RDR) (HsLit (HsInt 1))) + ) plus_RDR (HsLit (HsInt 1))) ------------------ single_con_inRange @@ -659,7 +659,7 @@ gen_Read_binds tycon = map read_con (tyConDataCons tycon) in mk_easy_FunMonoBind tycon_loc readsPrec_RDR [a_Pat, b_Pat] [] ( - foldl1 append_Expr read_con_comprehensions + foldr1 append_Expr read_con_comprehensions ) where read_con data_con -- note: "b" is the string being "read" @@ -683,7 +683,7 @@ gen_Read_binds tycon = if nullary_con then -- must be False (parens are surely optional) false_Expr else -- parens depend on precedence... - HsPar (OpApp a_Expr (HsVar gt_RDR) (HsLit (HsInt 9))) + HsPar (genOpApp a_Expr gt_RDR (HsLit (HsInt 9))) in HsApp ( readParen_Expr read_paren_arg $ HsPar $ @@ -747,7 +747,7 @@ gen_Show_binds tycon ([a_Pat, con_pat], show_con) else ([a_Pat, con_pat], - showParen_Expr (HsPar (OpApp a_Expr (HsVar ge_RDR) (HsLit (HsInt 10)))) + showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt 10)))) (HsPar (nested_compose_Expr show_thingies))) where spacified [] = [] @@ -912,9 +912,9 @@ careful_compare_Case ty lt eq gt a b compare_gen_Case compare_RDR lt eq gt a b else -- we have to do something special for primitive things... - HsIf (HsPar (OpApp a (HsVar relevant_eq_op) b)) + HsIf (genOpApp a relevant_eq_op b) eq - (HsIf (HsPar (OpApp a (HsVar relevant_lt_op) b)) lt gt mkGeneratedSrcLoc) + (HsIf (genOpApp a relevant_lt_op b) lt gt mkGeneratedSrcLoc) mkGeneratedSrcLoc where relevant_eq_op = assoc_ty_id eq_op_tbl ty @@ -948,17 +948,17 @@ lt_op_tbl = and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr -and_Expr a b = OpApp a (HsVar and_RDR) b -append_Expr a b = OpApp a (HsVar append_RDR) b +and_Expr a b = genOpApp a and_RDR b +append_Expr a b = genOpApp a append_RDR b ----------------------------------------------------------------------- eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr eq_Expr ty a b = if not (isPrimType ty) then - OpApp a (HsVar eq_RDR) b + genOpApp a eq_RDR b else -- we have to do something special for primitive things... - OpApp a (HsVar relevant_eq_op) b + genOpApp a relevant_eq_op b where relevant_eq_op = assoc_ty_id eq_op_tbl ty \end{code} @@ -981,7 +981,7 @@ cmp_tags_Expr :: RdrName -- Comparison op -> RdrNameHsExpr cmp_tags_Expr op a b true_case false_case - = HsIf (HsPar (OpApp (HsVar a) (HsVar op) (HsVar b))) true_case false_case mkGeneratedSrcLoc + = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case mkGeneratedSrcLoc enum_from_to_Expr :: RdrNameHsExpr -> RdrNameHsExpr @@ -1008,6 +1008,13 @@ nested_compose_Expr (e:es) parenify e@(HsVar _) = e parenify e = HsPar e + +-- genOpApp wraps brackets round the operator application, so that the +-- renamer won't subsequently try to re-associate it. +-- For some reason the renamer doesn't reassociate it right, and I can't +-- be bothered to find out why just now. + +genOpApp e1 op e2 = mkOpApp e1 op e2 \end{code} \begin{code} @@ -1050,26 +1057,4 @@ 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("#") - in - varQual (mod, con2tag) - -tag2con_RDR tycon - = let (mod, nm) = modAndOcc tycon - tag2con = SLIT("tag2con_") _APPEND_ occNameString nm _APPEND_ SLIT("#") - in - varQual (mod, tag2con) - -maxtag_RDR tycon - = let (mod, nm) = modAndOcc 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 6768120..a1662a0 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -373,11 +373,11 @@ zonkExpr te ve (HsApp e1 e2) zonkExpr te ve e2 `thenNF_Tc` \ new_e2 -> returnNF_Tc (HsApp new_e1 new_e2) -zonkExpr te ve (OpApp e1 op e2) +zonkExpr te ve (OpApp e1 op fixity e2) = zonkExpr te ve e1 `thenNF_Tc` \ new_e1 -> zonkExpr te ve op `thenNF_Tc` \ new_op -> zonkExpr te ve e2 `thenNF_Tc` \ new_e2 -> - returnNF_Tc (OpApp new_e1 new_op new_e2) + returnNF_Tc (OpApp new_e1 new_op fixity new_e2) zonkExpr te ve (NegApp _ _) = panic "zonkExpr te ve:NegApp" zonkExpr te ve (HsPar _) = panic "zonkExpr te ve:HsPar" diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 102af84..47b3e77 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -11,7 +11,7 @@ module TcIfaceSig ( tcInterfaceSigs ) where IMP_Ubiq() import TcMonad -import TcMonoType ( tcHsType ) +import TcMonoType ( tcHsType, tcHsTypeKind ) import TcEnv ( tcLookupGlobalValue, tcExtendTyVarEnv, tcExtendGlobalValEnv, tcLookupTyConByKey, tcLookupGlobalValueMaybe, tcLookupLocalValue ) @@ -218,7 +218,7 @@ tcCoreExpr (UfSCC cc expr) tcCoreExpr(UfCoerce coercion ty body) = tcCoercion coercion `thenTc` \ coercion' -> - tcHsType ty `thenTc` \ ty' -> + tcHsTypeKind ty `thenTc` \ (_,ty') -> tcCoreExpr body `thenTc` \ body' -> returnTc (Coerce coercion' ty' body') @@ -284,7 +284,7 @@ tcCoreValBndrs bndrs thing_inside -- Expect them all to be ValBinders \begin{code} tcCoreArg (UfVarArg v) = tcVar v `thenTc` \ v' -> returnTc (VarArg v') -tcCoreArg (UfTyArg ty) = tcHsType ty `thenTc` \ ty' -> returnTc (TyArg ty') +tcCoreArg (UfTyArg ty) = tcHsTypeKind ty `thenTc` \ (_,ty') -> returnTc (TyArg ty') tcCoreArg (UfLitArg lit) = returnTc (LitArg lit) tcCoreArg (UfUsageArg u) = error "tcCoreArg: usage" diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 63b280d..c129ae5 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -20,7 +20,7 @@ import HsSyn ( HsDecl(..), InstDecl(..), TyDecl, ClassDecl, DefaultDecl, SpecInstSig(..), HsBinds(..), Bind(..), MonoBinds(..), GRHSsAndBinds, Match, InPat(..), OutPat(..), HsExpr(..), HsLit(..), - Stmt, Qualifier, ArithSeqInfo, Fake, + Stmt, Qualifier, ArithSeqInfo, Fake, Fixity, HsType(..), HsTyVar ) import RnHsSyn ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedMonoBinds), SYN_IE(RenamedInstDecl), SYN_IE(RenamedFixityDecl), diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 09140f1..a5c3197 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -31,15 +31,19 @@ import TcBinds ( tcBindsAndThen ) import TcClassDcl ( tcClassDecls2 ) import TcDefaults ( tcDefaults ) import TcEnv ( tcExtendGlobalValEnv, getEnv_LocalIds, - getEnv_TyCons, getEnv_Classes, - tcLookupLocalValueByKey, tcLookupTyConByKey ) + getEnv_TyCons, getEnv_Classes, tcLookupLocalValue, + tcLookupLocalValueByKey, tcLookupTyCon, + tcLookupGlobalValueByKeyMaybe ) import SpecEnv ( SpecEnv ) +import TcExpr ( tcId ) import TcIfaceSig ( tcInterfaceSigs ) import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) import TcInstUtil ( buildInstanceEnvs, InstInfo ) import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls1 ) import TcTyDecls ( mkDataBinds ) +import TcType ( SYN_IE(TcType), tcInstType ) +import TcKind ( TcKind ) import RnMonad ( RnNameSupply(..) ) import Bag ( listToBag ) @@ -47,17 +51,21 @@ import Class ( GenClass, classSelIds ) import ErrUtils ( SYN_IE(Warning), SYN_IE(Error) ) import Id ( idType, GenId, SYN_IE(IdEnv), nullIdEnv ) import Maybes ( catMaybes ) -import Name ( isLocallyDefined ) +import Name ( Name, isLocallyDefined, pprModule ) import Pretty -import TyCon ( TyCon ) -import Type ( applyTyCon ) -import TysWiredIn ( unitTy, mkPrimIoTy ) -import TyVar ( SYN_IE(TyVarEnv), nullTyVarEnv ) +import TyCon ( TyCon, isSynTyCon ) +import Type ( applyTyCon, mkSynTy ) +import PprType ( GenType, GenTyVar ) +import TysWiredIn ( unitTy ) +import PrelMods ( gHC_MAIN, mAIN ) +import PrelInfo ( main_NAME, mainPrimIO_NAME, ioTyCon_NAME, primIoTyCon_NAME ) +import TyVar ( GenTyVar, SYN_IE(TyVarEnv), nullTyVarEnv ) import Unify ( unifyTauTy ) import UniqFM ( lookupUFM_Directly, lookupWithDefaultUFM_Directly, filterUFM, eltsUFM ) -import Unique ( iOTyConKey ) +import Unique ( Unique ) import Util +import Bag ( Bag, isEmptyBag ) import FiniteMap ( emptyFM, FiniteMap ) tycon_specs = emptyFM @@ -200,6 +208,7 @@ tcModule rn_name_supply -- trace "tc8" $ tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) -> tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_binds) -> + tcCheckMainSig mod_name `thenTc_` tcGetEnv `thenNF_Tc` \ env -> returnTc ( (EmptyBinds, (inst_binds, cls_binds, env)), lie_instdecls `plusLIE` lie_clasdecls, @@ -216,6 +225,7 @@ tcModule rn_name_supply -- trace "tc9" $ tcSimplifyTop lie_alldecls `thenTc` \ const_insts -> + -- Backsubstitution. Monomorphic top-level decls may have -- been instantiated by subsequent decls, and the final -- simplification step may have instantiated some @@ -254,3 +264,56 @@ tcModule rn_name_supply get_val_decls decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls] \end{code} + + +\begin{code} +tcCheckMainSig mod_name + | not is_main && not is_ghc_main + = returnTc () -- A non-main module + + | otherwise + = -- Check that main is defined + tcLookupTyCon tycon_name `thenTc` \ (_,_,tycon) -> + tcLookupLocalValue main_name `thenNF_Tc` \ maybe_main_id -> + case maybe_main_id of { + Nothing -> failTc (noMainErr mod_name main_name); + Just main_id -> + + -- Check that it has the right type (or a more general one) + let + expected_ty | isSynTyCon tycon = mkSynTy tycon [unitTy] + | otherwise = applyTyCon tycon [unitTy] + -- This is bizarre. There ought to be a suitable function in Type.lhs! + in + tcInstType [] expected_ty `thenNF_Tc` \ expected_tau -> + tcId main_name `thenNF_Tc` \ (_, lie, main_tau) -> + tcSetErrCtxt (mainTyCheckCtxt main_name) $ + unifyTauTy expected_tau + main_tau `thenTc_` + checkTc (isEmptyBag lie) (mainTyMisMatch main_name expected_ty (idType main_id)) + } + where + is_main = mod_name == mAIN + is_ghc_main = mod_name == gHC_MAIN + + main_name | is_main = main_NAME + | otherwise = mainPrimIO_NAME + + tycon_name | is_main = ioTyCon_NAME + | otherwise = primIoTyCon_NAME + +mainTyCheckCtxt main_name sty + = ppCat [ppStr "When checking that", ppr sty main_name, ppStr "has the required type"] + +noMainErr mod_name main_name sty + = ppCat [ppStr "Module", pprModule sty mod_name, + ppStr "must include a definition for", ppr sty main_name] + +mainTyMisMatch :: Name -> Type -> TcType s -> Error +mainTyMisMatch main_name expected actual sty + = ppHang (ppCat [ppr sty main_name, ppStr "has the wrong type"]) + 4 (ppAboves [ + ppCat [ppStr "Expected:", ppr sty expected], + ppCat [ppStr "Inferred:", ppr sty actual] + ]) +\end{code} diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 1a5f055..db3060e 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -11,7 +11,7 @@ module TcPat ( tcPat ) where IMP_Ubiq(){-uitous-} import HsSyn ( InPat(..), OutPat(..), HsExpr(..), HsLit(..), - Match, HsBinds, Qualifier, HsType, + Match, HsBinds, Qualifier, HsType, Fixity, ArithSeqInfo, Stmt, Fake ) import RnHsSyn ( SYN_IE(RenamedPat) ) import TcHsSyn ( SYN_IE(TcPat), TcIdOcc(..) ) @@ -174,7 +174,7 @@ tcPat pat_in@(ConPatIn name pats) lie, data_ty) -tcPat pat_in@(ConOpPatIn pat1 op pat2) -- in binary-op form... +tcPat pat_in@(ConOpPatIn pat1 op _ pat2) -- in binary-op form... = tcPat pat1 `thenTc` \ (pat1', lie1, ty1) -> tcPat pat2 `thenTc` \ (pat2', lie2, ty2) -> diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 93f04cd..a589499 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -15,7 +15,7 @@ module TcSimplify ( IMP_Ubiq() import HsSyn ( MonoBinds(..), HsExpr(..), InPat, OutPat, HsLit, - Match, HsBinds, Qualifier, HsType, ArithSeqInfo, + Match, HsBinds, Qualifier, HsType, ArithSeqInfo, Fixity, GRHSsAndBinds, Stmt, Fake ) import TcHsSyn ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcExpr), SYN_IE(TcMonoBinds) ) diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 960e2e5..00f1611 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -17,7 +17,7 @@ IMP_Ubiq(){-uitous-} import HsSyn ( TyDecl(..), ConDecl(..), BangType(..), HsExpr(..), Match(..), GRHSsAndBinds(..), GRHS(..), OutPat(..), HsBinds(..), HsLit, Stmt, Qualifier, ArithSeqInfo, - HsType, Fake, InPat, HsTyVar, + HsType, Fake, InPat, HsTyVar, Fixity, Bind(..), MonoBinds(..), Sig ) import HsTypes ( getTyVarName ) diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index aef3208..a0adc7d 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -291,7 +291,8 @@ We print type-variable binders with their kinds in interface files. \begin{code} pprTyVarBndr sty@PprInterface tyvar@(TyVar uniq kind name usage) | not (isBoxedTypeKind kind) - = ppBesides [pprGenTyVar sty tyvar, ppStr "::", pprParendKind kind] + = ppBesides [pprGenTyVar sty tyvar, ppStr " :: ", pprParendKind kind] + -- See comments with ppDcolon in PprCore.lhs pprTyVarBndr sty tyvar = pprGenTyVar sty tyvar \end{code} diff --git a/ghc/driver/ghc-iface.lprl b/ghc/driver/ghc-iface.lprl index 7c6d016..4fa4b8a 100644 --- a/ghc/driver/ghc-iface.lprl +++ b/ghc/driver/ghc-iface.lprl @@ -22,14 +22,15 @@ sub postprocessHiFile { $going_interactive) = @_; local($new_hi) = "$Tmp_prefix.hi-new"; + local($show_hi_diffs) = $HiDiff_flag && ! $HiOnStdout && ! $going_interactive && -f $hifile_target; # print STDERR "*** New hi file follows...\n"; # print STDERR `$Cat $hsc_hi`; - &constructNewHiFile($hsc_hi, $hifile_target, $new_hi); + &constructNewHiFile($hsc_hi, $hifile_target, $new_hi, $show_hi_diffs); # run diff if they asked for it - if ($HiDiff_flag && ! $HiOnStdout && ! $going_interactive && -f $hifile_target) { + if ($show_hi_diffs) { if ( $HiDiff_flag eq 'usages' ) { # lots of near-useless info; but if you want it... &run_something("$Cmp -s $hifile_target $new_hi || $Diff $hifile_target $new_hi 1>&2 || exit 0", @@ -90,7 +91,8 @@ sub deUsagifyHi { sub constructNewHiFile { local($hsc_hi, # The iface info produced by hsc. $hifile_target, # Pre-existing .hi filename (if it exists) - $new_hi) = @_; # Filename for new one + $new_hi, # Filename for new one + $show_hi_diffs) = @_; &readHiFile('old',$hifile_target) unless $HiHasBeenRead{'old'} == 1; &readHiFile('new',$hsc_hi) unless $HiHasBeenRead{'new'} == 1; @@ -128,7 +130,7 @@ sub constructNewHiFile { print NEWHI "_declarations_\n"; foreach $v (@decl_names) { - &printNewItemVersion(NEWHI, $v, $new_module_version); # Print new version number + &printNewItemVersion(NEWHI, $v, $new_module_version, $show_hi_diffs); # Print new version number print NEWHI $Decl{"new:$v"}; # Print the new decl itself } @@ -287,24 +289,24 @@ sub mv_change { } sub printNewItemVersion { - local($hifile, $item, $mod_version) = @_; + local($hifile, $item, $mod_version, $show_hi_diffs) = @_; local($idecl) = $Decl{"new:$item"}; if (! defined($Decl{"old:$item"})) { # Old decl doesn't exist - print STDERR "new: $item\n"; + if ($show_hi_diffs) {print STDERR "new: $item\n";} print $hifile "$mod_version "; # Use module version } elsif ($idecl ne $Decl{"old:$item"}) { # Old decl differs from new decl local($odecl) = $Decl{"old:$item"}; -# print STDERR "changed: $item\nOld: $odecl\nNew: $idecl\n"; + if ($show_hi_diffs) {print STDERR "changed: $item\nOld: $odecl\nNew: $idecl\n";} print $hifile "$mod_version "; # Use module version } elsif (! defined($OldVersion{"$item"}) ) { - print STDERR "$item: no old version?!\n"; + if ($show_hi_diffs) {print STDERR "$item: no old version?!\n";} print $hifile "$mod_version "; # Use module version } else { # Identical decls, so use old version number - print STDERR "$item: unchanged\n"; + if ($show_hi_diffs) {print STDERR "$item: unchanged\n";} print $hifile $OldVersion{"$item"}, " "; } return; diff --git a/ghc/driver/ghc.lprl b/ghc/driver/ghc.lprl index 71124c0..628233d 100644 --- a/ghc/driver/ghc.lprl +++ b/ghc/driver/ghc.lprl @@ -207,7 +207,7 @@ which are filled in later, using these. These are the default values, which may be changed by user flags. \begin{code} $Oopt_UnfoldingUseThreshold = '-funfolding-use-threshold8'; -$Oopt_MaxSimplifierIterations = '-fmax-simplifier-iterations4'; +$Oopt_MaxSimplifierIterations = '-fmax-simplifier-iterations5'; $Oopt_PedanticBottoms = '-fpedantic-bottoms'; # ON by default $Oopt_MonadEtaExpansion = ''; $Oopt_FinalStgProfilingMassage = ''; @@ -2170,7 +2170,7 @@ sub runHscAndProcessInterfaces { $i_atime,$i_mtime,$i_ctime,$i_blksize,$i_blocks) = stat($ifile); if ( ! -f $ofile_target ) { - print STDERR "$Pgm:compile:Output file $ofile_target doesn't exist\n"; +# print STDERR "$Pgm:compile:Output file $ofile_target doesn't exist\n"; $source_unchanged = 0; } @@ -2178,7 +2178,7 @@ sub runHscAndProcessInterfaces { $o_atime,$o_mtime,$o_ctime,$o_blksize,$o_blocks) = stat(_); # stat info from -f test if ( ! -f $hifile_target ) { - print STDERR "$Pgm:compile:Interface file $hifile_target doesn't exist\n"; +# print STDERR "$Pgm:compile:Interface file $hifile_target doesn't exist\n"; $source_unchanged = 0; } @@ -2186,7 +2186,7 @@ sub runHscAndProcessInterfaces { $hi_atime,$hi_mtime,$hi_ctime,$hi_blksize,$hi_blocks) = stat(_); # stat info from -f test if ($i_mtime > $o_mtime) { - print STDERR "$Pgm:recompile:Input file $ifile newer than $ofile_target\n"; +# print STDERR "$Pgm:recompile:Input file $ifile newer than $ofile_target\n"; $source_unchanged = 0; } diff --git a/ghc/lib/MODULES b/ghc/lib/MODULES index fab3e1d..24d4a5d 100644 --- a/ghc/lib/MODULES +++ b/ghc/lib/MODULES @@ -1,26 +1,2 @@ # Modules that the user is allowed to mention. # 'mkdependHS' consults this list. -Array -Channel -ChannelVar -Char -Complex -Concurrent -Directory -GHCbase -GHCio -GHCmain -GHCps -IO -Ix -List -Maybe -Merge -Monad -Parallel -Prelude -PreludeGlaST -Ratio -SampleVar -Semaphore -System diff --git a/ghc/lib/Makefile.libHS b/ghc/lib/Makefile.libHS index d112d45..55e3561 100644 --- a/ghc/lib/Makefile.libHS +++ b/ghc/lib/Makefile.libHS @@ -1,5 +1,5 @@ #----------------------------------------------------------------------------- -# $Id: Makefile.libHS,v 1.6 1997/01/07 13:20:35 simonm Exp $ +# $Id: Makefile.libHS,v 1.7 1997/01/18 10:04:27 simonpj Exp $ TOP = ../.. include $(TOP)/ghc/mk/ghc.mk @@ -42,12 +42,12 @@ ifneq ($(GhcWithHscBuiltViaC),YES) $(LIB_GHC) $($*_flags) $*.lhs %.$(suffix)_o : %.lhs - $(LIB_GHC) $(GHC_OPTS_$(suffix)) $($*_flags) $*.hs + $(LIB_GHC) $(GHC_OPTS_$(suffix)) $($*_flags) $*.lhs else # $(GhcWithHscBuiltViaC) == YES %.$(suffix)_o : %.hc - $(LIB_GHC) $(GHC_OPTS_$(suffix)) $($*_flags) $*.hs + $(LIB_GHC) $(GHC_OPTS_$(suffix)) $($*_flags) $*.hc endif #----------------------------------------------------------------------------- @@ -59,8 +59,12 @@ else ARCHIVE = libHS_$(suffix).a endif -SRCS = $(wildcard prelude/*.hs required/*.hs concurrent/*.hs) -LIBOBJS = $(SRCS:.hs=.$(suffix)_o) +SRCS = $(wildcard ghc/*.lhs glaExts/*.lhs required/*.lhs concurrent/*.lhs) +ifeq ($(suffix), norm) +LIBOBJS = $(SRCS:.lhs=.o) +else +LIBOBJS = $(SRCS:.lhs=.$(suffix)_o) +endif DESTDIR = $(INSTLIBDIR_GHC) include $(TOP)/mk/lib.mk @@ -75,6 +79,10 @@ ghc/PackedString_flags = '-\#include"cbits/stgio.h"' -monly-3-regs required/Directory_flags = '-\#include"cbits/stgio.h"' -monly-3-regs required/System_flags = '-\#include"cbits/stgio.h"' +concurrent/Merge_flags = -iconcurrent +concurrent/Parallel_flags = -fglasgow-exts +concurrent/Concurrent_flags = -iconcurrent + ghc/ArrBase_flags = '-fno-implicit-prelude' ghc/IOBase_flags = '-fno-implicit-prelude' ghc/IOHandle_flags = '-fno-implicit-prelude' @@ -96,9 +104,6 @@ required/Maybe_flags = '-fno-implicit-prelude' required/Monad_flags = '-fno-implicit-prelude' required/Ratio_flags = '-fno-implicit-prelude' -concurrent/Merge_flags = -iconcurrent -concurrent/Parallel_flags = -fglasgow-exts -concurrent/Concurrent_flags = -iconcurrent #----------------------------------------------------------------------------- # Depend and install stuff @@ -111,13 +116,19 @@ MKDEPENDHS_OPTS += $(foreach way,$(WAY_SUFFIXES),-s .$(way)) depend :: $(SRCS) $(MKDEPENDHS) $(MKDEPENDHSFLAGS) -- $(GHCFLAGS) -- -f .depend $(SRCS) +# Copy the crucial IOBase hi file over +hiboot :: + cp ghc/IOBase.hi-boot ghc/IOBase.hi + cp ghc/Main.hi-boot ghc/Main.hi + cp ghc/GHC.hi-boot ghc/GHC.hi + #----------------------------------------------------------------------------- # install hi files ifeq ($(suffix),norm) -HI_FILES = $(SRCS:.hs=.hi) +HI_FILES = $(SRCS:.lhs=.hi) else -HI_FILES = $(SRCS:.hs=.$(suffix)_hi) +HI_FILES = $(SRCS:.lhs=.$(suffix)_hi) endif install :: $(HI_FILES) diff --git a/ghc/lib/concurrent/Channel.lhs b/ghc/lib/concurrent/Channel.lhs index 2a947bb..2d0c935 100644 --- a/ghc/lib/concurrent/Channel.lhs +++ b/ghc/lib/concurrent/Channel.lhs @@ -26,6 +26,7 @@ module Channel ) where +import Prelude import IOBase ( IO(..) ) -- Suspicious! import ConcBase import STBase diff --git a/ghc/lib/concurrent/ChannelVar.lhs b/ghc/lib/concurrent/ChannelVar.lhs index cf3b5c9..ee21c87 100644 --- a/ghc/lib/concurrent/ChannelVar.lhs +++ b/ghc/lib/concurrent/ChannelVar.lhs @@ -18,6 +18,7 @@ module ChannelVar ) where +import Prelude import ConcBase \end{code} diff --git a/ghc/lib/ghc/ConcBase.lhs b/ghc/lib/ghc/ConcBase.lhs index 9969dbc..3a53271 100644 --- a/ghc/lib/ghc/ConcBase.lhs +++ b/ghc/lib/ghc/ConcBase.lhs @@ -19,6 +19,7 @@ module ConcBase( MVar, newMVar, newEmptyMVar, takeMVar, putMVar, readMVar, swapMVar ) where +import Prelude import STBase ( PrimIO(..), ST(..), State(..), StateAndPtr#(..) ) import IOBase ( IO(..) ) import GHCerr ( parError ) diff --git a/ghc/lib/ghc/GHC.hi b/ghc/lib/ghc/GHC.hi-boot similarity index 100% rename from ghc/lib/ghc/GHC.hi rename to ghc/lib/ghc/GHC.hi-boot diff --git a/ghc/lib/ghc/GHCerr.lhs b/ghc/lib/ghc/GHCerr.lhs index bad9723..c0d508d 100644 --- a/ghc/lib/ghc/GHCerr.lhs +++ b/ghc/lib/ghc/GHCerr.lhs @@ -14,6 +14,7 @@ with what the typechecker figures out. \begin{code} module GHCerr where +import Prelude import IOBase --------------------------------------------------------------- diff --git a/ghc/lib/ghc/GHCmain.lhs b/ghc/lib/ghc/GHCmain.lhs index 88de160..3926ba9 100644 --- a/ghc/lib/ghc/GHCmain.lhs +++ b/ghc/lib/ghc/GHCmain.lhs @@ -5,6 +5,7 @@ This is the mainPrimIO that must be used for Haskell~1.3. \begin{code} module GHCmain( mainPrimIO ) where +import Prelude import qualified Main -- for type of "Main.main" import IOBase import STBase diff --git a/ghc/lib/ghc/IOBase.hi-boot b/ghc/lib/ghc/IOBase.hi-boot new file mode 100644 index 0000000..002fe54 --- /dev/null +++ b/ghc/lib/ghc/IOBase.hi-boot @@ -0,0 +1,12 @@ +--------------------------------------------------------------------------- +-- IOBase.hi-boot +-- +-- This hand-written interface file is the initial bootstrap version +-- for IOBase.hi. +-- It doesn't need to give "error" a type signature, +-- because it's wired into the compiler +--------------------------------------------------------------------------- + +_interface_ IOBase 1 +_exports_ +IOBase error; diff --git a/ghc/lib/ghc/Main.hi b/ghc/lib/ghc/Main.hi-boot similarity index 92% rename from ghc/lib/ghc/Main.hi rename to ghc/lib/ghc/Main.hi-boot index ff65f04..0358a0d 100644 --- a/ghc/lib/ghc/Main.hi +++ b/ghc/lib/ghc/Main.hi-boot @@ -10,4 +10,4 @@ _interface_ Main 1 _exports_ Main main ; _declarations_ -1 main :: IOBase.IO PrelBase.(); +1 main :: IOBase.IO PrelBase.();; diff --git a/ghc/lib/ghc/PrelBase.lhs b/ghc/lib/ghc/PrelBase.lhs index 601500a..e83a391 100644 --- a/ghc/lib/ghc/PrelBase.lhs +++ b/ghc/lib/ghc/PrelBase.lhs @@ -13,7 +13,7 @@ import {-# SOURCE #-} IOBase ( error ) import GHC infixr 9 ., !! -infixl 7 *, / +infixl 7 * infixl 6 +, - infixr 5 ++, : infix 4 ==, /=, <, <=, >=, > diff --git a/ghc/lib/ghc/PrelNum.lhs b/ghc/lib/ghc/PrelNum.lhs index bf16dc0..940a57b 100644 --- a/ghc/lib/ghc/PrelNum.lhs +++ b/ghc/lib/ghc/PrelNum.lhs @@ -24,7 +24,7 @@ import PrelBase import GHC infixr 8 ^, ^^, ** -infixl 7 %, `quot`, `rem`, `div`, `mod` +infixl 7 /, %, `quot`, `rem`, `div`, `mod` \end{code} diff --git a/ghc/lib/required/Complex.lhs b/ghc/lib/required/Complex.lhs index fe66d2d..69e753e 100644 --- a/ghc/lib/required/Complex.lhs +++ b/ghc/lib/required/Complex.lhs @@ -12,6 +12,7 @@ module Complex ( cis, polar, magnitude, phase ) where +import Prelude infix 6 :+ \end{code} diff --git a/ghc/lib/required/Directory.lhs b/ghc/lib/required/Directory.lhs index 3f8b365..20d05dd 100644 --- a/ghc/lib/required/Directory.lhs +++ b/ghc/lib/required/Directory.lhs @@ -24,6 +24,7 @@ module Directory ( getCurrentDirectory, setCurrentDirectory ) where +import Prelude import Foreign import IOBase import STBase ( PrimIO ) diff --git a/ghc/lib/required/List.lhs b/ghc/lib/required/List.lhs index e742b0e..0260393 100644 --- a/ghc/lib/required/List.lhs +++ b/ghc/lib/required/List.lhs @@ -20,6 +20,7 @@ module List ( union, intersect ) where +import Prelude \end{code} %********************************************************* diff --git a/ghc/lib/required/System.lhs b/ghc/lib/required/System.lhs index 77d82a3..1bdaa1f 100644 --- a/ghc/lib/required/System.lhs +++ b/ghc/lib/required/System.lhs @@ -10,6 +10,7 @@ module System ( getArgs, getProgName, getEnv, system, exitWith ) where +import Prelude import Foreign ( Addr ) import IOBase ( IOError(..), thenIO_Prim, constructErrorAndFail ) import ArrBase ( indexAddrOffAddr )