diff -ruN ghc-6.12.1/ANNOUNCE ghc-6.13.20091231/ANNOUNCE --- ghc-6.12.1/ANNOUNCE 2009-12-10 10:11:33.000000000 -0800 +++ ghc-6.13.20091231/ANNOUNCE 2009-12-31 10:14:15.000000000 -0800 @@ -1,71 +1,35 @@ ============================================================== - The (Interactive) Glasgow Haskell Compiler -- version 6.12.1 + The (Interactive) Glasgow Haskell Compiler -- version 6.10.1 ============================================================== The GHC Team is pleased to announce a new major release of GHC. There have been a number of significant changes since the last major release, including: -* Considerably improved support for parallel execution. GHC 6.10 would - execute parallel Haskell programs, but performance was often not very - good. Simon Marlow has done lots of performance tuning in 6.12, - removing many of the accidental (and largely invisible) gotchas that - made parallel programs run slowly. - -* As part of this parallel-performance tuning, Satnam Singh and Simon - Marlow have developed ThreadScope, a GUI that lets you see what is - going on inside your parallel program. It's a huge step forward from - "It takes 4 seconds with 1 processor, and 3 seconds with 8 processors; - now what?". ThreadScope will be released separately from GHC, but at - more or less the same time as GHC 6.12. - -* Dynamic linking is now supported on Linux, and support for other - platforms will follow. Thanks for this most recently go to the - Industrial Haskell Group who pushed it into a fully-working state; - dynamic linking is the culmination of the work of several people over - recent years. One effect of dynamic linking is that binaries shrink - dramatically, because the run-time system and libraries are shared. - Perhaps more importantly, it is possible to make dynamic plugins from - Haskell code that can be used from other applications. - -* The I/O libraries are now Unicode-aware, so your Haskell programs - should now handle text files containing non-ascii characters, without - special effort. - -* The package system has been made more robust, by associating each - installed package with a unique identifier based on its exposed ABI. - Now, cases where the user re-installs a package without recompiling - packages that depend on it will be detected, and the packages with - broken dependencies will be disabled. Previously, this would lead to - obscure compilation errors, or worse, segfaulting programs. - - This change involved a lot of internal restructuring, but it paves the - way for future improvements to the way packages are handled. For - instance, in the future we expect to track profiled packages - independently of non-profiled ones, and we hope to make it possible to - upgrade a package in an ABI-compatible way, without recompiling the - packages that depend on it. This latter facility will be especially - important as we move towards using more shared libraries. - -* There are a variety of small language changes, including - * Some improvements to data types: record punning, declaring - constructors with class constraints, GADT syntax for type families - etc. - * You can omit the "$" in a top-level Template Haskell splice, which - makes the TH call look more like an ordinary top-level declaration - with a new keyword. - * We're are deprecating mdo for recursive do-notation, in favour of - the more expressive rec statement. - * We've concluded that the implementation of impredicative polymorphism - is unsustainably complicated, so we are re-trenching. It'll be - deprecated in 6.12 (but will still work), and will be either removed - or replaced with something simpler in 6.14. + * Some new language features have been implemented: + * Record syntax: wild-card patterns, punning, and field disambiguation + * Generalised quasi-quotes + * Generalised list comprehensions + * View patterns + * Type families have been completely re-implemented + + * Now comes with Haddock 2, which supports all GHC extensions + + * Parallel garbage collection + + * Base provides extensible exceptions + + * The GHC API is easier to use + + * External core (output only) now works again + + * Data Parallel Haskell (DPH) comes as part of GHC The full release notes are here: - http://haskell.org/ghc/docs/6.12.1/html/users_guide/release-6-12-1.html + http://haskell.org/ghc/docs/6.10.1/html/users_guide/release-6-10-1.html How to get it ~~~~~~~~~~~~~ diff -ruN ghc-6.12.1/bindisttest/Makefile ghc-6.13.20091231/bindisttest/Makefile --- ghc-6.12.1/bindisttest/Makefile 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/bindisttest/Makefile 2009-12-31 10:14:18.000000000 -0800 @@ -31,8 +31,11 @@ $(RM) HelloWorld HelloWorld.o HelloWorld.hi output # We use the a/b/c subdirectory as configure looks for install-sh in # . .. ../.. and we don't want it to find the build system's install-sh. -# --force-local makes tar not think that c:/foo refers to a remote file - cd a/b/c/ && $(TAR) --force-local -jxf ../../../$(BIN_DIST_TEST_TAR_BZ2) +# +# NB. tar has funny interpretation of filenames sometimes (thinking +# c:/foo is a remote file), so it's safer to bzip and then pipe into +# tar rather than using tar -xjf: + cd a/b/c/ && bzip2 -cd ../../../$(BIN_DIST_TEST_TAR_BZ2) | $(TAR) -xf - ifeq "$(Windows)" "YES" mv a/b/c/$(BIN_DIST_NAME) $(BIN_DIST_INST_DIR) else @@ -44,7 +47,8 @@ $(BIN_DIST_INST_DIR)/bin/ghc --make HelloWorld ./HelloWorld > output $(CONTEXT_DIFF) output expected_output - $(BIN_DIST_INST_DIR)/bin/ghc-pkg check +# Without --no-user-package-conf we might pick up random packages from ~/.ghc + $(BIN_DIST_INST_DIR)/bin/ghc-pkg check --no-user-package-conf clean distclean: $(RM) -rf $(BIN_DIST_INST_SUBDIR) diff -ruN ghc-6.12.1/compiler/basicTypes/BasicTypes.lhs ghc-6.13.20091231/compiler/basicTypes/BasicTypes.lhs --- ghc-6.12.1/compiler/basicTypes/BasicTypes.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/basicTypes/BasicTypes.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -42,8 +42,9 @@ TupCon(..), tupleParens, - OccInfo(..), seqOccInfo, isFragileOcc, isOneOcc, + OccInfo(..), seqOccInfo, zapFragileOcc, isOneOcc, isDeadOcc, isLoopBreaker, isNonRuleLoopBreaker, isNoOcc, + nonRuleLoopBreaker, InsideLam, insideLam, notInsideLam, OneBranch, oneBranch, notOneBranch, @@ -54,12 +55,12 @@ StrictnessMark(..), isMarkedUnboxed, isMarkedStrict, CompilerPhase, - Activation(..), isActive, isNeverActive, isAlwaysActive, - RuleMatchInfo(..), isConLike, isFunLike, - InlinePragma(..), defaultInlinePragma, isDefaultInlinePragma, + Activation(..), isActive, isNeverActive, isAlwaysActive, isEarlyActive, + RuleMatchInfo(..), isConLike, isFunLike, + InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma, + isDefaultInlinePragma, isInlinePragma, inlinePragmaActivation, inlinePragmaRuleMatchInfo, setInlinePragmaActivation, setInlinePragmaRuleMatchInfo, - InlineSpec(..), defaultInlineSpec, alwaysInlineSpec, neverInlineSpec, SuccessFlag(..), succeeded, failed, successIf ) where @@ -476,17 +477,20 @@ isNonRuleLoopBreaker (IAmALoopBreaker False) = True -- Loop-breaker that breaks a non-rule cycle isNonRuleLoopBreaker _ = False +nonRuleLoopBreaker :: OccInfo +nonRuleLoopBreaker = IAmALoopBreaker False + isDeadOcc :: OccInfo -> Bool isDeadOcc IAmDead = True isDeadOcc _ = False isOneOcc :: OccInfo -> Bool -isOneOcc (OneOcc _ _ _) = True -isOneOcc _ = False +isOneOcc (OneOcc {}) = True +isOneOcc _ = False -isFragileOcc :: OccInfo -> Bool -isFragileOcc (OneOcc _ _ _) = True -isFragileOcc _ = False +zapFragileOcc :: OccInfo -> OccInfo +zapFragileOcc (OneOcc {}) = NoOccInfo +zapFragileOcc occ = occ \end{code} \begin{code} @@ -585,10 +589,71 @@ | ActiveAfter CompilerPhase -- Active in this phase and later deriving( Eq ) -- Eq used in comparing rules in HsDecls -data RuleMatchInfo = ConLike +data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma] | FunLike deriving( Eq ) +data InlinePragma -- Note [InlinePragma] + = InlinePragma + { inl_inline :: Bool -- True <=> INLINE, + -- False <=> no pragma at all, or NOINLINE + , inl_act :: Activation -- Says during which phases inlining is allowed + , inl_rule :: RuleMatchInfo -- Should the function be treated like a constructor? + } deriving( Eq ) +\end{code} + +Note [InlinePragma] +~~~~~~~~~~~~~~~~~~~ +This data type mirrors what you can write in an INLINE or NOINLINE pragma in +the source program. + +If you write nothing at all, you get defaultInlinePragma: + inl_inline = False + inl_act = AlwaysActive + inl_rule = FunLike + +It's not possible to get that combination by *writing* something, so +if an Id has defaultInlinePragma it means the user didn't specify anything. + +If inl_inline = True, then the Id should have an InlineRule unfolding. + +Note [CONLIKE pragma] +~~~~~~~~~~~~~~~~~~~~~ +The ConLike constructor of a RuleMatchInfo is aimed at the following. +Consider first + {-# RULE "r/cons" forall a as. r (a:as) = f (a+1) #-} + g b bs = let x = b:bs in ..x...x...(r x)... +Now, the rule applies to the (r x) term, because GHC "looks through" +the definition of 'x' to see that it is (b:bs). + +Now consider + {-# RULE "r/f" forall v. r (f v) = f (v+1) #-} + g v = let x = f v in ..x...x...(r x)... +Normally the (r x) would *not* match the rule, because GHC would be +scared about duplicating the redex (f v), so it does not "look +through" the bindings. + +However the CONLIKE modifier says to treat 'f' like a constructor in +this situation, and "look through" the unfolding for x. So (r x) +fires, yielding (f (v+1)). + +This is all controlled with a user-visible pragma: + {-# NOINLINE CONLIKE [1] f #-} + +The main effects of CONLIKE are: + + - The occurrence analyser (OccAnal) and simplifier (Simplify) treat + CONLIKE thing like constructors, by ANF-ing them + + - New function coreUtils.exprIsExpandable is like exprIsCheap, but + additionally spots applications of CONLIKE functions + + - A CoreUnfolding has a field that caches exprIsExpandable + + - The rule matcher consults this field. See + Note [Expanding variables] in Rules.lhs. + +\begin{code} isConLike :: RuleMatchInfo -> Bool isConLike ConLike = True isConLike _ = False @@ -597,55 +662,42 @@ isFunLike FunLike = True isFunLike _ = False -data InlinePragma - = InlinePragma - Activation -- Says during which phases inlining is allowed - RuleMatchInfo -- Should the function be treated like a constructor? - deriving( Eq ) - -defaultInlinePragma :: InlinePragma -defaultInlinePragma = InlinePragma AlwaysActive FunLike +defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma + :: InlinePragma +defaultInlinePragma + = InlinePragma { inl_act = AlwaysActive, inl_rule = FunLike, inl_inline = False } +alwaysInlinePragma + = InlinePragma { inl_act = AlwaysActive, inl_rule = FunLike, inl_inline = True } +neverInlinePragma + = InlinePragma { inl_act = NeverActive, inl_rule = FunLike, inl_inline = False } +dfunInlinePragma + = InlinePragma { inl_act = AlwaysActive, inl_rule = ConLike, inl_inline = False } + isDefaultInlinePragma :: InlinePragma -> Bool -isDefaultInlinePragma (InlinePragma activation match_info) - = isAlwaysActive activation && isFunLike match_info +isDefaultInlinePragma (InlinePragma { inl_act = activation + , inl_rule = match_info + , inl_inline = inline }) + = not inline && isAlwaysActive activation && isFunLike match_info + +isInlinePragma :: InlinePragma -> Bool +isInlinePragma prag = inl_inline prag inlinePragmaActivation :: InlinePragma -> Activation -inlinePragmaActivation (InlinePragma activation _) = activation +inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -inlinePragmaRuleMatchInfo (InlinePragma _ info) = info +inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma -setInlinePragmaActivation (InlinePragma _ info) activation - = InlinePragma activation info +setInlinePragmaActivation prag activation = prag { inl_act = activation } setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma -setInlinePragmaRuleMatchInfo (InlinePragma activation _) info - = InlinePragma activation info - -data InlineSpec - = Inline - InlinePragma - Bool -- True <=> INLINE - -- False <=> NOINLINE - deriving( Eq ) - -defaultInlineSpec :: InlineSpec -alwaysInlineSpec, neverInlineSpec :: RuleMatchInfo -> InlineSpec - -defaultInlineSpec = Inline defaultInlinePragma False - -- Inlining is OK, but not forced -alwaysInlineSpec match_info - = Inline (InlinePragma AlwaysActive match_info) True - -- INLINE always -neverInlineSpec match_info - = Inline (InlinePragma NeverActive match_info) False - -- NOINLINE +setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info } instance Outputable Activation where - ppr NeverActive = ptext (sLit "NEVER") ppr AlwaysActive = ptext (sLit "ALWAYS") + ppr NeverActive = ptext (sLit "NEVER") ppr (ActiveBefore n) = brackets (char '~' <> int n) ppr (ActiveAfter n) = brackets (int n) @@ -654,25 +706,17 @@ ppr FunLike = ptext (sLit "FUNLIKE") instance Outputable InlinePragma where - ppr (InlinePragma activation FunLike) - = ppr activation - ppr (InlinePragma activation match_info) - = ppr match_info <+> ppr activation - -instance Outputable InlineSpec where - ppr (Inline (InlinePragma act match_info) is_inline) - | is_inline = ptext (sLit "INLINE") - <+> ppr_match_info - <+> case act of - AlwaysActive -> empty - _ -> ppr act - | otherwise = ptext (sLit "NOINLINE") - <+> ppr_match_info - <+> case act of - NeverActive -> empty - _ -> ppr act - where - ppr_match_info = if isFunLike match_info then empty else ppr match_info + ppr (InlinePragma { inl_inline = inline, inl_act = activation, inl_rule = info }) + = pp_inline <+> pp_info <+> pp_activation + where + pp_inline | inline = ptext (sLit "INLINE") + | otherwise = ptext (sLit "NOINLINE") + pp_info | isFunLike info = empty + | otherwise = ppr info + pp_activation + | inline && isAlwaysActive activation = empty + | not inline && isNeverActive activation = empty + | otherwise = ppr activation isActive :: CompilerPhase -> Activation -> Bool isActive _ NeverActive = False @@ -680,11 +724,15 @@ isActive p (ActiveAfter n) = p <= n isActive p (ActiveBefore n) = p > n -isNeverActive, isAlwaysActive :: Activation -> Bool +isNeverActive, isAlwaysActive, isEarlyActive :: Activation -> Bool isNeverActive NeverActive = True isNeverActive _ = False isAlwaysActive AlwaysActive = True isAlwaysActive _ = False + +isEarlyActive AlwaysActive = True +isEarlyActive (ActiveBefore {}) = True +isEarlyActive _ = False \end{code} diff -ruN ghc-6.12.1/compiler/basicTypes/Demand.lhs ghc-6.13.20091231/compiler/basicTypes/Demand.lhs --- ghc-6.12.1/compiler/basicTypes/Demand.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/basicTypes/Demand.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -5,215 +5,338 @@ \section[Demand]{@Demand@: the amount of demand on a value} \begin{code} -#ifndef OLD_STRICTNESS -module Demand () where -#else - module Demand( - Demand(..), - - wwLazy, wwStrict, wwUnpack, wwPrim, wwEnum, - isStrict, isLazy, isPrim, - - pprDemands, seqDemand, seqDemands, - - StrictnessInfo(..), - mkStrictnessInfo, - noStrictnessInfo, - ppStrictnessInfo, seqStrictnessInfo, - isBottomingStrictness, appIsBottom, - + Demand(..), + topDmd, lazyDmd, seqDmd, evalDmd, errDmd, isStrictDmd, + isTop, isAbsent, seqDemand, + + DmdType(..), topDmdType, botDmdType, mkDmdType, mkTopDmdType, + dmdTypeDepth, seqDmdType, + DmdEnv, emptyDmdEnv, + DmdResult(..), retCPR, isBotRes, returnsCPR, resTypeArgDmd, + + Demands(..), mapDmds, zipWithDmds, allTop, seqDemands, + + StrictSig(..), mkStrictSig, topSig, botSig, cprSig, + isTopSig, + splitStrictSig, increaseStrictSigArity, + pprIfaceStrictSig, appIsBottom, isBottomingSig, seqStrictSig, ) where #include "HsVersions.h" -import Outputable +import StaticFlags +import BasicTypes +import VarEnv +import UniqFM import Util +import Outputable \end{code} %************************************************************************ %* * -\subsection{The @Demand@ data type} +\subsection{Demands} %* * %************************************************************************ \begin{code} data Demand - = WwLazy -- Argument is lazy as far as we know - MaybeAbsent -- (does not imply worker's existence [etc]). - -- If MaybeAbsent == True, then it is - -- *definitely* lazy. (NB: Absence implies - -- a worker...) - - | WwStrict -- Argument is strict but that's all we know - -- (does not imply worker's existence or any - -- calling-convention magic) - - | WwUnpack -- Argument is strict & a single-constructor type - Bool -- True <=> wrapper unpacks it; False <=> doesn't - [Demand] -- Its constituent parts (whose StrictInfos - -- are in the list) should be passed - -- as arguments to the worker. - - | WwPrim -- Argument is of primitive type, therefore - -- strict; doesn't imply existence of a worker; - -- argument should be passed as is to worker. - - | WwEnum -- Argument is strict & an enumeration type; - -- an Int# representing the tag (start counting - -- at zero) should be passed to the worker. - deriving( Eq ) + = Top -- T; used for unlifted types too, so that + -- A `lub` T = T + | Abs -- A -type MaybeAbsent = Bool -- True <=> not even used + | Call Demand -- C(d) --- versions that don't worry about Absence: -wwLazy, wwStrict, wwPrim, wwEnum :: Demand -wwUnpack :: [Demand] -> Demand - -wwLazy = WwLazy False -wwStrict = WwStrict -wwUnpack xs = WwUnpack False xs -wwPrim = WwPrim -wwEnum = WwEnum + | Eval Demands -- U(ds) -seqDemand :: Demand -> () -seqDemand (WwLazy a) = a `seq` () -seqDemand (WwUnpack b ds) = b `seq` seqDemands ds -seqDemand _ = () - -seqDemands :: [Demand] -> () -seqDemands [] = () -seqDemands (d:ds) = seqDemand d `seq` seqDemands ds -\end{code} + | Defer Demands -- D(ds) + | Box Demand -- B(d) -%************************************************************************ -%* * -\subsection{Functions over @Demand@} -%* * -%************************************************************************ + | Bot -- B + deriving( Eq ) + -- Equality needed for fixpoints in DmdAnal -\begin{code} -isLazy :: Demand -> Bool -isLazy (WwLazy _) = True -isLazy _ = False - -isStrict :: Demand -> Bool -isStrict d = not (isLazy d) - -isPrim :: Demand -> Bool -isPrim WwPrim = True -isPrim _ = False +data Demands = Poly Demand -- Polymorphic case + | Prod [Demand] -- Product case + deriving( Eq ) + +allTop :: Demands -> Bool +allTop (Poly d) = isTop d +allTop (Prod ds) = all isTop ds + +isTop :: Demand -> Bool +isTop Top = True +isTop _ = False + +isAbsent :: Demand -> Bool +isAbsent Abs = True +isAbsent _ = False + +mapDmds :: (Demand -> Demand) -> Demands -> Demands +mapDmds f (Poly d) = Poly (f d) +mapDmds f (Prod ds) = Prod (map f ds) + +zipWithDmds :: (Demand -> Demand -> Demand) + -> Demands -> Demands -> Demands +zipWithDmds f (Poly d1) (Poly d2) = Poly (d1 `f` d2) +zipWithDmds f (Prod ds1) (Poly d2) = Prod [d1 `f` d2 | d1 <- ds1] +zipWithDmds f (Poly d1) (Prod ds2) = Prod [d1 `f` d2 | d2 <- ds2] +zipWithDmds f (Prod ds1) (Prod ds2) + | length ds1 == length ds2 = Prod (zipWithEqual "zipWithDmds" f ds1 ds2) + | otherwise = Poly topDmd + -- This really can happen with polymorphism + -- \f. case f x of (a,b) -> ... + -- case f y of (a,b,c) -> ... + -- Here the two demands on f are C(LL) and C(LLL)! + +topDmd, lazyDmd, seqDmd, evalDmd, errDmd :: Demand +topDmd = Top -- The most uninformative demand +lazyDmd = Box Abs +seqDmd = Eval (Poly Abs) -- Polymorphic seq demand +evalDmd = Box seqDmd -- Evaluate and return +errDmd = Box Bot -- This used to be called X + +isStrictDmd :: Demand -> Bool +isStrictDmd Bot = True +isStrictDmd (Eval _) = True +isStrictDmd (Call _) = True +isStrictDmd (Box d) = isStrictDmd d +isStrictDmd _ = False + +seqDemand :: Demand -> () +seqDemand (Call d) = seqDemand d +seqDemand (Eval ds) = seqDemands ds +seqDemand (Defer ds) = seqDemands ds +seqDemand (Box d) = seqDemand d +seqDemand _ = () + +seqDemands :: Demands -> () +seqDemands (Poly d) = seqDemand d +seqDemands (Prod ds) = seqDemandList ds + +seqDemandList :: [Demand] -> () +seqDemandList [] = () +seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds + +instance Outputable Demand where + ppr Top = char 'T' + ppr Abs = char 'A' + ppr Bot = char 'B' + + ppr (Defer ds) = char 'D' <> ppr ds + ppr (Eval ds) = char 'U' <> ppr ds + + ppr (Box (Eval ds)) = char 'S' <> ppr ds + ppr (Box Abs) = char 'L' + ppr (Box Bot) = char 'X' + ppr d@(Box _) = pprPanic "ppr: Bad boxed demand" (ppr d) + + ppr (Call d) = char 'C' <> parens (ppr d) + + +instance Outputable Demands where + ppr (Poly Abs) = empty + ppr (Poly d) = parens (ppr d <> char '*') + ppr (Prod ds) = parens (hcat (map ppr ds)) + -- At one time I printed U(AAA) as U, but that + -- confuses (Poly Abs) with (Prod AAA), and the + -- worker/wrapper generation differs slightly for these two + -- [Reason: in the latter case we can avoid passing the arg; + -- see notes with WwLib.mkWWstr_one.] \end{code} %************************************************************************ %* * -\subsection{Instances} +\subsection{Demand types} %* * %************************************************************************ - \begin{code} -pprDemands :: [Demand] -> Bool -> SDoc -pprDemands demands bot = hcat (map pprDemand demands) <> pp_bot - where - pp_bot | bot = ptext (sLit "B") - | otherwise = empty - - -pprDemand :: Demand -> SDoc -pprDemand (WwLazy False) = char 'L' -pprDemand (WwLazy True) = char 'A' -pprDemand WwStrict = char 'S' -pprDemand WwPrim = char 'P' -pprDemand WwEnum = char 'E' -pprDemand (WwUnpack wu args) = char ch <> parens (hcat (map pprDemand args)) - where - ch = if wu then 'U' else 'u' +data DmdType = DmdType + DmdEnv -- Demand on explicitly-mentioned + -- free variables + [Demand] -- Demand on arguments + DmdResult -- Nature of result + + -- IMPORTANT INVARIANT + -- The default demand on free variables not in the DmdEnv is: + -- DmdResult = BotRes <=> Bot + -- DmdResult = TopRes/ResCPR <=> Abs + + -- ANOTHER IMPORTANT INVARIANT + -- The Demands in the argument list are never + -- Bot, Defer d + -- Handwavey reason: these don't correspond to calling conventions + -- See DmdAnal.funArgDemand for details + + +-- This guy lets us switch off CPR analysis +-- by making sure that everything uses TopRes instead of RetCPR +-- Assuming, of course, that they don't mention RetCPR by name. +-- They should onlyu use retCPR +retCPR :: DmdResult +retCPR | opt_CprOff = TopRes + | otherwise = RetCPR + +seqDmdType :: DmdType -> () +seqDmdType (DmdType _env ds res) = + {- ??? env `seq` -} seqDemandList ds `seq` res `seq` () + +type DmdEnv = VarEnv Demand + +data DmdResult = TopRes -- Nothing known + | RetCPR -- Returns a constructed product + | BotRes -- Diverges or errors + deriving( Eq, Show ) + -- Equality for fixpoints + -- Show needed for Show in Lex.Token (sigh) + +-- Equality needed for fixpoints in DmdAnal +instance Eq DmdType where + (==) (DmdType fv1 ds1 res1) + (DmdType fv2 ds2 res2) = ufmToList fv1 == ufmToList fv2 + && ds1 == ds2 && res1 == res2 + +instance Outputable DmdType where + ppr (DmdType fv ds res) + = hsep [text "DmdType", + hcat (map ppr ds) <> ppr res, + if null fv_elts then empty + else braces (fsep (map pp_elt fv_elts))] + where + pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd + fv_elts = ufmToList fv + +instance Outputable DmdResult where + ppr TopRes = empty -- Keep these distinct from Demand letters + ppr RetCPR = char 'm' -- so that we can print strictness sigs as + ppr BotRes = char 'b' -- dddr + -- without ambiguity + +emptyDmdEnv :: VarEnv Demand +emptyDmdEnv = emptyVarEnv + +topDmdType, botDmdType, cprDmdType :: DmdType +topDmdType = DmdType emptyDmdEnv [] TopRes +botDmdType = DmdType emptyDmdEnv [] BotRes +cprDmdType = DmdType emptyVarEnv [] retCPR + +isTopDmdType :: DmdType -> Bool +-- Only used on top-level types, hence the assert +isTopDmdType (DmdType env [] TopRes) = ASSERT( isEmptyVarEnv env) True +isTopDmdType _ = False + +isBotRes :: DmdResult -> Bool +isBotRes BotRes = True +isBotRes _ = False + +resTypeArgDmd :: DmdResult -> Demand +-- TopRes and BotRes are polymorphic, so that +-- BotRes = Bot -> BotRes +-- TopRes = Top -> TopRes +-- This function makes that concrete +-- We can get a RetCPR, because of the way in which we are (now) +-- giving CPR info to strict arguments. On the first pass, when +-- nothing has demand info, we optimistically give CPR info or RetCPR to all args +resTypeArgDmd TopRes = Top +resTypeArgDmd RetCPR = Top +resTypeArgDmd BotRes = Bot + +returnsCPR :: DmdResult -> Bool +returnsCPR RetCPR = True +returnsCPR _ = False -instance Outputable Demand where - ppr (WwLazy False) = empty - ppr other_demand = ptext (sLit "__D") <+> pprDemand other_demand +mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType +mkDmdType fv ds res = DmdType fv ds res -instance Show Demand where - showsPrec p d = showsPrecSDoc p (ppr d) +mkTopDmdType :: [Demand] -> DmdResult -> DmdType +mkTopDmdType ds res = DmdType emptyDmdEnv ds res --- Reading demands is done in Lex.lhs +dmdTypeDepth :: DmdType -> Arity +dmdTypeDepth (DmdType _ ds _) = length ds \end{code} %************************************************************************ %* * -\subsection[strictness-IdInfo]{Strictness info about an @Id@} +\subsection{Strictness signature %* * %************************************************************************ -We specify the strictness of a function by giving information about -each of the ``wrapper's'' arguments (see the description about -worker/wrapper-style transformations in the PJ/Launchbury paper on -unboxed types). - -The list of @Demands@ specifies: (a)~the strictness properties of a -function's arguments; and (b)~the type signature of that worker (if it -exists); i.e. its calling convention. +In a let-bound Id we record its strictness info. +In principle, this strictness info is a demand transformer, mapping +a demand on the Id into a DmdType, which gives + a) the free vars of the Id's value + b) the Id's arguments + c) an indication of the result of applying + the Id to its arguments + +However, in fact we store in the Id an extremely emascuated demand transfomer, +namely + a single DmdType +(Nevertheless we dignify StrictSig as a distinct type.) + +This DmdType gives the demands unleashed by the Id when it is applied +to as many arguments as are given in by the arg demands in the DmdType. + +For example, the demand transformer described by the DmdType + DmdType {x -> U(LL)} [V,A] Top +says that when the function is applied to two arguments, it +unleashes demand U(LL) on the free var x, V on the first arg, +and A on the second. -Note that the existence of a worker function is now denoted by the Id's -workerInfo field. +If this same function is applied to one arg, all we can say is +that it uses x with U*(LL), and its arg with demand L. \begin{code} -data StrictnessInfo - = NoStrictnessInfo +newtype StrictSig = StrictSig DmdType + deriving( Eq ) - | StrictnessInfo [Demand] -- Demands on the arguments. +instance Outputable StrictSig where + ppr (StrictSig ty) = ppr ty - Bool -- True <=> the function diverges regardless of its arguments - -- Useful for "error" and other disguised variants thereof. - -- BUT NB: f = \x y. error "urk" - -- will have info SI [SS] True - -- but still (f) and (f 2) are not bot; only (f 3 2) is bot - deriving( Eq ) - - -- NOTA BENE: if the arg demands are, say, [S,L], this means that - -- (f bot) is not necy bot, only (f bot x) is bot - -- We simply cannot express accurately the strictness of a function - -- like f = \x -> case x of (a,b) -> \y -> ... - -- The up-side is that we don't need to restrict the strictness info - -- to the visible arity of the function. - -seqStrictnessInfo :: StrictnessInfo -> () -seqStrictnessInfo (StrictnessInfo ds b) = b `seq` seqDemands ds -seqStrictnessInfo _ = () -\end{code} +instance Show StrictSig where + show (StrictSig ty) = showSDoc (ppr ty) -\begin{code} -mkStrictnessInfo :: ([Demand], Bool) -> StrictnessInfo - -mkStrictnessInfo (xs, is_bot) - | all totally_boring xs && not is_bot = NoStrictnessInfo -- Uninteresting - | otherwise = StrictnessInfo xs is_bot - where - totally_boring (WwLazy False) = True - totally_boring _ = False - -noStrictnessInfo :: StrictnessInfo -noStrictnessInfo = NoStrictnessInfo - -isBottomingStrictness :: StrictnessInfo -> Bool -isBottomingStrictness (StrictnessInfo _ bot) = bot -isBottomingStrictness NoStrictnessInfo = False +mkStrictSig :: DmdType -> StrictSig +mkStrictSig dmd_ty = StrictSig dmd_ty + +splitStrictSig :: StrictSig -> ([Demand], DmdResult) +splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res) + +increaseStrictSigArity :: Int -> StrictSig -> StrictSig +-- Add extra arguments to a strictness signature +increaseStrictSigArity arity_increase (StrictSig (DmdType env dmds res)) + = StrictSig (DmdType env (replicate arity_increase topDmd ++ dmds) res) + +isTopSig :: StrictSig -> Bool +isTopSig (StrictSig ty) = isTopDmdType ty + +topSig, botSig, cprSig :: StrictSig +topSig = StrictSig topDmdType +botSig = StrictSig botDmdType +cprSig = StrictSig cprDmdType + -- appIsBottom returns true if an application to n args would diverge -appIsBottom :: StrictnessInfo -> Int -> Bool -appIsBottom (StrictnessInfo ds bot) n = bot && (listLengthCmp ds n /=GT) -- not more than 'n' elts in 'ds'. -appIsBottom NoStrictnessInfo _ = False - -ppStrictnessInfo :: StrictnessInfo -> SDoc -ppStrictnessInfo NoStrictnessInfo = empty -ppStrictnessInfo (StrictnessInfo wrapper_args bot) = hsep [pprDemands wrapper_args bot] +appIsBottom :: StrictSig -> Int -> Bool +appIsBottom (StrictSig (DmdType _ ds BotRes)) n = listLengthCmp ds n /= GT +appIsBottom _ _ = False + +isBottomingSig :: StrictSig -> Bool +isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True +isBottomingSig _ = False + +seqStrictSig :: StrictSig -> () +seqStrictSig (StrictSig ty) = seqDmdType ty + +pprIfaceStrictSig :: StrictSig -> SDoc +-- Used for printing top-level strictness pragmas in interface files +pprIfaceStrictSig (StrictSig (DmdType _ dmds res)) + = hcat (map ppr dmds) <> ppr res \end{code} + -\begin{code} -#endif /* OLD_STRICTNESS */ -\end{code} diff -ruN ghc-6.12.1/compiler/basicTypes/IdInfo.lhs ghc-6.13.20091231/compiler/basicTypes/IdInfo.lhs --- ghc-6.12.1/compiler/basicTypes/IdInfo.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/basicTypes/IdInfo.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -26,33 +26,8 @@ arityInfo, setArityInfo, ppArityInfo, -- ** Demand and strictness Info - newStrictnessInfo, setNewStrictnessInfo, - newDemandInfo, setNewDemandInfo, pprNewStrictness, - setAllStrictnessInfo, - -#ifdef OLD_STRICTNESS - -- ** Old strictness Info - StrictnessInfo(..), - mkStrictnessInfo, noStrictnessInfo, - ppStrictnessInfo, isBottomingStrictness, - strictnessInfo, setStrictnessInfo, - - oldStrictnessFromNew, newStrictnessFromOld, - - -- ** Old demand Info - demandInfo, setDemandInfo, - oldDemand, newDemand, - - -- ** Old Constructed Product Result Info - CprInfo(..), - cprInfo, setCprInfo, ppCprInfo, noCprInfo, - cprInfoFromNewStrictness, -#endif - - -- ** The WorkerInfo type - WorkerInfo(..), - workerExists, wrapperArity, workerId, - workerInfo, setWorkerInfo, ppWorkerInfo, + strictnessInfo, setStrictnessInfo, + demandInfo, setDemandInfo, pprStrictness, -- ** Unfolding Info unfoldingInfo, setUnfoldingInfo, setUnfoldingInfoLazily, @@ -63,7 +38,7 @@ -- ** The OccInfo type OccInfo(..), - isFragileOcc, isDeadOcc, isLoopBreaker, + isDeadOcc, isLoopBreaker, occInfo, setOccInfo, InsideLam, OneBranch, @@ -94,144 +69,30 @@ import Class import PrimOp import Name -import Var import VarSet import BasicTypes import DataCon import TyCon import ForeignCall -import NewDemand +import Demand import Outputable import Module import FastString import Data.Maybe -#ifdef OLD_STRICTNESS -import Demand -import qualified Demand -import Util -import Data.List -#endif - -- infixl so you can say (id `set` a `set` b) infixl 1 `setSpecInfo`, `setArityInfo`, `setInlinePragInfo`, `setUnfoldingInfo`, - `setWorkerInfo`, `setLBVarInfo`, `setOccInfo`, `setCafInfo`, - `setNewStrictnessInfo`, - `setAllStrictnessInfo`, - `setNewDemandInfo` -#ifdef OLD_STRICTNESS - , `setCprInfo` - , `setDemandInfo` - , `setStrictnessInfo` -#endif -\end{code} - -%************************************************************************ -%* * -\subsection{New strictness info} -%* * -%************************************************************************ - -To be removed later - -\begin{code} --- | Set old and new strictness information together -setAllStrictnessInfo :: IdInfo -> Maybe StrictSig -> IdInfo -setAllStrictnessInfo info Nothing - = info { newStrictnessInfo = Nothing -#ifdef OLD_STRICTNESS - , strictnessInfo = NoStrictnessInfo - , cprInfo = NoCPRInfo -#endif - } - -setAllStrictnessInfo info (Just sig) - = info { newStrictnessInfo = Just sig -#ifdef OLD_STRICTNESS - , strictnessInfo = oldStrictnessFromNew sig - , cprInfo = cprInfoFromNewStrictness sig -#endif - } - -seqNewStrictnessInfo :: Maybe StrictSig -> () -seqNewStrictnessInfo Nothing = () -seqNewStrictnessInfo (Just ty) = seqStrictSig ty - -pprNewStrictness :: Maybe StrictSig -> SDoc -pprNewStrictness Nothing = empty -pprNewStrictness (Just sig) = ftext (fsLit "Str:") <+> ppr sig - -#ifdef OLD_STRICTNESS -oldStrictnessFromNew :: StrictSig -> Demand.StrictnessInfo -oldStrictnessFromNew sig = mkStrictnessInfo (map oldDemand dmds, isBotRes res_info) - where - (dmds, res_info) = splitStrictSig sig - -cprInfoFromNewStrictness :: StrictSig -> CprInfo -cprInfoFromNewStrictness sig = case strictSigResInfo sig of - RetCPR -> ReturnsCPR - other -> NoCPRInfo - -newStrictnessFromOld :: Name -> Arity -> Demand.StrictnessInfo -> CprInfo -> StrictSig -newStrictnessFromOld name arity (Demand.StrictnessInfo ds res) cpr - | listLengthCmp ds arity /= GT -- length ds <= arity - -- Sometimes the old strictness analyser has more - -- demands than the arity justifies - = mk_strict_sig name arity $ - mkTopDmdType (map newDemand ds) (newRes res cpr) - -newStrictnessFromOld name arity other cpr - = -- Either no strictness info, or arity is too small - -- In either case we can't say anything useful - mk_strict_sig name arity $ - mkTopDmdType (replicate arity lazyDmd) (newRes False cpr) - -mk_strict_sig name arity dmd_ty - = WARN( arity /= dmdTypeDepth dmd_ty, ppr name <+> (ppr arity $$ ppr dmd_ty) ) - mkStrictSig dmd_ty - -newRes True _ = BotRes -newRes False ReturnsCPR = retCPR -newRes False NoCPRInfo = TopRes - -newDemand :: Demand.Demand -> NewDemand.Demand -newDemand (WwLazy True) = Abs -newDemand (WwLazy False) = lazyDmd -newDemand WwStrict = evalDmd -newDemand (WwUnpack unpk ds) = Eval (Prod (map newDemand ds)) -newDemand WwPrim = lazyDmd -newDemand WwEnum = evalDmd - -oldDemand :: NewDemand.Demand -> Demand.Demand -oldDemand Abs = WwLazy True -oldDemand Top = WwLazy False -oldDemand Bot = WwStrict -oldDemand (Box Bot) = WwStrict -oldDemand (Box Abs) = WwLazy False -oldDemand (Box (Eval _)) = WwStrict -- Pass box only -oldDemand (Defer d) = WwLazy False -oldDemand (Eval (Prod ds)) = WwUnpack True (map oldDemand ds) -oldDemand (Eval (Poly _)) = WwStrict -oldDemand (Call _) = WwStrict - -#endif /* OLD_STRICTNESS */ -\end{code} - - -\begin{code} -seqNewDemandInfo :: Maybe Demand -> () -seqNewDemandInfo Nothing = () -seqNewDemandInfo (Just dmd) = seqDemand dmd + `setStrictnessInfo`, + `setDemandInfo` \end{code} - %************************************************************************ %* * IdDetails @@ -260,35 +121,38 @@ -- b) when desugaring a RecordCon we can get -- from the Id back to the data con] - | ClassOpId Class -- ^ The 'Id' is an operation of a class + | ClassOpId Class -- ^ The 'Id' is an superclass selector or class operation of a class | PrimOpId PrimOp -- ^ The 'Id' is for a primitive operator | FCallId ForeignCall -- ^ The 'Id' is for a foreign call | TickBoxOpId TickBoxOp -- ^ The 'Id' is for a HPC tick box (both traditional and binary) - | DFunId -- ^ A dictionary function. We don't use this in an essential way, - -- currently, but it's kind of nice that we can keep track of - -- which Ids are DFuns, across module boundaries too + | DFunId Bool -- ^ A dictionary function. + -- True <=> the class has only one method, so may be + -- implemented with a newtype, so it might be bad + -- to be strict on this dictionary instance Outputable IdDetails where ppr = pprIdDetails pprIdDetails :: IdDetails -> SDoc -pprIdDetails VanillaId = empty -pprIdDetails (DataConWorkId _) = ptext (sLit "[DataCon]") -pprIdDetails (DataConWrapId _) = ptext (sLit "[DataConWrapper]") -pprIdDetails (ClassOpId _) = ptext (sLit "[ClassOp]") -pprIdDetails (PrimOpId _) = ptext (sLit "[PrimOp]") -pprIdDetails (FCallId _) = ptext (sLit "[ForeignCall]") -pprIdDetails (TickBoxOpId _) = ptext (sLit "[TickBoxOp]") -pprIdDetails DFunId = ptext (sLit "[DFunId]") -pprIdDetails (RecSelId { sel_naughty = is_naughty }) - = brackets $ ptext (sLit "RecSel") <> pp_naughty - where - pp_naughty | is_naughty = ptext (sLit "(naughty)") - | otherwise = empty +pprIdDetails VanillaId = empty +pprIdDetails other = brackets (pp other) + where + pp VanillaId = panic "pprIdDetails" + pp (DataConWorkId _) = ptext (sLit "DataCon") + pp (DataConWrapId _) = ptext (sLit "DataConWrapper") + pp (ClassOpId {}) = ptext (sLit "ClassOp") + pp (PrimOpId _) = ptext (sLit "PrimOp") + pp (FCallId _) = ptext (sLit "ForeignCall") + pp (TickBoxOpId _) = ptext (sLit "TickBoxOp") + pp (DFunId b) = ptext (sLit "DFunId") <> + ppWhen b (ptext (sLit "(newtype)")) + pp (RecSelId { sel_naughty = is_naughty }) + = brackets $ ptext (sLit "RecSel") + <> ppWhen is_naughty (ptext (sLit "(naughty)")) \end{code} @@ -314,32 +178,19 @@ = IdInfo { arityInfo :: !ArityInfo, -- ^ 'Id' arity specInfo :: SpecInfo, -- ^ Specialisations of the 'Id's function which exist -#ifdef OLD_STRICTNESS - cprInfo :: CprInfo, -- ^ If the 'Id's function always constructs a product result - demandInfo :: Demand.Demand, -- ^ Whether or not the 'Id' is definitely demanded - strictnessInfo :: StrictnessInfo, -- ^ 'Id' strictness properties -#endif - workerInfo :: WorkerInfo, -- ^ Pointer to worker function. - -- Within one module this is irrelevant; the - -- inlining of a worker is handled via the 'Unfolding'. - -- However, when the module is imported by others, the - -- 'WorkerInfo' is used /only/ to indicate the form of - -- the RHS, so that interface files don't actually - -- need to contain the RHS; it can be derived from - -- the strictness info - + -- See Note [Specialisations and RULES in IdInfo] unfoldingInfo :: Unfolding, -- ^ The 'Id's unfolding cafInfo :: CafInfo, -- ^ 'Id' CAF info lbvarInfo :: LBVarInfo, -- ^ Info about a lambda-bound variable, if the 'Id' is one inlinePragInfo :: InlinePragma, -- ^ Any inline pragma atached to the 'Id' occInfo :: OccInfo, -- ^ How the 'Id' occurs in the program - newStrictnessInfo :: Maybe StrictSig, -- ^ Id strictness information. Reason for Maybe: + strictnessInfo :: Maybe StrictSig, -- ^ Id strictness information. Reason for Maybe: -- the DmdAnal phase needs to know whether -- this is the first visit, so it can assign botSig. -- Other customers want topSig. So @Nothing@ is good. - newDemandInfo :: Maybe Demand -- ^ Id demand information. Similarly we want to know + demandInfo :: Maybe Demand -- ^ Id demand information. Similarly we want to know -- if there's no known demand yet, for when we are looking -- for CPR info } @@ -353,40 +204,36 @@ megaSeqIdInfo :: IdInfo -> () megaSeqIdInfo info = seqSpecInfo (specInfo info) `seq` - seqWorker (workerInfo info) `seq` -- Omitting this improves runtimes a little, presumably because -- some unfoldings are not calculated at all -- seqUnfolding (unfoldingInfo info) `seq` - seqNewDemandInfo (newDemandInfo info) `seq` - seqNewStrictnessInfo (newStrictnessInfo info) `seq` - -#ifdef OLD_STRICTNESS - Demand.seqDemand (demandInfo info) `seq` - seqStrictnessInfo (strictnessInfo info) `seq` - seqCpr (cprInfo info) `seq` -#endif + seqDemandInfo (demandInfo info) `seq` + seqStrictnessInfo (strictnessInfo info) `seq` seqCaf (cafInfo info) `seq` seqLBVar (lbvarInfo info) `seq` seqOccInfo (occInfo info) + +seqStrictnessInfo :: Maybe StrictSig -> () +seqStrictnessInfo Nothing = () +seqStrictnessInfo (Just ty) = seqStrictSig ty + +seqDemandInfo :: Maybe Demand -> () +seqDemandInfo Nothing = () +seqDemandInfo (Just dmd) = seqDemand dmd \end{code} Setters \begin{code} -setWorkerInfo :: IdInfo -> WorkerInfo -> IdInfo -setWorkerInfo info wk = wk `seq` info { workerInfo = wk } setSpecInfo :: IdInfo -> SpecInfo -> IdInfo setSpecInfo info sp = sp `seq` info { specInfo = sp } setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr } setOccInfo :: IdInfo -> OccInfo -> IdInfo setOccInfo info oc = oc `seq` info { occInfo = oc } -#ifdef OLD_STRICTNESS -setStrictnessInfo info st = st `seq` info { strictnessInfo = st } -#endif -- Try to avoid spack leaks by seq'ing setUnfoldingInfoLazily :: IdInfo -> Unfolding -> IdInfo @@ -400,11 +247,6 @@ -- actually increases residency significantly. = info { unfoldingInfo = uf } -#ifdef OLD_STRICTNESS -setDemandInfo info dd = info { demandInfo = dd } -setCprInfo info cp = info { cprInfo = cp } -#endif - setArityInfo :: IdInfo -> ArityInfo -> IdInfo setArityInfo info ar = info { arityInfo = ar } setCafInfo :: IdInfo -> CafInfo -> IdInfo @@ -413,10 +255,11 @@ setLBVarInfo :: IdInfo -> LBVarInfo -> IdInfo setLBVarInfo info lb = {-lb `seq`-} info { lbvarInfo = lb } -setNewDemandInfo :: IdInfo -> Maybe Demand -> IdInfo -setNewDemandInfo info dd = dd `seq` info { newDemandInfo = dd } -setNewStrictnessInfo :: IdInfo -> Maybe StrictSig -> IdInfo -setNewStrictnessInfo info dd = dd `seq` info { newStrictnessInfo = dd } +setDemandInfo :: IdInfo -> Maybe Demand -> IdInfo +setDemandInfo info dd = dd `seq` info { demandInfo = dd } + +setStrictnessInfo :: IdInfo -> Maybe StrictSig -> IdInfo +setStrictnessInfo info dd = dd `seq` info { strictnessInfo = dd } \end{code} @@ -427,19 +270,13 @@ = IdInfo { cafInfo = vanillaCafInfo, arityInfo = unknownArity, -#ifdef OLD_STRICTNESS - cprInfo = NoCPRInfo, - demandInfo = wwLazy, - strictnessInfo = NoStrictnessInfo, -#endif specInfo = emptySpecInfo, - workerInfo = NoWorker, unfoldingInfo = noUnfolding, lbvarInfo = NoLBVarInfo, inlinePragInfo = defaultInlinePragma, occInfo = NoOccInfo, - newDemandInfo = Nothing, - newStrictnessInfo = Nothing + demandInfo = Nothing, + strictnessInfo = Nothing } -- | More informative 'IdInfo' we can use when we know the 'Id' has no CAF references @@ -501,10 +338,42 @@ %************************************************************************ %* * + Strictness +%* * +%************************************************************************ + +\begin{code} +pprStrictness :: Maybe StrictSig -> SDoc +pprStrictness Nothing = empty +pprStrictness (Just sig) = ppr sig +\end{code} + + +%************************************************************************ +%* * SpecInfo %* * %************************************************************************ +Note [Specialisations and RULES in IdInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally speaking, a GlobalIdshas an *empty* SpecInfo. All their +RULES are contained in the globally-built rule-base. In principle, +one could attach the to M.f the RULES for M.f that are defined in M. +But we don't do that for instance declarations and so we just treat +them all uniformly. + +The EXCEPTION is PrimOpIds, which do have rules in their IdInfo. That is +jsut for convenience really. + +However, LocalIds may have non-empty SpecInfo. We treat them +differently because: + a) they might be nested, in which case a global table won't work + b) the RULE might mention free variables, which we use to keep things alive + +In TidyPgm, when the LocalId becomes a GlobalId, its RULES are stripped off +and put in the global list. + \begin{code} -- | Records the specializations of this 'Id' that we know about -- in the form of rewrite 'CoreRule's that target them @@ -542,67 +411,6 @@ %************************************************************************ %* * -\subsection[worker-IdInfo]{Worker info about an @Id@} -%* * -%************************************************************************ - -There might not be a worker, even for a strict function, because: -(a) the function might be small enough to inline, so no need - for w/w split -(b) the strictness info might be "SSS" or something, so no w/w split. - -Sometimes the arity of a wrapper changes from the original arity from -which it was generated, so we always emit the "original" arity into -the interface file, as part of the worker info. - -How can this happen? Sometimes we get - f = coerce t (\x y -> $wf x y) -at the moment of w/w split; but the eta reducer turns it into - f = coerce t $wf -which is perfectly fine except that the exposed arity so far as -the code generator is concerned (zero) differs from the arity -when we did the split (2). - -All this arises because we use 'arity' to mean "exactly how many -top level lambdas are there" in interface files; but during the -compilation of this module it means "how many things can I apply -this to". - -\begin{code} - --- | If this Id has a worker then we store a reference to it. Worker --- functions are generated by the worker\/wrapper pass, using information --- information from strictness analysis. -data WorkerInfo = NoWorker -- ^ No known worker function - | HasWorker Id Arity -- ^ The 'Arity' is the arity of the /wrapper/ at the moment of the - -- worker\/wrapper split, which may be different from the current 'Id' 'Aritiy' - -seqWorker :: WorkerInfo -> () -seqWorker (HasWorker id a) = id `seq` a `seq` () -seqWorker NoWorker = () - -ppWorkerInfo :: WorkerInfo -> SDoc -ppWorkerInfo NoWorker = empty -ppWorkerInfo (HasWorker wk_id _) = ptext (sLit "Worker") <+> ppr wk_id - -workerExists :: WorkerInfo -> Bool -workerExists NoWorker = False -workerExists (HasWorker _ _) = True - --- | The 'Id' of the worker function if it exists, or a panic otherwise -workerId :: WorkerInfo -> Id -workerId (HasWorker id _) = id -workerId NoWorker = panic "workerId: NoWorker" - --- | The 'Arity' of the worker function at the time of the split if it exists, or a panic otherwise -wrapperArity :: WorkerInfo -> Arity -wrapperArity (HasWorker _ a) = a -wrapperArity NoWorker = panic "wrapperArity: NoWorker" -\end{code} - - -%************************************************************************ -%* * \subsection[CG-IdInfo]{Code generator-related information} %* * %************************************************************************ @@ -634,6 +442,9 @@ seqCaf :: CafInfo -> () seqCaf c = c `seq` () +instance Outputable CafInfo where + ppr = ppCafInfo + ppCafInfo :: CafInfo -> SDoc ppCafInfo NoCafRefs = ptext (sLit "NoCafRefs") ppCafInfo MayHaveCafRefs = empty @@ -641,59 +452,6 @@ %************************************************************************ %* * -\subsection[cpr-IdInfo]{Constructed Product Result info about an @Id@} -%* * -%************************************************************************ - -\begin{code} -#ifdef OLD_STRICTNESS --- | If the @Id@ is a function then it may have Constructed Product Result --- (CPR) info. A CPR analysis phase detects whether: --- --- 1. The function's return value has a product type, i.e. an algebraic type --- with a single constructor. Examples of such types are tuples and boxed --- primitive values. --- --- 2. The function always 'constructs' the value that it is returning. It --- must do this on every path through, and it's OK if it calls another --- function which constructs the result. --- --- If this is the case then we store a template which tells us the --- function has the CPR property and which components of the result are --- also CPRs. -data CprInfo - = NoCPRInfo -- ^ No, this function does not return a constructed product - | ReturnsCPR -- ^ Yes, this function returns a constructed product - - -- Implicitly, this means "after the function has been applied - -- to all its arguments", so the worker\/wrapper builder in - -- WwLib.mkWWcpr checks that that it is indeed saturated before - -- making use of the CPR info - - -- We used to keep nested info about sub-components, but - -- we never used it so I threw it away - --- | It's always safe to assume that an 'Id' does not have the CPR property -noCprInfo :: CprInt -noCprInfo = NoCPRInfo - -seqCpr :: CprInfo -> () -seqCpr ReturnsCPR = () -seqCpr NoCPRInfo = () - -ppCprInfo NoCPRInfo = empty -ppCprInfo ReturnsCPR = ptext (sLit "__M") - -instance Outputable CprInfo where - ppr = ppCprInfo - -instance Show CprInfo where - showsPrec p c = showsPrecSDoc p (ppr c) -#endif -\end{code} - -%************************************************************************ -%* * \subsection[lbvar-IdInfo]{Lambda-bound var info about an @Id@} %* * %************************************************************************ @@ -745,11 +503,11 @@ -- -- > (\x1. \x2. e) arg1 zapLamInfo :: IdInfo -> Maybe IdInfo -zapLamInfo info@(IdInfo {occInfo = occ, newDemandInfo = demand}) +zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand}) | is_safe_occ occ && is_safe_dmd demand = Nothing | otherwise - = Just (info {occInfo = safe_occ, newDemandInfo = Nothing}) + = Just (info {occInfo = safe_occ, demandInfo = Nothing}) where -- The "unsafe" occ info is the ones that say I'm not in a lambda -- because that might not be true for an unsaturated lambda @@ -767,8 +525,8 @@ \begin{code} -- | Remove demand info on the 'IdInfo' if it is present, otherwise return @Nothing@ zapDemandInfo :: IdInfo -> Maybe IdInfo -zapDemandInfo info@(IdInfo {newDemandInfo = dmd}) - | isJust dmd = Just (info {newDemandInfo = Nothing}) +zapDemandInfo info@(IdInfo {demandInfo = dmd}) + | isJust dmd = Just (info {demandInfo = Nothing}) | otherwise = Nothing \end{code} @@ -777,9 +535,8 @@ -- ^ Zap info that depends on free variables zapFragileInfo info = Just (info `setSpecInfo` emptySpecInfo - `setWorkerInfo` NoWorker `setUnfoldingInfo` noUnfolding - `setOccInfo` if isFragileOcc occ then NoOccInfo else occ) + `setOccInfo` zapFragileOcc occ) where occ = occInfo info \end{code} diff -ruN ghc-6.12.1/compiler/basicTypes/Id.lhs ghc-6.13.20091231/compiler/basicTypes/Id.lhs --- ghc-6.12.1/compiler/basicTypes/Id.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/basicTypes/Id.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -67,41 +67,28 @@ -- ** Reading 'IdInfo' fields idArity, - idNewDemandInfo, idNewDemandInfo_maybe, - idNewStrictness, idNewStrictness_maybe, - idWorkerInfo, - idUnfolding, + idDemandInfo, idDemandInfo_maybe, + idStrictness, idStrictness_maybe, + idUnfolding, realIdUnfolding, idSpecialisation, idCoreRules, idHasRules, idCafInfo, idLBVarInfo, idOccInfo, -#ifdef OLD_STRICTNESS - idDemandInfo, - idStrictness, - idCprInfo, -#endif - -- ** Writing 'IdInfo' fields setIdUnfolding, setIdArity, - setIdNewDemandInfo, - setIdNewStrictness, zapIdNewStrictness, - setIdWorkerInfo, + setIdDemandInfo, + setIdStrictness, zapIdStrictness, setIdSpecialisation, setIdCafInfo, setIdOccInfo, zapIdOccInfo, -#ifdef OLD_STRICTNESS - setIdStrictness, - setIdDemandInfo, - setIdCprInfo, -#endif ) where #include "HsVersions.h" -import CoreSyn ( CoreRule, Unfolding ) +import CoreSyn ( CoreRule, Unfolding( NoUnfolding ) ) import IdInfo import BasicTypes @@ -116,11 +103,8 @@ import Type import TcType import TysPrim -#ifdef OLD_STRICTNESS -import qualified Demand -#endif import DataCon -import NewDemand +import Demand import Name import Module import Class @@ -138,17 +122,13 @@ -- infixl so you can say (id `set` a `set` b) infixl 1 `setIdUnfolding`, `setIdArity`, - `setIdNewDemandInfo`, - `setIdNewStrictness`, - `setIdWorkerInfo`, + `setIdOccInfo`, + `setIdDemandInfo`, + `setIdStrictness`, `setIdSpecialisation`, `setInlinePragma`, + `setInlineActivation`, `idCafInfo` -#ifdef OLD_STRICTNESS - ,`idCprInfo` - ,`setIdStrictness` - ,`setIdDemandInfo` -#endif \end{code} %************************************************************************ @@ -289,9 +269,7 @@ -- | Workers get local names. "CoreTidy" will externalise these if necessary mkWorkerId :: Unique -> Id -> Type -> Id mkWorkerId uniq unwrkr ty - = mkLocalId wkr_name ty - where - wkr_name = mkInternalName uniq (mkWorkerOcc (getOccName unwrkr)) (getSrcSpan unwrkr) + = mkLocalId (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) ty -- | Create a /template local/: a family of system local 'Id's in bijection with @Int@s, typically used in unfoldings mkTemplateLocal :: Int -> Type -> Id @@ -350,8 +328,8 @@ _ -> False isDFunId id = case Var.idDetails id of - DFunId -> True - _ -> False + DFunId _ -> True + _ -> False isPrimOpId_maybe id = case Var.idDetails id of PrimOpId op -> Just op @@ -409,11 +387,11 @@ -- file, even if it's mentioned in some other interface unfolding. isImplicitId id = case Var.idDetails id of - FCallId _ -> True - ClassOpId _ -> True - PrimOpId _ -> True - DataConWorkId _ -> True - DataConWrapId _ -> True + FCallId {} -> True + ClassOpId {} -> True + PrimOpId {} -> True + DataConWorkId {} -> True + DataConWrapId {} -> True -- These are are implied by their type or class decl; -- remember that all type and class decls appear in the interface file. -- The dfun id is not an implicit Id; it must *not* be omitted, because @@ -474,31 +452,21 @@ setIdArity :: Id -> Arity -> Id setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id -#ifdef OLD_STRICTNESS - --------------------------------- - -- (OLD) STRICTNESS -idStrictness :: Id -> StrictnessInfo -idStrictness id = strictnessInfo (idInfo id) - -setIdStrictness :: Id -> StrictnessInfo -> Id -setIdStrictness id strict_info = modifyIdInfo (`setStrictnessInfo` strict_info) id -#endif - -- | Returns true if an application to n args would diverge isBottomingId :: Id -> Bool -isBottomingId id = isBottomingSig (idNewStrictness id) +isBottomingId id = isBottomingSig (idStrictness id) -idNewStrictness_maybe :: Id -> Maybe StrictSig -idNewStrictness :: Id -> StrictSig +idStrictness_maybe :: Id -> Maybe StrictSig +idStrictness :: Id -> StrictSig -idNewStrictness_maybe id = newStrictnessInfo (idInfo id) -idNewStrictness id = idNewStrictness_maybe id `orElse` topSig +idStrictness_maybe id = strictnessInfo (idInfo id) +idStrictness id = idStrictness_maybe id `orElse` topSig -setIdNewStrictness :: Id -> StrictSig -> Id -setIdNewStrictness id sig = modifyIdInfo (`setNewStrictnessInfo` Just sig) id +setIdStrictness :: Id -> StrictSig -> Id +setIdStrictness id sig = modifyIdInfo (`setStrictnessInfo` Just sig) id -zapIdNewStrictness :: Id -> Id -zapIdNewStrictness id = modifyIdInfo (`setNewStrictnessInfo` Nothing) id +zapIdStrictness :: Id -> Id +zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` Nothing) id -- | This predicate says whether the 'Id' has a strict demand placed on it or -- has a type such that it can always be evaluated strictly (e.g., an @@ -509,46 +477,40 @@ isStrictId :: Id -> Bool isStrictId id = ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id ) - (isStrictDmd (idNewDemandInfo id)) || + (isStrictDmd (idDemandInfo id)) || (isStrictType (idType id)) --------------------------------- - -- WORKER ID -idWorkerInfo :: Id -> WorkerInfo -idWorkerInfo id = workerInfo (idInfo id) - -setIdWorkerInfo :: Id -> WorkerInfo -> Id -setIdWorkerInfo id work_info = modifyIdInfo (`setWorkerInfo` work_info) id - - --------------------------------- -- UNFOLDING idUnfolding :: Id -> Unfolding -idUnfolding id = unfoldingInfo (idInfo id) +-- Do not expose the unfolding of a loop breaker! +idUnfolding id + | isNonRuleLoopBreaker (occInfo info) = NoUnfolding + | otherwise = unfoldingInfo info + where + info = idInfo id + +realIdUnfolding :: Id -> Unfolding +-- Expose the unfolding if there is one, including for loop breakers +realIdUnfolding id = unfoldingInfo (idInfo id) setIdUnfolding :: Id -> Unfolding -> Id setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id -#ifdef OLD_STRICTNESS - --------------------------------- - -- (OLD) DEMAND -idDemandInfo :: Id -> Demand.Demand -idDemandInfo id = demandInfo (idInfo id) - -setIdDemandInfo :: Id -> Demand.Demand -> Id -setIdDemandInfo id demand_info = modifyIdInfo (`setDemandInfo` demand_info) id -#endif - -idNewDemandInfo_maybe :: Id -> Maybe NewDemand.Demand -idNewDemandInfo :: Id -> NewDemand.Demand +idDemandInfo_maybe :: Id -> Maybe Demand +idDemandInfo :: Id -> Demand -idNewDemandInfo_maybe id = newDemandInfo (idInfo id) -idNewDemandInfo id = newDemandInfo (idInfo id) `orElse` NewDemand.topDmd +idDemandInfo_maybe id = demandInfo (idInfo id) +idDemandInfo id = demandInfo (idInfo id) `orElse` topDmd -setIdNewDemandInfo :: Id -> NewDemand.Demand -> Id -setIdNewDemandInfo id dmd = modifyIdInfo (`setNewDemandInfo` Just dmd) id +setIdDemandInfo :: Id -> Demand -> Id +setIdDemandInfo id dmd = modifyIdInfo (`setDemandInfo` Just dmd) id --------------------------------- -- SPECIALISATION + +-- See Note [Specialisations and RULES in IdInfo] in IdInfo.lhs + idSpecialisation :: Id -> SpecInfo idSpecialisation id = specInfo (idInfo id) @@ -564,28 +526,12 @@ --------------------------------- -- CAF INFO idCafInfo :: Id -> CafInfo -#ifdef OLD_STRICTNESS -idCafInfo id = case cgInfo (idInfo id) of - NoCgInfo -> pprPanic "idCafInfo" (ppr id) - info -> cgCafInfo info -#else idCafInfo id = cafInfo (idInfo id) -#endif setIdCafInfo :: Id -> CafInfo -> Id setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id --------------------------------- - -- CPR INFO -#ifdef OLD_STRICTNESS -idCprInfo :: Id -> CprInfo -idCprInfo id = cprInfo (idInfo id) - -setIdCprInfo :: Id -> CprInfo -> Id -setIdCprInfo id cpr_info = modifyIdInfo (`setCprInfo` cpr_info) id -#endif - - --------------------------------- -- Occcurrence INFO idOccInfo :: Id -> OccInfo idOccInfo id = occInfo (idInfo id) @@ -617,7 +563,7 @@ idInlineActivation id = inlinePragmaActivation (idInlinePragma id) setInlineActivation :: Id -> Activation -> Id -setInlineActivation id act = modifyInlinePragma id (\(InlinePragma _ match_info) -> InlinePragma act match_info) +setInlineActivation id act = modifyInlinePragma id (\prag -> setInlinePragmaActivation prag act) idRuleMatchInfo :: Id -> RuleMatchInfo idRuleMatchInfo id = inlinePragmaRuleMatchInfo (idInlinePragma id) @@ -752,10 +698,10 @@ old_arity = arityInfo old_info old_inline_prag = inlinePragInfo old_info new_arity = old_arity + arity_increase - old_strictness = newStrictnessInfo old_info + old_strictness = strictnessInfo old_info new_strictness = fmap (increaseStrictSigArity arity_increase) old_strictness - transfer new_info = new_info `setNewStrictnessInfo` new_strictness + transfer new_info = new_info `setStrictnessInfo` new_strictness `setArityInfo` new_arity `setInlinePragInfo` old_inline_prag \end{code} diff -ruN ghc-6.12.1/compiler/basicTypes/MkId.lhs ghc-6.13.20091231/compiler/basicTypes/MkId.lhs --- ghc-6.12.1/compiler/basicTypes/MkId.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/basicTypes/MkId.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -65,7 +65,7 @@ import Id import Var ( Var, TyVar, mkCoVar, mkExportedLocalVar ) import IdInfo -import NewDemand +import Demand import CoreSyn import Unique import PrelNames @@ -265,7 +265,7 @@ wkr_arity = dataConRepArity data_con wkr_info = noCafIdInfo `setArityInfo` wkr_arity - `setAllStrictnessInfo` Just wkr_sig + `setStrictnessInfo` Just wkr_sig `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, -- even if arity = 0 @@ -329,7 +329,7 @@ -- It's important to specify the arity, so that partial -- applications are treated as values `setUnfoldingInfo` wrap_unf - `setAllStrictnessInfo` Just wrap_sig + `setStrictnessInfo` Just wrap_sig all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con wrap_sig = mkStrictSig (mkTopDmdType arg_dmds cpr_info) @@ -345,8 +345,8 @@ -- ...(let w = C x in ...(w p q)...)... -- we want to see that w is strict in its two arguments - wrap_unf = mkImplicitUnfolding $ Note InlineMe $ - mkLams wrap_tvs $ + wrap_unf = mkInlineRule needSaturated wrap_rhs (length dict_args + length id_args) + wrap_rhs = mkLams wrap_tvs $ mkLams eq_args $ mkLams dict_args $ mkLams id_args $ foldr mk_case con_app @@ -457,34 +457,57 @@ -- But it's type must expose the representation of the dictionary -- to get (say) C a -> (a -> a) - info = noCafIdInfo - `setArityInfo` 1 - `setAllStrictnessInfo` Just strict_sig - `setUnfoldingInfo` (if no_unf then noUnfolding - else mkImplicitUnfolding rhs) - - -- We no longer use 'must-inline' on record selectors. They'll - -- inline like crazy if they scrutinise a constructor + base_info = noCafIdInfo + `setArityInfo` 1 + `setStrictnessInfo` Just strict_sig + `setUnfoldingInfo` (if no_unf then noUnfolding + else mkImplicitUnfolding rhs) + -- In module where class op is defined, we must add + -- the unfolding, even though it'll never be inlined + -- becuase we use that to generate a top-level binding + -- for the ClassOp + + info | new_tycon = base_info + -- For newtype dictionaries, just inline the class op + -- See Note [Single-method classes] in TcInstDcls + | otherwise = base_info + `setSpecInfo` mkSpecInfo [rule] + `setInlinePragInfo` neverInlinePragma + -- Otherwise add a magic BuiltinRule, and never inline it + -- so that the rule is always available to fire. + -- See Note [ClassOp/DFun selection] in TcInstDcls + + n_ty_args = length tyvars + + -- This is the built-in rule that goes + -- op (dfT d1 d2) ---> opT d1 d2 + rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS` + occNameFS (getOccName name) + , ru_fn = name + , ru_nargs = n_ty_args + 1 + , ru_try = dictSelRule index n_ty_args } -- The strictness signature is of the form U(AAAVAAAA) -> T -- where the V depends on which item we are selecting -- It's worth giving one, so that absence info etc is generated -- even if the selector isn't inlined strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] TopRes) - arg_dmd | isNewTyCon tycon = evalDmd - | otherwise = Eval (Prod [ if the_arg_id == id then evalDmd else Abs - | id <- arg_ids ]) + arg_dmd | new_tycon = evalDmd + | otherwise = Eval (Prod [ if the_arg_id == id then evalDmd else Abs + | id <- arg_ids ]) tycon = classTyCon clas + new_tycon = isNewTyCon tycon [data_con] = tyConDataCons tycon tyvars = dataConUnivTyVars data_con arg_tys = {- ASSERT( isVanillaDataCon data_con ) -} dataConRepArgTys data_con eq_theta = dataConEqTheta data_con - the_arg_id = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` arg_ids) name + index = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` [0..]) name + the_arg_id = arg_ids !! index pred = mkClassPred clas (mkTyVarTys tyvars) - dict_id = mkTemplateLocal 1 $ mkPredTy pred - (eq_ids,n) = mkCoVarLocals 2 $ mkPredTys eq_theta + dict_id = mkTemplateLocal 1 $ mkPredTy pred + (eq_ids,n) = mkCoVarLocals 2 $ mkPredTys eq_theta arg_ids = mkTemplateLocalsNum n arg_tys mkCoVarLocals i [] = ([],i) @@ -493,9 +516,23 @@ in (y:ys,j) rhs = mkLams tyvars (Lam dict_id rhs_body) - rhs_body | isNewTyCon tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id) - | otherwise = Case (Var dict_id) dict_id (idType the_arg_id) - [(DataAlt data_con, eq_ids ++ arg_ids, Var the_arg_id)] + rhs_body | new_tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id) + | otherwise = Case (Var dict_id) dict_id (idType the_arg_id) + [(DataAlt data_con, eq_ids ++ arg_ids, Var the_arg_id)] + +dictSelRule :: Int -> Arity -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr +-- Oh, very clever +-- op_i t1..tk (df s1..sn d1..dm) = op_i_helper s1..sn d1..dm +-- op_i t1..tk (D t1..tk op1 ... opm) = opi +-- +-- NB: the data constructor has the same number of type args as the class op + +dictSelRule index n_ty_args id_unf args + | (dict_arg : _) <- drop n_ty_args args + , Just (_, _, val_args) <- exprIsConApp_maybe id_unf dict_arg + = Just (val_args !! index) + | otherwise + = Nothing \end{code} @@ -726,7 +763,7 @@ info = noCafIdInfo `setSpecInfo` mkSpecInfo (primOpRules prim_op name) `setArityInfo` arity - `setAllStrictnessInfo` Just strict_sig + `setStrictnessInfo` Just strict_sig -- For each ccall we manufacture a separate CCallOpId, giving it -- a fresh unique, a type that is correct for this particular ccall, @@ -752,7 +789,7 @@ info = noCafIdInfo `setArityInfo` arity - `setAllStrictnessInfo` Just strict_sig + `setStrictnessInfo` Just strict_sig (_, tau) = tcSplitForAllTys ty (arg_tys, _) = tcSplitFunTys tau @@ -825,8 +862,9 @@ -> Id mkDictFunId dfun_name inst_tyvars dfun_theta clas inst_tys - = mkExportedLocalVar DFunId dfun_name dfun_ty vanillaIdInfo + = mkExportedLocalVar (DFunId is_nt) dfun_name dfun_ty vanillaIdInfo where + is_nt = isNewTyCon (classTyCon clas) dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys) \end{code} @@ -905,6 +943,7 @@ seqId = pcMiscPrelId seqName ty info where info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs + `setSpecInfo` mkSpecInfo [seq_cast_rule] ty = mkForAllTys [alphaTyVar,openBetaTyVar] @@ -912,6 +951,20 @@ [x,y] = mkTemplateLocals [alphaTy, openBetaTy] rhs = mkLams [alphaTyVar,openBetaTyVar,x,y] (Case (Var x) x openBetaTy [(DEFAULT, [], Var y)]) + -- See Note [Built-in RULES for seq] + seq_cast_rule = BuiltinRule { ru_name = fsLit "seq of cast" + , ru_fn = seqName + , ru_nargs = 4 + , ru_try = match_seq_of_cast + } + +match_seq_of_cast :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr + -- See Note [Built-in RULES for seq] +match_seq_of_cast _ [Type _, Type res_ty, Cast scrut co, expr] + = Just (Var seqId `mkApps` [Type (fst (coercionKind co)), Type res_ty, + scrut, expr]) +match_seq_of_cast _ _ = Nothing + ------------------------------------------------ lazyId :: Id -- See Note [lazyId magic] lazyId = pcMiscPrelId lazyIdName ty info @@ -922,7 +975,7 @@ Note [seqId magic] ~~~~~~~~~~~~~~~~~~ -'seq' is special in several ways. +'GHC.Prim.seq' is special in several ways. a) Its second arg can have an unboxed type x `seq` (v +# w) @@ -932,10 +985,10 @@ c) It has quite a bit of desugaring magic. See DsUtils.lhs Note [Desugaring seq (1)] and (2) and (3) -d) There is some special rule handing: Note [RULES for seq] +d) There is some special rule handing: Note [User-defined RULES for seq] -Note [Rules for seq] -~~~~~~~~~~~~~~~~~~~~ +Note [User-defined RULES for seq] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Roman found situations where he had case (f n) of _ -> e where he knew that f (which was strict in n) would terminate if n did. @@ -957,6 +1010,20 @@ done in Note [seqId magic] item (c) is *not* done on the LHS of a rule. Or rather, we arrange to un-do it, in DsBinds.decomposeRuleLhs. +Note [Built-in RULES for seq] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We also have the following built-in rule for seq + + seq (x `cast` co) y = seq x y + +This eliminates unnecessary casts and also allows other seq rules to +match more often. Notably, + + seq (f x `cast` co) y --> seq (f x) y + +and now a user-defined rule for seq (see Note [User-defined RULES for seq]) +may fire. + Note [lazyId magic] ~~~~~~~~~~~~~~~~~~~ @@ -1091,7 +1158,7 @@ pc_bottoming_Id name ty = pcMiscPrelId name ty bottoming_info where - bottoming_info = vanillaIdInfo `setAllStrictnessInfo` Just strict_sig + bottoming_info = vanillaIdInfo `setStrictnessInfo` Just strict_sig `setArityInfo` 1 -- Make arity and strictness agree diff -ruN ghc-6.12.1/compiler/basicTypes/Name.lhs ghc-6.13.20091231/compiler/basicTypes/Name.lhs --- ghc-6.12.1/compiler/basicTypes/Name.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/basicTypes/Name.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -37,7 +37,7 @@ BuiltInSyntax(..), -- ** Creating 'Name's - mkInternalName, mkSystemName, + mkInternalName, mkSystemName, mkDerivedInternalName, mkSystemVarName, mkSysTvName, mkFCallName, mkIPName, mkTickBoxOpName, @@ -249,6 +249,11 @@ -- * for interface files we tidyCore first, which puts the uniques -- into the print name (see setNameVisibility below) +mkDerivedInternalName :: (OccName -> OccName) -> Unique -> Name -> Name +mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc }) + = Name { n_uniq = getKeyFastInt uniq, n_sort = Internal + , n_occ = derive_occ occ, n_loc = loc } + -- | Create a name which definitely originates in the given module mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name mkExternalName uniq mod occ loc diff -ruN ghc-6.12.1/compiler/basicTypes/NewDemand.lhs ghc-6.13.20091231/compiler/basicTypes/NewDemand.lhs --- ghc-6.12.1/compiler/basicTypes/NewDemand.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/basicTypes/NewDemand.lhs 1969-12-31 16:00:00.000000000 -0800 @@ -1,342 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[Demand]{@Demand@: the amount of demand on a value} - -\begin{code} -module NewDemand( - Demand(..), - topDmd, lazyDmd, seqDmd, evalDmd, errDmd, isStrictDmd, - isTop, isAbsent, seqDemand, - - DmdType(..), topDmdType, botDmdType, mkDmdType, mkTopDmdType, - dmdTypeDepth, seqDmdType, - DmdEnv, emptyDmdEnv, - DmdResult(..), retCPR, isBotRes, returnsCPR, resTypeArgDmd, - - Demands(..), mapDmds, zipWithDmds, allTop, seqDemands, - - StrictSig(..), mkStrictSig, topSig, botSig, cprSig, - isTopSig, - splitStrictSig, increaseStrictSigArity, - pprIfaceStrictSig, appIsBottom, isBottomingSig, seqStrictSig, - ) where - -#include "HsVersions.h" - -import StaticFlags -import BasicTypes -import VarEnv -import UniqFM -import Util -import Outputable -\end{code} - - -%************************************************************************ -%* * -\subsection{Demands} -%* * -%************************************************************************ - -\begin{code} -data Demand - = Top -- T; used for unlifted types too, so that - -- A `lub` T = T - | Abs -- A - - | Call Demand -- C(d) - - | Eval Demands -- U(ds) - - | Defer Demands -- D(ds) - - | Box Demand -- B(d) - - | Bot -- B - deriving( Eq ) - -- Equality needed for fixpoints in DmdAnal - -data Demands = Poly Demand -- Polymorphic case - | Prod [Demand] -- Product case - deriving( Eq ) - -allTop :: Demands -> Bool -allTop (Poly d) = isTop d -allTop (Prod ds) = all isTop ds - -isTop :: Demand -> Bool -isTop Top = True -isTop _ = False - -isAbsent :: Demand -> Bool -isAbsent Abs = True -isAbsent _ = False - -mapDmds :: (Demand -> Demand) -> Demands -> Demands -mapDmds f (Poly d) = Poly (f d) -mapDmds f (Prod ds) = Prod (map f ds) - -zipWithDmds :: (Demand -> Demand -> Demand) - -> Demands -> Demands -> Demands -zipWithDmds f (Poly d1) (Poly d2) = Poly (d1 `f` d2) -zipWithDmds f (Prod ds1) (Poly d2) = Prod [d1 `f` d2 | d1 <- ds1] -zipWithDmds f (Poly d1) (Prod ds2) = Prod [d1 `f` d2 | d2 <- ds2] -zipWithDmds f (Prod ds1) (Prod ds2) - | length ds1 == length ds2 = Prod (zipWithEqual "zipWithDmds" f ds1 ds2) - | otherwise = Poly topDmd - -- This really can happen with polymorphism - -- \f. case f x of (a,b) -> ... - -- case f y of (a,b,c) -> ... - -- Here the two demands on f are C(LL) and C(LLL)! - -topDmd, lazyDmd, seqDmd, evalDmd, errDmd :: Demand -topDmd = Top -- The most uninformative demand -lazyDmd = Box Abs -seqDmd = Eval (Poly Abs) -- Polymorphic seq demand -evalDmd = Box seqDmd -- Evaluate and return -errDmd = Box Bot -- This used to be called X - -isStrictDmd :: Demand -> Bool -isStrictDmd Bot = True -isStrictDmd (Eval _) = True -isStrictDmd (Call _) = True -isStrictDmd (Box d) = isStrictDmd d -isStrictDmd _ = False - -seqDemand :: Demand -> () -seqDemand (Call d) = seqDemand d -seqDemand (Eval ds) = seqDemands ds -seqDemand (Defer ds) = seqDemands ds -seqDemand (Box d) = seqDemand d -seqDemand _ = () - -seqDemands :: Demands -> () -seqDemands (Poly d) = seqDemand d -seqDemands (Prod ds) = seqDemandList ds - -seqDemandList :: [Demand] -> () -seqDemandList [] = () -seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds - -instance Outputable Demand where - ppr Top = char 'T' - ppr Abs = char 'A' - ppr Bot = char 'B' - - ppr (Defer ds) = char 'D' <> ppr ds - ppr (Eval ds) = char 'U' <> ppr ds - - ppr (Box (Eval ds)) = char 'S' <> ppr ds - ppr (Box Abs) = char 'L' - ppr (Box Bot) = char 'X' - ppr d@(Box _) = pprPanic "ppr: Bad boxed demand" (ppr d) - - ppr (Call d) = char 'C' <> parens (ppr d) - - -instance Outputable Demands where - ppr (Poly Abs) = empty - ppr (Poly d) = parens (ppr d <> char '*') - ppr (Prod ds) = parens (hcat (map ppr ds)) - -- At one time I printed U(AAA) as U, but that - -- confuses (Poly Abs) with (Prod AAA), and the - -- worker/wrapper generation differs slightly for these two - -- [Reason: in the latter case we can avoid passing the arg; - -- see notes with WwLib.mkWWstr_one.] -\end{code} - - -%************************************************************************ -%* * -\subsection{Demand types} -%* * -%************************************************************************ - -\begin{code} -data DmdType = DmdType - DmdEnv -- Demand on explicitly-mentioned - -- free variables - [Demand] -- Demand on arguments - DmdResult -- Nature of result - - -- IMPORTANT INVARIANT - -- The default demand on free variables not in the DmdEnv is: - -- DmdResult = BotRes <=> Bot - -- DmdResult = TopRes/ResCPR <=> Abs - - -- ANOTHER IMPORTANT INVARIANT - -- The Demands in the argument list are never - -- Bot, Defer d - -- Handwavey reason: these don't correspond to calling conventions - -- See DmdAnal.funArgDemand for details - - --- This guy lets us switch off CPR analysis --- by making sure that everything uses TopRes instead of RetCPR --- Assuming, of course, that they don't mention RetCPR by name. --- They should onlyu use retCPR -retCPR :: DmdResult -retCPR | opt_CprOff = TopRes - | otherwise = RetCPR - -seqDmdType :: DmdType -> () -seqDmdType (DmdType _env ds res) = - {- ??? env `seq` -} seqDemandList ds `seq` res `seq` () - -type DmdEnv = VarEnv Demand - -data DmdResult = TopRes -- Nothing known - | RetCPR -- Returns a constructed product - | BotRes -- Diverges or errors - deriving( Eq, Show ) - -- Equality for fixpoints - -- Show needed for Show in Lex.Token (sigh) - --- Equality needed for fixpoints in DmdAnal -instance Eq DmdType where - (==) (DmdType fv1 ds1 res1) - (DmdType fv2 ds2 res2) = ufmToList fv1 == ufmToList fv2 - && ds1 == ds2 && res1 == res2 - -instance Outputable DmdType where - ppr (DmdType fv ds res) - = hsep [text "DmdType", - hcat (map ppr ds) <> ppr res, - if null fv_elts then empty - else braces (fsep (map pp_elt fv_elts))] - where - pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd - fv_elts = ufmToList fv - -instance Outputable DmdResult where - ppr TopRes = empty -- Keep these distinct from Demand letters - ppr RetCPR = char 'm' -- so that we can print strictness sigs as - ppr BotRes = char 'b' -- dddr - -- without ambiguity - -emptyDmdEnv :: VarEnv Demand -emptyDmdEnv = emptyVarEnv - -topDmdType, botDmdType, cprDmdType :: DmdType -topDmdType = DmdType emptyDmdEnv [] TopRes -botDmdType = DmdType emptyDmdEnv [] BotRes -cprDmdType = DmdType emptyVarEnv [] retCPR - -isTopDmdType :: DmdType -> Bool --- Only used on top-level types, hence the assert -isTopDmdType (DmdType env [] TopRes) = ASSERT( isEmptyVarEnv env) True -isTopDmdType _ = False - -isBotRes :: DmdResult -> Bool -isBotRes BotRes = True -isBotRes _ = False - -resTypeArgDmd :: DmdResult -> Demand --- TopRes and BotRes are polymorphic, so that --- BotRes = Bot -> BotRes --- TopRes = Top -> TopRes --- This function makes that concrete --- We can get a RetCPR, because of the way in which we are (now) --- giving CPR info to strict arguments. On the first pass, when --- nothing has demand info, we optimistically give CPR info or RetCPR to all args -resTypeArgDmd TopRes = Top -resTypeArgDmd RetCPR = Top -resTypeArgDmd BotRes = Bot - -returnsCPR :: DmdResult -> Bool -returnsCPR RetCPR = True -returnsCPR _ = False - -mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType -mkDmdType fv ds res = DmdType fv ds res - -mkTopDmdType :: [Demand] -> DmdResult -> DmdType -mkTopDmdType ds res = DmdType emptyDmdEnv ds res - -dmdTypeDepth :: DmdType -> Arity -dmdTypeDepth (DmdType _ ds _) = length ds -\end{code} - - -%************************************************************************ -%* * -\subsection{Strictness signature -%* * -%************************************************************************ - -In a let-bound Id we record its strictness info. -In principle, this strictness info is a demand transformer, mapping -a demand on the Id into a DmdType, which gives - a) the free vars of the Id's value - b) the Id's arguments - c) an indication of the result of applying - the Id to its arguments - -However, in fact we store in the Id an extremely emascuated demand transfomer, -namely - a single DmdType -(Nevertheless we dignify StrictSig as a distinct type.) - -This DmdType gives the demands unleashed by the Id when it is applied -to as many arguments as are given in by the arg demands in the DmdType. - -For example, the demand transformer described by the DmdType - DmdType {x -> U(LL)} [V,A] Top -says that when the function is applied to two arguments, it -unleashes demand U(LL) on the free var x, V on the first arg, -and A on the second. - -If this same function is applied to one arg, all we can say is -that it uses x with U*(LL), and its arg with demand L. - -\begin{code} -newtype StrictSig = StrictSig DmdType - deriving( Eq ) - -instance Outputable StrictSig where - ppr (StrictSig ty) = ppr ty - -instance Show StrictSig where - show (StrictSig ty) = showSDoc (ppr ty) - -mkStrictSig :: DmdType -> StrictSig -mkStrictSig dmd_ty = StrictSig dmd_ty - -splitStrictSig :: StrictSig -> ([Demand], DmdResult) -splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res) - -increaseStrictSigArity :: Int -> StrictSig -> StrictSig --- Add extra arguments to a strictness signature -increaseStrictSigArity arity_increase (StrictSig (DmdType env dmds res)) - = StrictSig (DmdType env (replicate arity_increase topDmd ++ dmds) res) - -isTopSig :: StrictSig -> Bool -isTopSig (StrictSig ty) = isTopDmdType ty - -topSig, botSig, cprSig :: StrictSig -topSig = StrictSig topDmdType -botSig = StrictSig botDmdType -cprSig = StrictSig cprDmdType - - --- appIsBottom returns true if an application to n args would diverge -appIsBottom :: StrictSig -> Int -> Bool -appIsBottom (StrictSig (DmdType _ ds BotRes)) n = listLengthCmp ds n /= GT -appIsBottom _ _ = False - -isBottomingSig :: StrictSig -> Bool -isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True -isBottomingSig _ = False - -seqStrictSig :: StrictSig -> () -seqStrictSig (StrictSig ty) = seqDmdType ty - -pprIfaceStrictSig :: StrictSig -> SDoc --- Used for printing top-level strictness pragmas in interface files -pprIfaceStrictSig (StrictSig (DmdType _ dmds res)) - = hcat (map ppr dmds) <> ppr res -\end{code} - - diff -ruN ghc-6.12.1/compiler/basicTypes/OccName.lhs ghc-6.13.20091231/compiler/basicTypes/OccName.lhs --- ghc-6.12.1/compiler/basicTypes/OccName.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/basicTypes/OccName.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -49,7 +49,7 @@ -- ** Derived 'OccName's isDerivedOccName, mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, - mkDerivedTyConOcc, mkNewTyCoOcc, + mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc, mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, @@ -58,7 +58,7 @@ mkInstTyCoOcc, mkEqPredCoOcc, mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc, mkPDataTyConOcc, mkPDataDataConOcc, - mkPReprTyConOcc, + mkPReprTyConOcc, mkPADFunOcc, -- ** Deconstruction @@ -75,7 +75,7 @@ OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv, lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv, occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C, - filterOccEnv, delListFromOccEnv, delFromOccEnv, + extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv, -- * The 'OccSet' type OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet, @@ -98,7 +98,6 @@ import UniqFM import UniqSet import FastString -import FastTypes import Outputable import Binary import Data.Char @@ -304,22 +303,24 @@ OccEnvs are used mainly for the envts in ModIfaces. +Note [The Unique of an OccName] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ They are efficient, because FastStrings have unique Int# keys. We assume -this key is less than 2^24, so we can make a Unique using +this key is less than 2^24, and indeed FastStrings are allocated keys +sequentially starting at 0. + +So we can make a Unique using mkUnique ns key :: Unique where 'ns' is a Char reprsenting the name space. This in turn makes it easy to build an OccEnv. \begin{code} instance Uniquable OccName where - getUnique (OccName ns fs) - = mkUnique char (iBox (uniqueOfFS fs)) - where -- See notes above about this getUnique function - char = case ns of - VarName -> 'i' - DataName -> 'd' - TvName -> 'v' - TcClsName -> 't' + -- See Note [The Unique of an OccName] + getUnique (OccName VarName fs) = mkVarOccUnique fs + getUnique (OccName DataName fs) = mkDataOccUnique fs + getUnique (OccName TvName fs) = mkTvOccUnique fs + getUnique (OccName TcClsName fs) = mkTcOccUnique fs newtype OccEnv a = A (UniqFM a) @@ -334,6 +335,7 @@ foldOccEnv :: (a -> b -> b) -> b -> OccEnv a -> b occEnvElts :: OccEnv a -> [a] extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a +extendOccEnv_Acc :: (a->b->b) -> (a->b) -> OccEnv b -> OccName -> a -> OccEnv b plusOccEnv :: OccEnv a -> OccEnv a -> OccEnv a plusOccEnv_C :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a mapOccEnv :: (a->b) -> OccEnv a -> OccEnv b @@ -353,6 +355,7 @@ plusOccEnv (A x) (A y) = A $ plusUFM x y plusOccEnv_C f (A x) (A y) = A $ plusUFM_C f x y extendOccEnv_C f (A x) y z = A $ addToUFM_C f x y z +extendOccEnv_Acc f g (A x) y z = A $ addToUFM_Acc f g x y z mapOccEnv f (A x) = A $ mapUFM f x mkOccEnv_C comb l = A $ addListToUFM_C comb emptyUFM l delFromOccEnv (A x) y = A $ delFromUFM x y @@ -525,7 +528,7 @@ mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc, - mkInstTyCoOcc, mkEqPredCoOcc, + mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc, mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc, mkPDataTyConOcc, mkPDataDataConOcc, mkPReprTyConOcc, mkPADFunOcc @@ -535,6 +538,7 @@ mkDataConWrapperOcc = mk_simple_deriv varName "$W" mkWorkerOcc = mk_simple_deriv varName "$w" mkDefaultMethodOcc = mk_simple_deriv varName "$dm" +mkClassOpAuxOcc = mk_simple_deriv varName "$c" mkDerivedTyConOcc = mk_simple_deriv tcName ":" -- The : prefix makes sure it classifies mkClassTyConOcc = mk_simple_deriv tcName "T:" -- as a tycon/datacon mkClassDataConOcc = mk_simple_deriv dataName "D:" -- We go straight to the "real" data con @@ -543,9 +547,9 @@ mkIPOcc = mk_simple_deriv varName "$i" mkSpecOcc = mk_simple_deriv varName "$s" mkForeignExportOcc = mk_simple_deriv varName "$f" -mkNewTyCoOcc = mk_simple_deriv tcName "NTCo:" -- Coercion for newtypes -mkInstTyCoOcc = mk_simple_deriv tcName "TFCo:" -- Coercion for type functions -mkEqPredCoOcc = mk_simple_deriv tcName "$co" +mkNewTyCoOcc = mk_simple_deriv tcName "NTCo:" -- Coercion for newtypes +mkInstTyCoOcc = mk_simple_deriv tcName "TFCo:" -- Coercion for type functions +mkEqPredCoOcc = mk_simple_deriv tcName "$co" -- used in derived instances mkCon2TagOcc = mk_simple_deriv varName "$con2tag_" diff -ruN ghc-6.12.1/compiler/basicTypes/RdrName.lhs ghc-6.13.20091231/compiler/basicTypes/RdrName.lhs --- ghc-6.12.1/compiler/basicTypes/RdrName.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/basicTypes/RdrName.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -428,10 +428,9 @@ Just gres -> gres extendGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv -extendGlobalRdrEnv env gre = extendOccEnv_C add env occ [gre] +extendGlobalRdrEnv env gre = extendOccEnv_Acc (:) singleton env occ gre where occ = nameOccName (gre_name gre) - add gres _ = gre:gres lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt] lookupGRE_RdrName rdr_name env @@ -515,9 +514,9 @@ mkGlobalRdrEnv gres = foldr add emptyGlobalRdrEnv gres where - add gre env = extendOccEnv_C (foldr insertGRE) env - (nameOccName (gre_name gre)) - [gre] + add gre env = extendOccEnv_Acc insertGRE singleton env + (nameOccName (gre_name gre)) + gre findLocalDupsRdrEnv :: GlobalRdrEnv -> [OccName] -> (GlobalRdrEnv, [[Name]]) -- ^ For each 'OccName', see if there are multiple local definitions diff -ruN ghc-6.12.1/compiler/basicTypes/SrcLoc.lhs ghc-6.13.20091231/compiler/basicTypes/SrcLoc.lhs --- ghc-6.12.1/compiler/basicTypes/SrcLoc.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/basicTypes/SrcLoc.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -72,6 +72,8 @@ import Util import Outputable import FastString + +import Data.Bits \end{code} %************************************************************************ @@ -87,10 +89,7 @@ data SrcLoc = SrcLoc FastString -- A precise location (file name) {-# UNPACK #-} !Int -- line number, begins at 1 - {-# UNPACK #-} !Int -- column number, begins at 0 - -- Don't ask me why lines start at 1 and columns start at - -- zero. That's just the way it is, so there. --SDM - + {-# UNPACK #-} !Int -- column number, begins at 1 | UnhelpfulLoc FastString -- Just a general indication \end{code} @@ -127,19 +126,22 @@ -- | Raises an error when used on a "bad" 'SrcLoc' srcLocLine :: SrcLoc -> Int srcLocLine (SrcLoc _ l _) = l -srcLocLine _other = panic "srcLocLine: unknown line" +srcLocLine (UnhelpfulLoc s) = pprPanic "srcLocLine" (ftext s) -- | Raises an error when used on a "bad" 'SrcLoc' srcLocCol :: SrcLoc -> Int srcLocCol (SrcLoc _ _ c) = c -srcLocCol _other = panic "srcLocCol: unknown col" +srcLocCol (UnhelpfulLoc s) = pprPanic "srcLocCol" (ftext s) --- | Move the 'SrcLoc' down by one line if the character is a newline --- and across by one character in any other case +-- | Move the 'SrcLoc' down by one line if the character is a newline, +-- to the next 8-char tabstop if it is a tab, and across by one +-- character in any other case advanceSrcLoc :: SrcLoc -> Char -> SrcLoc -advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f (l + 1) 0 +advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f (l + 1) 1 +advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f l (((((c - 1) `shiftR` 3) + 1) + `shiftL` 3) + 1) advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1) -advanceSrcLoc loc _ = loc -- Better than nothing +advanceSrcLoc loc _ = loc -- Better than nothing \end{code} %************************************************************************ diff -ruN ghc-6.12.1/compiler/basicTypes/Unique.lhs ghc-6.13.20091231/compiler/basicTypes/Unique.lhs --- ghc-6.12.1/compiler/basicTypes/Unique.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/basicTypes/Unique.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -25,7 +25,6 @@ pprUnique, - mkUnique, -- Used in UniqSupply mkUniqueGrimily, -- Used in UniqSupply only! getKey, getKeyFastInt, -- Used in Var, UniqFM, Name only! @@ -47,6 +46,9 @@ mkPreludeTyConUnique, mkPreludeClassUnique, mkPArrDataConUnique, + mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique, + mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique, + mkBuiltinUnique, mkPseudoUniqueC, mkPseudoUniqueD, @@ -93,7 +95,6 @@ The stuff about unique *supplies* is handled further down this module. \begin{code} -mkUnique :: Char -> Int -> Unique -- Builds a unique from pieces unpkUnique :: Unique -> (Char, Int) -- The reverse mkUniqueGrimily :: Int -> Unique -- A trap-door for UniqSupply @@ -131,6 +132,9 @@ -- and as long as the Char fits in 8 bits, which we assume anyway! +mkUnique :: Char -> Int -> Unique -- Builds a unique from pieces +-- NOT EXPORTED, so that we can see all the Chars that +-- are used in this one module mkUnique c i = MkUnique (tag `bitOrFastInt` bits) where @@ -340,8 +344,7 @@ mkPrimOpIdUnique op = mkUnique '9' op mkPreludeMiscIdUnique i = mkUnique '0' i --- No numbers left anymore, so I pick something different for the character --- tag +-- No numbers left anymore, so I pick something different for the character tag mkPArrDataConUnique a = mkUnique ':' (2*a) -- The "tyvar uniques" print specially nicely: a, b, c, etc. @@ -358,5 +361,18 @@ mkPseudoUniqueD i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs mkPseudoUniqueE i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs mkPseudoUniqueH i = mkUnique 'H' i -- used in NCG spiller to create spill VirtualRegs + +mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique +mkRegSingleUnique = mkUnique 'R' +mkRegSubUnique = mkUnique 'S' +mkRegPairUnique = mkUnique 'P' +mkRegClassUnique = mkUnique 'L' + +mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique +-- See Note [The Unique of an OccName] in OccName +mkVarOccUnique fs = mkUnique 'i' (iBox (uniqueOfFS fs)) +mkDataOccUnique fs = mkUnique 'd' (iBox (uniqueOfFS fs)) +mkTvOccUnique fs = mkUnique 'v' (iBox (uniqueOfFS fs)) +mkTcOccUnique fs = mkUnique 'c' (iBox (uniqueOfFS fs)) \end{code} diff -ruN ghc-6.12.1/compiler/basicTypes/VarEnv.lhs ghc-6.13.20091231/compiler/basicTypes/VarEnv.lhs --- ghc-6.12.1/compiler/basicTypes/VarEnv.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/basicTypes/VarEnv.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -11,7 +11,7 @@ -- ** Manipulating these environments emptyVarEnv, unitVarEnv, mkVarEnv, elemVarEnv, varEnvElts, varEnvKeys, - extendVarEnv, extendVarEnv_C, extendVarEnvList, + extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnvList, plusVarEnv, plusVarEnv_C, delVarEnvList, delVarEnv, lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv, @@ -316,6 +316,7 @@ unitVarEnv :: Var -> a -> VarEnv a extendVarEnv :: VarEnv a -> Var -> a -> VarEnv a extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a +extendVarEnv_Acc :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a @@ -344,6 +345,7 @@ elemVarEnvByKey = elemUFM_Directly extendVarEnv = addToUFM extendVarEnv_C = addToUFM_C +extendVarEnv_Acc = addToUFM_Acc extendVarEnvList = addListToUFM plusVarEnv_C = plusUFM_C delVarEnvList = delListFromUFM diff -ruN ghc-6.12.1/compiler/basicTypes/Var.lhs ghc-6.13.20091231/compiler/basicTypes/Var.lhs --- ghc-6.12.1/compiler/basicTypes/Var.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/basicTypes/Var.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -363,7 +363,7 @@ %************************************************************************ \begin{code} -isTyVar :: Var -> Bool +isTyVar :: Var -> Bool -- True of both type and coercion variables isTyVar (TyVar {}) = True isTyVar (TcTyVar {}) = True isTyVar _ = False diff -ruN ghc-6.12.1/compiler/cmm/CLabel.hs ghc-6.13.20091231/compiler/cmm/CLabel.hs --- ghc-6.12.1/compiler/cmm/CLabel.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/cmm/CLabel.hs 2009-12-31 10:14:17.000000000 -0800 @@ -73,20 +73,13 @@ mkSelectorInfoLabel, mkSelectorEntryLabel, - mkRtsInfoLabel, - mkRtsEntryLabel, - mkRtsRetInfoLabel, - mkRtsRetLabel, - mkRtsCodeLabel, - mkRtsDataLabel, - mkRtsGcPtrLabel, - - mkRtsInfoLabelFS, - mkRtsEntryLabelFS, - mkRtsRetInfoLabelFS, - mkRtsRetLabelFS, - mkRtsCodeLabelFS, - mkRtsDataLabelFS, + mkCmmInfoLabel, + mkCmmEntryLabel, + mkCmmRetInfoLabel, + mkCmmRetLabel, + mkCmmCodeLabel, + mkCmmDataLabel, + mkCmmGcPtrLabel, mkRtsApFastLabel, @@ -141,7 +134,7 @@ -- The CLabel type {- -CLabel is an abstract type that supports the following operations: + | CLabel is an abstract type that supports the following operations: - Pretty printing @@ -163,13 +156,35 @@ -} data CLabel - = IdLabel -- A family of labels related to the - Name -- definition of a particular Id or Con + = -- | A label related to the definition of a particular Id or Con in a .hs file. + IdLabel + Name CafInfo - IdLabelInfo + IdLabelInfo -- encodes the suffix of the label + + -- | A label from a .cmm file that is not associated with a .hs level Id. + | CmmLabel + PackageId -- what package the label belongs to. + FastString -- identifier giving the prefix of the label + CmmLabelInfo -- encodes the suffix of the label + + -- | A label with a baked-in \/ algorithmically generated name that definitely + -- comes from the RTS. The code for it must compile into libHSrts.a \/ libHSrts.so + -- If it doesn't have an algorithmically generated name then use a CmmLabel + -- instead and give it an appropriate Module argument. + | RtsLabel + RtsLabelInfo + + -- | A 'C' (or otherwise foreign) label + | ForeignLabel FastString + (Maybe Int) -- possible '@n' suffix for stdcall functions + -- When generating C, the '@n' suffix is omitted, but when + -- generating assembler we must add it to the label. + Bool -- True <=> is dynamic + FunctionOrData - | CaseLabel -- A family of labels related to a particular - -- case expression. + -- | A family of labels related to a particular case expression. + | CaseLabel {-# UNPACK #-} !Unique -- Unique says which case expression CaseLabelInfo @@ -196,62 +211,57 @@ | ModuleRegdLabel - | RtsLabel RtsLabelInfo - - | ForeignLabel FastString -- a 'C' (or otherwise foreign) label - (Maybe Int) -- possible '@n' suffix for stdcall functions - -- When generating C, the '@n' suffix is omitted, but when - -- generating assembler we must add it to the label. - Bool -- True <=> is dynamic - FunctionOrData - | CC_Label CostCentre | CCS_Label CostCentreStack - -- Dynamic Linking in the NCG: - -- generated and used inside the NCG only, - -- see module PositionIndependentCode for details. - + + -- | These labels are generated and used inside the NCG only. + -- They are special variants of a label used for dynamic linking + -- see module PositionIndependentCode for details. | DynamicLinkerLabel DynamicLinkerLabelInfo CLabel - -- special variants of a label used for dynamic linking + + -- | This label is generated and used inside the NCG only. + -- It is used as a base for PIC calculations on some platforms. + -- It takes the form of a local numeric assembler label '1'; and + -- is pretty-printed as 1b, referring to the previous definition + -- of 1: in the assembler source file. + | PicBaseLabel + + -- | A label before an info table to prevent excessive dead-stripping on darwin + | DeadStripPreventer CLabel - | PicBaseLabel -- a label used as a base for PIC calculations - -- on some platforms. - -- It takes the form of a local numeric - -- assembler label '1'; it is pretty-printed - -- as 1b, referring to the previous definition - -- of 1: in the assembler source file. - | DeadStripPreventer CLabel - -- label before an info table to prevent excessive dead-stripping on darwin + -- | Per-module table of tick locations + | HpcTicksLabel Module - | HpcTicksLabel Module -- Per-module table of tick locations - | HpcModuleNameLabel -- Per-module name of the module for Hpc + -- | Per-module name of the module for Hpc + | HpcModuleNameLabel - | LargeSRTLabel -- Label of an StgLargeSRT + -- | Label of an StgLargeSRT + | LargeSRTLabel {-# UNPACK #-} !Unique - | LargeBitmapLabel -- A bitmap (function or case return) + -- | A bitmap (function or case return) + | LargeBitmapLabel {-# UNPACK #-} !Unique deriving (Eq, Ord) data IdLabelInfo - = Closure -- Label for closure - | SRT -- Static reference table - | InfoTable -- Info tables for closures; always read-only - | Entry -- entry point - | Slow -- slow entry point - - | RednCounts -- Label of place to keep Ticky-ticky info for - -- this Id - - | ConEntry -- constructor entry point - | ConInfoTable -- corresponding info table - | StaticConEntry -- static constructor entry point - | StaticInfoTable -- corresponding info table + = Closure -- ^ Label for closure + | SRT -- ^ Static reference table + | InfoTable -- ^ Info tables for closures; always read-only + | Entry -- ^ Entry point + | Slow -- ^ Slow entry point + + | RednCounts -- ^ Label of place to keep Ticky-ticky info for this Id + + | ConEntry -- ^ Constructor entry point + | ConInfoTable -- ^ Corresponding info table + | StaticConEntry -- ^ Static constructor entry point + | StaticInfoTable -- ^ Corresponding info table - | ClosureTable -- table of closures for Enum tycons + | ClosureTable -- ^ Table of closures for Enum tycons deriving (Eq, Ord) @@ -265,50 +275,50 @@ data RtsLabelInfo - = RtsSelectorInfoTable Bool{-updatable-} Int{-offset-} -- Selector thunks - | RtsSelectorEntry Bool{-updatable-} Int{-offset-} + = RtsSelectorInfoTable Bool{-updatable-} Int{-offset-} -- ^ Selector thunks + | RtsSelectorEntry Bool{-updatable-} Int{-offset-} - | RtsApInfoTable Bool{-updatable-} Int{-arity-} -- AP thunks - | RtsApEntry Bool{-updatable-} Int{-arity-} + | RtsApInfoTable Bool{-updatable-} Int{-arity-} -- ^ AP thunks + | RtsApEntry Bool{-updatable-} Int{-arity-} | RtsPrimOp PrimOp + | RtsApFast FastString -- ^ _fast versions of generic apply + | RtsSlowTickyCtr String - | RtsInfo LitString -- misc rts info tables - | RtsEntry LitString -- misc rts entry points - | RtsRetInfo LitString -- misc rts ret info tables - | RtsRet LitString -- misc rts return points - | RtsData LitString -- misc rts data bits - | RtsGcPtr LitString -- GcPtrs eg CHARLIKE_closure - | RtsCode LitString -- misc rts code - - | RtsInfoFS FastString -- misc rts info tables - | RtsEntryFS FastString -- misc rts entry points - | RtsRetInfoFS FastString -- misc rts ret info tables - | RtsRetFS FastString -- misc rts return points - | RtsDataFS FastString -- misc rts data bits, eg CHARLIKE_closure - | RtsCodeFS FastString -- misc rts code - - | RtsApFast LitString -- _fast versions of generic apply + deriving (Eq, Ord) + -- NOTE: Eq on LitString compares the pointer only, so this isn't + -- a real equality. - | RtsSlowTickyCtr String +-- | What type of Cmm label we're dealing with. +-- Determines the suffix appended to the name when a CLabel.CmmLabel +-- is pretty printed. +data CmmLabelInfo + = CmmInfo -- ^ misc rts info tabless, suffix _info + | CmmEntry -- ^ misc rts entry points, suffix _entry + | CmmRetInfo -- ^ misc rts ret info tables, suffix _info + | CmmRet -- ^ misc rts return points, suffix _ret + | CmmData -- ^ misc rts data bits, eg CHARLIKE_closure + | CmmCode -- ^ misc rts code + | CmmGcPtr -- ^ GcPtrs eg CHARLIKE_closure deriving (Eq, Ord) - -- NOTE: Eq on LitString compares the pointer only, so this isn't - -- a real equality. data DynamicLinkerLabelInfo - = CodeStub -- MachO: Lfoo$stub, ELF: foo@plt - | SymbolPtr -- MachO: Lfoo$non_lazy_ptr, Windows: __imp_foo - | GotSymbolPtr -- ELF: foo@got - | GotSymbolOffset -- ELF: foo@gotoff + = CodeStub -- MachO: Lfoo$stub, ELF: foo@plt + | SymbolPtr -- MachO: Lfoo$non_lazy_ptr, Windows: __imp_foo + | GotSymbolPtr -- ELF: foo@got + | GotSymbolOffset -- ELF: foo@gotoff deriving (Eq, Ord) - + + -- ----------------------------------------------------------------------------- -- Constructing CLabels +-- ----------------------------------------------------------------------------- +-- Constructing IdLabels -- These are always local: -mkSRTLabel name c = IdLabel name c SRT +mkSRTLabel name c = IdLabel name c SRT mkSlowEntryLabel name c = IdLabel name c Slow mkRednCountsLabel name c = IdLabel name c RednCounts @@ -332,155 +342,164 @@ mkConEntryLabel name c = IdLabel name c ConEntry mkStaticConEntryLabel name c = IdLabel name c StaticConEntry -mkLargeSRTLabel uniq = LargeSRTLabel uniq -mkBitmapLabel uniq = LargeBitmapLabel uniq +-- Constructing Cmm Labels +mkSplitMarkerLabel = CmmLabel rtsPackageId (fsLit "__stg_split_marker") CmmCode +mkDirty_MUT_VAR_Label = CmmLabel rtsPackageId (fsLit "dirty_MUT_VAR") CmmCode +mkUpdInfoLabel = CmmLabel rtsPackageId (fsLit "stg_upd_frame") CmmInfo +mkIndStaticInfoLabel = CmmLabel rtsPackageId (fsLit "stg_IND_STATIC") CmmInfo +mkMainCapabilityLabel = CmmLabel rtsPackageId (fsLit "MainCapability") CmmData +mkMAP_FROZEN_infoLabel = CmmLabel rtsPackageId (fsLit "stg_MUT_ARR_PTRS_FROZEN0") CmmInfo +mkMAP_DIRTY_infoLabel = CmmLabel rtsPackageId (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo +mkEMPTY_MVAR_infoLabel = CmmLabel rtsPackageId (fsLit "stg_EMPTY_MVAR") CmmInfo +mkTopTickyCtrLabel = CmmLabel rtsPackageId (fsLit "top_ct") CmmData +mkCAFBlackHoleInfoTableLabel = CmmLabel rtsPackageId (fsLit "stg_CAF_BLACKHOLE") CmmInfo + +----- +mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel, + mkCmmCodeLabel, mkCmmDataLabel, mkCmmGcPtrLabel + :: PackageId -> FastString -> CLabel + +mkCmmInfoLabel pkg str = CmmLabel pkg str CmmInfo +mkCmmEntryLabel pkg str = CmmLabel pkg str CmmEntry +mkCmmRetInfoLabel pkg str = CmmLabel pkg str CmmRetInfo +mkCmmRetLabel pkg str = CmmLabel pkg str CmmRet +mkCmmCodeLabel pkg str = CmmLabel pkg str CmmCode +mkCmmDataLabel pkg str = CmmLabel pkg str CmmData +mkCmmGcPtrLabel pkg str = CmmLabel pkg str CmmGcPtr -mkReturnPtLabel uniq = CaseLabel uniq CaseReturnPt -mkReturnInfoLabel uniq = CaseLabel uniq CaseReturnInfo -mkAltLabel uniq tag = CaseLabel uniq (CaseAlt tag) -mkDefaultLabel uniq = CaseLabel uniq CaseDefault -mkStringLitLabel = StringLitLabel -mkAsmTempLabel :: Uniquable a => a -> CLabel -mkAsmTempLabel a = AsmTempLabel (getUnique a) - -mkModuleInitLabel :: Module -> String -> CLabel -mkModuleInitLabel mod way = ModuleInitLabel mod way - -mkPlainModuleInitLabel :: Module -> CLabel -mkPlainModuleInitLabel mod = PlainModuleInitLabel mod - -mkModuleInitTableLabel :: Module -> CLabel -mkModuleInitTableLabel mod = ModuleInitTableLabel mod - - -- Some fixed runtime system labels - -mkSplitMarkerLabel = RtsLabel (RtsCode (sLit "__stg_split_marker")) -mkDirty_MUT_VAR_Label = RtsLabel (RtsCode (sLit "dirty_MUT_VAR")) -mkUpdInfoLabel = RtsLabel (RtsInfo (sLit "stg_upd_frame")) -mkIndStaticInfoLabel = RtsLabel (RtsInfo (sLit "stg_IND_STATIC")) -mkMainCapabilityLabel = RtsLabel (RtsData (sLit "MainCapability")) -mkMAP_FROZEN_infoLabel = RtsLabel (RtsInfo (sLit "stg_MUT_ARR_PTRS_FROZEN0")) -mkMAP_DIRTY_infoLabel = RtsLabel (RtsInfo (sLit "stg_MUT_ARR_PTRS_DIRTY")) -mkEMPTY_MVAR_infoLabel = RtsLabel (RtsInfo (sLit "stg_EMPTY_MVAR")) - -mkTopTickyCtrLabel = RtsLabel (RtsData (sLit "top_ct")) -mkCAFBlackHoleInfoTableLabel = RtsLabel (RtsInfo (sLit "stg_CAF_BLACKHOLE")) +-- Constructing RtsLabels mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop) -moduleRegdLabel = ModuleRegdLabel -moduleRegTableLabel = ModuleInitTableLabel - mkSelectorInfoLabel upd off = RtsLabel (RtsSelectorInfoTable upd off) -mkSelectorEntryLabel upd off = RtsLabel (RtsSelectorEntry upd off) +mkSelectorEntryLabel upd off = RtsLabel (RtsSelectorEntry upd off) -mkApInfoTableLabel upd off = RtsLabel (RtsApInfoTable upd off) -mkApEntryLabel upd off = RtsLabel (RtsApEntry upd off) +mkApInfoTableLabel upd off = RtsLabel (RtsApInfoTable upd off) +mkApEntryLabel upd off = RtsLabel (RtsApEntry upd off) - -- Primitive / cmm call labels +-- Constructing ForeignLabels +-- Primitive / cmm call labels mkPrimCallLabel :: PrimCall -> CLabel mkPrimCallLabel (PrimCall str) = ForeignLabel str Nothing False IsFunction - -- Foreign labels - +-- Foreign labels mkForeignLabel :: FastString -> Maybe Int -> Bool -> FunctionOrData -> CLabel mkForeignLabel str mb_sz is_dynamic fod = ForeignLabel str mb_sz is_dynamic fod addLabelSize :: CLabel -> Int -> CLabel addLabelSize (ForeignLabel str _ is_dynamic fod) sz - = ForeignLabel str (Just sz) is_dynamic fod + = ForeignLabel str (Just sz) is_dynamic fod addLabelSize label _ - = label + = label foreignLabelStdcallInfo :: CLabel -> Maybe Int foreignLabelStdcallInfo (ForeignLabel _ info _ _) = info foreignLabelStdcallInfo _lbl = Nothing - -- Cost centres etc. -mkCCLabel cc = CC_Label cc -mkCCSLabel ccs = CCS_Label ccs +-- Constructing Large*Labels +mkLargeSRTLabel uniq = LargeSRTLabel uniq +mkBitmapLabel uniq = LargeBitmapLabel uniq + + +-- Constructin CaseLabels +mkReturnPtLabel uniq = CaseLabel uniq CaseReturnPt +mkReturnInfoLabel uniq = CaseLabel uniq CaseReturnInfo +mkAltLabel uniq tag = CaseLabel uniq (CaseAlt tag) +mkDefaultLabel uniq = CaseLabel uniq CaseDefault -mkRtsInfoLabel str = RtsLabel (RtsInfo str) -mkRtsEntryLabel str = RtsLabel (RtsEntry str) -mkRtsRetInfoLabel str = RtsLabel (RtsRetInfo str) -mkRtsRetLabel str = RtsLabel (RtsRet str) -mkRtsCodeLabel str = RtsLabel (RtsCode str) -mkRtsDataLabel str = RtsLabel (RtsData str) -mkRtsGcPtrLabel str = RtsLabel (RtsGcPtr str) - -mkRtsInfoLabelFS str = RtsLabel (RtsInfoFS str) -mkRtsEntryLabelFS str = RtsLabel (RtsEntryFS str) -mkRtsRetInfoLabelFS str = RtsLabel (RtsRetInfoFS str) -mkRtsRetLabelFS str = RtsLabel (RtsRetFS str) -mkRtsCodeLabelFS str = RtsLabel (RtsCodeFS str) -mkRtsDataLabelFS str = RtsLabel (RtsDataFS str) +-- Constructing Cost Center Labels +mkCCLabel cc = CC_Label cc +mkCCSLabel ccs = CCS_Label ccs mkRtsApFastLabel str = RtsLabel (RtsApFast str) mkRtsSlowTickyCtrLabel :: String -> CLabel mkRtsSlowTickyCtrLabel pat = RtsLabel (RtsSlowTickyCtr pat) - -- Coverage +-- Constructing Code Coverage Labels mkHpcTicksLabel = HpcTicksLabel mkHpcModuleNameLabel = HpcModuleNameLabel - -- Dynamic linking - + +-- Constructing labels used for dynamic linking mkDynamicLinkerLabel :: DynamicLinkerLabelInfo -> CLabel -> CLabel -mkDynamicLinkerLabel = DynamicLinkerLabel +mkDynamicLinkerLabel = DynamicLinkerLabel dynamicLinkerLabelInfo :: CLabel -> Maybe (DynamicLinkerLabelInfo, CLabel) dynamicLinkerLabelInfo (DynamicLinkerLabel info lbl) = Just (info, lbl) -dynamicLinkerLabelInfo _ = Nothing - - -- Position independent code - +dynamicLinkerLabelInfo _ = Nothing + mkPicBaseLabel :: CLabel -mkPicBaseLabel = PicBaseLabel +mkPicBaseLabel = PicBaseLabel + +-- Constructing miscellaneous other labels mkDeadStripPreventer :: CLabel -> CLabel -mkDeadStripPreventer lbl = DeadStripPreventer lbl +mkDeadStripPreventer lbl = DeadStripPreventer lbl + +mkStringLitLabel :: Unique -> CLabel +mkStringLitLabel = StringLitLabel + +mkAsmTempLabel :: Uniquable a => a -> CLabel +mkAsmTempLabel a = AsmTempLabel (getUnique a) + +mkModuleInitLabel :: Module -> String -> CLabel +mkModuleInitLabel mod way = ModuleInitLabel mod way + +mkPlainModuleInitLabel :: Module -> CLabel +mkPlainModuleInitLabel mod = PlainModuleInitLabel mod + +mkModuleInitTableLabel :: Module -> CLabel +mkModuleInitTableLabel mod = ModuleInitTableLabel mod + +moduleRegdLabel = ModuleRegdLabel +moduleRegTableLabel = ModuleInitTableLabel + -- ----------------------------------------------------------------------------- -- Converting between info labels and entry/ret labels. infoLblToEntryLbl :: CLabel -> CLabel -infoLblToEntryLbl (IdLabel n c InfoTable) = IdLabel n c Entry -infoLblToEntryLbl (IdLabel n c ConInfoTable) = IdLabel n c ConEntry -infoLblToEntryLbl (IdLabel n c StaticInfoTable) = IdLabel n c StaticConEntry -infoLblToEntryLbl (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt -infoLblToEntryLbl (RtsLabel (RtsInfo s)) = RtsLabel (RtsEntry s) -infoLblToEntryLbl (RtsLabel (RtsRetInfo s)) = RtsLabel (RtsRet s) -infoLblToEntryLbl (RtsLabel (RtsInfoFS s)) = RtsLabel (RtsEntryFS s) -infoLblToEntryLbl (RtsLabel (RtsRetInfoFS s)) = RtsLabel (RtsRetFS s) -infoLblToEntryLbl _ = panic "CLabel.infoLblToEntryLbl" +infoLblToEntryLbl (IdLabel n c InfoTable) = IdLabel n c Entry +infoLblToEntryLbl (IdLabel n c ConInfoTable) = IdLabel n c ConEntry +infoLblToEntryLbl (IdLabel n c StaticInfoTable) = IdLabel n c StaticConEntry +infoLblToEntryLbl (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt +infoLblToEntryLbl (CmmLabel m str CmmInfo) = CmmLabel m str CmmEntry +infoLblToEntryLbl (CmmLabel m str CmmRetInfo) = CmmLabel m str CmmRet +infoLblToEntryLbl _ + = panic "CLabel.infoLblToEntryLbl" + entryLblToInfoLbl :: CLabel -> CLabel -entryLblToInfoLbl (IdLabel n c Entry) = IdLabel n c InfoTable -entryLblToInfoLbl (IdLabel n c ConEntry) = IdLabel n c ConInfoTable -entryLblToInfoLbl (IdLabel n c StaticConEntry) = IdLabel n c StaticInfoTable -entryLblToInfoLbl (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo -entryLblToInfoLbl (RtsLabel (RtsEntry s)) = RtsLabel (RtsInfo s) -entryLblToInfoLbl (RtsLabel (RtsRet s)) = RtsLabel (RtsRetInfo s) -entryLblToInfoLbl (RtsLabel (RtsEntryFS s)) = RtsLabel (RtsInfoFS s) -entryLblToInfoLbl (RtsLabel (RtsRetFS s)) = RtsLabel (RtsRetInfoFS s) -entryLblToInfoLbl l = pprPanic "CLabel.entryLblToInfoLbl" (pprCLabel l) - -cvtToClosureLbl (IdLabel n c InfoTable) = IdLabel n c Closure -cvtToClosureLbl (IdLabel n c Entry) = IdLabel n c Closure -cvtToClosureLbl (IdLabel n c ConEntry) = IdLabel n c Closure -cvtToClosureLbl l@(IdLabel n c Closure) = l -cvtToClosureLbl l = pprPanic "cvtToClosureLbl" (pprCLabel l) - -cvtToSRTLbl (IdLabel n c InfoTable) = mkSRTLabel n c -cvtToSRTLbl (IdLabel n c Entry) = mkSRTLabel n c -cvtToSRTLbl (IdLabel n c ConEntry) = mkSRTLabel n c -cvtToSRTLbl l@(IdLabel n c Closure) = mkSRTLabel n c -cvtToSRTLbl l = pprPanic "cvtToSRTLbl" (pprCLabel l) +entryLblToInfoLbl (IdLabel n c Entry) = IdLabel n c InfoTable +entryLblToInfoLbl (IdLabel n c ConEntry) = IdLabel n c ConInfoTable +entryLblToInfoLbl (IdLabel n c StaticConEntry) = IdLabel n c StaticInfoTable +entryLblToInfoLbl (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo +entryLblToInfoLbl (CmmLabel m str CmmEntry) = CmmLabel m str CmmInfo +entryLblToInfoLbl (CmmLabel m str CmmRet) = CmmLabel m str CmmRetInfo +entryLblToInfoLbl l + = pprPanic "CLabel.entryLblToInfoLbl" (pprCLabel l) + + +cvtToClosureLbl (IdLabel n c InfoTable) = IdLabel n c Closure +cvtToClosureLbl (IdLabel n c Entry) = IdLabel n c Closure +cvtToClosureLbl (IdLabel n c ConEntry) = IdLabel n c Closure +cvtToClosureLbl l@(IdLabel n c Closure) = l +cvtToClosureLbl l + = pprPanic "cvtToClosureLbl" (pprCLabel l) + + +cvtToSRTLbl (IdLabel n c InfoTable) = mkSRTLabel n c +cvtToSRTLbl (IdLabel n c Entry) = mkSRTLabel n c +cvtToSRTLbl (IdLabel n c ConEntry) = mkSRTLabel n c +cvtToSRTLbl l@(IdLabel n c Closure) = mkSRTLabel n c +cvtToSRTLbl l + = pprPanic "cvtToSRTLbl" (pprCLabel l) + -- ----------------------------------------------------------------------------- -- Does a CLabel refer to a CAF? @@ -488,6 +507,7 @@ hasCAF (IdLabel _ MayHaveCafRefs _) = True hasCAF _ = False + -- ----------------------------------------------------------------------------- -- Does a CLabel need declaring before use or not? -- @@ -510,25 +530,31 @@ needsCDecl (StringLitLabel _) = False needsCDecl (AsmTempLabel _) = False needsCDecl (RtsLabel _) = False +needsCDecl (CmmLabel _ _ _) = False needsCDecl l@(ForeignLabel _ _ _ _) = not (isMathFun l) needsCDecl (CC_Label _) = True needsCDecl (CCS_Label _) = True needsCDecl (HpcTicksLabel _) = True needsCDecl HpcModuleNameLabel = False --- Whether the label is an assembler temporary: -isAsmTemp :: CLabel -> Bool -- is a local temporary for native code generation -isAsmTemp (AsmTempLabel _) = True -isAsmTemp _ = False +-- | Check whether a label is a local temporary for native code generation +isAsmTemp :: CLabel -> Bool +isAsmTemp (AsmTempLabel _) = True +isAsmTemp _ = False + +-- | If a label is a local temporary used for native code generation +-- then return just its unique, otherwise nothing. maybeAsmTemp :: CLabel -> Maybe Unique -maybeAsmTemp (AsmTempLabel uq) = Just uq -maybeAsmTemp _ = Nothing +maybeAsmTemp (AsmTempLabel uq) = Just uq +maybeAsmTemp _ = Nothing --- some labels have C prototypes in scope when compiling via C, because --- they are builtin to the C compiler. For these labels we avoid --- generating our own C prototypes. + +-- Check whether a label corresponds to a C function that has +-- a prototype in a system header somehere, or is built-in +-- to the C compiler. For these labels we abovoid generating our +-- own C prototypes. isMathFun :: CLabel -> Bool isMathFun (ForeignLabel fs _ _ _) = fs `elementOfUniqSet` math_funs isMathFun _ = False @@ -621,23 +647,24 @@ -- in the .o file's symbol table; that is, made non-static. externallyVisibleCLabel :: CLabel -> Bool -- not C "static" -externallyVisibleCLabel (CaseLabel _ _) = False -externallyVisibleCLabel (StringLitLabel _) = False -externallyVisibleCLabel (AsmTempLabel _) = False -externallyVisibleCLabel (ModuleInitLabel _ _) = True +externallyVisibleCLabel (CaseLabel _ _) = False +externallyVisibleCLabel (StringLitLabel _) = False +externallyVisibleCLabel (AsmTempLabel _) = False +externallyVisibleCLabel (ModuleInitLabel _ _) = True externallyVisibleCLabel (PlainModuleInitLabel _)= True externallyVisibleCLabel (ModuleInitTableLabel _)= False -externallyVisibleCLabel ModuleRegdLabel = False -externallyVisibleCLabel (RtsLabel _) = True -externallyVisibleCLabel (ForeignLabel _ _ _ _) = True -externallyVisibleCLabel (IdLabel name _ _) = isExternalName name -externallyVisibleCLabel (CC_Label _) = True -externallyVisibleCLabel (CCS_Label _) = True +externallyVisibleCLabel ModuleRegdLabel = False +externallyVisibleCLabel (RtsLabel _) = True +externallyVisibleCLabel (CmmLabel _ _ _) = True +externallyVisibleCLabel (ForeignLabel _ _ _ _) = True +externallyVisibleCLabel (IdLabel name _ _) = isExternalName name +externallyVisibleCLabel (CC_Label _) = True +externallyVisibleCLabel (CCS_Label _) = True externallyVisibleCLabel (DynamicLinkerLabel _ _) = False -externallyVisibleCLabel (HpcTicksLabel _) = True -externallyVisibleCLabel HpcModuleNameLabel = False -externallyVisibleCLabel (LargeBitmapLabel _) = False -externallyVisibleCLabel (LargeSRTLabel _) = False +externallyVisibleCLabel (HpcTicksLabel _) = True +externallyVisibleCLabel HpcModuleNameLabel = False +externallyVisibleCLabel (LargeBitmapLabel _) = False +externallyVisibleCLabel (LargeSRTLabel _) = False -- ----------------------------------------------------------------------------- -- Finding the "type" of a CLabel @@ -659,33 +686,30 @@ GcPtrLabel -> True _other -> False + +-- | Work out the general type of data at the address of this label +-- whether it be code, data, or static GC object. labelType :: CLabel -> CLabelType +labelType (CmmLabel _ _ CmmData) = DataLabel +labelType (CmmLabel _ _ CmmGcPtr) = GcPtrLabel +labelType (CmmLabel _ _ CmmCode) = CodeLabel +labelType (CmmLabel _ _ CmmInfo) = DataLabel +labelType (CmmLabel _ _ CmmEntry) = CodeLabel +labelType (CmmLabel _ _ CmmRetInfo) = DataLabel +labelType (CmmLabel _ _ CmmRet) = CodeLabel labelType (RtsLabel (RtsSelectorInfoTable _ _)) = DataLabel labelType (RtsLabel (RtsApInfoTable _ _)) = DataLabel -labelType (RtsLabel (RtsData _)) = DataLabel -labelType (RtsLabel (RtsGcPtr _)) = GcPtrLabel -labelType (RtsLabel (RtsCode _)) = CodeLabel -labelType (RtsLabel (RtsInfo _)) = DataLabel -labelType (RtsLabel (RtsEntry _)) = CodeLabel -labelType (RtsLabel (RtsRetInfo _)) = DataLabel -labelType (RtsLabel (RtsRet _)) = CodeLabel -labelType (RtsLabel (RtsDataFS _)) = DataLabel -labelType (RtsLabel (RtsCodeFS _)) = CodeLabel -labelType (RtsLabel (RtsInfoFS _)) = DataLabel -labelType (RtsLabel (RtsEntryFS _)) = CodeLabel -labelType (RtsLabel (RtsRetInfoFS _)) = DataLabel -labelType (RtsLabel (RtsRetFS _)) = CodeLabel -labelType (RtsLabel (RtsApFast _)) = CodeLabel -labelType (CaseLabel _ CaseReturnInfo) = DataLabel -labelType (CaseLabel _ _) = CodeLabel -labelType (ModuleInitLabel _ _) = CodeLabel -labelType (PlainModuleInitLabel _) = CodeLabel -labelType (ModuleInitTableLabel _) = DataLabel -labelType (LargeSRTLabel _) = DataLabel -labelType (LargeBitmapLabel _) = DataLabel -labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel -labelType (IdLabel _ _ info) = idInfoLabelType info -labelType _ = DataLabel +labelType (RtsLabel (RtsApFast _)) = CodeLabel +labelType (CaseLabel _ CaseReturnInfo) = DataLabel +labelType (CaseLabel _ _) = CodeLabel +labelType (ModuleInitLabel _ _) = CodeLabel +labelType (PlainModuleInitLabel _) = CodeLabel +labelType (ModuleInitTableLabel _) = DataLabel +labelType (LargeSRTLabel _) = DataLabel +labelType (LargeBitmapLabel _) = DataLabel +labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel +labelType (IdLabel _ _ info) = idInfoLabelType info +labelType _ = DataLabel idInfoLabelType info = case info of @@ -709,8 +733,9 @@ labelDynamic :: PackageId -> CLabel -> Bool labelDynamic this_pkg lbl = case lbl of - RtsLabel _ -> not opt_Static && (this_pkg /= rtsPackageId) -- i.e., is the RTS in a DLL or not? - IdLabel n _ k -> isDllName this_pkg n + RtsLabel _ -> not opt_Static && (this_pkg /= rtsPackageId) -- i.e., is the RTS in a DLL or not? + CmmLabel pkg _ _ -> not opt_Static && (this_pkg /= pkg) + IdLabel n _ k -> isDllName this_pkg n #if mingw32_TARGET_OS ForeignLabel _ _ d _ -> d #else @@ -836,13 +861,11 @@ -- with a letter so the label will be legal assmbly code. -pprCLbl (RtsLabel (RtsCode str)) = ptext str -pprCLbl (RtsLabel (RtsData str)) = ptext str -pprCLbl (RtsLabel (RtsGcPtr str)) = ptext str -pprCLbl (RtsLabel (RtsCodeFS str)) = ftext str -pprCLbl (RtsLabel (RtsDataFS str)) = ftext str +pprCLbl (CmmLabel _ str CmmCode) = ftext str +pprCLbl (CmmLabel _ str CmmData) = ftext str +pprCLbl (CmmLabel _ str CmmGcPtr) = ftext str -pprCLbl (RtsLabel (RtsApFast str)) = ptext str <> ptext (sLit "_fast") +pprCLbl (RtsLabel (RtsApFast str)) = ftext str <> ptext (sLit "_fast") pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset)) = hcat [ptext (sLit "stg_sel_"), text (show offset), @@ -872,28 +895,16 @@ else (sLit "_noupd_entry")) ] -pprCLbl (RtsLabel (RtsInfo fs)) - = ptext fs <> ptext (sLit "_info") - -pprCLbl (RtsLabel (RtsEntry fs)) - = ptext fs <> ptext (sLit "_entry") - -pprCLbl (RtsLabel (RtsRetInfo fs)) - = ptext fs <> ptext (sLit "_info") - -pprCLbl (RtsLabel (RtsRet fs)) - = ptext fs <> ptext (sLit "_ret") - -pprCLbl (RtsLabel (RtsInfoFS fs)) +pprCLbl (CmmLabel _ fs CmmInfo) = ftext fs <> ptext (sLit "_info") -pprCLbl (RtsLabel (RtsEntryFS fs)) +pprCLbl (CmmLabel _ fs CmmEntry) = ftext fs <> ptext (sLit "_entry") -pprCLbl (RtsLabel (RtsRetInfoFS fs)) +pprCLbl (CmmLabel _ fs CmmRetInfo) = ftext fs <> ptext (sLit "_info") -pprCLbl (RtsLabel (RtsRetFS fs)) +pprCLbl (CmmLabel _ fs CmmRet) = ftext fs <> ptext (sLit "_ret") pprCLbl (RtsLabel (RtsPrimOp primop)) @@ -916,8 +927,10 @@ pprCLbl (ModuleInitLabel mod way) = ptext (sLit "__stginit_") <> ppr mod <> char '_' <> text way + pprCLbl (PlainModuleInitLabel mod) = ptext (sLit "__stginit_") <> ppr mod + pprCLbl (ModuleInitTableLabel mod) = ptext (sLit "__stginittable_") <> ppr mod @@ -979,6 +992,7 @@ = pprCLabel lbl pprDynamicLinkerAsmLabel _ _ = panic "pprDynamicLinkerAsmLabel" + #elif darwin_TARGET_OS pprDynamicLinkerAsmLabel CodeStub lbl = char 'L' <> pprCLabel lbl <> text "$stub" @@ -986,6 +1000,7 @@ = char 'L' <> pprCLabel lbl <> text "$non_lazy_ptr" pprDynamicLinkerAsmLabel _ _ = panic "pprDynamicLinkerAsmLabel" + #elif powerpc_TARGET_ARCH && linux_TARGET_OS pprDynamicLinkerAsmLabel CodeStub lbl = pprCLabel lbl <> text "@plt" @@ -993,6 +1008,7 @@ = text ".LC_" <> pprCLabel lbl pprDynamicLinkerAsmLabel _ _ = panic "pprDynamicLinkerAsmLabel" + #elif x86_64_TARGET_ARCH && linux_TARGET_OS pprDynamicLinkerAsmLabel CodeStub lbl = pprCLabel lbl <> text "@plt" @@ -1002,6 +1018,7 @@ = pprCLabel lbl pprDynamicLinkerAsmLabel SymbolPtr lbl = text ".LC_" <> pprCLabel lbl + #elif linux_TARGET_OS pprDynamicLinkerAsmLabel CodeStub lbl = pprCLabel lbl <> text "@plt" @@ -1011,11 +1028,13 @@ = pprCLabel lbl <> text "@got" pprDynamicLinkerAsmLabel GotSymbolOffset lbl = pprCLabel lbl <> text "@gotoff" + #elif mingw32_TARGET_OS pprDynamicLinkerAsmLabel SymbolPtr lbl = text "__imp_" <> pprCLabel lbl pprDynamicLinkerAsmLabel _ _ = panic "pprDynamicLinkerAsmLabel" + #else pprDynamicLinkerAsmLabel _ _ = panic "pprDynamicLinkerAsmLabel" diff -ruN ghc-6.12.1/compiler/cmm/CmmBuildInfoTables.hs ghc-6.13.20091231/compiler/cmm/CmmBuildInfoTables.hs --- ghc-6.12.1/compiler/cmm/CmmBuildInfoTables.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/cmm/CmmBuildInfoTables.hs 2009-12-31 10:14:17.000000000 -0800 @@ -3,7 +3,9 @@ , setInfoTableSRT, setInfoTableStackMap , TopSRT, emptySRT, srtToData , bundleCAFs - , finishInfoTables, lowerSafeForeignCalls, extendEnvsForSafeForeignCalls ) + , finishInfoTables, lowerSafeForeignCalls + , cafTransfers, liveSlotTransfers + , extendEnvWithSafeForeignCalls, extendEnvsForSafeForeignCalls ) where #include "HsVersions.h" @@ -23,6 +25,7 @@ import CmmStackLayout import CmmTx import DFMonad +import Module import FastString import FiniteMap import ForeignCall @@ -76,9 +79,12 @@ -- which may differ depending on whether there is an update frame. live_ptrs :: ByteOff -> BlockEnv SubAreaSet -> AreaMap -> BlockId -> [Maybe LocalReg] live_ptrs oldByte slotEnv areaMap bid = - -- pprTrace "live_ptrs for" (ppr bid <+> ppr youngByte <+> ppr liveSlots) $ - reverse $ slotsToList youngByte liveSlots [] - where slotsToList n [] results | n == oldByte = results -- at old end of stack frame + -- pprTrace "live_ptrs for" (ppr bid <+> text (show oldByte ++ "-" ++ show youngByte) <+> + -- ppr liveSlots) $ + -- pprTrace ("stack layout for " ++ show bid ++ ": ") (ppr res) $ res + res + where res = reverse $ slotsToList youngByte liveSlots [] + slotsToList n [] results | n == oldByte = results -- at old end of stack frame slotsToList n (s : _) _ | n == oldByte = pprPanic "slot left off live_ptrs" (ppr s <+> ppr oldByte <+> ppr n <+> ppr liveSlots <+> ppr youngByte) @@ -229,6 +235,8 @@ do let liftCAF lbl () z = -- get CAFs for functions without static closures case lookupFM topCAFMap lbl of Just cafs -> z `plusFM` cafs Nothing -> addToFM z lbl () + -- For each label referring to a function f without a static closure, + -- replace it with the CAFs that are reachable from f. sub_srt topSRT localCafs = let cafs = keysFM (foldFM liftCAF emptyFM localCafs) mkSRT topSRT = @@ -302,7 +310,7 @@ -- doesn't have a static closure. -- (If it has a static closure, it will already have an SRT to -- keep its CAFs live.) --- Any procedure referring to a non-static CAF c must keep live the +-- Any procedure referring to a non-static CAF c must keep live -- any CAF that is reachable from c. localCAFInfo :: CAFEnv -> CmmTopZ -> Maybe (CLabel, CAFSet) localCAFInfo _ (CmmData _ _) = Nothing @@ -346,7 +354,7 @@ bundleCAFs :: CAFEnv -> CmmTopForInfoTables -> (CAFSet, CmmTopForInfoTables) bundleCAFs cafEnv t@(ProcInfoTable _ procpoints) = case blockSetToList procpoints of - [bid] -> (expectJust "bundleCAFs " (lookupBlockEnv cafEnv bid), t) + [bid] -> (expectJust "bundleCAFs" (lookupBlockEnv cafEnv bid), t) _ -> panic "setInfoTableStackMap: unexpect number of procpoints" -- until we stop splitting the graphs at procpoints in the native path bundleCAFs cafEnv t@(FloatingInfoTable _ bid _) = @@ -408,6 +416,22 @@ -- Our analyses capture the dataflow facts at block boundaries, but we need -- to extend the CAF and live-slot analyses to safe foreign calls as well, -- which show up as middle nodes. +extendEnvWithSafeForeignCalls :: + BackwardTransfers Middle Last a -> BlockEnv a -> CmmGraph -> BlockEnv a +extendEnvWithSafeForeignCalls transfers env g = fold_blocks block env g + where block b z = + tail (bt_last_in transfers l (lookup env)) z head + where (head, last) = goto_end (G.unzip b) + l = case last of LastOther l -> l + LastExit -> panic "extendEnvs lastExit" + tail _ z (ZFirst _) = z + tail fact env (ZHead h m@(MidForeignCall (Safe bid _) _ _ _)) = + tail (mid m fact) (extendBlockEnv env bid fact) h + tail fact env (ZHead h m) = tail (mid m fact) env h + lookup map k = expectJust "extendEnvWithSafeFCalls" $ lookupBlockEnv map k + mid = bt_middle_in transfers + + extendEnvsForSafeForeignCalls :: CAFEnv -> SlotEnv -> CmmGraph -> (CAFEnv, SlotEnv) extendEnvsForSafeForeignCalls cafEnv slotEnv g = fold_blocks block (cafEnv, slotEnv) g @@ -496,7 +520,7 @@ tail s b@(ZBlock (ZFirst _) _) = do state <- s return $ state { s_blocks = insertBlock (G.zip b) (s_blocks state) } - tail s (ZBlock (ZHead h m@(MidForeignCall (Safe bid updfr_off) _ _ _)) t) = + tail s (ZBlock (ZHead h m@(MidForeignCall (Safe bid updfr_off) _ _ _)) t) = do state <- s let state' = state { s_safeCalls = FloatingInfoTable emptyContInfoTable bid updfr_off : @@ -518,8 +542,8 @@ new_base <- newTemp (cmmRegType (CmmGlobal BaseReg)) let (caller_save, caller_load) = callerSaveVolatileRegs load_tso <- newTemp gcWord -- TODO FIXME NOW - let suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "suspendThread"))) - resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "resumeThread"))) + let suspendThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "suspendThread"))) + resumeThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "resumeThread"))) suspend = mkStore (CmmReg spReg) (CmmLit (CmmBlock infotable)) <*> saveThreadState <*> caller_save <*> diff -ruN ghc-6.12.1/compiler/cmm/CmmCallConv.hs ghc-6.13.20091231/compiler/cmm/CmmCallConv.hs --- ghc-6.12.1/compiler/cmm/CmmCallConv.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/cmm/CmmCallConv.hs 2009-12-31 10:14:17.000000000 -0800 @@ -13,6 +13,7 @@ import ZipCfgCmmRep (Convention(..)) import Constants +import qualified Data.List as L import StaticFlags (opt_Unregisterised) import Outputable @@ -31,23 +32,14 @@ -- Stack parameters are returned as word offsets. assignArguments :: (a -> CmmType) -> [a] -> ArgumentFormat a WordOff -assignArguments f reps = assignments - where - availRegs = getRegsWithNode - (sizes, assignments) = unzip $ assignArguments' reps (negate (sum sizes)) availRegs - assignArguments' [] _ _ = [] - assignArguments' (r:rs) offset availRegs = - (size,(r,assignment)):assignArguments' rs new_offset remaining - where - (assignment, new_offset, size, remaining) = - assign_reg assign_slot_neg (f r) offset availRegs +assignArguments _ _ = panic "assignArguments only used in dead codegen" -- assignments -- | JD: For the new stack story, I want arguments passed on the stack to manifest as -- positive offsets in a CallArea, not negative offsets from the stack pointer. -- Also, I want byte offsets, not word offsets. assignArgumentsPos :: (Outputable a) => Convention -> (a -> CmmType) -> [a] -> ArgumentFormat a ByteOff -assignArgumentsPos conv arg_ty reps = map cvt assignments +assignArgumentsPos conv arg_ty reps = assignments where -- The calling conventions (CgCallConv.hs) are complicated, to say the least regs = case (reps, conv) of (_, NativeNodeCall) -> getRegsWithNode @@ -60,16 +52,47 @@ (_, PrimOpReturn) -> getRegsWithNode (_, Slow) -> noRegs _ -> pprPanic "Unknown calling convention" (ppr conv) - (sizes, assignments) = unzip $ assignArguments' reps (sum sizes) regs - assignArguments' [] _ _ = [] - assignArguments' (r:rs) offset avails = - (size, (r,assignment)):assignArguments' rs new_offset remaining - where - (assignment, new_offset, size, remaining) = - assign_reg assign_slot_pos (arg_ty r) offset avails - cvt (l, RegisterParam r) = (l, RegisterParam r) - cvt (l, StackParam off) = (l, StackParam $ off * wORD_SIZE) - + -- The calling conventions first assign arguments to registers, + -- then switch to the stack when we first run out of registers + -- (even if there are still available registers for args of a different type). + -- When returning an unboxed tuple, we also separate the stack + -- arguments by pointerhood. + (reg_assts, stk_args) = assign_regs [] reps regs + stk_args' = case conv of NativeReturn -> part + PrimOpReturn -> part + _ -> stk_args + where part = uncurry (++) + (L.partition (not . isGcPtrType . arg_ty) stk_args) + stk_assts = assign_stk 0 [] (reverse stk_args') + assignments = reg_assts ++ stk_assts + + assign_regs assts [] _ = (assts, []) + assign_regs assts (r:rs) regs = if isFloatType ty then float else int + where float = case (w, regs) of + (W32, (vs, f:fs, ds, ls)) -> k (RegisterParam f, (vs, fs, ds, ls)) + (W64, (vs, fs, d:ds, ls)) -> k (RegisterParam d, (vs, fs, ds, ls)) + (W80, _) -> panic "F80 unsupported register type" + _ -> (assts, (r:rs)) + int = case (w, regs) of + (W128, _) -> panic "W128 unsupported register type" + (_, (v:vs, fs, ds, ls)) | widthInBits w <= widthInBits wordWidth + -> k (RegisterParam (v gcp), (vs, fs, ds, ls)) + (_, (vs, fs, ds, l:ls)) | widthInBits w > widthInBits wordWidth + -> k (RegisterParam l, (vs, fs, ds, ls)) + _ -> (assts, (r:rs)) + k (asst, regs') = assign_regs ((r, asst) : assts) rs regs' + ty = arg_ty r + w = typeWidth ty + gcp | isGcPtrType ty = VGcPtr + | otherwise = VNonGcPtr + + assign_stk _ assts [] = assts + assign_stk offset assts (r:rs) = assign_stk off' ((r, StackParam off') : assts) rs + where w = typeWidth (arg_ty r) + size = (((widthInBytes w - 1) `div` wORD_SIZE) + 1) * wORD_SIZE + off' = offset + size + + argumentsSize :: (a -> CmmType) -> [a] -> WordOff argumentsSize f reps = maximum (0 : map arg_top args) where @@ -81,10 +104,10 @@ -- Local information about the registers available type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs. - , [GlobalReg] -- floats - , [GlobalReg] -- doubles - , [GlobalReg] -- longs (int64 and word64) - ) + , [GlobalReg] -- floats + , [GlobalReg] -- doubles + , [GlobalReg] -- longs (int64 and word64) + ) -- Vanilla registers can contain pointers, Ints, Chars. -- Floats and doubles have separate register supplies. @@ -127,57 +150,3 @@ noRegs :: AvailRegs noRegs = ([], [], [], []) - --- Round the size of a local register up to the nearest word. -{- -UNUSED 2008-12-29 - -slot_size :: LocalReg -> Int -slot_size reg = slot_size' (typeWidth (localRegType reg)) --} - -slot_size' :: Width -> Int -slot_size' reg = ((widthInBytes reg - 1) `div` wORD_SIZE) + 1 - -type Assignment = (ParamLocation WordOff, WordOff, WordOff, AvailRegs) -type SlotAssigner = Width -> Int -> AvailRegs -> Assignment - -assign_reg :: SlotAssigner -> CmmType -> WordOff -> AvailRegs -> Assignment -assign_reg slot ty off avails - | isFloatType ty = assign_float_reg slot width off avails - | otherwise = assign_bits_reg slot width off gcp avails - where - width = typeWidth ty - gcp | isGcPtrType ty = VGcPtr - | otherwise = VNonGcPtr - --- Assigning a slot using negative offsets from the stack pointer. --- JD: I don't know why this convention stops using all the registers --- after running out of one class of registers. -assign_slot_neg :: SlotAssigner -assign_slot_neg width off _regs = - (StackParam $ off, off + size, size, ([], [], [], [])) where size = slot_size' width - --- Assigning a slot using positive offsets into a CallArea. -assign_slot_pos :: SlotAssigner -assign_slot_pos width off _regs = - (StackParam $ off, off - size, size, ([], [], [], [])) - where size = slot_size' width - --- On calls in the native convention, `node` is used to hold the environment --- for the closure, so we can't pass arguments in that register. -assign_bits_reg :: SlotAssigner -> Width -> WordOff -> VGcPtr -> AvailRegs -> Assignment -assign_bits_reg _ W128 _ _ _ = panic "W128 is not a supported register type" -assign_bits_reg _ w off gcp (v:vs, fs, ds, ls) - | widthInBits w <= widthInBits wordWidth = - (RegisterParam (v gcp), off, 0, (vs, fs, ds, ls)) -assign_bits_reg _ w off _ (vs, fs, ds, l:ls) - | widthInBits w > widthInBits wordWidth = - (RegisterParam l, off, 0, (vs, fs, ds, ls)) -assign_bits_reg assign_slot w off _ regs@(_, _, _, _) = assign_slot w off regs - -assign_float_reg :: SlotAssigner -> Width -> WordOff -> AvailRegs -> Assignment -assign_float_reg _ W32 off (vs, f:fs, ds, ls) = (RegisterParam $ f, off, 0, (vs, fs, ds, ls)) -assign_float_reg _ W64 off (vs, fs, d:ds, ls) = (RegisterParam $ d, off, 0, (vs, fs, ds, ls)) -assign_float_reg _ W80 _ _ = panic "F80 is not a supported register type" -assign_float_reg assign_slot width off r = assign_slot width off r diff -ruN ghc-6.12.1/compiler/cmm/CmmCPSGen.hs ghc-6.13.20091231/compiler/cmm/CmmCPSGen.hs --- ghc-6.12.1/compiler/cmm/CmmCPSGen.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/cmm/CmmCPSGen.hs 2009-12-31 10:14:17.000000000 -0800 @@ -20,6 +20,7 @@ import SMRep import ForeignCall +import Module import Constants import StaticFlags import Unique @@ -259,8 +260,8 @@ -- Save/restore the thread state in the TSO suspendThread, resumeThread :: CmmExpr -suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "suspendThread"))) -resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "resumeThread"))) +suspendThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "suspendThread"))) +resumeThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "resumeThread"))) -- This stuff can't be done in suspendThread/resumeThread, because it -- refers to global registers which aren't available in the C world. diff -ruN ghc-6.12.1/compiler/cmm/CmmCPSZ.hs ghc-6.13.20091231/compiler/cmm/CmmCPSZ.hs --- ghc-6.12.1/compiler/cmm/CmmCPSZ.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/cmm/CmmCPSZ.hs 2009-12-31 10:14:17.000000000 -0800 @@ -46,19 +46,16 @@ -> (TopSRT, [CmmZ]) -- SRT table and accumulating list of compiled procs -> CmmZ -- Input C-- with Procedures -> IO (TopSRT, [CmmZ]) -- Output CPS transformed C-- -protoCmmCPSZ hsc_env (topSRT, rst) (Cmm tops) - | not (dopt Opt_TryNewCodeGen (hsc_dflags hsc_env)) - = return (topSRT, Cmm tops : rst) -- Only if -fnew-codegen - | otherwise - = do let dflags = hsc_dflags hsc_env - showPass dflags "CPSZ" - (cafEnvs, tops) <- liftM unzip $ mapM (cpsTop hsc_env) tops - let topCAFEnv = mkTopCAFInfo (concat cafEnvs) - (topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops - -- (topSRT, tops) <- foldM (\ z f -> f topCAFEnv z) (topSRT, []) toTops - let cmms = Cmm (reverse (concat tops)) - dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms) - return (topSRT, cmms : rst) +protoCmmCPSZ hsc_env (topSRT, rst) (Cmm tops) = + do let dflags = hsc_dflags hsc_env + showPass dflags "CPSZ" + (cafEnvs, tops) <- liftM unzip $ mapM (cpsTop hsc_env) tops + let topCAFEnv = mkTopCAFInfo (concat cafEnvs) + (topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops + -- (topSRT, tops) <- foldM (\ z f -> f topCAFEnv z) (topSRT, []) toTops + let cmms = Cmm (reverse (concat tops)) + dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms) + return (topSRT, cmms : rst) {- [Note global fuel] ~~~~~~~~~~~~~~~~~~~~~ @@ -116,12 +113,11 @@ --------------- Stack layout ---------------- slotEnv <- run $ liveSlotAnal g mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return () - cafEnv <- - -- trace "post liveSlotAnal" $ - run $ cafAnal g - (cafEnv, slotEnv) <- - -- trace "post print cafAnal" $ - return $ extendEnvsForSafeForeignCalls cafEnv slotEnv g + -- cafEnv <- -- trace "post liveSlotAnal" $ run $ cafAnal g + -- (cafEnv, slotEnv) <- + -- -- trace "post print cafAnal" $ + -- return $ extendEnvsForSafeForeignCalls cafEnv slotEnv g + slotEnv <- return $ extendEnvWithSafeForeignCalls liveSlotTransfers slotEnv g mbpprTrace "slotEnv extended for safe foreign calls: " (ppr slotEnv) $ return () let areaMap = layout procPoints slotEnv entry_off g mbpprTrace "areaMap" (ppr areaMap) $ return () @@ -140,8 +136,11 @@ mapM_ (dump Opt_D_dump_cmmz "after splitting") gs ------------- More CAFs and foreign calls ------------ + cafEnv <- run $ cafAnal g + cafEnv <- return $ extendEnvWithSafeForeignCalls cafTransfers cafEnv g let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs mbpprTrace "localCAFs" (ppr localCAFs) $ return () + gs <- liftM concat $ run $ foldM lowerSafeForeignCalls [] gs mapM_ (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs diff -ruN ghc-6.12.1/compiler/cmm/CmmCvt.hs ghc-6.13.20091231/compiler/cmm/CmmCvt.hs --- ghc-6.12.1/compiler/cmm/CmmCvt.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/cmm/CmmCvt.hs 2009-12-31 10:14:17.000000000 -0800 @@ -115,6 +115,7 @@ mid (MidComment s) = CmmComment s mid (MidAssign l r) = CmmAssign l r mid (MidStore l r) = CmmStore l r + mid (MidForeignCall _ (PrimTarget MO_Touch) _ _) = CmmNop mid (MidForeignCall _ target ress args) = CmmCall (cmm_target target) (add_hints conv Results ress) diff -ruN ghc-6.12.1/compiler/cmm/Cmm.hs ghc-6.13.20091231/compiler/cmm/Cmm.hs --- ghc-6.12.1/compiler/cmm/Cmm.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/cmm/Cmm.hs 2009-12-31 10:14:17.000000000 -0800 @@ -384,6 +384,7 @@ | MO_F32_Exp | MO_F32_Sqrt | MO_WriteBarrier + | MO_Touch -- Keep variables live (when using interior pointers) deriving (Eq, Show) pprCallishMachOp :: CallishMachOp -> SDoc diff -ruN ghc-6.12.1/compiler/cmm/CmmLex.hs ghc-6.13.20091231/compiler/cmm/CmmLex.hs --- ghc-6.12.1/compiler/cmm/CmmLex.hs 2009-12-10 12:13:27.000000000 -0800 +++ ghc-6.13.20091231/compiler/cmm/CmmLex.hs 2009-12-31 12:35:22.000000000 -0800 @@ -1,7 +1,7 @@ {-# OPTIONS -fglasgow-exts -cpp #-} {-# LINE 13 "compiler/cmm/CmmLex.x" #-} {-# OPTIONS -Wwarn -w #-} --- The above warning supression flag is a temporary kludge. +-- The above -Wwarn supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings @@ -205,7 +205,7 @@ setLine :: Int -> Action setLine code span buf len = do let line = parseUnsignedInteger buf len 10 octDecDigit - setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 0) + setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) -- subtract one: the line number refers to the *following* line -- trace ("setLine " ++ show line) $ do popLexState @@ -236,7 +236,7 @@ sc <- getLexState case alexScan inp sc of AlexEOF -> do let span = mkSrcSpan loc1 loc1 - setLastToken span 0 0 + setLastToken span 0 return (L span CmmT_EOF) AlexError (loc2,_) -> do failLocMsgP loc1 loc2 "lexical error" AlexSkip inp2 _ -> do @@ -245,7 +245,7 @@ AlexToken inp2@(end,buf2) len t -> do setInput inp2 let span = mkSrcSpan loc1 end - span `seq` setLastToken span len len + span `seq` setLastToken span len t span buf len -- ----------------------------------------------------------------------------- diff -ruN ghc-6.12.1/compiler/cmm/CmmLex.x.source ghc-6.13.20091231/compiler/cmm/CmmLex.x.source --- ghc-6.12.1/compiler/cmm/CmmLex.x.source 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/cmm/CmmLex.x.source 2009-12-31 10:14:18.000000000 -0800 @@ -12,7 +12,7 @@ { {-# OPTIONS -Wwarn -w #-} --- The above warning supression flag is a temporary kludge. +-- The above -Wwarn supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings @@ -269,7 +269,7 @@ setLine :: Int -> Action setLine code span buf len = do let line = parseUnsignedInteger buf len 10 octDecDigit - setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 0) + setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) -- subtract one: the line number refers to the *following* line -- trace ("setLine " ++ show line) $ do popLexState @@ -300,7 +300,7 @@ sc <- getLexState case alexScan inp sc of AlexEOF -> do let span = mkSrcSpan loc1 loc1 - setLastToken span 0 0 + setLastToken span 0 return (L span CmmT_EOF) AlexError (loc2,_) -> do failLocMsgP loc1 loc2 "lexical error" AlexSkip inp2 _ -> do @@ -309,7 +309,7 @@ AlexToken inp2@(end,buf2) len t -> do setInput inp2 let span = mkSrcSpan loc1 end - span `seq` setLastToken span len len + span `seq` setLastToken span len t span buf len -- ----------------------------------------------------------------------------- diff -ruN ghc-6.12.1/compiler/cmm/cmm-notes ghc-6.13.20091231/compiler/cmm/cmm-notes --- ghc-6.12.1/compiler/cmm/cmm-notes 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/cmm/cmm-notes 2009-12-31 10:14:18.000000000 -0800 @@ -2,6 +2,43 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Things to do: + + + - All dataflow analyses are in the FuelMonad, even though they + are guarnteed to consume no fuel. This seems silly + + - CmmContFlowOpt.runCmmContFlowOptZs is not called! + - Why is runCmmOpts called from HscMain? Seems too "high up". + In fact HscMain calls (runCmmOpts cmmCfgOptsZ) which is what + runCmmContFlowOptZs does. Tidy up! + + + - AsmCodeGen has a generic Cmm optimiser; move this into new pipeline + + - AsmCodeGen has post-native-cg branch elimiator (shortCutBranches); + we ultimately want to share this with the Cmm branch eliminator. + + - At the moment, references to global registers like Hp are "lowered" + late (in AsmCodeGen.fixAssignTop and cmmToCmm). We should do this + early, in the new native codegen, much in the way that we lower + calling conventions. Might need to be a bit sophisticated about + aliasing. + + - Refactor Cmm so that it contains only shared stuff + Add a module MoribundCmm which contains stuff from + Cmm for old code gen path + + - Question: currently we lift procpoints to become separate + CmmProcs. Do we still want to do this? + + NB: and advantage of continuing to do this is that + we can do common-proc elimination! + + - Move to new Cmm rep: + * Make native CG consume New Cmm; + * Convert Old Cmm->New Cmm to keep old path alive + * Produce New Cmm when reading in .cmm files + - Consider module names - Top-level SRT threading is a bit ugly diff -ruN ghc-6.12.1/compiler/cmm/CmmParse.hs ghc-6.13.20091231/compiler/cmm/CmmParse.hs --- ghc-6.12.1/compiler/cmm/CmmParse.hs 2009-12-10 12:13:28.000000000 -0800 +++ ghc-6.13.20091231/compiler/cmm/CmmParse.hs 2009-12-31 12:35:22.000000000 -0800 @@ -9,7 +9,8 @@ module CmmParse ( parseCmmFile ) where -import CgMonad +import CgMonad hiding (getDynFlags) +import CgExtCode import CgHeapery import CgUtils import CgProf @@ -33,6 +34,7 @@ import Lexer import ForeignCall +import Module import Literal import Unique import UniqFM @@ -47,6 +49,7 @@ import Outputable import BasicTypes import Bag ( emptyBag, unitBag ) +import Var import Control.Monad import Data.Array @@ -133,118 +136,118 @@ happyOut13 :: (HappyAbsSyn ) -> (ExtCode) happyOut13 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut13 #-} -happyIn14 :: ([FastString]) -> (HappyAbsSyn ) +happyIn14 :: ([(Maybe PackageId, FastString)]) -> (HappyAbsSyn ) happyIn14 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn14 #-} -happyOut14 :: (HappyAbsSyn ) -> ([FastString]) +happyOut14 :: (HappyAbsSyn ) -> ([(Maybe PackageId, FastString)]) happyOut14 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut14 #-} -happyIn15 :: (ExtCode) -> (HappyAbsSyn ) +happyIn15 :: ((Maybe PackageId, FastString)) -> (HappyAbsSyn ) happyIn15 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn15 #-} -happyOut15 :: (HappyAbsSyn ) -> (ExtCode) +happyOut15 :: (HappyAbsSyn ) -> ((Maybe PackageId, FastString)) happyOut15 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut15 #-} -happyIn16 :: (CmmReturnInfo) -> (HappyAbsSyn ) +happyIn16 :: ([FastString]) -> (HappyAbsSyn ) happyIn16 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn16 #-} -happyOut16 :: (HappyAbsSyn ) -> (CmmReturnInfo) +happyOut16 :: (HappyAbsSyn ) -> ([FastString]) happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut16 #-} -happyIn17 :: (ExtFCode BoolExpr) -> (HappyAbsSyn ) +happyIn17 :: (ExtCode) -> (HappyAbsSyn ) happyIn17 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn17 #-} -happyOut17 :: (HappyAbsSyn ) -> (ExtFCode BoolExpr) +happyOut17 :: (HappyAbsSyn ) -> (ExtCode) happyOut17 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut17 #-} -happyIn18 :: (ExtFCode BoolExpr) -> (HappyAbsSyn ) +happyIn18 :: (CmmReturnInfo) -> (HappyAbsSyn ) happyIn18 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn18 #-} -happyOut18 :: (HappyAbsSyn ) -> (ExtFCode BoolExpr) +happyOut18 :: (HappyAbsSyn ) -> (CmmReturnInfo) happyOut18 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut18 #-} -happyIn19 :: (CmmSafety) -> (HappyAbsSyn ) +happyIn19 :: (ExtFCode BoolExpr) -> (HappyAbsSyn ) happyIn19 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn19 #-} -happyOut19 :: (HappyAbsSyn ) -> (CmmSafety) +happyOut19 :: (HappyAbsSyn ) -> (ExtFCode BoolExpr) happyOut19 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut19 #-} -happyIn20 :: (Maybe [GlobalReg]) -> (HappyAbsSyn ) +happyIn20 :: (ExtFCode BoolExpr) -> (HappyAbsSyn ) happyIn20 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn20 #-} -happyOut20 :: (HappyAbsSyn ) -> (Maybe [GlobalReg]) +happyOut20 :: (HappyAbsSyn ) -> (ExtFCode BoolExpr) happyOut20 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut20 #-} -happyIn21 :: ([GlobalReg]) -> (HappyAbsSyn ) +happyIn21 :: (CmmSafety) -> (HappyAbsSyn ) happyIn21 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn21 #-} -happyOut21 :: (HappyAbsSyn ) -> ([GlobalReg]) +happyOut21 :: (HappyAbsSyn ) -> (CmmSafety) happyOut21 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut21 #-} -happyIn22 :: (Maybe (Int,Int)) -> (HappyAbsSyn ) +happyIn22 :: (Maybe [GlobalReg]) -> (HappyAbsSyn ) happyIn22 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn22 #-} -happyOut22 :: (HappyAbsSyn ) -> (Maybe (Int,Int)) +happyOut22 :: (HappyAbsSyn ) -> (Maybe [GlobalReg]) happyOut22 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut22 #-} -happyIn23 :: ([([Int],ExtCode)]) -> (HappyAbsSyn ) +happyIn23 :: ([GlobalReg]) -> (HappyAbsSyn ) happyIn23 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn23 #-} -happyOut23 :: (HappyAbsSyn ) -> ([([Int],ExtCode)]) +happyOut23 :: (HappyAbsSyn ) -> ([GlobalReg]) happyOut23 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut23 #-} -happyIn24 :: (([Int],ExtCode)) -> (HappyAbsSyn ) +happyIn24 :: (Maybe (Int,Int)) -> (HappyAbsSyn ) happyIn24 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn24 #-} -happyOut24 :: (HappyAbsSyn ) -> (([Int],ExtCode)) +happyOut24 :: (HappyAbsSyn ) -> (Maybe (Int,Int)) happyOut24 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut24 #-} -happyIn25 :: ([Int]) -> (HappyAbsSyn ) +happyIn25 :: ([([Int],ExtCode)]) -> (HappyAbsSyn ) happyIn25 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn25 #-} -happyOut25 :: (HappyAbsSyn ) -> ([Int]) +happyOut25 :: (HappyAbsSyn ) -> ([([Int],ExtCode)]) happyOut25 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut25 #-} -happyIn26 :: (Maybe ExtCode) -> (HappyAbsSyn ) +happyIn26 :: (([Int],ExtCode)) -> (HappyAbsSyn ) happyIn26 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn26 #-} -happyOut26 :: (HappyAbsSyn ) -> (Maybe ExtCode) +happyOut26 :: (HappyAbsSyn ) -> (([Int],ExtCode)) happyOut26 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut26 #-} -happyIn27 :: (ExtCode) -> (HappyAbsSyn ) +happyIn27 :: ([Int]) -> (HappyAbsSyn ) happyIn27 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn27 #-} -happyOut27 :: (HappyAbsSyn ) -> (ExtCode) +happyOut27 :: (HappyAbsSyn ) -> ([Int]) happyOut27 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut27 #-} -happyIn28 :: (ExtFCode CmmExpr) -> (HappyAbsSyn ) +happyIn28 :: (Maybe ExtCode) -> (HappyAbsSyn ) happyIn28 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn28 #-} -happyOut28 :: (HappyAbsSyn ) -> (ExtFCode CmmExpr) +happyOut28 :: (HappyAbsSyn ) -> (Maybe ExtCode) happyOut28 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut28 #-} -happyIn29 :: (ExtFCode CmmExpr) -> (HappyAbsSyn ) +happyIn29 :: (ExtCode) -> (HappyAbsSyn ) happyIn29 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn29 #-} -happyOut29 :: (HappyAbsSyn ) -> (ExtFCode CmmExpr) +happyOut29 :: (HappyAbsSyn ) -> (ExtCode) happyOut29 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut29 #-} -happyIn30 :: (CmmType) -> (HappyAbsSyn ) +happyIn30 :: (ExtFCode CmmExpr) -> (HappyAbsSyn ) happyIn30 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn30 #-} -happyOut30 :: (HappyAbsSyn ) -> (CmmType) +happyOut30 :: (HappyAbsSyn ) -> (ExtFCode CmmExpr) happyOut30 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut30 #-} -happyIn31 :: ([ExtFCode HintedCmmActual]) -> (HappyAbsSyn ) +happyIn31 :: (ExtFCode CmmExpr) -> (HappyAbsSyn ) happyIn31 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn31 #-} -happyOut31 :: (HappyAbsSyn ) -> ([ExtFCode HintedCmmActual]) +happyOut31 :: (HappyAbsSyn ) -> (ExtFCode CmmExpr) happyOut31 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut31 #-} -happyIn32 :: ([ExtFCode HintedCmmActual]) -> (HappyAbsSyn ) +happyIn32 :: (CmmType) -> (HappyAbsSyn ) happyIn32 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn32 #-} -happyOut32 :: (HappyAbsSyn ) -> ([ExtFCode HintedCmmActual]) +happyOut32 :: (HappyAbsSyn ) -> (CmmType) happyOut32 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut32 #-} happyIn33 :: ([ExtFCode HintedCmmActual]) -> (HappyAbsSyn ) @@ -253,70 +256,70 @@ happyOut33 :: (HappyAbsSyn ) -> ([ExtFCode HintedCmmActual]) happyOut33 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut33 #-} -happyIn34 :: (ExtFCode HintedCmmActual) -> (HappyAbsSyn ) +happyIn34 :: ([ExtFCode HintedCmmActual]) -> (HappyAbsSyn ) happyIn34 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn34 #-} -happyOut34 :: (HappyAbsSyn ) -> (ExtFCode HintedCmmActual) +happyOut34 :: (HappyAbsSyn ) -> ([ExtFCode HintedCmmActual]) happyOut34 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut34 #-} -happyIn35 :: ([ExtFCode CmmExpr]) -> (HappyAbsSyn ) +happyIn35 :: ([ExtFCode HintedCmmActual]) -> (HappyAbsSyn ) happyIn35 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn35 #-} -happyOut35 :: (HappyAbsSyn ) -> ([ExtFCode CmmExpr]) +happyOut35 :: (HappyAbsSyn ) -> ([ExtFCode HintedCmmActual]) happyOut35 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut35 #-} -happyIn36 :: ([ExtFCode CmmExpr]) -> (HappyAbsSyn ) +happyIn36 :: (ExtFCode HintedCmmActual) -> (HappyAbsSyn ) happyIn36 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn36 #-} -happyOut36 :: (HappyAbsSyn ) -> ([ExtFCode CmmExpr]) +happyOut36 :: (HappyAbsSyn ) -> (ExtFCode HintedCmmActual) happyOut36 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut36 #-} -happyIn37 :: (ExtFCode CmmExpr) -> (HappyAbsSyn ) +happyIn37 :: ([ExtFCode CmmExpr]) -> (HappyAbsSyn ) happyIn37 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn37 #-} -happyOut37 :: (HappyAbsSyn ) -> (ExtFCode CmmExpr) +happyOut37 :: (HappyAbsSyn ) -> ([ExtFCode CmmExpr]) happyOut37 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut37 #-} -happyIn38 :: ([ExtFCode HintedCmmFormal]) -> (HappyAbsSyn ) +happyIn38 :: ([ExtFCode CmmExpr]) -> (HappyAbsSyn ) happyIn38 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn38 #-} -happyOut38 :: (HappyAbsSyn ) -> ([ExtFCode HintedCmmFormal]) +happyOut38 :: (HappyAbsSyn ) -> ([ExtFCode CmmExpr]) happyOut38 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut38 #-} -happyIn39 :: ([ExtFCode HintedCmmFormal]) -> (HappyAbsSyn ) +happyIn39 :: (ExtFCode CmmExpr) -> (HappyAbsSyn ) happyIn39 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn39 #-} -happyOut39 :: (HappyAbsSyn ) -> ([ExtFCode HintedCmmFormal]) +happyOut39 :: (HappyAbsSyn ) -> (ExtFCode CmmExpr) happyOut39 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut39 #-} -happyIn40 :: (ExtFCode HintedCmmFormal) -> (HappyAbsSyn ) +happyIn40 :: ([ExtFCode HintedCmmFormal]) -> (HappyAbsSyn ) happyIn40 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn40 #-} -happyOut40 :: (HappyAbsSyn ) -> (ExtFCode HintedCmmFormal) +happyOut40 :: (HappyAbsSyn ) -> ([ExtFCode HintedCmmFormal]) happyOut40 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut40 #-} -happyIn41 :: (ExtFCode LocalReg) -> (HappyAbsSyn ) +happyIn41 :: ([ExtFCode HintedCmmFormal]) -> (HappyAbsSyn ) happyIn41 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn41 #-} -happyOut41 :: (HappyAbsSyn ) -> (ExtFCode LocalReg) +happyOut41 :: (HappyAbsSyn ) -> ([ExtFCode HintedCmmFormal]) happyOut41 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut41 #-} -happyIn42 :: (ExtFCode CmmReg) -> (HappyAbsSyn ) +happyIn42 :: (ExtFCode HintedCmmFormal) -> (HappyAbsSyn ) happyIn42 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn42 #-} -happyOut42 :: (HappyAbsSyn ) -> (ExtFCode CmmReg) +happyOut42 :: (HappyAbsSyn ) -> (ExtFCode HintedCmmFormal) happyOut42 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut42 #-} -happyIn43 :: ([ExtFCode LocalReg]) -> (HappyAbsSyn ) +happyIn43 :: (ExtFCode LocalReg) -> (HappyAbsSyn ) happyIn43 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn43 #-} -happyOut43 :: (HappyAbsSyn ) -> ([ExtFCode LocalReg]) +happyOut43 :: (HappyAbsSyn ) -> (ExtFCode LocalReg) happyOut43 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut43 #-} -happyIn44 :: ([ExtFCode LocalReg]) -> (HappyAbsSyn ) +happyIn44 :: (ExtFCode CmmReg) -> (HappyAbsSyn ) happyIn44 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn44 #-} -happyOut44 :: (HappyAbsSyn ) -> ([ExtFCode LocalReg]) +happyOut44 :: (HappyAbsSyn ) -> (ExtFCode CmmReg) happyOut44 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut44 #-} happyIn45 :: ([ExtFCode LocalReg]) -> (HappyAbsSyn ) @@ -325,36 +328,48 @@ happyOut45 :: (HappyAbsSyn ) -> ([ExtFCode LocalReg]) happyOut45 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut45 #-} -happyIn46 :: (ExtFCode LocalReg) -> (HappyAbsSyn ) +happyIn46 :: ([ExtFCode LocalReg]) -> (HappyAbsSyn ) happyIn46 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn46 #-} -happyOut46 :: (HappyAbsSyn ) -> (ExtFCode LocalReg) +happyOut46 :: (HappyAbsSyn ) -> ([ExtFCode LocalReg]) happyOut46 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut46 #-} -happyIn47 :: (ExtFCode (Maybe UpdateFrame)) -> (HappyAbsSyn ) +happyIn47 :: ([ExtFCode LocalReg]) -> (HappyAbsSyn ) happyIn47 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn47 #-} -happyOut47 :: (HappyAbsSyn ) -> (ExtFCode (Maybe UpdateFrame)) +happyOut47 :: (HappyAbsSyn ) -> ([ExtFCode LocalReg]) happyOut47 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut47 #-} -happyIn48 :: (ExtFCode (Maybe BlockId)) -> (HappyAbsSyn ) +happyIn48 :: (ExtFCode LocalReg) -> (HappyAbsSyn ) happyIn48 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn48 #-} -happyOut48 :: (HappyAbsSyn ) -> (ExtFCode (Maybe BlockId)) +happyOut48 :: (HappyAbsSyn ) -> (ExtFCode LocalReg) happyOut48 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut48 #-} -happyIn49 :: (CmmType) -> (HappyAbsSyn ) +happyIn49 :: (ExtFCode (Maybe UpdateFrame)) -> (HappyAbsSyn ) happyIn49 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn49 #-} -happyOut49 :: (HappyAbsSyn ) -> (CmmType) +happyOut49 :: (HappyAbsSyn ) -> (ExtFCode (Maybe UpdateFrame)) happyOut49 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut49 #-} -happyIn50 :: (CmmType) -> (HappyAbsSyn ) +happyIn50 :: (ExtFCode (Maybe BlockId)) -> (HappyAbsSyn ) happyIn50 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn50 #-} -happyOut50 :: (HappyAbsSyn ) -> (CmmType) +happyOut50 :: (HappyAbsSyn ) -> (ExtFCode (Maybe BlockId)) happyOut50 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut50 #-} +happyIn51 :: (CmmType) -> (HappyAbsSyn ) +happyIn51 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn51 #-} +happyOut51 :: (HappyAbsSyn ) -> (CmmType) +happyOut51 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut51 #-} +happyIn52 :: (CmmType) -> (HappyAbsSyn ) +happyIn52 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn52 #-} +happyOut52 :: (HappyAbsSyn ) -> (CmmType) +happyOut52 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut52 #-} happyInTok :: (Located CmmToken) -> (HappyAbsSyn ) happyInTok x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyInTok #-} @@ -364,21 +379,21 @@ happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\x3e\x01\x00\x00\x2e\x03\x3e\x01\x00\x00\x00\x00\x6a\x03\x00\x00\x30\x03\x00\x00\x68\x03\x66\x03\x62\x03\x61\x03\x60\x03\x5b\x03\x19\x03\x1e\x03\x18\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x03\x21\x03\x33\x01\x50\x03\x2b\x03\x3b\x03\x39\x03\x17\x03\x11\x03\x0f\x03\x02\x03\xfc\x02\xf8\x02\x34\x03\x05\x00\x00\x00\x04\x03\x00\x00\xec\x02\x00\x00\x1b\x03\x1a\x03\x0b\x03\x0a\x03\x08\x03\x07\x03\x00\x00\x48\x01\xdf\x02\x00\x00\x13\x03\x00\x00\x01\x03\xd5\x02\xe1\x02\x0d\x03\x61\x00\x00\x00\x33\x01\x00\x00\x00\x00\xfe\x02\x48\x01\xff\xff\xfa\x02\xf6\x02\xc3\x02\xf2\x02\xe5\x02\xbf\x02\xbe\x02\xb9\x02\xae\x02\xa5\x02\xad\x02\x00\x00\xde\x02\x1a\x00\xcf\x02\xca\x02\x62\x00\xc9\x02\xc7\x02\xc5\x02\x00\x00\x02\x00\xce\x02\x8f\x02\x8a\x02\xa5\x01\xc0\x02\x00\x00\xc4\x02\x00\x00\x61\x00\x61\x00\x86\x02\x61\x00\x00\x00\x00\x00\x00\x00\xab\x02\xab\x02\x00\x00\x00\x00\x00\x00\x38\x02\x1a\x00\xbc\x02\x1a\x00\x1a\x00\xda\xff\xb6\x02\x0d\x00\x00\x00\x98\x00\x7e\x02\x54\x00\x61\x00\xa8\x02\xb5\x02\x00\x00\x1c\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x00\x00\x33\x01\x00\x00\xdd\x00\xa7\x02\x00\x00\x50\x02\x61\x00\x6d\x02\x00\x00\xa6\x02\x95\x02\x00\x00\x68\x02\x98\x02\x63\x02\x61\x02\x5b\x02\x00\x00\x33\x01\x53\x02\x88\x02\x61\x00\x8b\x02\x00\x00\x84\x03\x8c\x02\x75\x02\x72\x02\x5d\x02\x5c\x02\x52\x02\x67\x02\x65\x02\x5e\x02\x59\x02\x4f\x02\xed\x01\x00\x00\x61\x00\x00\x00\xac\x03\xac\x03\xac\x03\xac\x03\x7b\x00\x7b\x00\xac\x03\xac\x03\xc0\x03\xc7\x03\xd0\x03\xdd\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x70\x03\x49\x02\x00\x00\x00\x00\x61\x00\x61\x00\x18\x02\x4e\x02\x61\x00\x1f\x02\x0c\x00\x00\x00\x98\x03\x54\x00\x54\x00\x4d\x02\x46\x02\x2d\x02\x00\x00\x00\x00\x02\x02\x61\x00\x61\x00\x00\x02\x32\x02\x00\x00\x00\x00\x00\x00\xf7\x01\x61\x00\x91\x01\xd3\x01\x00\x00\x98\x00\x2f\x02\x00\x00\x00\x00\xa7\x00\x2e\x02\x50\x02\x1a\x00\x54\x00\x54\x00\x33\x02\x99\x00\x22\x02\x00\x00\x13\x02\x00\x00\x0f\x02\xb9\x01\x20\x02\x00\x00\x61\x00\x17\x02\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x01\xdb\x01\xda\x01\x00\x00\xcf\x01\x00\x00\x00\x00\xfa\x01\xf9\x01\xf8\x01\xf0\x01\x00\x00\x00\x00\x00\x00\x03\x02\xce\x01\xc1\x01\x61\x00\x00\x00\x00\x00\x00\x00\xa7\x00\xd7\x01\xf2\x01\x00\x00\x00\x00\x00\x00\xef\x01\x00\x00\x06\x02\xee\x01\x61\x00\x61\x00\x61\x00\xcc\x01\x00\x00\xe6\x01\xa6\x01\xb4\x01\xa9\x01\x00\x00\xa8\x01\x9c\x01\x9b\x01\x9a\x01\xc4\x01\xbc\x01\xbb\x01\xc8\x01\xbd\x01\xa7\x01\x00\x00\xcb\x01\xba\x01\x00\x00\x00\x00\x93\x01\x7d\x01\x8d\x01\x8c\x01\x69\x01\x69\x01\x00\x00\x1a\x00\x72\x01\x00\x00\x3b\x01\x71\x01\x00\x00\x68\x01\x67\x01\x46\x01\x55\x01\x53\x01\x50\x01\x1a\x00\x00\x00\x1a\x00\x58\x01\x52\x01\x00\x00\x52\x01\x54\x01\x06\x00\x23\x01\x00\x00\x47\x01\x3c\x01\xfc\x00\xf8\x00\x00\x00\x13\x00\x34\x01\x00\x00\x00\x00\x32\x01\xfb\x00\x24\x01\x00\x00\x10\x01\x00\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\x00\x15\x01\x00\x00\x00\x00\x00\x00"# +happyActOffsets = HappyA# "\x33\x01\x00\x00\x57\x03\x33\x01\x00\x00\x00\x00\x92\x03\x00\x00\x47\x03\x00\x00\x71\x03\x70\x03\x6f\x03\x6c\x03\x66\x03\x65\x03\x29\x03\x31\x03\x05\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x03\x2b\x03\x3c\x01\x4a\x03\x32\x03\x00\x00\x26\x03\x46\x03\x38\x03\x30\x03\x23\x03\x21\x03\x1d\x03\x1c\x03\x1b\x03\x0b\x03\x28\x03\x09\x00\x00\x00\xf8\x02\x00\x00\x0a\x03\x00\x00\x2c\x03\x2a\x03\x25\x03\x1a\x03\x17\x03\x16\x03\xeb\x02\x00\x00\x47\x01\x00\x00\x05\x01\x00\x00\x10\x03\x00\x00\x0c\x03\xe8\x02\xed\x02\x08\x03\x61\x00\x00\x00\x3c\x01\x00\x00\x00\x00\x0d\x03\x47\x01\xff\xff\x07\x03\x09\x03\xd0\x02\x05\x03\xfa\x02\x00\x00\xc6\x02\xc4\x02\xb8\x02\xb5\x02\xb3\x02\xa9\x02\x00\x00\xe2\x02\x1a\x00\xde\x02\xdb\x02\x12\x00\xd9\x02\xd5\x02\xd4\x02\x00\x00\x02\x00\xd8\x02\x99\x02\x95\x02\xa4\x01\xce\x02\x00\x00\xcf\x02\x00\x00\x61\x00\x61\x00\x96\x02\x61\x00\x00\x00\x00\x00\x00\x00\xb7\x02\xb7\x02\x00\x00\x00\x00\x00\x00\x37\x02\x1a\x00\xca\x02\x1a\x00\x1a\x00\xa7\x00\xc0\x02\x0d\x00\x00\x00\xf8\x00\x88\x02\x54\x00\x61\x00\xb9\x02\xb6\x02\x00\x00\x1c\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x00\x00\x3c\x01\x00\x00\x02\x01\xa1\x02\x00\x00\x4f\x02\x61\x00\x78\x02\x00\x00\xb4\x02\xa3\x02\x00\x00\x59\x02\xa5\x02\x74\x02\x5b\x02\x53\x02\x00\x00\x3c\x01\x4d\x02\x86\x02\x61\x00\x7f\x02\x00\x00\x82\x03\x8b\x02\x6a\x02\x75\x02\x69\x02\x68\x02\x66\x02\x79\x02\x77\x02\x60\x02\x65\x02\x5c\x02\xec\x01\x00\x00\x61\x00\x00\x00\xaa\x03\xaa\x03\xaa\x03\xaa\x03\x7b\x00\x7b\x00\xaa\x03\xaa\x03\xbe\x03\xc5\x03\xf9\x00\x02\x01\x02\x01\x00\x00\x00\x00\x00\x00\x6e\x03\x5d\x02\x00\x00\x00\x00\x61\x00\x61\x00\x17\x02\x58\x02\x61\x00\x1e\x02\x4d\x00\x00\x00\x96\x03\x54\x00\x54\x00\x56\x02\x45\x02\x3a\x02\x00\x00\x00\x00\x0f\x02\x61\x00\x61\x00\x0d\x02\x34\x02\x00\x00\x00\x00\x00\x00\x01\x02\x61\x00\x90\x01\xd2\x01\x00\x00\xf8\x00\x36\x02\x00\x00\x00\x00\x00\x01\x38\x02\x4f\x02\x1a\x00\x54\x00\x54\x00\x35\x02\x99\x00\x2e\x02\x00\x00\x10\x02\x00\x00\xf7\x01\xb8\x01\x2d\x02\x00\x00\x61\x00\x2c\x02\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x01\xe6\x01\xe5\x01\x00\x00\xd9\x01\x00\x00\x00\x00\x08\x02\x07\x02\x06\x02\xfa\x01\x00\x00\x00\x00\x00\x00\x0c\x02\xd7\x01\xc3\x01\x61\x00\x00\x00\x00\x00\x00\x00\x00\x01\xe4\x01\xff\x01\x00\x00\x00\x00\x00\x00\xf9\x01\x00\x00\x05\x02\xf0\x01\x61\x00\x61\x00\x61\x00\xce\x01\x00\x00\xef\x01\xbd\x01\xb3\x01\xb1\x01\x00\x00\xaa\x01\xa8\x01\xa7\x01\x9c\x01\xc6\x01\xc5\x01\xc4\x01\xd1\x01\xcf\x01\xbb\x01\x00\x00\xcb\x01\xcd\x01\x00\x00\x00\x00\xba\x01\x7c\x01\xb4\x01\x9f\x01\x68\x01\x68\x01\x00\x00\x1a\x00\xa5\x01\x00\x00\x78\x01\x92\x01\x00\x00\x53\x01\x52\x01\x45\x01\x74\x01\x67\x01\x65\x01\x1a\x00\x00\x00\x1a\x00\x66\x01\x63\x01\x00\x00\x63\x01\x64\x01\x06\x00\x35\x01\x00\x00\x60\x01\x5e\x01\x22\x01\x19\x01\x00\x00\x11\x00\x4b\x01\x00\x00\x00\x00\x4d\x01\x15\x01\x41\x01\x00\x00\x38\x01\x00\x00\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x01\x32\x01\x00\x00\x00\x00\x00\x00"# happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\xc3\x00\x00\x00\x00\x00\xb9\x00\x00\x00\x00\x00\xf7\x00\x00\x00\x0f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x01\x00\x00\xf3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\x00\xe1\x00\x27\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc1\x00\x00\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2f\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\x00\x00\x4d\x03\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x01\x00\x4b\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x01\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x03\x33\x03\x00\x00\x2f\x03\x00\x00\x00\x00\x00\x00\xc2\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x00\x00\xf6\x00\xed\x00\x00\x00\x00\x00\xd1\x00\x00\x00\xf2\x00\x00\x00\x31\x01\x2d\x03\xb0\x00\xbb\x00\x00\x00\x00\x00\x79\x02\x1c\x03\x16\x03\x12\x03\x0c\x03\xfb\x02\xf9\x02\xf5\x02\xeb\x02\xdd\x02\xdb\x02\xd9\x02\xcb\x02\xc1\x02\xbd\x02\xbb\x02\xaa\x02\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x02\x00\x00\x00\x00\x00\x00\xbc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\x00\x00\x00\x00\x00\xa0\x02\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\xff\x9a\x02\x00\x00\x00\x00\x5f\x02\x97\x00\x00\x00\x00\x00\x00\x00\x2b\x01\x1a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x89\x02\x87\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x02\x00\x00\x00\x00\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xda\x00\x14\x01\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x01\x00\x00\x00\x00\xfd\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x66\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x02\x48\x00\xa5\x00\x81\x00\x00\x00\x00\x00\x51\x00\xef\xff\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x27\x00\x00\x00\xd5\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x00\x00\x00\xc6\x00\x00\x00\x14\x00\x00\x00\x03\x00\x00\x00\x1f\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# +happyGotoOffsets = HappyA# "\xb9\x00\x00\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x0e\x01\x00\x00\x29\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x01\x00\x00\x0d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x01\x01\x01\xb2\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xee\x00\x00\x00\xed\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x01\x00\x00\xac\x00\x00\x00\xdc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd6\x00\x00\x00\x56\x03\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x01\x00\x45\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\xf3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x03\x3b\x03\x00\x00\x35\x03\x00\x00\x00\x00\x00\x00\xe5\x00\xd5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\x00\x00\x00\xf5\x00\xcc\x00\x00\x00\x00\x00\xe3\x00\x00\x00\xd0\x00\x00\x00\x31\x01\x24\x03\xc7\x00\xdf\x00\x00\x00\x00\x00\x81\x02\x22\x03\x1e\x03\x14\x03\x06\x03\x04\x03\x02\x03\xf4\x02\xea\x02\xe6\x02\xe4\x02\xd3\x02\xcd\x02\xc9\x02\xc3\x02\xb2\x02\xb0\x02\x00\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xac\x02\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x48\x00\x00\x00\x00\x00\xa2\x02\x00\x00\x00\x00\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x02\x94\x02\x00\x00\x00\x00\x55\x02\xaa\x00\x00\x00\x00\x00\x00\x00\x2f\x01\x21\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9a\x00\x92\x02\x8f\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x02\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x00\x13\x01\xfb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x76\x02\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x00\x00\x57\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x00\xf5\xff\xfc\xff\x58\x00\x00\x00\x00\x00\x80\x00\x64\x00\x47\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x56\x00\x00\x00\xbd\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x00\x00\xfa\xff\x00\x00\x14\x00\x00\x00\x0e\x00\x00\x00\x08\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf6\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# happyDefActions :: HappyAddr -happyDefActions = HappyA# "\xfe\xff\x00\x00\x00\x00\xfe\xff\xfb\xff\xfc\xff\x7e\xff\xfa\xff\x00\x00\x71\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\xff\x70\xff\x6f\xff\x6e\xff\x6d\xff\x6c\xff\x6b\xff\x7e\xff\x74\xff\x7c\xff\x00\x00\xdb\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\xff\xfd\xff\x76\xff\xea\xff\x00\x00\xde\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\xff\xf7\xff\x00\x00\xdd\xff\x00\x00\x7b\xff\x79\xff\x00\x00\x76\xff\x00\x00\x00\x00\x77\xff\x7a\xff\x7d\xff\xda\xff\x00\x00\xf7\xff\x00\x00\x71\xff\x00\x00\x00\x00\x72\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\xff\x00\x00\xe1\xff\xed\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\xff\x9c\xff\x00\x00\xf3\xff\x00\x00\x00\x00\x00\x00\x00\x00\x89\xff\x8a\xff\x9d\xff\x98\xff\x98\xff\xf6\xff\xf8\xff\x78\xff\x00\x00\xe1\xff\x00\x00\xe1\xff\xe1\xff\x00\x00\x00\x00\x00\x00\xd9\xff\x00\x00\x00\x00\x00\x00\x00\x00\x96\xff\xbd\xff\x7f\xff\x80\xff\x8e\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\xff\x00\x00\x9f\xff\xa2\xff\x00\x00\xa3\xff\x00\x00\x00\x00\x00\x00\xf4\xff\x00\x00\xed\xff\xef\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\xff\x7c\xff\x00\x00\x00\x00\x00\x00\x00\x00\xeb\xff\xed\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\xff\x8e\xff\x97\xff\xa5\xff\xa4\xff\xa7\xff\xa9\xff\xad\xff\xae\xff\xa6\xff\xa8\xff\xaa\xff\xab\xff\xac\xff\xaf\xff\xb0\xff\xb1\xff\xb2\xff\xb3\xff\x8c\xff\x00\x00\x8d\xff\xd8\xff\x8e\xff\x00\x00\x00\x00\x00\x00\x94\xff\x96\xff\x00\x00\xcb\xff\xca\xff\x00\x00\x00\x00\x00\x00\x00\x00\x86\xff\x83\xff\x81\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\xff\xe0\xff\xe9\xff\x00\x00\x00\x00\x00\x00\x00\x00\x82\xff\x85\xff\x00\x00\xd1\xff\xc7\xff\x00\x00\xcb\xff\xca\xff\xe1\xff\x00\x00\x00\x00\x00\x00\x90\xff\x00\x00\x93\xff\x92\xff\xcf\xff\x00\x00\x00\x00\x00\x00\x75\xff\x00\x00\x00\x00\x9b\xff\x00\x00\xf0\xff\xee\xff\xf2\xff\xf1\xff\x00\x00\x00\x00\x00\x00\xe2\xff\x00\x00\xf9\xff\xec\xff\x00\x00\x00\x00\x00\x00\x00\x00\xa1\xff\x9a\xff\x8b\xff\x00\x00\xbc\xff\x00\x00\x00\x00\x95\xff\x8f\xff\xd0\xff\xc8\xff\xc9\xff\x00\x00\xc6\xff\x87\xff\x84\xff\x00\x00\xd7\xff\x00\x00\x00\x00\x94\xff\x94\xff\x00\x00\xb5\xff\x91\xff\x00\x00\xb6\xff\xbc\xff\x00\x00\xd3\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\xff\xbb\xff\x00\x00\x00\x00\xbe\xff\xce\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc5\xff\xc5\xff\xd6\xff\xe1\xff\x00\x00\xd2\xff\x00\x00\x00\x00\xe4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\xff\xb8\xff\xe1\xff\x00\x00\xc3\xff\xc4\xff\xc3\xff\x00\x00\x00\x00\xcd\xff\xb4\xff\x00\x00\x00\x00\x00\x00\x00\x00\xe8\xff\x00\x00\x00\x00\xba\xff\xb7\xff\x00\x00\x00\x00\x00\x00\xc2\xff\xc0\xff\xd4\xff\x00\x00\xc1\xff\xcc\xff\xd5\xff\xe5\xff\xe7\xff\x00\x00\x00\x00\xbf\xff\xe6\xff"# +happyDefActions = HappyA# "\xfe\xff\x00\x00\x00\x00\xfe\xff\xfb\xff\xfc\xff\x7a\xff\xfa\xff\x00\x00\x6d\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\xff\x6c\xff\x6b\xff\x6a\xff\x69\xff\x68\xff\x67\xff\x7a\xff\x70\xff\x78\xff\x00\x00\xdb\xff\xd9\xff\x00\x00\x00\x00\x00\x00\xd7\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\xff\xfd\xff\x72\xff\xea\xff\x00\x00\xde\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\xff\xf7\xff\xd8\xff\x00\x00\xdd\xff\x00\x00\x77\xff\x75\xff\x00\x00\x72\xff\x00\x00\x00\x00\x73\xff\x76\xff\x79\xff\xda\xff\x00\x00\xf7\xff\x00\x00\x6d\xff\x00\x00\x00\x00\x6e\xff\x00\x00\xd6\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xff\x00\x00\xe1\xff\xed\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\xff\x98\xff\x00\x00\xf3\xff\x00\x00\x00\x00\x00\x00\x00\x00\x85\xff\x86\xff\x99\xff\x94\xff\x94\xff\xf6\xff\xf8\xff\x74\xff\x00\x00\xe1\xff\x00\x00\xe1\xff\xe1\xff\x00\x00\x00\x00\x00\x00\xd5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x92\xff\xb9\xff\x7b\xff\x7c\xff\x8a\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9a\xff\x00\x00\x9b\xff\x9e\xff\x00\x00\x9f\xff\x00\x00\x00\x00\x00\x00\xf4\xff\x00\x00\xed\xff\xef\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\xff\x78\xff\x00\x00\x00\x00\x00\x00\x00\x00\xeb\xff\xed\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x95\xff\x8a\xff\x93\xff\xa1\xff\xa0\xff\xa3\xff\xa5\xff\xa9\xff\xaa\xff\xa2\xff\xa4\xff\xa6\xff\xa7\xff\xa8\xff\xab\xff\xac\xff\xad\xff\xae\xff\xaf\xff\x88\xff\x00\x00\x89\xff\xd4\xff\x8a\xff\x00\x00\x00\x00\x00\x00\x90\xff\x92\xff\x00\x00\xc7\xff\xc6\xff\x00\x00\x00\x00\x00\x00\x00\x00\x82\xff\x7f\xff\x7d\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\xff\xe0\xff\xe9\xff\x00\x00\x00\x00\x00\x00\x00\x00\x7e\xff\x81\xff\x00\x00\xcd\xff\xc3\xff\x00\x00\xc7\xff\xc6\xff\xe1\xff\x00\x00\x00\x00\x00\x00\x8c\xff\x00\x00\x8f\xff\x8e\xff\xcb\xff\x00\x00\x00\x00\x00\x00\x71\xff\x00\x00\x00\x00\x97\xff\x00\x00\xf0\xff\xee\xff\xf2\xff\xf1\xff\x00\x00\x00\x00\x00\x00\xe2\xff\x00\x00\xf9\xff\xec\xff\x00\x00\x00\x00\x00\x00\x00\x00\x9d\xff\x96\xff\x87\xff\x00\x00\xb8\xff\x00\x00\x00\x00\x91\xff\x8b\xff\xcc\xff\xc4\xff\xc5\xff\x00\x00\xc2\xff\x83\xff\x80\xff\x00\x00\xd3\xff\x00\x00\x00\x00\x90\xff\x90\xff\x00\x00\xb1\xff\x8d\xff\x00\x00\xb2\xff\xb8\xff\x00\x00\xcf\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\xff\xb7\xff\x00\x00\x00\x00\xba\xff\xca\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc1\xff\xc1\xff\xd2\xff\xe1\xff\x00\x00\xce\xff\x00\x00\x00\x00\xe4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\xff\xb4\xff\xe1\xff\x00\x00\xbf\xff\xc0\xff\xbf\xff\x00\x00\x00\x00\xc9\xff\xb0\xff\x00\x00\x00\x00\x00\x00\x00\x00\xe8\xff\x00\x00\x00\x00\xb6\xff\xb3\xff\x00\x00\x00\x00\x00\x00\xbe\xff\xbc\xff\xd0\xff\x00\x00\xbd\xff\xc8\xff\xd1\xff\xe5\xff\xe7\xff\x00\x00\x00\x00\xbb\xff\xe6\xff"# happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x02\x00\x13\x00\x14\x00\x03\x00\x04\x00\x07\x00\x02\x00\x06\x00\x2f\x00\x0b\x00\x31\x00\x06\x00\x0e\x00\x0f\x00\x03\x00\x18\x00\x19\x00\x05\x00\x10\x00\x0d\x00\x0e\x00\x19\x00\x1f\x00\x20\x00\x21\x00\x11\x00\x08\x00\x02\x00\x01\x00\x21\x00\x18\x00\x19\x00\x07\x00\x0c\x00\x07\x00\x10\x00\x2d\x00\x2e\x00\x15\x00\x21\x00\x16\x00\x2d\x00\x2e\x00\x20\x00\x21\x00\x2d\x00\x2e\x00\x11\x00\x2c\x00\x03\x00\x04\x00\x2d\x00\x2e\x00\x0f\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x29\x00\x42\x00\x3f\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x07\x00\x31\x00\x32\x00\x40\x00\x34\x00\x35\x00\x0f\x00\x0e\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x07\x00\x2d\x00\x2e\x00\x15\x00\x0b\x00\x18\x00\x19\x00\x0e\x00\x0f\x00\x1c\x00\x1d\x00\x1e\x00\x16\x00\x07\x00\x21\x00\x08\x00\x17\x00\x0b\x00\x29\x00\x2a\x00\x0e\x00\x0f\x00\x2d\x00\x2e\x00\x13\x00\x14\x00\x2d\x00\x2e\x00\x25\x00\x16\x00\x2d\x00\x2e\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x17\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x23\x00\x24\x00\x25\x00\x1b\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x01\x00\x02\x00\x05\x00\x18\x00\x19\x00\x06\x00\x07\x00\x05\x00\x09\x00\x00\x00\x01\x00\x02\x00\x21\x00\x20\x00\x21\x00\x06\x00\x07\x00\x1b\x00\x09\x00\x12\x00\x08\x00\x09\x00\x1a\x00\x0b\x00\x2d\x00\x2e\x00\x08\x00\x09\x00\x2b\x00\x0b\x00\x40\x00\x41\x00\x41\x00\x0a\x00\x1a\x00\x08\x00\x09\x00\x2b\x00\x0b\x00\x0a\x00\x08\x00\x09\x00\x05\x00\x0b\x00\x2d\x00\x2e\x00\x22\x00\x0c\x00\x0d\x00\x0e\x00\x26\x00\x2c\x00\x22\x00\x27\x00\x2d\x00\x2e\x00\x26\x00\x2d\x00\x2e\x00\x08\x00\x09\x00\x22\x00\x0b\x00\x2d\x00\x2e\x00\x26\x00\x22\x00\x0a\x00\x08\x00\x09\x00\x26\x00\x0b\x00\x2d\x00\x2e\x00\x28\x00\x29\x00\x2a\x00\x2d\x00\x2e\x00\x2d\x00\x2e\x00\x08\x00\x09\x00\x2c\x00\x0b\x00\x22\x00\x0a\x00\x08\x00\x09\x00\x26\x00\x0b\x00\x23\x00\x24\x00\x25\x00\x22\x00\x0a\x00\x2d\x00\x2e\x00\x26\x00\x08\x00\x27\x00\x3f\x00\x42\x00\x0d\x00\x0e\x00\x2d\x00\x2e\x00\x22\x00\x16\x00\x0d\x00\x0e\x00\x26\x00\x06\x00\x22\x00\x18\x00\x19\x00\x33\x00\x26\x00\x2d\x00\x2e\x00\x18\x00\x19\x00\x02\x00\x21\x00\x2d\x00\x2e\x00\x0d\x00\x0e\x00\x42\x00\x21\x00\x08\x00\x41\x00\x0d\x00\x0e\x00\x04\x00\x2d\x00\x2e\x00\x18\x00\x19\x00\x18\x00\x19\x00\x2d\x00\x2e\x00\x18\x00\x19\x00\x04\x00\x21\x00\x20\x00\x21\x00\x28\x00\x29\x00\x2a\x00\x21\x00\x30\x00\x2d\x00\x2e\x00\x02\x00\x05\x00\x2d\x00\x2e\x00\x2d\x00\x2e\x00\x04\x00\x08\x00\x2d\x00\x2e\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x16\x00\x29\x00\x2a\x00\x16\x00\x22\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x34\x00\x2b\x00\x03\x00\x03\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x42\x00\x40\x00\x02\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x41\x00\x40\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x08\x00\x08\x00\x03\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x41\x00\x41\x00\x41\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x01\x00\x03\x00\x16\x00\x01\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x04\x00\x08\x00\x16\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x16\x00\x41\x00\x41\x00\x37\x00\x42\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x41\x00\x36\x00\x42\x00\x06\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x28\x00\x07\x00\x04\x00\x20\x00\x09\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x42\x00\x36\x00\x02\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x07\x00\x16\x00\x16\x00\x16\x00\x42\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x42\x00\x42\x00\x41\x00\x08\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x07\x00\x18\x00\x08\x00\x16\x00\x08\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x08\x00\x40\x00\x09\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x07\x00\x0e\x00\x41\x00\x40\x00\x16\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x02\x00\x02\x00\x08\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x08\x00\x0a\x00\x42\x00\x02\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x02\x00\x16\x00\x02\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x18\x00\x19\x00\x16\x00\x16\x00\x1c\x00\x1d\x00\x1e\x00\x18\x00\x19\x00\x21\x00\x08\x00\x1c\x00\x1d\x00\x1e\x00\x18\x00\x19\x00\x21\x00\x18\x00\x19\x00\x1d\x00\x1e\x00\x2d\x00\x2e\x00\x21\x00\x1f\x00\x20\x00\x21\x00\x16\x00\x2d\x00\x2e\x00\x02\x00\x04\x00\x08\x00\x18\x00\x19\x00\x2d\x00\x2e\x00\x42\x00\x2d\x00\x2e\x00\x1f\x00\x20\x00\x21\x00\x18\x00\x19\x00\x42\x00\x06\x00\x18\x00\x19\x00\x18\x00\x19\x00\x42\x00\x21\x00\x42\x00\x2d\x00\x2e\x00\x21\x00\x41\x00\x21\x00\x16\x00\x06\x00\x40\x00\x07\x00\x07\x00\x2d\x00\x2e\x00\x18\x00\x19\x00\x2d\x00\x2e\x00\x2d\x00\x2e\x00\x18\x00\x19\x00\x05\x00\x21\x00\x18\x00\x19\x00\x40\x00\x09\x00\x04\x00\x21\x00\x18\x00\x19\x00\x19\x00\x21\x00\x40\x00\x2d\x00\x2e\x00\x05\x00\x0a\x00\x21\x00\x42\x00\x2d\x00\x2e\x00\x40\x00\x02\x00\x2d\x00\x2e\x00\x18\x00\x19\x00\x18\x00\x19\x00\x2d\x00\x2e\x00\x18\x00\x19\x00\x16\x00\x21\x00\x16\x00\x21\x00\x16\x00\x16\x00\x03\x00\x21\x00\x18\x00\x19\x00\x16\x00\x01\x00\x42\x00\x2d\x00\x2e\x00\x2d\x00\x2e\x00\x21\x00\x40\x00\x2d\x00\x2e\x00\x42\x00\x18\x00\x19\x00\x18\x00\x19\x00\x18\x00\x19\x00\x05\x00\x2d\x00\x2e\x00\x21\x00\x42\x00\x21\x00\x07\x00\x21\x00\x05\x00\x42\x00\x42\x00\x04\x00\x18\x00\x19\x00\x42\x00\x2d\x00\x2e\x00\x2d\x00\x2e\x00\x2d\x00\x2e\x00\x21\x00\x18\x00\x19\x00\x2e\x00\x03\x00\x18\x00\x19\x00\x18\x00\x19\x00\x40\x00\x21\x00\x16\x00\x2d\x00\x2e\x00\x21\x00\x08\x00\x21\x00\x16\x00\x16\x00\x40\x00\x16\x00\x16\x00\x2d\x00\x2e\x00\x18\x00\x19\x00\x2d\x00\x2e\x00\x2d\x00\x2e\x00\x18\x00\x19\x00\x40\x00\x21\x00\x18\x00\x19\x00\x16\x00\x16\x00\x2e\x00\x21\x00\x18\x00\x19\x00\x02\x00\x21\x00\x40\x00\x2d\x00\x2e\x00\x02\x00\x40\x00\x21\x00\x03\x00\x2d\x00\x2e\x00\x16\x00\x40\x00\x2d\x00\x2e\x00\x18\x00\x19\x00\x18\x00\x19\x00\x2d\x00\x2e\x00\x18\x00\x19\x00\x2c\x00\x21\x00\x40\x00\x21\x00\x40\x00\x02\x00\x07\x00\x21\x00\x18\x00\x19\x00\x40\x00\x40\x00\x40\x00\x2d\x00\x2e\x00\x2d\x00\x2e\x00\x21\x00\x41\x00\x2d\x00\x2e\x00\x07\x00\x18\x00\x19\x00\x18\x00\x19\x00\x07\x00\x07\x00\x07\x00\x2d\x00\x2e\x00\x21\x00\x07\x00\x21\x00\x07\x00\x40\x00\x07\x00\x44\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\x2e\x00\x2d\x00\x2e\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\xff\xff\x1a\x00\x1b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x1a\x00\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# +happyCheck = HappyA# "\xff\xff\x02\x00\x08\x00\x09\x00\x03\x00\x04\x00\x07\x00\x0d\x00\x06\x00\x13\x00\x0b\x00\x02\x00\x06\x00\x0e\x00\x0f\x00\x1a\x00\x1b\x00\x0e\x00\x05\x00\x1e\x00\x1f\x00\x20\x00\x1a\x00\x1b\x00\x23\x00\x08\x00\x08\x00\x13\x00\x02\x00\x01\x00\x24\x00\x23\x00\x12\x00\x07\x00\x28\x00\x07\x00\x2f\x00\x30\x00\x12\x00\x16\x00\x16\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x00\x00\x01\x00\x02\x00\x2f\x00\x30\x00\x17\x00\x06\x00\x07\x00\x2c\x00\x09\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x29\x00\x42\x00\x3f\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x07\x00\x31\x00\x32\x00\x40\x00\x34\x00\x35\x00\x03\x00\x0e\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x07\x00\x2f\x00\x30\x00\x17\x00\x0b\x00\x1a\x00\x1b\x00\x0e\x00\x0f\x00\x1e\x00\x1f\x00\x20\x00\x11\x00\x07\x00\x23\x00\x11\x00\x17\x00\x0b\x00\x20\x00\x21\x00\x0e\x00\x0f\x00\x19\x00\x2a\x00\x2b\x00\x2c\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x15\x00\x16\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x18\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x03\x00\x04\x00\x15\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x01\x00\x02\x00\x25\x00\x26\x00\x27\x00\x06\x00\x07\x00\x27\x00\x09\x00\x08\x00\x09\x00\x08\x00\x09\x00\x1d\x00\x0d\x00\x1b\x00\x0d\x00\x2b\x00\x2c\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x23\x00\x08\x00\x09\x00\x08\x00\x09\x00\x2f\x00\x0d\x00\x31\x00\x0d\x00\x41\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x24\x00\x05\x00\x24\x00\x05\x00\x28\x00\x1d\x00\x28\x00\x0a\x00\x0b\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x24\x00\x0c\x00\x24\x00\x1c\x00\x28\x00\x14\x00\x28\x00\x25\x00\x26\x00\x27\x00\x05\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x08\x00\x09\x00\x08\x00\x09\x00\x1c\x00\x0d\x00\x2d\x00\x0d\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x0f\x00\x10\x00\x08\x00\x09\x00\x0c\x00\x0d\x00\x0e\x00\x0d\x00\x0c\x00\x1a\x00\x1b\x00\x1a\x00\x1b\x00\x0a\x00\x0b\x00\x24\x00\x2d\x00\x24\x00\x2e\x00\x28\x00\x23\x00\x28\x00\x20\x00\x21\x00\x0f\x00\x10\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x24\x00\x0c\x00\x2f\x00\x30\x00\x28\x00\x1a\x00\x1b\x00\x2e\x00\x0f\x00\x10\x00\x29\x00\x2f\x00\x30\x00\x0c\x00\x23\x00\x29\x00\x40\x00\x41\x00\x08\x00\x1a\x00\x1b\x00\x3f\x00\x0f\x00\x10\x00\x0f\x00\x10\x00\x2f\x00\x30\x00\x23\x00\x40\x00\x41\x00\x06\x00\x33\x00\x1a\x00\x1b\x00\x1a\x00\x1b\x00\x42\x00\x16\x00\x02\x00\x2f\x00\x30\x00\x23\x00\x08\x00\x23\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x42\x00\x29\x00\x2a\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x04\x00\x41\x00\x04\x00\x30\x00\x02\x00\x34\x00\x05\x00\x22\x00\x04\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x2b\x00\x40\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x16\x00\x08\x00\x16\x00\x02\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x41\x00\x40\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x41\x00\x41\x00\x03\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x08\x00\x03\x00\x41\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x42\x00\x03\x00\x08\x00\x03\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x01\x00\x04\x00\x01\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x08\x00\x16\x00\x16\x00\x16\x00\x41\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x41\x00\x36\x00\x42\x00\x41\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x42\x00\x37\x00\x06\x00\x28\x00\x07\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x09\x00\x04\x00\x20\x00\x42\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x07\x00\x36\x00\x02\x00\x18\x00\x16\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x42\x00\x16\x00\x16\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x07\x00\x16\x00\x42\x00\x42\x00\x41\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x08\x00\x08\x00\x02\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x07\x00\x09\x00\x08\x00\x40\x00\x0e\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x41\x00\x40\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x08\x00\x02\x00\x42\x00\x02\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x0a\x00\x02\x00\x08\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x1a\x00\x1b\x00\x1a\x00\x1b\x00\x1e\x00\x1f\x00\x20\x00\x1f\x00\x20\x00\x23\x00\x02\x00\x23\x00\x02\x00\x16\x00\x08\x00\x16\x00\x16\x00\x16\x00\x1a\x00\x1b\x00\x04\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x21\x00\x22\x00\x23\x00\x1a\x00\x1b\x00\x02\x00\x08\x00\x42\x00\x1a\x00\x1b\x00\x21\x00\x22\x00\x23\x00\x42\x00\x2f\x00\x30\x00\x22\x00\x23\x00\x41\x00\x1a\x00\x1b\x00\x42\x00\x1a\x00\x1b\x00\x2f\x00\x30\x00\x21\x00\x22\x00\x23\x00\x2f\x00\x30\x00\x23\x00\x07\x00\x1a\x00\x1b\x00\x06\x00\x1a\x00\x1b\x00\x1a\x00\x1b\x00\x2f\x00\x30\x00\x23\x00\x2f\x00\x30\x00\x23\x00\x42\x00\x23\x00\x40\x00\x16\x00\x06\x00\x05\x00\x1a\x00\x1b\x00\x2f\x00\x30\x00\x07\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x23\x00\x1a\x00\x1b\x00\x40\x00\x09\x00\x1a\x00\x1b\x00\x1a\x00\x1b\x00\x04\x00\x23\x00\x19\x00\x2f\x00\x30\x00\x23\x00\x05\x00\x23\x00\x40\x00\x42\x00\x0a\x00\x40\x00\x02\x00\x2f\x00\x30\x00\x1a\x00\x1b\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x1a\x00\x1b\x00\x03\x00\x23\x00\x1a\x00\x1b\x00\x40\x00\x16\x00\x16\x00\x23\x00\x1a\x00\x1b\x00\x16\x00\x23\x00\x16\x00\x2f\x00\x30\x00\x16\x00\x42\x00\x23\x00\x42\x00\x2f\x00\x30\x00\x42\x00\x01\x00\x2f\x00\x30\x00\x1a\x00\x1b\x00\x1a\x00\x1b\x00\x2f\x00\x30\x00\x1a\x00\x1b\x00\x42\x00\x23\x00\x42\x00\x23\x00\x05\x00\x03\x00\x05\x00\x23\x00\x1a\x00\x1b\x00\x07\x00\x04\x00\x42\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x23\x00\x08\x00\x2f\x00\x30\x00\x2e\x00\x1a\x00\x1b\x00\x1a\x00\x1b\x00\x1a\x00\x1b\x00\x16\x00\x2f\x00\x30\x00\x23\x00\x2e\x00\x23\x00\x40\x00\x23\x00\x02\x00\x40\x00\x16\x00\x16\x00\x1a\x00\x1b\x00\x16\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x23\x00\x1a\x00\x1b\x00\x02\x00\x16\x00\x1a\x00\x1b\x00\x1a\x00\x1b\x00\x16\x00\x23\x00\x16\x00\x2f\x00\x30\x00\x23\x00\x16\x00\x23\x00\x16\x00\x03\x00\x40\x00\x40\x00\x02\x00\x2f\x00\x30\x00\x1a\x00\x1b\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x1a\x00\x1b\x00\x2c\x00\x23\x00\x1a\x00\x1b\x00\x40\x00\x40\x00\x40\x00\x23\x00\x1a\x00\x1b\x00\x40\x00\x23\x00\x40\x00\x2f\x00\x30\x00\x40\x00\x07\x00\x23\x00\x40\x00\x2f\x00\x30\x00\x07\x00\x07\x00\x2f\x00\x30\x00\x1a\x00\x1b\x00\x41\x00\x07\x00\x2f\x00\x30\x00\x07\x00\x07\x00\x07\x00\x23\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x2f\x00\x30\x00\x40\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x07\x00\xff\xff\x44\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\xff\xff\x1a\x00\x1b\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x1a\x00\x1b\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x64\x00\x3b\x01\x2e\x01\x6d\x00\x44\x00\x65\x00\x2c\x00\xa0\x00\xe3\x00\x66\x00\xe4\x00\x6b\x01\x67\x00\x68\x00\xf4\x00\xcb\x00\x60\x00\xe1\x00\x5a\x01\x1d\x01\xd6\x00\x13\x01\xfe\x00\xcd\x00\x61\x00\x75\x01\x73\x01\x79\x00\xcf\x00\x61\x00\xd7\x00\x60\x00\x7a\x00\x67\x01\xd0\x00\x5c\x01\x62\x00\x09\x00\x54\x01\x61\x00\x74\x01\x62\x00\x09\x00\xf5\x00\xf6\x00\x45\x00\x46\x00\x69\x01\x2d\x00\x43\x00\x44\x00\x62\x00\x09\x00\x57\x01\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x11\x00\xa1\x00\x6c\x01\x7b\x00\x7c\x00\x7d\x00\x88\xff\x65\x00\x88\xff\x7e\x00\x1f\x00\x13\x00\x7f\x00\x59\x01\x67\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x80\x00\x81\x00\xd9\x00\x45\x00\x46\x00\x39\x01\x66\x00\xf7\x00\x60\x00\x67\x00\x68\x00\x42\x01\xf9\x00\xfa\x00\x3c\x01\x65\x00\x61\x00\xa5\x00\xda\x00\x66\x00\x6f\x00\x3a\x00\x67\x00\x68\x00\x3b\x00\x09\x00\x2d\x01\x2e\x01\x62\x00\x09\x00\xeb\x00\xa6\x00\xba\x00\x09\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x3f\x01\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x22\x01\xdc\x00\xdd\x00\xf6\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x29\x00\x03\x00\x04\x00\x0e\x01\x41\x01\x60\x00\x05\x00\x06\x00\xb4\x00\x07\x00\x02\x00\x03\x00\x04\x00\x61\x00\xf5\x00\xf6\x00\x05\x00\x06\x00\xd2\x00\x07\x00\xd0\x00\x5e\x01\x73\x00\x92\x00\x74\x00\x62\x00\x09\x00\x5f\x01\x73\x00\x3d\x00\x74\x00\xdf\x00\xe0\x00\x1c\x01\x27\x00\x94\x00\x56\x01\x73\x00\x52\x00\x74\x00\x42\x00\x1f\x01\x73\x00\xa7\x00\x74\x00\x08\x00\x09\x00\x75\x00\x83\x00\x84\x00\x85\x00\x76\x00\x2a\x00\x75\x00\x1b\x00\x08\x00\x09\x00\x76\x00\x77\x00\x09\x00\xe4\x00\x73\x00\x75\x00\x74\x00\x77\x00\x09\x00\x76\x00\x75\x00\x1d\x00\xe5\x00\x73\x00\x76\x00\x74\x00\x77\x00\x09\x00\xae\x00\x39\x00\x3a\x00\x77\x00\x09\x00\x3b\x00\x09\x00\x72\x00\x73\x00\x3c\x00\x74\x00\x75\x00\x20\x00\xa9\x00\x73\x00\x76\x00\x74\x00\xdb\x00\xdc\x00\xdd\x00\x75\x00\x27\x00\x77\x00\x09\x00\x76\x00\x77\x01\x28\x00\x6c\x01\x75\x01\x1e\x01\xd6\x00\x77\x00\x09\x00\x75\x00\x6e\x01\xef\x00\xd6\x00\x76\x00\x6f\x01\x75\x00\xd7\x00\x60\x00\x70\x01\x76\x00\x77\x00\x09\x00\xd7\x00\x60\x00\x71\x01\x61\x00\x77\x00\x09\x00\xf0\x00\xf1\x00\x64\x01\x61\x00\x72\x01\x65\x01\xd5\x00\xd6\x00\x66\x01\x62\x00\x09\x00\xf2\x00\x60\x00\xcb\x00\x60\x00\x62\x00\x09\x00\xd7\x00\x60\x00\x67\x01\x61\x00\x15\x01\x61\x00\x38\x00\x39\x00\x3a\x00\x61\x00\x69\x01\x3b\x00\x09\x00\x6d\x01\x5c\x01\x62\x00\x09\x00\x62\x00\x09\x00\x5e\x01\x63\x01\x62\x00\x09\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x61\x01\x11\x00\x12\x00\x62\x01\x48\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x13\x00\x49\x00\x54\x01\x56\x01\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x3b\x01\x1b\x00\x47\x01\x4a\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x51\x01\x4b\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x25\x01\x45\x01\x46\x01\x48\x01\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x9c\x00\x52\x01\x53\x01\x59\x01\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x49\x01\x18\x01\x4b\x01\x4c\x01\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x4a\x01\x4d\x01\x4e\x01\x4f\x01\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x24\x01\x50\x01\x36\x01\x37\x01\x3e\x01\x38\x01\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x39\x01\x30\x01\x3b\x01\x3f\x01\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x03\x01\x41\x01\x28\x01\x2b\x01\xf5\x00\x2a\x01\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x2d\x01\x30\x01\x31\x01\x32\x01\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x29\x01\x33\x01\x34\x01\x35\x01\x10\x01\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x11\x01\x12\x01\x13\x01\x15\x01\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xd4\x00\x19\x01\x17\x01\x1a\x01\x1b\x01\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x1d\x01\x21\x01\x27\x01\x22\x01\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x82\x00\xe8\x00\xe9\x00\xdf\x00\xed\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\xee\x00\xef\x00\xfc\x00\x00\x01\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xb9\x00\x04\x01\xfd\x00\x05\x01\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x06\x01\x07\x01\x09\x01\x08\x01\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xf7\x00\x60\x00\x0a\x01\x0b\x01\x43\x01\xf9\x00\xfa\x00\xf7\x00\x60\x00\x61\x00\x0c\x01\xf8\x00\xf9\x00\xfa\x00\xf7\x00\x60\x00\x61\x00\xcb\x00\x60\x00\x2b\x01\xfa\x00\x62\x00\x09\x00\x61\x00\x01\x01\xcd\x00\x61\x00\x0d\x01\x62\x00\x09\x00\x0e\x01\xab\x00\xad\x00\xcb\x00\x60\x00\x62\x00\x09\x00\xae\x00\x62\x00\x09\x00\xcc\x00\xcd\x00\x61\x00\x25\x01\x60\x00\xb0\x00\xb3\x00\xe9\x00\x60\x00\xea\x00\x60\x00\xb1\x00\x61\x00\xb2\x00\x62\x00\x09\x00\x61\x00\xb4\x00\x61\x00\xa9\x00\xb6\x00\xb7\x00\xba\x00\xd4\x00\x62\x00\x09\x00\xfd\x00\x60\x00\x62\x00\x09\x00\x62\x00\x09\x00\xab\x00\x60\x00\xd2\x00\x61\x00\xb7\x00\x60\x00\xdb\x00\xe2\x00\xe7\x00\x61\x00\xbb\x00\x60\x00\x94\x00\x61\x00\x97\x00\x62\x00\x09\x00\x9a\x00\x9b\x00\x61\x00\x9d\x00\x62\x00\x09\x00\x9e\x00\x9f\x00\x62\x00\x09\x00\xbc\x00\x60\x00\xbd\x00\x60\x00\x62\x00\x09\x00\xbe\x00\x60\x00\xa2\x00\x61\x00\xa3\x00\x61\x00\xa4\x00\xa7\x00\x54\x00\x61\x00\xbf\x00\x60\x00\xa9\x00\x5b\x00\x56\x00\x62\x00\x09\x00\x62\x00\x09\x00\x61\x00\x55\x00\x62\x00\x09\x00\x57\x00\xc0\x00\x60\x00\xc1\x00\x60\x00\xc2\x00\x60\x00\x5c\x00\x62\x00\x09\x00\x61\x00\x58\x00\x61\x00\x5e\x00\x61\x00\x5f\x00\x59\x00\x5a\x00\x6f\x00\xc3\x00\x60\x00\x5d\x00\x62\x00\x09\x00\x62\x00\x09\x00\x62\x00\x09\x00\x61\x00\xc4\x00\x60\x00\x3f\x00\x72\x00\xc5\x00\x60\x00\xc6\x00\x60\x00\x40\x00\x61\x00\x41\x00\x62\x00\x09\x00\x61\x00\x42\x00\x61\x00\x4c\x00\x4d\x00\x1f\x00\x4e\x00\x4f\x00\x62\x00\x09\x00\xc7\x00\x60\x00\x62\x00\x09\x00\x62\x00\x09\x00\xc8\x00\x60\x00\x52\x00\x61\x00\xc9\x00\x60\x00\x50\x00\x51\x00\x3f\x00\x61\x00\xca\x00\x60\x00\x2e\x00\x61\x00\x2f\x00\x62\x00\x09\x00\x35\x00\x30\x00\x61\x00\x36\x00\x62\x00\x09\x00\x37\x00\x31\x00\x62\x00\x09\x00\xd4\x00\x60\x00\x95\x00\x60\x00\x62\x00\x09\x00\x97\x00\x60\x00\x2d\x00\x61\x00\x32\x00\x61\x00\x33\x00\x38\x00\x1d\x00\x61\x00\x98\x00\x60\x00\x34\x00\x1f\x00\x1f\x00\x62\x00\x09\x00\x62\x00\x09\x00\x61\x00\x20\x00\x62\x00\x09\x00\x22\x00\x5f\x00\x60\x00\x70\x00\x60\x00\x23\x00\x24\x00\x25\x00\x62\x00\x09\x00\x61\x00\x26\x00\x61\x00\x27\x00\x1f\x00\x1d\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x09\x00\x62\x00\x09\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x01\x01\x00\x00\x00\x00\x00\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\xa9\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x00\x00\x8d\x00\x8e\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x8d\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# +happyTable = HappyA# "\x00\x00\x6a\x00\x64\x01\x79\x00\x73\x00\x49\x00\x6b\x00\x7a\x00\xa6\x00\x7b\x01\x6c\x00\x2f\x00\x71\x01\x6d\x00\x6e\x00\xfd\x00\x66\x00\x6d\x01\xe7\x00\x48\x01\xff\x00\x00\x01\x47\x01\x66\x00\x67\x00\x79\x01\xab\x00\x6f\x01\x7f\x00\xd5\x00\x7b\x00\x67\x00\x60\x01\x80\x00\x7c\x00\xd6\x00\x68\x00\x09\x00\x62\x01\x7a\x01\xac\x00\x7d\x00\x09\x00\x68\x00\x09\x00\x2c\x00\x03\x00\x04\x00\x4a\x00\x4b\x00\x5a\x01\x05\x00\x06\x00\x30\x00\x07\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x11\x00\xa7\x00\x72\x01\x81\x00\x82\x00\x83\x00\x84\xff\x6b\x00\x84\xff\x84\x00\x24\x00\x13\x00\x85\x00\xfa\x00\x6d\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x86\x00\x87\x00\xdf\x00\x08\x00\x09\x00\x3f\x01\x6c\x00\xfd\x00\x66\x00\x6d\x00\x6e\x00\x49\x01\xff\x00\x00\x01\x5d\x01\x6b\x00\x67\x00\x5f\x01\xe0\x00\x6c\x00\xfb\x00\xfc\x00\x6d\x00\x6e\x00\x45\x01\xb4\x00\x3e\x00\x3f\x00\x68\x00\x09\x00\x40\x00\x09\x00\x41\x01\x34\x01\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x42\x01\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x48\x00\x49\x00\x33\x01\x34\x01\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x02\x00\x03\x00\x04\x00\x28\x01\xe2\x00\xe3\x00\x05\x00\x06\x00\xf1\x00\x07\x00\x65\x01\x79\x00\x5c\x01\x79\x00\xfc\x00\x7a\x00\x19\x01\x7a\x00\x75\x00\x3f\x00\xc0\x00\x09\x00\x40\x00\x09\x00\x67\x00\x25\x01\x79\x00\xea\x00\x79\x00\xe9\x00\x7a\x00\xea\x00\x7a\x00\x22\x01\x4a\x00\x4b\x00\x68\x00\x09\x00\x7b\x00\x14\x01\x7b\x00\xba\x00\x7c\x00\xd8\x00\x7c\x00\x47\x00\x1e\x00\x08\x00\x09\x00\x7d\x00\x09\x00\x7d\x00\x09\x00\x7b\x00\x2a\x00\x7b\x00\x98\x00\x7c\x00\xd6\x00\x7c\x00\xe1\x00\xe2\x00\xe3\x00\xad\x00\x7d\x00\x09\x00\x7d\x00\x09\x00\xeb\x00\x79\x00\x78\x00\x79\x00\x9a\x00\x7a\x00\x42\x00\x7a\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x23\x01\xdc\x00\xaf\x00\x79\x00\x89\x00\x8a\x00\x8b\x00\x7a\x00\x50\x00\x93\x00\x94\x00\xdd\x00\x66\x00\x1d\x00\x1e\x00\x7b\x00\x58\x00\x7b\x00\x2d\x00\x7c\x00\x67\x00\x7c\x00\xfb\x00\xfc\x00\x24\x01\xdc\x00\x7d\x00\x09\x00\x7d\x00\x09\x00\x7b\x00\x22\x00\x68\x00\x09\x00\x7c\x00\xdd\x00\x66\x00\x41\x00\xf5\x00\xdc\x00\x1b\x00\x7d\x00\x09\x00\x2a\x00\x67\x00\x2b\x00\xe5\x00\xe6\x00\x7d\x01\xdd\x00\x66\x00\x72\x01\xf6\x00\xf7\x00\xdb\x00\xdc\x00\x68\x00\x09\x00\x67\x00\x20\x00\x21\x00\x75\x01\x76\x01\xf8\x00\x66\x00\xdd\x00\x66\x00\x7b\x01\x74\x01\x77\x01\x68\x00\x09\x00\x67\x00\x78\x01\x67\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x6a\x01\x11\x00\x12\x00\x68\x00\x09\x00\x68\x00\x09\x00\x6c\x01\x6b\x01\x6d\x01\x6f\x01\x73\x01\x13\x00\x62\x01\x4d\x00\x64\x01\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x4e\x00\x1b\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x67\x01\x69\x01\x68\x01\x4d\x01\x4f\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x57\x01\x50\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x2b\x01\x58\x01\x59\x01\x5a\x01\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xa2\x00\x4b\x01\x5c\x01\x5f\x01\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x41\x01\x1e\x01\x4c\x01\x4e\x01\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x4f\x01\x50\x01\x52\x01\x51\x01\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x2a\x01\x53\x01\x54\x01\x55\x01\x56\x01\x3c\x01\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x3d\x01\x36\x01\x3e\x01\x3f\x01\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x09\x01\x41\x01\x44\x01\x45\x01\x47\x01\x2e\x01\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x30\x01\x31\x01\xfb\x00\x33\x01\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x2f\x01\x36\x01\x37\x01\x1f\x01\x38\x01\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x16\x01\x39\x01\x3a\x01\x3b\x01\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xda\x00\x20\x01\x17\x01\x18\x01\x19\x01\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x1b\x01\x1d\x01\x21\x01\x23\x01\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x88\x00\x28\x01\x27\x01\x2d\x01\xee\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xf4\x00\xef\x00\xe5\x00\xf3\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xbf\x00\xf5\x00\x03\x01\x02\x01\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x06\x01\x0a\x01\x0b\x01\x0c\x01\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xfd\x00\x66\x00\xfd\x00\x66\x00\xfe\x00\xff\x00\x00\x01\x31\x01\x00\x01\x67\x00\x0d\x01\x67\x00\x0e\x01\x0f\x01\x12\x01\x10\x01\x11\x01\x13\x01\xd1\x00\x66\x00\xb1\x00\x68\x00\x09\x00\x68\x00\x09\x00\x04\x01\xd3\x00\x67\x00\xd1\x00\x66\x00\x14\x01\xb3\x00\xb4\x00\xd1\x00\x66\x00\x07\x01\xd3\x00\x67\x00\xb6\x00\x68\x00\x09\x00\x1b\x01\x67\x00\xba\x00\xd1\x00\x66\x00\xb7\x00\x2b\x01\x66\x00\x68\x00\x09\x00\xd2\x00\xd3\x00\x67\x00\x68\x00\x09\x00\x67\x00\xc0\x00\xef\x00\x66\x00\xb9\x00\xf0\x00\x66\x00\x03\x01\x66\x00\x68\x00\x09\x00\x67\x00\x68\x00\x09\x00\x67\x00\xb8\x00\x67\x00\xbd\x00\xaf\x00\xbc\x00\xd8\x00\xb1\x00\x66\x00\x68\x00\x09\x00\xda\x00\x68\x00\x09\x00\x68\x00\x09\x00\x67\x00\xbd\x00\x66\x00\xe1\x00\xe8\x00\xc1\x00\x66\x00\xc2\x00\x66\x00\xed\x00\x67\x00\x9a\x00\x68\x00\x09\x00\x67\x00\xa0\x00\x67\x00\x9d\x00\xa3\x00\xa1\x00\xa4\x00\xa5\x00\x68\x00\x09\x00\xc3\x00\x66\x00\x68\x00\x09\x00\x68\x00\x09\x00\xc4\x00\x66\x00\x5a\x00\x67\x00\xc5\x00\x66\x00\x5b\x00\xa8\x00\xa9\x00\x67\x00\xc6\x00\x66\x00\xaa\x00\x67\x00\xad\x00\x68\x00\x09\x00\xaf\x00\x5c\x00\x67\x00\x5d\x00\x68\x00\x09\x00\x5e\x00\x61\x00\x68\x00\x09\x00\xc7\x00\x66\x00\xc8\x00\x66\x00\x68\x00\x09\x00\xc9\x00\x66\x00\x5f\x00\x67\x00\x60\x00\x67\x00\x62\x00\x78\x00\x65\x00\x67\x00\xca\x00\x66\x00\x64\x00\x75\x00\x63\x00\x68\x00\x09\x00\x68\x00\x09\x00\x67\x00\x47\x00\x68\x00\x09\x00\x44\x00\xcb\x00\x66\x00\xcc\x00\x66\x00\xcd\x00\x66\x00\x46\x00\x68\x00\x09\x00\x67\x00\x44\x00\x67\x00\x45\x00\x67\x00\x31\x00\x24\x00\x52\x00\x53\x00\xce\x00\x66\x00\x54\x00\x68\x00\x09\x00\x68\x00\x09\x00\x68\x00\x09\x00\x67\x00\xcf\x00\x66\x00\x39\x00\x55\x00\xd0\x00\x66\x00\xda\x00\x66\x00\x56\x00\x67\x00\x57\x00\x68\x00\x09\x00\x67\x00\x38\x00\x67\x00\x3c\x00\x3a\x00\x58\x00\x32\x00\x3d\x00\x68\x00\x09\x00\x9b\x00\x66\x00\x68\x00\x09\x00\x68\x00\x09\x00\x9d\x00\x66\x00\x30\x00\x67\x00\x9e\x00\x66\x00\x33\x00\x34\x00\x35\x00\x67\x00\x65\x00\x66\x00\x36\x00\x67\x00\x37\x00\x68\x00\x09\x00\x3b\x00\x1d\x00\x67\x00\x24\x00\x68\x00\x09\x00\x25\x00\x26\x00\x68\x00\x09\x00\x76\x00\x66\x00\x22\x00\x27\x00\x68\x00\x09\x00\x28\x00\x29\x00\x2a\x00\x67\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x07\x01\x68\x00\x09\x00\x24\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xaf\x00\x1d\x00\x00\x00\xff\xff\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x00\x00\x93\x00\x94\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x93\x00\x94\x00\x40\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# -happyReduceArr = Happy_Data_Array.array (1, 148) [ +happyReduceArr = Happy_Data_Array.array (1, 152) [ (1 , happyReduce_1), (2 , happyReduce_2), (3 , happyReduce_3), @@ -526,11 +541,15 @@ (145 , happyReduce_145), (146 , happyReduce_146), (147 , happyReduce_147), - (148 , happyReduce_148) + (148 , happyReduce_148), + (149 , happyReduce_149), + (150 , happyReduce_150), + (151 , happyReduce_151), + (152 , happyReduce_152) ] happy_n_terms = 69 :: Int -happy_n_nonterms = 47 :: Int +happy_n_nonterms = 49 :: Int happyReduce_1 = happySpecReduce_0 0# happyReduction_1 happyReduction_1 = happyIn4 @@ -567,7 +586,7 @@ (happy_var_1 )} -happyReduce_6 = happyReduce 8# 1# happyReduction_6 +happyReduce_6 = happyMonadReduce 8# 1# happyReduction_6 happyReduction_6 (happy_x_8 `HappyStk` happy_x_7 `HappyStk` happy_x_6 `HappyStk` @@ -576,14 +595,14 @@ happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + happyRest) tk + = happyThen (case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> case happyOutTok happy_x_5 of { (L _ (CmmT_Name happy_var_5)) -> case happyOut9 happy_x_6 of { happy_var_6 -> - happyIn5 - (do lits <- sequence happy_var_6; - staticClosure happy_var_3 happy_var_5 (map getLit lits) - ) `HappyStk` happyRest}}} + ( withThisPackage $ \pkg -> + do lits <- sequence happy_var_6; + staticClosure pkg happy_var_3 happy_var_5 (map getLit lits))}}} + ) (\r -> happyReturn (happyIn5 r)) happyReduce_7 = happyReduce 5# 2# happyReduction_7 happyReduction_7 (happy_x_5 `HappyStk` @@ -613,19 +632,20 @@ (happy_var_1 : happy_var_2 )}} -happyReduce_10 = happySpecReduce_2 4# happyReduction_10 -happyReduction_10 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - happyIn8 - (return [CmmDataLabel (mkRtsDataLabelFS happy_var_1)] - )} +happyReduce_10 = happyMonadReduce 2# 4# happyReduction_10 +happyReduction_10 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + ( withThisPackage $ \pkg -> + return [CmmDataLabel (mkCmmDataLabel pkg happy_var_1)])} + ) (\r -> happyReturn (happyIn8 r)) happyReduce_11 = happySpecReduce_3 4# happyReduction_11 happyReduction_11 happy_x_3 happy_x_2 happy_x_1 - = case happyOut28 happy_x_2 of { happy_var_2 -> + = case happyOut30 happy_x_2 of { happy_var_2 -> happyIn8 (do e <- happy_var_2; return [CmmStaticLit (getLit e)] @@ -634,7 +654,7 @@ happyReduce_12 = happySpecReduce_2 4# happyReduction_12 happyReduction_12 happy_x_2 happy_x_1 - = case happyOut49 happy_x_1 of { happy_var_1 -> + = case happyOut51 happy_x_1 of { happy_var_1 -> happyIn8 (return [CmmUninitialised (widthInBytes (typeWidth happy_var_1))] @@ -672,7 +692,7 @@ happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut50 happy_x_1 of { happy_var_1 -> + = case happyOut52 happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_3 of { (L _ (CmmT_Int happy_var_3)) -> happyIn8 (return [CmmUninitialised @@ -716,7 +736,7 @@ happyReduction_19 happy_x_3 happy_x_2 happy_x_1 - = case happyOut28 happy_x_2 of { happy_var_2 -> + = case happyOut30 happy_x_2 of { happy_var_2 -> case happyOut9 happy_x_3 of { happy_var_3 -> happyIn9 (happy_var_2 : happy_var_3 @@ -732,9 +752,9 @@ happy_x_1 `HappyStk` happyRest) = case happyOut11 happy_x_1 of { happy_var_1 -> - case happyOut43 happy_x_2 of { happy_var_2 -> - case happyOut48 happy_x_3 of { happy_var_3 -> - case happyOut47 happy_x_4 of { happy_var_4 -> + case happyOut45 happy_x_2 of { happy_var_2 -> + case happyOut50 happy_x_3 of { happy_var_3 -> + case happyOut49 happy_x_4 of { happy_var_4 -> case happyOut12 happy_x_6 of { happy_var_6 -> happyIn10 (do ((entry_ret_label, info, live, formals, gc_block, frame), stmts) <- @@ -754,14 +774,14 @@ happy_x_2 happy_x_1 = case happyOut11 happy_x_1 of { happy_var_1 -> - case happyOut43 happy_x_2 of { happy_var_2 -> + case happyOut45 happy_x_2 of { happy_var_2 -> happyIn10 (do (entry_ret_label, info, live) <- happy_var_1; formals <- sequence happy_var_2; code (emitInfoTableAndCode entry_ret_label (CmmInfo Nothing Nothing info) formals []) )}} -happyReduce_22 = happyReduce 7# 6# happyReduction_22 +happyReduce_22 = happyMonadReduce 7# 6# happyReduction_22 happyReduction_22 (happy_x_7 `HappyStk` happy_x_6 `HappyStk` happy_x_5 `HappyStk` @@ -769,25 +789,26 @@ happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - case happyOut43 happy_x_2 of { happy_var_2 -> - case happyOut48 happy_x_3 of { happy_var_3 -> - case happyOut47 happy_x_4 of { happy_var_4 -> + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + case happyOut45 happy_x_2 of { happy_var_2 -> + case happyOut50 happy_x_3 of { happy_var_3 -> + case happyOut49 happy_x_4 of { happy_var_4 -> case happyOut12 happy_x_6 of { happy_var_6 -> - happyIn10 - (do ((formals, gc_block, frame), stmts) <- - getCgStmtsEC' $ loopDecls $ do { - formals <- sequence happy_var_2; - gc_block <- happy_var_3; - frame <- happy_var_4; - happy_var_6; - return (formals, gc_block, frame) } - blks <- code (cgStmtsToBlocks stmts) - code (emitProc (CmmInfo gc_block frame CmmNonInfoTable) (mkRtsCodeLabelFS happy_var_1) formals blks) - ) `HappyStk` happyRest}}}}} + ( withThisPackage $ \pkg -> + do newFunctionName happy_var_1 pkg + ((formals, gc_block, frame), stmts) <- + getCgStmtsEC' $ loopDecls $ do { + formals <- sequence happy_var_2; + gc_block <- happy_var_3; + frame <- happy_var_4; + happy_var_6; + return (formals, gc_block, frame) } + blks <- code (cgStmtsToBlocks stmts) + code (emitProc (CmmInfo gc_block frame CmmNonInfoTable) (mkCmmCodeLabel pkg happy_var_1) formals blks))}}}}} + ) (\r -> happyReturn (happyIn10 r)) -happyReduce_23 = happyReduce 14# 7# happyReduction_23 +happyReduce_23 = happyMonadReduce 14# 7# happyReduction_23 happyReduction_23 (happy_x_14 `HappyStk` happy_x_13 `HappyStk` happy_x_12 `HappyStk` @@ -802,22 +823,22 @@ happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + happyRest) tk + = happyThen (case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> case happyOutTok happy_x_7 of { (L _ (CmmT_Int happy_var_7)) -> case happyOutTok happy_x_9 of { (L _ (CmmT_Int happy_var_9)) -> case happyOutTok happy_x_11 of { (L _ (CmmT_String happy_var_11)) -> case happyOutTok happy_x_13 of { (L _ (CmmT_String happy_var_13)) -> - happyIn11 - (do prof <- profilingInfo happy_var_11 happy_var_13 - return (mkRtsEntryLabelFS happy_var_3, + ( withThisPackage $ \pkg -> + do prof <- profilingInfo happy_var_11 happy_var_13 + return (mkCmmEntryLabel pkg happy_var_3, CmmInfoTable False prof (fromIntegral happy_var_9) (ThunkInfo (fromIntegral happy_var_5, fromIntegral happy_var_7) NoC_SRT), - []) - ) `HappyStk` happyRest}}}}}} + []))}}}}}} + ) (\r -> happyReturn (happyIn11 r)) -happyReduce_24 = happyReduce 16# 7# happyReduction_24 +happyReduce_24 = happyMonadReduce 16# 7# happyReduction_24 happyReduction_24 (happy_x_16 `HappyStk` happy_x_15 `HappyStk` happy_x_14 `HappyStk` @@ -834,26 +855,26 @@ happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + happyRest) tk + = happyThen (case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> case happyOutTok happy_x_7 of { (L _ (CmmT_Int happy_var_7)) -> case happyOutTok happy_x_9 of { (L _ (CmmT_Int happy_var_9)) -> case happyOutTok happy_x_11 of { (L _ (CmmT_String happy_var_11)) -> case happyOutTok happy_x_13 of { (L _ (CmmT_String happy_var_13)) -> case happyOutTok happy_x_15 of { (L _ (CmmT_Int happy_var_15)) -> - happyIn11 - (do prof <- profilingInfo happy_var_11 happy_var_13 - return (mkRtsEntryLabelFS happy_var_3, + ( withThisPackage $ \pkg -> + do prof <- profilingInfo happy_var_11 happy_var_13 + return (mkCmmEntryLabel pkg happy_var_3, CmmInfoTable False prof (fromIntegral happy_var_9) (FunInfo (fromIntegral happy_var_5, fromIntegral happy_var_7) NoC_SRT 0 -- Arity zero (ArgSpec (fromIntegral happy_var_15)) zeroCLit), - []) - ) `HappyStk` happyRest}}}}}}} + []))}}}}}}} + ) (\r -> happyReturn (happyIn11 r)) -happyReduce_25 = happyReduce 18# 7# happyReduction_25 +happyReduce_25 = happyMonadReduce 18# 7# happyReduction_25 happyReduction_25 (happy_x_18 `HappyStk` happy_x_17 `HappyStk` happy_x_16 `HappyStk` @@ -872,8 +893,8 @@ happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + happyRest) tk + = happyThen (case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> case happyOutTok happy_x_7 of { (L _ (CmmT_Int happy_var_7)) -> case happyOutTok happy_x_9 of { (L _ (CmmT_Int happy_var_9)) -> @@ -881,17 +902,17 @@ case happyOutTok happy_x_13 of { (L _ (CmmT_String happy_var_13)) -> case happyOutTok happy_x_15 of { (L _ (CmmT_Int happy_var_15)) -> case happyOutTok happy_x_17 of { (L _ (CmmT_Int happy_var_17)) -> - happyIn11 - (do prof <- profilingInfo happy_var_11 happy_var_13 - return (mkRtsEntryLabelFS happy_var_3, + ( withThisPackage $ \pkg -> + do prof <- profilingInfo happy_var_11 happy_var_13 + return (mkCmmEntryLabel pkg happy_var_3, CmmInfoTable False prof (fromIntegral happy_var_9) (FunInfo (fromIntegral happy_var_5, fromIntegral happy_var_7) NoC_SRT (fromIntegral happy_var_17) (ArgSpec (fromIntegral happy_var_15)) zeroCLit), - []) - ) `HappyStk` happyRest}}}}}}}} + []))}}}}}}}} + ) (\r -> happyReturn (happyIn11 r)) -happyReduce_26 = happyReduce 16# 7# happyReduction_26 +happyReduce_26 = happyMonadReduce 16# 7# happyReduction_26 happyReduction_26 (happy_x_16 `HappyStk` happy_x_15 `HappyStk` happy_x_14 `HappyStk` @@ -908,26 +929,26 @@ happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + happyRest) tk + = happyThen (case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> case happyOutTok happy_x_7 of { (L _ (CmmT_Int happy_var_7)) -> case happyOutTok happy_x_9 of { (L _ (CmmT_Int happy_var_9)) -> case happyOutTok happy_x_11 of { (L _ (CmmT_Int happy_var_11)) -> case happyOutTok happy_x_13 of { (L _ (CmmT_String happy_var_13)) -> case happyOutTok happy_x_15 of { (L _ (CmmT_String happy_var_15)) -> - happyIn11 - (do prof <- profilingInfo happy_var_13 happy_var_15 + ( withThisPackage $ \pkg -> + do prof <- profilingInfo happy_var_13 happy_var_15 -- If profiling is on, this string gets duplicated, -- but that's the way the old code did it we can fix it some other time. - desc_lit <- code $ mkStringCLit happy_var_13 - return (mkRtsEntryLabelFS happy_var_3, + desc_lit <- code $ mkStringCLit happy_var_13 + return (mkCmmEntryLabel pkg happy_var_3, CmmInfoTable False prof (fromIntegral happy_var_11) (ConstrInfo (fromIntegral happy_var_5, fromIntegral happy_var_7) (fromIntegral happy_var_9) desc_lit), - []) - ) `HappyStk` happyRest}}}}}}} + []))}}}}}}} + ) (\r -> happyReturn (happyIn11 r)) -happyReduce_27 = happyReduce 12# 7# happyReduction_27 +happyReduce_27 = happyMonadReduce 12# 7# happyReduction_27 happyReduction_27 (happy_x_12 `HappyStk` happy_x_11 `HappyStk` happy_x_10 `HappyStk` @@ -940,39 +961,39 @@ happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + happyRest) tk + = happyThen (case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> case happyOutTok happy_x_7 of { (L _ (CmmT_Int happy_var_7)) -> case happyOutTok happy_x_9 of { (L _ (CmmT_String happy_var_9)) -> case happyOutTok happy_x_11 of { (L _ (CmmT_String happy_var_11)) -> - happyIn11 - (do prof <- profilingInfo happy_var_9 happy_var_11 - return (mkRtsEntryLabelFS happy_var_3, + ( withThisPackage $ \pkg -> + do prof <- profilingInfo happy_var_9 happy_var_11 + return (mkCmmEntryLabel pkg happy_var_3, CmmInfoTable False prof (fromIntegral happy_var_7) (ThunkSelectorInfo (fromIntegral happy_var_5) NoC_SRT), - []) - ) `HappyStk` happyRest}}}}} + []))}}}}} + ) (\r -> happyReturn (happyIn11 r)) -happyReduce_28 = happyReduce 6# 7# happyReduction_28 +happyReduce_28 = happyMonadReduce 6# 7# happyReduction_28 happyReduction_28 (happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + happyRest) tk + = happyThen (case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> - happyIn11 - (do let infoLabel = mkRtsInfoLabelFS happy_var_3 - return (mkRtsRetLabelFS happy_var_3, + ( withThisPackage $ \pkg -> + do let infoLabel = mkCmmInfoLabel pkg happy_var_3 + return (mkCmmRetLabel pkg happy_var_3, CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral happy_var_5) (ContInfo [] NoC_SRT), - []) - ) `HappyStk` happyRest}} + []))}} + ) (\r -> happyReturn (happyIn11 r)) -happyReduce_29 = happyReduce 8# 7# happyReduction_29 +happyReduce_29 = happyMonadReduce 8# 7# happyReduction_29 happyReduction_29 (happy_x_8 `HappyStk` happy_x_7 `HappyStk` happy_x_6 `HappyStk` @@ -981,17 +1002,17 @@ happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + happyRest) tk + = happyThen (case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> - case happyOut44 happy_x_7 of { happy_var_7 -> - happyIn11 - (do live <- sequence (map (liftM Just) happy_var_7) - return (mkRtsRetLabelFS happy_var_3, + case happyOut46 happy_x_7 of { happy_var_7 -> + ( withThisPackage $ \pkg -> + do live <- sequence (map (liftM Just) happy_var_7) + return (mkCmmRetLabel pkg happy_var_3, CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral happy_var_5) (ContInfo live NoC_SRT), - live) - ) `HappyStk` happyRest}}} + live))}}} + ) (\r -> happyReturn (happyIn11 r)) happyReduce_30 = happySpecReduce_0 8# happyReduction_30 happyReduction_30 = happyIn12 @@ -1010,7 +1031,7 @@ happyReduce_32 = happySpecReduce_2 8# happyReduction_32 happyReduction_32 happy_x_2 happy_x_1 - = case happyOut15 happy_x_1 of { happy_var_1 -> + = case happyOut17 happy_x_1 of { happy_var_1 -> case happyOut12 happy_x_2 of { happy_var_2 -> happyIn12 (do happy_var_1; happy_var_2 @@ -1020,8 +1041,8 @@ happyReduction_33 happy_x_3 happy_x_2 happy_x_1 - = case happyOut49 happy_x_1 of { happy_var_1 -> - case happyOut14 happy_x_2 of { happy_var_2 -> + = case happyOut51 happy_x_1 of { happy_var_1 -> + case happyOut16 happy_x_2 of { happy_var_2 -> happyIn13 (mapM_ (newLocal happy_var_1) happy_var_2 )}} @@ -1045,7 +1066,7 @@ happyReduce_36 = happySpecReduce_1 10# happyReduction_36 happyReduction_36 happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + = case happyOut15 happy_x_1 of { happy_var_1 -> happyIn14 ([happy_var_1] )} @@ -1054,7 +1075,7 @@ happyReduction_37 happy_x_3 happy_x_2 happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + = case happyOut15 happy_x_1 of { happy_var_1 -> case happyOut14 happy_x_3 of { happy_var_3 -> happyIn14 (happy_var_1 : happy_var_3 @@ -1062,32 +1083,65 @@ happyReduce_38 = happySpecReduce_1 11# happyReduction_38 happyReduction_38 happy_x_1 - = happyIn15 - (nopEC - ) + = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + happyIn15 + ((Nothing, happy_var_1) + )} happyReduce_39 = happySpecReduce_2 11# happyReduction_39 happyReduction_39 happy_x_2 happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + = case happyOutTok happy_x_1 of { (L _ (CmmT_String happy_var_1)) -> + case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> happyIn15 + ((Just (fsToPackageId (mkFastString happy_var_1)), happy_var_2) + )}} + +happyReduce_40 = happySpecReduce_1 12# happyReduction_40 +happyReduction_40 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + happyIn16 + ([happy_var_1] + )} + +happyReduce_41 = happySpecReduce_3 12# happyReduction_41 +happyReduction_41 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + case happyOut16 happy_x_3 of { happy_var_3 -> + happyIn16 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_42 = happySpecReduce_1 13# happyReduction_42 +happyReduction_42 happy_x_1 + = happyIn17 + (nopEC + ) + +happyReduce_43 = happySpecReduce_2 13# happyReduction_43 +happyReduction_43 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + happyIn17 (do l <- newLabel happy_var_1; code (labelC l) )} -happyReduce_40 = happyReduce 4# 11# happyReduction_40 -happyReduction_40 (happy_x_4 `HappyStk` +happyReduce_44 = happyReduce 4# 13# happyReduction_44 +happyReduction_44 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut42 happy_x_1 of { happy_var_1 -> - case happyOut28 happy_x_3 of { happy_var_3 -> - happyIn15 + = case happyOut44 happy_x_1 of { happy_var_1 -> + case happyOut30 happy_x_3 of { happy_var_3 -> + happyIn17 (do reg <- happy_var_1; e <- happy_var_3; stmtEC (CmmAssign reg e) ) `HappyStk` happyRest}} -happyReduce_41 = happyReduce 7# 11# happyReduction_41 -happyReduction_41 (happy_x_7 `HappyStk` +happyReduce_45 = happyReduce 7# 13# happyReduction_45 +happyReduction_45 (happy_x_7 `HappyStk` happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` @@ -1095,15 +1149,15 @@ happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut49 happy_x_1 of { happy_var_1 -> - case happyOut28 happy_x_3 of { happy_var_3 -> - case happyOut28 happy_x_6 of { happy_var_6 -> - happyIn15 + = case happyOut51 happy_x_1 of { happy_var_1 -> + case happyOut30 happy_x_3 of { happy_var_3 -> + case happyOut30 happy_x_6 of { happy_var_6 -> + happyIn17 (doStore happy_var_1 happy_var_3 happy_var_6 ) `HappyStk` happyRest}}} -happyReduce_42 = happyMonadReduce 11# 11# happyReduction_42 -happyReduction_42 (happy_x_11 `HappyStk` +happyReduce_46 = happyMonadReduce 11# 13# happyReduction_46 +happyReduction_46 (happy_x_11 `HappyStk` happy_x_10 `HappyStk` happy_x_9 `HappyStk` happy_x_8 `HappyStk` @@ -1115,18 +1169,18 @@ happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk - = happyThen (case happyOut38 happy_x_1 of { happy_var_1 -> + = happyThen (case happyOut40 happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_3 of { (L _ (CmmT_String happy_var_3)) -> - case happyOut28 happy_x_4 of { happy_var_4 -> - case happyOut32 happy_x_6 of { happy_var_6 -> - case happyOut19 happy_x_8 of { happy_var_8 -> - case happyOut20 happy_x_9 of { happy_var_9 -> - case happyOut16 happy_x_10 of { happy_var_10 -> + case happyOut30 happy_x_4 of { happy_var_4 -> + case happyOut34 happy_x_6 of { happy_var_6 -> + case happyOut21 happy_x_8 of { happy_var_8 -> + case happyOut22 happy_x_9 of { happy_var_9 -> + case happyOut18 happy_x_10 of { happy_var_10 -> ( foreignCall happy_var_3 happy_var_1 happy_var_4 happy_var_6 happy_var_9 happy_var_8 happy_var_10)}}}}}}} - ) (\r -> happyReturn (happyIn15 r)) + ) (\r -> happyReturn (happyIn17 r)) -happyReduce_43 = happyMonadReduce 10# 11# happyReduction_43 -happyReduction_43 (happy_x_10 `HappyStk` +happyReduce_47 = happyMonadReduce 10# 13# happyReduction_47 +happyReduction_47 (happy_x_10 `HappyStk` happy_x_9 `HappyStk` happy_x_8 `HappyStk` happy_x_7 `HappyStk` @@ -1137,28 +1191,28 @@ happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk - = happyThen (case happyOut38 happy_x_1 of { happy_var_1 -> + = happyThen (case happyOut40 happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_4 of { (L _ (CmmT_Name happy_var_4)) -> - case happyOut32 happy_x_6 of { happy_var_6 -> - case happyOut19 happy_x_8 of { happy_var_8 -> - case happyOut20 happy_x_9 of { happy_var_9 -> + case happyOut34 happy_x_6 of { happy_var_6 -> + case happyOut21 happy_x_8 of { happy_var_8 -> + case happyOut22 happy_x_9 of { happy_var_9 -> ( primCall happy_var_1 happy_var_4 happy_var_6 happy_var_9 happy_var_8)}}}}} - ) (\r -> happyReturn (happyIn15 r)) + ) (\r -> happyReturn (happyIn17 r)) -happyReduce_44 = happyMonadReduce 5# 11# happyReduction_44 -happyReduction_44 (happy_x_5 `HappyStk` +happyReduce_48 = happyMonadReduce 5# 13# happyReduction_48 +happyReduction_48 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - case happyOut35 happy_x_3 of { happy_var_3 -> + case happyOut37 happy_x_3 of { happy_var_3 -> ( stmtMacro happy_var_1 happy_var_3)}} - ) (\r -> happyReturn (happyIn15 r)) + ) (\r -> happyReturn (happyIn17 r)) -happyReduce_45 = happyReduce 7# 11# happyReduction_45 -happyReduction_45 (happy_x_7 `HappyStk` +happyReduce_49 = happyReduce 7# 13# happyReduction_49 +happyReduction_49 (happy_x_7 `HappyStk` happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` @@ -1166,176 +1220,176 @@ happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut22 happy_x_2 of { happy_var_2 -> - case happyOut28 happy_x_3 of { happy_var_3 -> - case happyOut23 happy_x_5 of { happy_var_5 -> - case happyOut26 happy_x_6 of { happy_var_6 -> - happyIn15 + = case happyOut24 happy_x_2 of { happy_var_2 -> + case happyOut30 happy_x_3 of { happy_var_3 -> + case happyOut25 happy_x_5 of { happy_var_5 -> + case happyOut28 happy_x_6 of { happy_var_6 -> + happyIn17 (doSwitch happy_var_2 happy_var_3 happy_var_5 happy_var_6 ) `HappyStk` happyRest}}}} -happyReduce_46 = happySpecReduce_3 11# happyReduction_46 -happyReduction_46 happy_x_3 +happyReduce_50 = happySpecReduce_3 13# happyReduction_50 +happyReduction_50 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> - happyIn15 + happyIn17 (do l <- lookupLabel happy_var_2; stmtEC (CmmBranch l) )} -happyReduce_47 = happyReduce 4# 11# happyReduction_47 -happyReduction_47 (happy_x_4 `HappyStk` +happyReduce_51 = happyReduce 4# 13# happyReduction_51 +happyReduction_51 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut28 happy_x_2 of { happy_var_2 -> - case happyOut31 happy_x_3 of { happy_var_3 -> - happyIn15 + = case happyOut30 happy_x_2 of { happy_var_2 -> + case happyOut33 happy_x_3 of { happy_var_3 -> + happyIn17 (do e1 <- happy_var_2; e2 <- sequence happy_var_3; stmtEC (CmmJump e1 e2) ) `HappyStk` happyRest}} -happyReduce_48 = happySpecReduce_3 11# happyReduction_48 -happyReduction_48 happy_x_3 +happyReduce_52 = happySpecReduce_3 13# happyReduction_52 +happyReduction_52 happy_x_3 happy_x_2 happy_x_1 - = case happyOut31 happy_x_2 of { happy_var_2 -> - happyIn15 + = case happyOut33 happy_x_2 of { happy_var_2 -> + happyIn17 (do e <- sequence happy_var_2; stmtEC (CmmReturn e) )} -happyReduce_49 = happyReduce 6# 11# happyReduction_49 -happyReduction_49 (happy_x_6 `HappyStk` +happyReduce_53 = happyReduce 6# 13# happyReduction_53 +happyReduction_53 (happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut17 happy_x_2 of { happy_var_2 -> + = case happyOut19 happy_x_2 of { happy_var_2 -> case happyOut12 happy_x_4 of { happy_var_4 -> - case happyOut27 happy_x_6 of { happy_var_6 -> - happyIn15 + case happyOut29 happy_x_6 of { happy_var_6 -> + happyIn17 (ifThenElse happy_var_2 happy_var_4 happy_var_6 ) `HappyStk` happyRest}}} -happyReduce_50 = happySpecReduce_0 12# happyReduction_50 -happyReduction_50 = happyIn16 +happyReduce_54 = happySpecReduce_0 14# happyReduction_54 +happyReduction_54 = happyIn18 (CmmMayReturn ) -happyReduce_51 = happySpecReduce_2 12# happyReduction_51 -happyReduction_51 happy_x_2 +happyReduce_55 = happySpecReduce_2 14# happyReduction_55 +happyReduction_55 happy_x_2 happy_x_1 - = happyIn16 + = happyIn18 (CmmNeverReturns ) -happyReduce_52 = happySpecReduce_1 13# happyReduction_52 -happyReduction_52 happy_x_1 - = case happyOut18 happy_x_1 of { happy_var_1 -> - happyIn17 +happyReduce_56 = happySpecReduce_1 15# happyReduction_56 +happyReduction_56 happy_x_1 + = case happyOut20 happy_x_1 of { happy_var_1 -> + happyIn19 (happy_var_1 )} -happyReduce_53 = happySpecReduce_1 13# happyReduction_53 -happyReduction_53 happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - happyIn17 +happyReduce_57 = happySpecReduce_1 15# happyReduction_57 +happyReduction_57 happy_x_1 + = case happyOut30 happy_x_1 of { happy_var_1 -> + happyIn19 (do e <- happy_var_1; return (BoolTest e) )} -happyReduce_54 = happySpecReduce_3 14# happyReduction_54 -happyReduction_54 happy_x_3 +happyReduce_58 = happySpecReduce_3 16# happyReduction_58 +happyReduction_58 happy_x_3 happy_x_2 happy_x_1 - = case happyOut17 happy_x_1 of { happy_var_1 -> - case happyOut17 happy_x_3 of { happy_var_3 -> - happyIn18 + = case happyOut19 happy_x_1 of { happy_var_1 -> + case happyOut19 happy_x_3 of { happy_var_3 -> + happyIn20 (do e1 <- happy_var_1; e2 <- happy_var_3; return (BoolAnd e1 e2) )}} -happyReduce_55 = happySpecReduce_3 14# happyReduction_55 -happyReduction_55 happy_x_3 +happyReduce_59 = happySpecReduce_3 16# happyReduction_59 +happyReduction_59 happy_x_3 happy_x_2 happy_x_1 - = case happyOut17 happy_x_1 of { happy_var_1 -> - case happyOut17 happy_x_3 of { happy_var_3 -> - happyIn18 + = case happyOut19 happy_x_1 of { happy_var_1 -> + case happyOut19 happy_x_3 of { happy_var_3 -> + happyIn20 (do e1 <- happy_var_1; e2 <- happy_var_3; return (BoolOr e1 e2) )}} -happyReduce_56 = happySpecReduce_2 14# happyReduction_56 -happyReduction_56 happy_x_2 +happyReduce_60 = happySpecReduce_2 16# happyReduction_60 +happyReduction_60 happy_x_2 happy_x_1 - = case happyOut17 happy_x_2 of { happy_var_2 -> - happyIn18 + = case happyOut19 happy_x_2 of { happy_var_2 -> + happyIn20 (do e <- happy_var_2; return (BoolNot e) )} -happyReduce_57 = happySpecReduce_3 14# happyReduction_57 -happyReduction_57 happy_x_3 +happyReduce_61 = happySpecReduce_3 16# happyReduction_61 +happyReduction_61 happy_x_3 happy_x_2 happy_x_1 - = case happyOut18 happy_x_2 of { happy_var_2 -> - happyIn18 + = case happyOut20 happy_x_2 of { happy_var_2 -> + happyIn20 (happy_var_2 )} -happyReduce_58 = happySpecReduce_0 15# happyReduction_58 -happyReduction_58 = happyIn19 +happyReduce_62 = happySpecReduce_0 17# happyReduction_62 +happyReduction_62 = happyIn21 (CmmUnsafe ) -happyReduce_59 = happyMonadReduce 1# 15# happyReduction_59 -happyReduction_59 (happy_x_1 `HappyStk` +happyReduce_63 = happyMonadReduce 1# 17# happyReduction_63 +happyReduction_63 (happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { (L _ (CmmT_String happy_var_1)) -> ( parseSafety happy_var_1)} - ) (\r -> happyReturn (happyIn19 r)) + ) (\r -> happyReturn (happyIn21 r)) -happyReduce_60 = happySpecReduce_0 16# happyReduction_60 -happyReduction_60 = happyIn20 +happyReduce_64 = happySpecReduce_0 18# happyReduction_64 +happyReduction_64 = happyIn22 (Nothing ) -happyReduce_61 = happySpecReduce_2 16# happyReduction_61 -happyReduction_61 happy_x_2 +happyReduce_65 = happySpecReduce_2 18# happyReduction_65 +happyReduction_65 happy_x_2 happy_x_1 - = happyIn20 + = happyIn22 (Just [] ) -happyReduce_62 = happySpecReduce_3 16# happyReduction_62 -happyReduction_62 happy_x_3 +happyReduce_66 = happySpecReduce_3 18# happyReduction_66 +happyReduction_66 happy_x_3 happy_x_2 happy_x_1 - = case happyOut21 happy_x_2 of { happy_var_2 -> - happyIn20 + = case happyOut23 happy_x_2 of { happy_var_2 -> + happyIn22 (Just happy_var_2 )} -happyReduce_63 = happySpecReduce_1 17# happyReduction_63 -happyReduction_63 happy_x_1 +happyReduce_67 = happySpecReduce_1 19# happyReduction_67 +happyReduction_67 happy_x_1 = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> - happyIn21 + happyIn23 ([happy_var_1] )} -happyReduce_64 = happySpecReduce_3 17# happyReduction_64 -happyReduction_64 happy_x_3 +happyReduce_68 = happySpecReduce_3 19# happyReduction_68 +happyReduction_68 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> - case happyOut21 happy_x_3 of { happy_var_3 -> - happyIn21 + case happyOut23 happy_x_3 of { happy_var_3 -> + happyIn23 (happy_var_1 : happy_var_3 )}} -happyReduce_65 = happyReduce 5# 18# happyReduction_65 -happyReduction_65 (happy_x_5 `HappyStk` +happyReduce_69 = happyReduce 5# 20# happyReduction_69 +happyReduction_69 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` @@ -1343,536 +1397,536 @@ happyRest) = case happyOutTok happy_x_2 of { (L _ (CmmT_Int happy_var_2)) -> case happyOutTok happy_x_4 of { (L _ (CmmT_Int happy_var_4)) -> - happyIn22 + happyIn24 (Just (fromIntegral happy_var_2, fromIntegral happy_var_4) ) `HappyStk` happyRest}} -happyReduce_66 = happySpecReduce_0 18# happyReduction_66 -happyReduction_66 = happyIn22 +happyReduce_70 = happySpecReduce_0 20# happyReduction_70 +happyReduction_70 = happyIn24 (Nothing ) -happyReduce_67 = happySpecReduce_0 19# happyReduction_67 -happyReduction_67 = happyIn23 +happyReduce_71 = happySpecReduce_0 21# happyReduction_71 +happyReduction_71 = happyIn25 ([] ) -happyReduce_68 = happySpecReduce_2 19# happyReduction_68 -happyReduction_68 happy_x_2 +happyReduce_72 = happySpecReduce_2 21# happyReduction_72 +happyReduction_72 happy_x_2 happy_x_1 - = case happyOut24 happy_x_1 of { happy_var_1 -> - case happyOut23 happy_x_2 of { happy_var_2 -> - happyIn23 + = case happyOut26 happy_x_1 of { happy_var_1 -> + case happyOut25 happy_x_2 of { happy_var_2 -> + happyIn25 (happy_var_1 : happy_var_2 )}} -happyReduce_69 = happyReduce 6# 20# happyReduction_69 -happyReduction_69 (happy_x_6 `HappyStk` +happyReduce_73 = happyReduce 6# 22# happyReduction_73 +happyReduction_73 (happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut25 happy_x_2 of { happy_var_2 -> + = case happyOut27 happy_x_2 of { happy_var_2 -> case happyOut12 happy_x_5 of { happy_var_5 -> - happyIn24 + happyIn26 ((happy_var_2, happy_var_5) ) `HappyStk` happyRest}} -happyReduce_70 = happySpecReduce_1 21# happyReduction_70 -happyReduction_70 happy_x_1 +happyReduce_74 = happySpecReduce_1 23# happyReduction_74 +happyReduction_74 happy_x_1 = case happyOutTok happy_x_1 of { (L _ (CmmT_Int happy_var_1)) -> - happyIn25 + happyIn27 ([ fromIntegral happy_var_1 ] )} -happyReduce_71 = happySpecReduce_3 21# happyReduction_71 -happyReduction_71 happy_x_3 +happyReduce_75 = happySpecReduce_3 23# happyReduction_75 +happyReduction_75 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { (L _ (CmmT_Int happy_var_1)) -> - case happyOut25 happy_x_3 of { happy_var_3 -> - happyIn25 + case happyOut27 happy_x_3 of { happy_var_3 -> + happyIn27 (fromIntegral happy_var_1 : happy_var_3 )}} -happyReduce_72 = happyReduce 5# 22# happyReduction_72 -happyReduction_72 (happy_x_5 `HappyStk` +happyReduce_76 = happyReduce 5# 24# happyReduction_76 +happyReduction_76 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOut12 happy_x_4 of { happy_var_4 -> - happyIn26 + happyIn28 (Just happy_var_4 ) `HappyStk` happyRest} -happyReduce_73 = happySpecReduce_0 22# happyReduction_73 -happyReduction_73 = happyIn26 +happyReduce_77 = happySpecReduce_0 24# happyReduction_77 +happyReduction_77 = happyIn28 (Nothing ) -happyReduce_74 = happySpecReduce_0 23# happyReduction_74 -happyReduction_74 = happyIn27 +happyReduce_78 = happySpecReduce_0 25# happyReduction_78 +happyReduction_78 = happyIn29 (nopEC ) -happyReduce_75 = happyReduce 4# 23# happyReduction_75 -happyReduction_75 (happy_x_4 `HappyStk` +happyReduce_79 = happyReduce 4# 25# happyReduction_79 +happyReduction_79 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOut12 happy_x_3 of { happy_var_3 -> - happyIn27 + happyIn29 (happy_var_3 ) `HappyStk` happyRest} -happyReduce_76 = happySpecReduce_3 24# happyReduction_76 -happyReduction_76 happy_x_3 +happyReduce_80 = happySpecReduce_3 26# happyReduction_80 +happyReduction_80 happy_x_3 happy_x_2 happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - case happyOut28 happy_x_3 of { happy_var_3 -> - happyIn28 + = case happyOut30 happy_x_1 of { happy_var_1 -> + case happyOut30 happy_x_3 of { happy_var_3 -> + happyIn30 (mkMachOp MO_U_Quot [happy_var_1,happy_var_3] )}} -happyReduce_77 = happySpecReduce_3 24# happyReduction_77 -happyReduction_77 happy_x_3 +happyReduce_81 = happySpecReduce_3 26# happyReduction_81 +happyReduction_81 happy_x_3 happy_x_2 happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - case happyOut28 happy_x_3 of { happy_var_3 -> - happyIn28 + = case happyOut30 happy_x_1 of { happy_var_1 -> + case happyOut30 happy_x_3 of { happy_var_3 -> + happyIn30 (mkMachOp MO_Mul [happy_var_1,happy_var_3] )}} -happyReduce_78 = happySpecReduce_3 24# happyReduction_78 -happyReduction_78 happy_x_3 +happyReduce_82 = happySpecReduce_3 26# happyReduction_82 +happyReduction_82 happy_x_3 happy_x_2 happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - case happyOut28 happy_x_3 of { happy_var_3 -> - happyIn28 + = case happyOut30 happy_x_1 of { happy_var_1 -> + case happyOut30 happy_x_3 of { happy_var_3 -> + happyIn30 (mkMachOp MO_U_Rem [happy_var_1,happy_var_3] )}} -happyReduce_79 = happySpecReduce_3 24# happyReduction_79 -happyReduction_79 happy_x_3 +happyReduce_83 = happySpecReduce_3 26# happyReduction_83 +happyReduction_83 happy_x_3 happy_x_2 happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - case happyOut28 happy_x_3 of { happy_var_3 -> - happyIn28 + = case happyOut30 happy_x_1 of { happy_var_1 -> + case happyOut30 happy_x_3 of { happy_var_3 -> + happyIn30 (mkMachOp MO_Sub [happy_var_1,happy_var_3] )}} -happyReduce_80 = happySpecReduce_3 24# happyReduction_80 -happyReduction_80 happy_x_3 +happyReduce_84 = happySpecReduce_3 26# happyReduction_84 +happyReduction_84 happy_x_3 happy_x_2 happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - case happyOut28 happy_x_3 of { happy_var_3 -> - happyIn28 + = case happyOut30 happy_x_1 of { happy_var_1 -> + case happyOut30 happy_x_3 of { happy_var_3 -> + happyIn30 (mkMachOp MO_Add [happy_var_1,happy_var_3] )}} -happyReduce_81 = happySpecReduce_3 24# happyReduction_81 -happyReduction_81 happy_x_3 +happyReduce_85 = happySpecReduce_3 26# happyReduction_85 +happyReduction_85 happy_x_3 happy_x_2 happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - case happyOut28 happy_x_3 of { happy_var_3 -> - happyIn28 + = case happyOut30 happy_x_1 of { happy_var_1 -> + case happyOut30 happy_x_3 of { happy_var_3 -> + happyIn30 (mkMachOp MO_U_Shr [happy_var_1,happy_var_3] )}} -happyReduce_82 = happySpecReduce_3 24# happyReduction_82 -happyReduction_82 happy_x_3 +happyReduce_86 = happySpecReduce_3 26# happyReduction_86 +happyReduction_86 happy_x_3 happy_x_2 happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - case happyOut28 happy_x_3 of { happy_var_3 -> - happyIn28 + = case happyOut30 happy_x_1 of { happy_var_1 -> + case happyOut30 happy_x_3 of { happy_var_3 -> + happyIn30 (mkMachOp MO_Shl [happy_var_1,happy_var_3] )}} -happyReduce_83 = happySpecReduce_3 24# happyReduction_83 -happyReduction_83 happy_x_3 +happyReduce_87 = happySpecReduce_3 26# happyReduction_87 +happyReduction_87 happy_x_3 happy_x_2 happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - case happyOut28 happy_x_3 of { happy_var_3 -> - happyIn28 + = case happyOut30 happy_x_1 of { happy_var_1 -> + case happyOut30 happy_x_3 of { happy_var_3 -> + happyIn30 (mkMachOp MO_And [happy_var_1,happy_var_3] )}} -happyReduce_84 = happySpecReduce_3 24# happyReduction_84 -happyReduction_84 happy_x_3 +happyReduce_88 = happySpecReduce_3 26# happyReduction_88 +happyReduction_88 happy_x_3 happy_x_2 happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - case happyOut28 happy_x_3 of { happy_var_3 -> - happyIn28 + = case happyOut30 happy_x_1 of { happy_var_1 -> + case happyOut30 happy_x_3 of { happy_var_3 -> + happyIn30 (mkMachOp MO_Xor [happy_var_1,happy_var_3] )}} -happyReduce_85 = happySpecReduce_3 24# happyReduction_85 -happyReduction_85 happy_x_3 +happyReduce_89 = happySpecReduce_3 26# happyReduction_89 +happyReduction_89 happy_x_3 happy_x_2 happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - case happyOut28 happy_x_3 of { happy_var_3 -> - happyIn28 + = case happyOut30 happy_x_1 of { happy_var_1 -> + case happyOut30 happy_x_3 of { happy_var_3 -> + happyIn30 (mkMachOp MO_Or [happy_var_1,happy_var_3] )}} -happyReduce_86 = happySpecReduce_3 24# happyReduction_86 -happyReduction_86 happy_x_3 +happyReduce_90 = happySpecReduce_3 26# happyReduction_90 +happyReduction_90 happy_x_3 happy_x_2 happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - case happyOut28 happy_x_3 of { happy_var_3 -> - happyIn28 + = case happyOut30 happy_x_1 of { happy_var_1 -> + case happyOut30 happy_x_3 of { happy_var_3 -> + happyIn30 (mkMachOp MO_U_Ge [happy_var_1,happy_var_3] )}} -happyReduce_87 = happySpecReduce_3 24# happyReduction_87 -happyReduction_87 happy_x_3 +happyReduce_91 = happySpecReduce_3 26# happyReduction_91 +happyReduction_91 happy_x_3 happy_x_2 happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - case happyOut28 happy_x_3 of { happy_var_3 -> - happyIn28 + = case happyOut30 happy_x_1 of { happy_var_1 -> + case happyOut30 happy_x_3 of { happy_var_3 -> + happyIn30 (mkMachOp MO_U_Gt [happy_var_1,happy_var_3] )}} -happyReduce_88 = happySpecReduce_3 24# happyReduction_88 -happyReduction_88 happy_x_3 +happyReduce_92 = happySpecReduce_3 26# happyReduction_92 +happyReduction_92 happy_x_3 happy_x_2 happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - case happyOut28 happy_x_3 of { happy_var_3 -> - happyIn28 + = case happyOut30 happy_x_1 of { happy_var_1 -> + case happyOut30 happy_x_3 of { happy_var_3 -> + happyIn30 (mkMachOp MO_U_Le [happy_var_1,happy_var_3] )}} -happyReduce_89 = happySpecReduce_3 24# happyReduction_89 -happyReduction_89 happy_x_3 +happyReduce_93 = happySpecReduce_3 26# happyReduction_93 +happyReduction_93 happy_x_3 happy_x_2 happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - case happyOut28 happy_x_3 of { happy_var_3 -> - happyIn28 + = case happyOut30 happy_x_1 of { happy_var_1 -> + case happyOut30 happy_x_3 of { happy_var_3 -> + happyIn30 (mkMachOp MO_U_Lt [happy_var_1,happy_var_3] )}} -happyReduce_90 = happySpecReduce_3 24# happyReduction_90 -happyReduction_90 happy_x_3 +happyReduce_94 = happySpecReduce_3 26# happyReduction_94 +happyReduction_94 happy_x_3 happy_x_2 happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - case happyOut28 happy_x_3 of { happy_var_3 -> - happyIn28 + = case happyOut30 happy_x_1 of { happy_var_1 -> + case happyOut30 happy_x_3 of { happy_var_3 -> + happyIn30 (mkMachOp MO_Ne [happy_var_1,happy_var_3] )}} -happyReduce_91 = happySpecReduce_3 24# happyReduction_91 -happyReduction_91 happy_x_3 +happyReduce_95 = happySpecReduce_3 26# happyReduction_95 +happyReduction_95 happy_x_3 happy_x_2 happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - case happyOut28 happy_x_3 of { happy_var_3 -> - happyIn28 + = case happyOut30 happy_x_1 of { happy_var_1 -> + case happyOut30 happy_x_3 of { happy_var_3 -> + happyIn30 (mkMachOp MO_Eq [happy_var_1,happy_var_3] )}} -happyReduce_92 = happySpecReduce_2 24# happyReduction_92 -happyReduction_92 happy_x_2 +happyReduce_96 = happySpecReduce_2 26# happyReduction_96 +happyReduction_96 happy_x_2 happy_x_1 - = case happyOut28 happy_x_2 of { happy_var_2 -> - happyIn28 + = case happyOut30 happy_x_2 of { happy_var_2 -> + happyIn30 (mkMachOp MO_Not [happy_var_2] )} -happyReduce_93 = happySpecReduce_2 24# happyReduction_93 -happyReduction_93 happy_x_2 +happyReduce_97 = happySpecReduce_2 26# happyReduction_97 +happyReduction_97 happy_x_2 happy_x_1 - = case happyOut28 happy_x_2 of { happy_var_2 -> - happyIn28 + = case happyOut30 happy_x_2 of { happy_var_2 -> + happyIn30 (mkMachOp MO_S_Neg [happy_var_2] )} -happyReduce_94 = happyMonadReduce 5# 24# happyReduction_94 -happyReduction_94 (happy_x_5 `HappyStk` +happyReduce_98 = happyMonadReduce 5# 26# happyReduction_98 +happyReduction_98 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk - = happyThen (case happyOut29 happy_x_1 of { happy_var_1 -> + = happyThen (case happyOut31 happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> - case happyOut29 happy_x_5 of { happy_var_5 -> + case happyOut31 happy_x_5 of { happy_var_5 -> ( do { mo <- nameToMachOp happy_var_3 ; return (mkMachOp mo [happy_var_1,happy_var_5]) })}}} - ) (\r -> happyReturn (happyIn28 r)) + ) (\r -> happyReturn (happyIn30 r)) -happyReduce_95 = happySpecReduce_1 24# happyReduction_95 -happyReduction_95 happy_x_1 - = case happyOut29 happy_x_1 of { happy_var_1 -> - happyIn28 +happyReduce_99 = happySpecReduce_1 26# happyReduction_99 +happyReduction_99 happy_x_1 + = case happyOut31 happy_x_1 of { happy_var_1 -> + happyIn30 (happy_var_1 )} -happyReduce_96 = happySpecReduce_2 25# happyReduction_96 -happyReduction_96 happy_x_2 +happyReduce_100 = happySpecReduce_2 27# happyReduction_100 +happyReduction_100 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { (L _ (CmmT_Int happy_var_1)) -> - case happyOut30 happy_x_2 of { happy_var_2 -> - happyIn29 + case happyOut32 happy_x_2 of { happy_var_2 -> + happyIn31 (return (CmmLit (CmmInt happy_var_1 (typeWidth happy_var_2))) )}} -happyReduce_97 = happySpecReduce_2 25# happyReduction_97 -happyReduction_97 happy_x_2 +happyReduce_101 = happySpecReduce_2 27# happyReduction_101 +happyReduction_101 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { (L _ (CmmT_Float happy_var_1)) -> - case happyOut30 happy_x_2 of { happy_var_2 -> - happyIn29 + case happyOut32 happy_x_2 of { happy_var_2 -> + happyIn31 (return (CmmLit (CmmFloat happy_var_1 (typeWidth happy_var_2))) )}} -happyReduce_98 = happySpecReduce_1 25# happyReduction_98 -happyReduction_98 happy_x_1 +happyReduce_102 = happySpecReduce_1 27# happyReduction_102 +happyReduction_102 happy_x_1 = case happyOutTok happy_x_1 of { (L _ (CmmT_String happy_var_1)) -> - happyIn29 + happyIn31 (do s <- code (mkStringCLit happy_var_1); return (CmmLit s) )} -happyReduce_99 = happySpecReduce_1 25# happyReduction_99 -happyReduction_99 happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - happyIn29 +happyReduce_103 = happySpecReduce_1 27# happyReduction_103 +happyReduction_103 happy_x_1 + = case happyOut39 happy_x_1 of { happy_var_1 -> + happyIn31 (happy_var_1 )} -happyReduce_100 = happyReduce 4# 25# happyReduction_100 -happyReduction_100 (happy_x_4 `HappyStk` +happyReduce_104 = happyReduce 4# 27# happyReduction_104 +happyReduction_104 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut49 happy_x_1 of { happy_var_1 -> - case happyOut28 happy_x_3 of { happy_var_3 -> - happyIn29 + = case happyOut51 happy_x_1 of { happy_var_1 -> + case happyOut30 happy_x_3 of { happy_var_3 -> + happyIn31 (do e <- happy_var_3; return (CmmLoad e happy_var_1) ) `HappyStk` happyRest}} -happyReduce_101 = happyMonadReduce 5# 25# happyReduction_101 -happyReduction_101 (happy_x_5 `HappyStk` +happyReduce_105 = happyMonadReduce 5# 27# happyReduction_105 +happyReduction_105 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> - case happyOut35 happy_x_4 of { happy_var_4 -> + case happyOut37 happy_x_4 of { happy_var_4 -> ( exprOp happy_var_2 happy_var_4)}} - ) (\r -> happyReturn (happyIn29 r)) + ) (\r -> happyReturn (happyIn31 r)) -happyReduce_102 = happySpecReduce_3 25# happyReduction_102 -happyReduction_102 happy_x_3 +happyReduce_106 = happySpecReduce_3 27# happyReduction_106 +happyReduction_106 happy_x_3 happy_x_2 happy_x_1 - = case happyOut28 happy_x_2 of { happy_var_2 -> - happyIn29 + = case happyOut30 happy_x_2 of { happy_var_2 -> + happyIn31 (happy_var_2 )} -happyReduce_103 = happySpecReduce_0 26# happyReduction_103 -happyReduction_103 = happyIn30 +happyReduce_107 = happySpecReduce_0 28# happyReduction_107 +happyReduction_107 = happyIn32 (bWord ) -happyReduce_104 = happySpecReduce_2 26# happyReduction_104 -happyReduction_104 happy_x_2 +happyReduce_108 = happySpecReduce_2 28# happyReduction_108 +happyReduction_108 happy_x_2 happy_x_1 - = case happyOut49 happy_x_2 of { happy_var_2 -> - happyIn30 + = case happyOut51 happy_x_2 of { happy_var_2 -> + happyIn32 (happy_var_2 )} -happyReduce_105 = happySpecReduce_0 27# happyReduction_105 -happyReduction_105 = happyIn31 +happyReduce_109 = happySpecReduce_0 29# happyReduction_109 +happyReduction_109 = happyIn33 ([] ) -happyReduce_106 = happySpecReduce_3 27# happyReduction_106 -happyReduction_106 happy_x_3 +happyReduce_110 = happySpecReduce_3 29# happyReduction_110 +happyReduction_110 happy_x_3 happy_x_2 happy_x_1 - = case happyOut32 happy_x_2 of { happy_var_2 -> - happyIn31 + = case happyOut34 happy_x_2 of { happy_var_2 -> + happyIn33 (happy_var_2 )} -happyReduce_107 = happySpecReduce_0 28# happyReduction_107 -happyReduction_107 = happyIn32 +happyReduce_111 = happySpecReduce_0 30# happyReduction_111 +happyReduction_111 = happyIn34 ([] ) -happyReduce_108 = happySpecReduce_1 28# happyReduction_108 -happyReduction_108 happy_x_1 - = case happyOut33 happy_x_1 of { happy_var_1 -> - happyIn32 +happyReduce_112 = happySpecReduce_1 30# happyReduction_112 +happyReduction_112 happy_x_1 + = case happyOut35 happy_x_1 of { happy_var_1 -> + happyIn34 (happy_var_1 )} -happyReduce_109 = happySpecReduce_1 29# happyReduction_109 -happyReduction_109 happy_x_1 - = case happyOut34 happy_x_1 of { happy_var_1 -> - happyIn33 +happyReduce_113 = happySpecReduce_1 31# happyReduction_113 +happyReduction_113 happy_x_1 + = case happyOut36 happy_x_1 of { happy_var_1 -> + happyIn35 ([happy_var_1] )} -happyReduce_110 = happySpecReduce_3 29# happyReduction_110 -happyReduction_110 happy_x_3 +happyReduce_114 = happySpecReduce_3 31# happyReduction_114 +happyReduction_114 happy_x_3 happy_x_2 happy_x_1 - = case happyOut34 happy_x_1 of { happy_var_1 -> - case happyOut33 happy_x_3 of { happy_var_3 -> - happyIn33 + = case happyOut36 happy_x_1 of { happy_var_1 -> + case happyOut35 happy_x_3 of { happy_var_3 -> + happyIn35 (happy_var_1 : happy_var_3 )}} -happyReduce_111 = happySpecReduce_1 30# happyReduction_111 -happyReduction_111 happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - happyIn34 +happyReduce_115 = happySpecReduce_1 32# happyReduction_115 +happyReduction_115 happy_x_1 + = case happyOut30 happy_x_1 of { happy_var_1 -> + happyIn36 (do e <- happy_var_1; return (CmmHinted e (inferCmmHint e)) )} -happyReduce_112 = happyMonadReduce 2# 30# happyReduction_112 -happyReduction_112 (happy_x_2 `HappyStk` +happyReduce_116 = happyMonadReduce 2# 32# happyReduction_116 +happyReduction_116 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk - = happyThen (case happyOut28 happy_x_1 of { happy_var_1 -> + = happyThen (case happyOut30 happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { (L _ (CmmT_String happy_var_2)) -> ( do h <- parseCmmHint happy_var_2; return $ do e <- happy_var_1; return (CmmHinted e h))}} - ) (\r -> happyReturn (happyIn34 r)) + ) (\r -> happyReturn (happyIn36 r)) -happyReduce_113 = happySpecReduce_0 31# happyReduction_113 -happyReduction_113 = happyIn35 +happyReduce_117 = happySpecReduce_0 33# happyReduction_117 +happyReduction_117 = happyIn37 ([] ) -happyReduce_114 = happySpecReduce_1 31# happyReduction_114 -happyReduction_114 happy_x_1 - = case happyOut36 happy_x_1 of { happy_var_1 -> - happyIn35 +happyReduce_118 = happySpecReduce_1 33# happyReduction_118 +happyReduction_118 happy_x_1 + = case happyOut38 happy_x_1 of { happy_var_1 -> + happyIn37 (happy_var_1 )} -happyReduce_115 = happySpecReduce_1 32# happyReduction_115 -happyReduction_115 happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - happyIn36 +happyReduce_119 = happySpecReduce_1 34# happyReduction_119 +happyReduction_119 happy_x_1 + = case happyOut30 happy_x_1 of { happy_var_1 -> + happyIn38 ([ happy_var_1 ] )} -happyReduce_116 = happySpecReduce_3 32# happyReduction_116 -happyReduction_116 happy_x_3 +happyReduce_120 = happySpecReduce_3 34# happyReduction_120 +happyReduction_120 happy_x_3 happy_x_2 happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - case happyOut36 happy_x_3 of { happy_var_3 -> - happyIn36 + = case happyOut30 happy_x_1 of { happy_var_1 -> + case happyOut38 happy_x_3 of { happy_var_3 -> + happyIn38 (happy_var_1 : happy_var_3 )}} -happyReduce_117 = happySpecReduce_1 33# happyReduction_117 -happyReduction_117 happy_x_1 +happyReduce_121 = happySpecReduce_1 35# happyReduction_121 +happyReduction_121 happy_x_1 = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - happyIn37 + happyIn39 (lookupName happy_var_1 )} -happyReduce_118 = happySpecReduce_1 33# happyReduction_118 -happyReduction_118 happy_x_1 +happyReduce_122 = happySpecReduce_1 35# happyReduction_122 +happyReduction_122 happy_x_1 = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> - happyIn37 + happyIn39 (return (CmmReg (CmmGlobal happy_var_1)) )} -happyReduce_119 = happySpecReduce_0 34# happyReduction_119 -happyReduction_119 = happyIn38 +happyReduce_123 = happySpecReduce_0 36# happyReduction_123 +happyReduction_123 = happyIn40 ([] ) -happyReduce_120 = happyReduce 4# 34# happyReduction_120 -happyReduction_120 (happy_x_4 `HappyStk` +happyReduce_124 = happyReduce 4# 36# happyReduction_124 +happyReduction_124 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut39 happy_x_2 of { happy_var_2 -> - happyIn38 + = case happyOut41 happy_x_2 of { happy_var_2 -> + happyIn40 (happy_var_2 ) `HappyStk` happyRest} -happyReduce_121 = happySpecReduce_1 35# happyReduction_121 -happyReduction_121 happy_x_1 - = case happyOut40 happy_x_1 of { happy_var_1 -> - happyIn39 +happyReduce_125 = happySpecReduce_1 37# happyReduction_125 +happyReduction_125 happy_x_1 + = case happyOut42 happy_x_1 of { happy_var_1 -> + happyIn41 ([happy_var_1] )} -happyReduce_122 = happySpecReduce_2 35# happyReduction_122 -happyReduction_122 happy_x_2 +happyReduce_126 = happySpecReduce_2 37# happyReduction_126 +happyReduction_126 happy_x_2 happy_x_1 - = case happyOut40 happy_x_1 of { happy_var_1 -> - happyIn39 + = case happyOut42 happy_x_1 of { happy_var_1 -> + happyIn41 ([happy_var_1] )} -happyReduce_123 = happySpecReduce_3 35# happyReduction_123 -happyReduction_123 happy_x_3 +happyReduce_127 = happySpecReduce_3 37# happyReduction_127 +happyReduction_127 happy_x_3 happy_x_2 happy_x_1 - = case happyOut40 happy_x_1 of { happy_var_1 -> - case happyOut39 happy_x_3 of { happy_var_3 -> - happyIn39 + = case happyOut42 happy_x_1 of { happy_var_1 -> + case happyOut41 happy_x_3 of { happy_var_3 -> + happyIn41 (happy_var_1 : happy_var_3 )}} -happyReduce_124 = happySpecReduce_1 36# happyReduction_124 -happyReduction_124 happy_x_1 - = case happyOut41 happy_x_1 of { happy_var_1 -> - happyIn40 +happyReduce_128 = happySpecReduce_1 38# happyReduction_128 +happyReduction_128 happy_x_1 + = case happyOut43 happy_x_1 of { happy_var_1 -> + happyIn42 (do e <- happy_var_1; return (CmmHinted e (inferCmmHint (CmmReg (CmmLocal e)))) )} -happyReduce_125 = happyMonadReduce 2# 36# happyReduction_125 -happyReduction_125 (happy_x_2 `HappyStk` +happyReduce_129 = happyMonadReduce 2# 38# happyReduction_129 +happyReduction_129 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { (L _ (CmmT_String happy_var_1)) -> - case happyOut41 happy_x_2 of { happy_var_2 -> + case happyOut43 happy_x_2 of { happy_var_2 -> ( do h <- parseCmmHint happy_var_1; return $ do e <- happy_var_2; return (CmmHinted e h))}} - ) (\r -> happyReturn (happyIn40 r)) + ) (\r -> happyReturn (happyIn42 r)) -happyReduce_126 = happySpecReduce_1 37# happyReduction_126 -happyReduction_126 happy_x_1 +happyReduce_130 = happySpecReduce_1 39# happyReduction_130 +happyReduction_130 happy_x_1 = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - happyIn41 + happyIn43 (do e <- lookupName happy_var_1; return $ case e of @@ -1880,10 +1934,10 @@ other -> pprPanic "CmmParse:" (ftext happy_var_1 <> text " not a local register") )} -happyReduce_127 = happySpecReduce_1 38# happyReduction_127 -happyReduction_127 happy_x_1 +happyReduce_131 = happySpecReduce_1 40# happyReduction_131 +happyReduction_131 happy_x_1 = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - happyIn42 + happyIn44 (do e <- lookupName happy_var_1; return $ case e of @@ -1891,152 +1945,152 @@ other -> pprPanic "CmmParse:" (ftext happy_var_1 <> text " not a register") )} -happyReduce_128 = happySpecReduce_1 38# happyReduction_128 -happyReduction_128 happy_x_1 +happyReduce_132 = happySpecReduce_1 40# happyReduction_132 +happyReduction_132 happy_x_1 = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> - happyIn42 + happyIn44 (return (CmmGlobal happy_var_1) )} -happyReduce_129 = happySpecReduce_0 39# happyReduction_129 -happyReduction_129 = happyIn43 +happyReduce_133 = happySpecReduce_0 41# happyReduction_133 +happyReduction_133 = happyIn45 ([] ) -happyReduce_130 = happySpecReduce_3 39# happyReduction_130 -happyReduction_130 happy_x_3 +happyReduce_134 = happySpecReduce_3 41# happyReduction_134 +happyReduction_134 happy_x_3 happy_x_2 happy_x_1 - = case happyOut44 happy_x_2 of { happy_var_2 -> - happyIn43 + = case happyOut46 happy_x_2 of { happy_var_2 -> + happyIn45 (happy_var_2 )} -happyReduce_131 = happySpecReduce_0 40# happyReduction_131 -happyReduction_131 = happyIn44 +happyReduce_135 = happySpecReduce_0 42# happyReduction_135 +happyReduction_135 = happyIn46 ([] ) -happyReduce_132 = happySpecReduce_1 40# happyReduction_132 -happyReduction_132 happy_x_1 - = case happyOut45 happy_x_1 of { happy_var_1 -> - happyIn44 +happyReduce_136 = happySpecReduce_1 42# happyReduction_136 +happyReduction_136 happy_x_1 + = case happyOut47 happy_x_1 of { happy_var_1 -> + happyIn46 (happy_var_1 )} -happyReduce_133 = happySpecReduce_2 41# happyReduction_133 -happyReduction_133 happy_x_2 +happyReduce_137 = happySpecReduce_2 43# happyReduction_137 +happyReduction_137 happy_x_2 happy_x_1 - = case happyOut46 happy_x_1 of { happy_var_1 -> - happyIn45 + = case happyOut48 happy_x_1 of { happy_var_1 -> + happyIn47 ([happy_var_1] )} -happyReduce_134 = happySpecReduce_1 41# happyReduction_134 -happyReduction_134 happy_x_1 - = case happyOut46 happy_x_1 of { happy_var_1 -> - happyIn45 +happyReduce_138 = happySpecReduce_1 43# happyReduction_138 +happyReduction_138 happy_x_1 + = case happyOut48 happy_x_1 of { happy_var_1 -> + happyIn47 ([happy_var_1] )} -happyReduce_135 = happySpecReduce_3 41# happyReduction_135 -happyReduction_135 happy_x_3 +happyReduce_139 = happySpecReduce_3 43# happyReduction_139 +happyReduction_139 happy_x_3 happy_x_2 happy_x_1 - = case happyOut46 happy_x_1 of { happy_var_1 -> - case happyOut45 happy_x_3 of { happy_var_3 -> - happyIn45 + = case happyOut48 happy_x_1 of { happy_var_1 -> + case happyOut47 happy_x_3 of { happy_var_3 -> + happyIn47 (happy_var_1 : happy_var_3 )}} -happyReduce_136 = happySpecReduce_2 42# happyReduction_136 -happyReduction_136 happy_x_2 +happyReduce_140 = happySpecReduce_2 44# happyReduction_140 +happyReduction_140 happy_x_2 happy_x_1 - = case happyOut49 happy_x_1 of { happy_var_1 -> + = case happyOut51 happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> - happyIn46 + happyIn48 (newLocal happy_var_1 happy_var_2 )}} -happyReduce_137 = happySpecReduce_0 43# happyReduction_137 -happyReduction_137 = happyIn47 +happyReduce_141 = happySpecReduce_0 45# happyReduction_141 +happyReduction_141 = happyIn49 (return Nothing ) -happyReduce_138 = happyReduce 5# 43# happyReduction_138 -happyReduction_138 (happy_x_5 `HappyStk` +happyReduce_142 = happyReduce 5# 45# happyReduction_142 +happyReduction_142 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut28 happy_x_2 of { happy_var_2 -> - case happyOut35 happy_x_4 of { happy_var_4 -> - happyIn47 + = case happyOut30 happy_x_2 of { happy_var_2 -> + case happyOut37 happy_x_4 of { happy_var_4 -> + happyIn49 (do { target <- happy_var_2; args <- sequence happy_var_4; return $ Just (UpdateFrame target args) } ) `HappyStk` happyRest}} -happyReduce_139 = happySpecReduce_0 44# happyReduction_139 -happyReduction_139 = happyIn48 +happyReduce_143 = happySpecReduce_0 46# happyReduction_143 +happyReduction_143 = happyIn50 (return Nothing ) -happyReduce_140 = happySpecReduce_2 44# happyReduction_140 -happyReduction_140 happy_x_2 +happyReduce_144 = happySpecReduce_2 46# happyReduction_144 +happyReduction_144 happy_x_2 happy_x_1 = case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> - happyIn48 + happyIn50 (do l <- lookupLabel happy_var_2; return (Just l) )} -happyReduce_141 = happySpecReduce_1 45# happyReduction_141 -happyReduction_141 happy_x_1 - = happyIn49 +happyReduce_145 = happySpecReduce_1 47# happyReduction_145 +happyReduction_145 happy_x_1 + = happyIn51 (b8 ) -happyReduce_142 = happySpecReduce_1 45# happyReduction_142 -happyReduction_142 happy_x_1 - = case happyOut50 happy_x_1 of { happy_var_1 -> - happyIn49 +happyReduce_146 = happySpecReduce_1 47# happyReduction_146 +happyReduction_146 happy_x_1 + = case happyOut52 happy_x_1 of { happy_var_1 -> + happyIn51 (happy_var_1 )} -happyReduce_143 = happySpecReduce_1 46# happyReduction_143 -happyReduction_143 happy_x_1 - = happyIn50 +happyReduce_147 = happySpecReduce_1 48# happyReduction_147 +happyReduction_147 happy_x_1 + = happyIn52 (b16 ) -happyReduce_144 = happySpecReduce_1 46# happyReduction_144 -happyReduction_144 happy_x_1 - = happyIn50 +happyReduce_148 = happySpecReduce_1 48# happyReduction_148 +happyReduction_148 happy_x_1 + = happyIn52 (b32 ) -happyReduce_145 = happySpecReduce_1 46# happyReduction_145 -happyReduction_145 happy_x_1 - = happyIn50 +happyReduce_149 = happySpecReduce_1 48# happyReduction_149 +happyReduction_149 happy_x_1 + = happyIn52 (b64 ) -happyReduce_146 = happySpecReduce_1 46# happyReduction_146 -happyReduction_146 happy_x_1 - = happyIn50 +happyReduce_150 = happySpecReduce_1 48# happyReduction_150 +happyReduction_150 happy_x_1 + = happyIn52 (f32 ) -happyReduce_147 = happySpecReduce_1 46# happyReduction_147 -happyReduction_147 happy_x_1 - = happyIn50 +happyReduce_151 = happySpecReduce_1 48# happyReduction_151 +happyReduction_151 happy_x_1 + = happyIn52 (f64 ) -happyReduce_148 = happySpecReduce_1 46# happyReduction_148 -happyReduction_148 happy_x_1 - = happyIn50 +happyReduce_152 = happySpecReduce_1 48# happyReduction_152 +happyReduction_152 happy_x_1 + = happyIn52 (gcWord ) @@ -2340,110 +2394,6 @@ ] --- ----------------------------------------------------------------------------- --- Our extended FCode monad. - --- We add a mapping from names to CmmExpr, to support local variable names in --- the concrete C-- code. The unique supply of the underlying FCode monad --- is used to grab a new unique for each local variable. - --- In C--, a local variable can be declared anywhere within a proc, --- and it scopes from the beginning of the proc to the end. Hence, we have --- to collect declarations as we parse the proc, and feed the environment --- back in circularly (to avoid a two-pass algorithm). - -data Named = Var CmmExpr | Label BlockId -type Decls = [(FastString,Named)] -type Env = UniqFM Named - -newtype ExtFCode a = EC { unEC :: Env -> Decls -> FCode (Decls, a) } - -type ExtCode = ExtFCode () - -returnExtFC a = EC $ \e s -> return (s, a) -thenExtFC (EC m) k = EC $ \e s -> do (s',r) <- m e s; unEC (k r) e s' - -instance Monad ExtFCode where - (>>=) = thenExtFC - return = returnExtFC - --- This function takes the variable decarations and imports and makes --- an environment, which is looped back into the computation. In this --- way, we can have embedded declarations that scope over the whole --- procedure, and imports that scope over the entire module. --- Discards the local declaration contained within decl' -loopDecls :: ExtFCode a -> ExtFCode a -loopDecls (EC fcode) = - EC $ \e globalDecls -> do - (decls', a) <- fixC (\ ~(decls,a) -> fcode (addListToUFM e (decls ++ globalDecls)) globalDecls) - return (globalDecls, a) - -getEnv :: ExtFCode Env -getEnv = EC $ \e s -> return (s, e) - -addVarDecl :: FastString -> CmmExpr -> ExtCode -addVarDecl var expr = EC $ \e s -> return ((var, Var expr):s, ()) - -addLabel :: FastString -> BlockId -> ExtCode -addLabel name block_id = EC $ \e s -> return ((name, Label block_id):s, ()) - -newLocal :: CmmType -> FastString -> ExtFCode LocalReg -newLocal ty name = do - u <- code newUnique - let reg = LocalReg u ty - addVarDecl name (CmmReg (CmmLocal reg)) - return reg - --- Creates a foreign label in the import. CLabel's labelDynamic --- classifies these labels as dynamic, hence the code generator emits the --- PIC code for them. -newImport :: FastString -> ExtFCode () -newImport name - = addVarDecl name (CmmLit (CmmLabel (mkForeignLabel name Nothing True IsFunction))) - -newLabel :: FastString -> ExtFCode BlockId -newLabel name = do - u <- code newUnique - addLabel name (BlockId u) - return (BlockId u) - -lookupLabel :: FastString -> ExtFCode BlockId -lookupLabel name = do - env <- getEnv - return $ - case lookupUFM env name of - Just (Label l) -> l - _other -> BlockId (newTagUnique (getUnique name) 'L') - --- Unknown names are treated as if they had been 'import'ed. --- This saves us a lot of bother in the RTS sources, at the expense of --- deferring some errors to link time. -lookupName :: FastString -> ExtFCode CmmExpr -lookupName name = do - env <- getEnv - return $ - case lookupUFM env name of - Just (Var e) -> e - _other -> CmmLit (CmmLabel (mkRtsCodeLabelFS name)) - --- Lifting FCode computations into the ExtFCode monad: -code :: FCode a -> ExtFCode a -code fc = EC $ \e s -> do r <- fc; return (s, r) - -code2 :: (FCode (Decls,b) -> FCode ((Decls,b),c)) - -> ExtFCode b -> ExtFCode c -code2 f (EC ec) = EC $ \e s -> do ((s',b),c) <- f (ec e s); return (s',c) - -nopEC = code nopC -stmtEC stmt = code (stmtC stmt) -stmtsEC stmts = code (stmtsC stmts) -getCgStmtsEC = code2 getCgStmts' -getCgStmtsEC' = code2 (\m -> getCgStmts' m >>= f) - where f ((decl, b), c) = return ((decl, b), (b, c)) - -forkLabelledCodeEC ec = do - stmts <- getCgStmtsEC ec - code (forkCgStmts stmts) profilingInfo desc_str ty_str = do @@ -2456,10 +2406,10 @@ return (ProfilingInfo lit1 lit2) -staticClosure :: FastString -> FastString -> [CmmLit] -> ExtCode -staticClosure cl_label info payload - = code $ emitDataLits (mkRtsDataLabelFS cl_label) lits - where lits = mkStaticClosure (mkRtsInfoLabelFS info) dontCareCCS payload [] [] [] +staticClosure :: PackageId -> FastString -> FastString -> [CmmLit] -> ExtCode +staticClosure pkg cl_label info payload + = code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits + where lits = mkStaticClosure (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] [] foreignCall :: String @@ -2670,7 +2620,7 @@ showPass dflags "ParseCmm" buf <- hGetStringBuffer filename let - init_loc = mkSrcLoc (mkFastString filename) 1 0 + init_loc = mkSrcLoc (mkFastString filename) 1 1 init_state = (mkPState buf init_loc dflags) { lex_state = [0] } -- reset the lex_state: the Lexer monad leaves some stuff -- in there we don't want. diff -ruN ghc-6.12.1/compiler/cmm/CmmParse.y.source ghc-6.13.20091231/compiler/cmm/CmmParse.y.source --- ghc-6.12.1/compiler/cmm/CmmParse.y.source 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/cmm/CmmParse.y.source 2009-12-31 10:14:18.000000000 -0800 @@ -3,6 +3,8 @@ -- (c) The University of Glasgow, 2004-2006 -- -- Parser for concrete Cmm. +-- This doesn't just parse the Cmm file, we also do some code generation +-- along the way for switches and foreign calls etc. -- ----------------------------------------------------------------------------- @@ -16,7 +18,8 @@ module CmmParse ( parseCmmFile ) where -import CgMonad +import CgMonad hiding (getDynFlags) +import CgExtCode import CgHeapery import CgUtils import CgProf @@ -40,6 +43,7 @@ import Lexer import ForeignCall +import Module import Literal import Unique import UniqFM @@ -54,6 +58,7 @@ import Outputable import BasicTypes import Bag ( emptyBag, unitBag ) +import Var import Control.Monad import Data.Array @@ -166,8 +171,9 @@ | cmmdata { $1 } | decl { $1 } | 'CLOSURE' '(' NAME ',' NAME lits ')' ';' - { do lits <- sequence $6; - staticClosure $3 $5 (map getLit lits) } + {% withThisPackage $ \pkg -> + do lits <- sequence $6; + staticClosure pkg $3 $5 (map getLit lits) } -- The only static closures in the RTS are dummy closures like -- stg_END_TSO_QUEUE_closure and stg_dummy_ret. We don't need @@ -190,7 +196,10 @@ -- Strings aren't used much in the RTS HC code, so it doesn't seem -- worth allowing inline strings. C-- doesn't allow them anyway. static :: { ExtFCode [CmmStatic] } - : NAME ':' { return [CmmDataLabel (mkRtsDataLabelFS $1)] } + : NAME ':' + {% withThisPackage $ \pkg -> + return [CmmDataLabel (mkCmmDataLabel pkg $1)] } + | type expr ';' { do e <- $2; return [CmmStaticLit (getLit e)] } | type ';' { return [CmmUninitialised @@ -235,29 +244,33 @@ code (emitInfoTableAndCode entry_ret_label (CmmInfo Nothing Nothing info) formals []) } | NAME maybe_formals_without_hints maybe_gc_block maybe_frame '{' body '}' - { do ((formals, gc_block, frame), stmts) <- - getCgStmtsEC' $ loopDecls $ do { - formals <- sequence $2; - gc_block <- $3; - frame <- $4; - $6; - return (formals, gc_block, frame) } - blks <- code (cgStmtsToBlocks stmts) - code (emitProc (CmmInfo gc_block frame CmmNonInfoTable) (mkRtsCodeLabelFS $1) formals blks) } + {% withThisPackage $ \pkg -> + do newFunctionName $1 pkg + ((formals, gc_block, frame), stmts) <- + getCgStmtsEC' $ loopDecls $ do { + formals <- sequence $2; + gc_block <- $3; + frame <- $4; + $6; + return (formals, gc_block, frame) } + blks <- code (cgStmtsToBlocks stmts) + code (emitProc (CmmInfo gc_block frame CmmNonInfoTable) (mkCmmCodeLabel pkg $1) formals blks) } info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' -- ptrs, nptrs, closure type, description, type - { do prof <- profilingInfo $11 $13 - return (mkRtsEntryLabelFS $3, + {% withThisPackage $ \pkg -> + do prof <- profilingInfo $11 $13 + return (mkCmmEntryLabel pkg $3, CmmInfoTable False prof (fromIntegral $9) (ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT), []) } | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')' -- ptrs, nptrs, closure type, description, type, fun type - { do prof <- profilingInfo $11 $13 - return (mkRtsEntryLabelFS $3, + {% withThisPackage $ \pkg -> + do prof <- profilingInfo $11 $13 + return (mkCmmEntryLabel pkg $3, CmmInfoTable False prof (fromIntegral $9) (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT 0 -- Arity zero @@ -270,8 +283,9 @@ -- A variant with a non-zero arity (needed to write Main_main in Cmm) | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ',' INT ')' -- ptrs, nptrs, closure type, description, type, fun type, arity - { do prof <- profilingInfo $11 $13 - return (mkRtsEntryLabelFS $3, + {% withThisPackage $ \pkg -> + do prof <- profilingInfo $11 $13 + return (mkCmmEntryLabel pkg $3, CmmInfoTable False prof (fromIntegral $9) (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $17) (ArgSpec (fromIntegral $15)) @@ -282,35 +296,39 @@ | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' -- ptrs, nptrs, tag, closure type, description, type - { do prof <- profilingInfo $13 $15 + {% withThisPackage $ \pkg -> + do prof <- profilingInfo $13 $15 -- If profiling is on, this string gets duplicated, -- but that's the way the old code did it we can fix it some other time. - desc_lit <- code $ mkStringCLit $13 - return (mkRtsEntryLabelFS $3, + desc_lit <- code $ mkStringCLit $13 + return (mkCmmEntryLabel pkg $3, CmmInfoTable False prof (fromIntegral $11) (ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit), []) } | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')' -- selector, closure type, description, type - { do prof <- profilingInfo $9 $11 - return (mkRtsEntryLabelFS $3, + {% withThisPackage $ \pkg -> + do prof <- profilingInfo $9 $11 + return (mkCmmEntryLabel pkg $3, CmmInfoTable False prof (fromIntegral $7) (ThunkSelectorInfo (fromIntegral $5) NoC_SRT), []) } | 'INFO_TABLE_RET' '(' NAME ',' INT ')' -- closure type (no live regs) - { do let infoLabel = mkRtsInfoLabelFS $3 - return (mkRtsRetLabelFS $3, + {% withThisPackage $ \pkg -> + do let infoLabel = mkCmmInfoLabel pkg $3 + return (mkCmmRetLabel pkg $3, CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5) (ContInfo [] NoC_SRT), []) } | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals_without_hints0 ')' -- closure type, live regs - { do live <- sequence (map (liftM Just) $7) - return (mkRtsRetLabelFS $3, + {% withThisPackage $ \pkg -> + do live <- sequence (map (liftM Just) $7) + return (mkCmmRetLabel pkg $3, CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5) (ContInfo live NoC_SRT), live) } @@ -322,12 +340,25 @@ decl :: { ExtCode } : type names ';' { mapM_ (newLocal $1) $2 } - | 'import' names ';' { mapM_ newImport $2 } + | 'import' importNames ';' { mapM_ newImport $2 } | 'export' names ';' { return () } -- ignore exports + +-- an imported function name, with optional packageId +importNames + :: { [(Maybe PackageId, FastString)] } + : importName { [$1] } + | importName ',' importNames { $1 : $3 } + +importName + :: { (Maybe PackageId, FastString) } + : NAME { (Nothing, $1) } + | STRING NAME { (Just (fsToPackageId (mkFastString $1)), $2) } + + names :: { [FastString] } - : NAME { [$1] } - | NAME ',' names { $1 : $3 } + : NAME { [$1] } + | NAME ',' names { $1 : $3 } stmt :: { ExtCode } : ';' { nopEC } @@ -768,110 +799,6 @@ ] --- ----------------------------------------------------------------------------- --- Our extended FCode monad. - --- We add a mapping from names to CmmExpr, to support local variable names in --- the concrete C-- code. The unique supply of the underlying FCode monad --- is used to grab a new unique for each local variable. - --- In C--, a local variable can be declared anywhere within a proc, --- and it scopes from the beginning of the proc to the end. Hence, we have --- to collect declarations as we parse the proc, and feed the environment --- back in circularly (to avoid a two-pass algorithm). - -data Named = Var CmmExpr | Label BlockId -type Decls = [(FastString,Named)] -type Env = UniqFM Named - -newtype ExtFCode a = EC { unEC :: Env -> Decls -> FCode (Decls, a) } - -type ExtCode = ExtFCode () - -returnExtFC a = EC $ \e s -> return (s, a) -thenExtFC (EC m) k = EC $ \e s -> do (s',r) <- m e s; unEC (k r) e s' - -instance Monad ExtFCode where - (>>=) = thenExtFC - return = returnExtFC - --- This function takes the variable decarations and imports and makes --- an environment, which is looped back into the computation. In this --- way, we can have embedded declarations that scope over the whole --- procedure, and imports that scope over the entire module. --- Discards the local declaration contained within decl' -loopDecls :: ExtFCode a -> ExtFCode a -loopDecls (EC fcode) = - EC $ \e globalDecls -> do - (decls', a) <- fixC (\ ~(decls,a) -> fcode (addListToUFM e (decls ++ globalDecls)) globalDecls) - return (globalDecls, a) - -getEnv :: ExtFCode Env -getEnv = EC $ \e s -> return (s, e) - -addVarDecl :: FastString -> CmmExpr -> ExtCode -addVarDecl var expr = EC $ \e s -> return ((var, Var expr):s, ()) - -addLabel :: FastString -> BlockId -> ExtCode -addLabel name block_id = EC $ \e s -> return ((name, Label block_id):s, ()) - -newLocal :: CmmType -> FastString -> ExtFCode LocalReg -newLocal ty name = do - u <- code newUnique - let reg = LocalReg u ty - addVarDecl name (CmmReg (CmmLocal reg)) - return reg - --- Creates a foreign label in the import. CLabel's labelDynamic --- classifies these labels as dynamic, hence the code generator emits the --- PIC code for them. -newImport :: FastString -> ExtFCode () -newImport name - = addVarDecl name (CmmLit (CmmLabel (mkForeignLabel name Nothing True IsFunction))) - -newLabel :: FastString -> ExtFCode BlockId -newLabel name = do - u <- code newUnique - addLabel name (BlockId u) - return (BlockId u) - -lookupLabel :: FastString -> ExtFCode BlockId -lookupLabel name = do - env <- getEnv - return $ - case lookupUFM env name of - Just (Label l) -> l - _other -> BlockId (newTagUnique (getUnique name) 'L') - --- Unknown names are treated as if they had been 'import'ed. --- This saves us a lot of bother in the RTS sources, at the expense of --- deferring some errors to link time. -lookupName :: FastString -> ExtFCode CmmExpr -lookupName name = do - env <- getEnv - return $ - case lookupUFM env name of - Just (Var e) -> e - _other -> CmmLit (CmmLabel (mkRtsCodeLabelFS name)) - --- Lifting FCode computations into the ExtFCode monad: -code :: FCode a -> ExtFCode a -code fc = EC $ \e s -> do r <- fc; return (s, r) - -code2 :: (FCode (Decls,b) -> FCode ((Decls,b),c)) - -> ExtFCode b -> ExtFCode c -code2 f (EC ec) = EC $ \e s -> do ((s',b),c) <- f (ec e s); return (s',c) - -nopEC = code nopC -stmtEC stmt = code (stmtC stmt) -stmtsEC stmts = code (stmtsC stmts) -getCgStmtsEC = code2 getCgStmts' -getCgStmtsEC' = code2 (\m -> getCgStmts' m >>= f) - where f ((decl, b), c) = return ((decl, b), (b, c)) - -forkLabelledCodeEC ec = do - stmts <- getCgStmtsEC ec - code (forkCgStmts stmts) profilingInfo desc_str ty_str = do @@ -884,10 +811,10 @@ return (ProfilingInfo lit1 lit2) -staticClosure :: FastString -> FastString -> [CmmLit] -> ExtCode -staticClosure cl_label info payload - = code $ emitDataLits (mkRtsDataLabelFS cl_label) lits - where lits = mkStaticClosure (mkRtsInfoLabelFS info) dontCareCCS payload [] [] [] +staticClosure :: PackageId -> FastString -> FastString -> [CmmLit] -> ExtCode +staticClosure pkg cl_label info payload + = code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits + where lits = mkStaticClosure (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] [] foreignCall :: String @@ -1098,7 +1025,7 @@ showPass dflags "ParseCmm" buf <- hGetStringBuffer filename let - init_loc = mkSrcLoc (mkFastString filename) 1 0 + init_loc = mkSrcLoc (mkFastString filename) 1 1 init_state = (mkPState buf init_loc dflags) { lex_state = [0] } -- reset the lex_state: the Lexer monad leaves some stuff -- in there we don't want. diff -ruN ghc-6.12.1/compiler/cmm/CmmSpillReload.hs ghc-6.13.20091231/compiler/cmm/CmmSpillReload.hs --- ghc-6.12.1/compiler/cmm/CmmSpillReload.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/cmm/CmmSpillReload.hs 2009-12-31 10:14:17.000000000 -0800 @@ -31,20 +31,23 @@ import Data.Maybe import Prelude hiding (zip) --- The point of this module is to insert spills and reloads to --- establish the invariant that at a call (or at any proc point with --- an established protocol) all live variables not expected in --- registers are sitting on the stack. We use a backward analysis to --- insert spills and reloads. It should be followed by a --- forward transformation to sink reloads as deeply as possible, so as --- to reduce register pressure. - --- A variable can be expected to be live in a register, live on the --- stack, or both. This analysis ensures that spills and reloads are --- inserted as needed to make sure that every live variable needed --- after a call is available on the stack. Spills are pushed back to --- their reaching definitions, but reloads are dropped wherever needed --- and will have to be sunk by a later forward transformation. +{- Note [Overview of spill/reload] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The point of this module is to insert spills and reloads to +establish the invariant that at a call (or at any proc point with +an established protocol) all live variables not expected in +registers are sitting on the stack. We use a backward analysis to +insert spills and reloads. It should be followed by a +forward transformation to sink reloads as deeply as possible, so as +to reduce register pressure. + +A variable can be expected to be live in a register, live on the +stack, or both. This analysis ensures that spills and reloads are +inserted as needed to make sure that every live variable needed +after a call is available on the stack. Spills are pushed back to +their reaching definitions, but reloads are dropped wherever needed +and will have to be sunk by a later forward transformation. +-} data DualLive = DualLive { on_stack :: RegSet, in_regs :: RegSet } @@ -64,7 +67,7 @@ dualLiveLattice :: DataflowLattice DualLive dualLiveLattice = - DataflowLattice "variables live in registers and on stack" empty add True + DataflowLattice "variables live in registers and on stack" empty add False where empty = DualLive emptyRegSet emptyRegSet -- | compute in the Tx monad to track whether anything has changed add new old = do stack <- add1 (on_stack new) (on_stack old) diff -ruN ghc-6.12.1/compiler/cmm/PprC.hs ghc-6.13.20091231/compiler/cmm/PprC.hs --- ghc-6.12.1/compiler/cmm/PprC.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/cmm/PprC.hs 2009-12-31 10:14:17.000000000 -0800 @@ -92,7 +92,7 @@ -- pprC :: RawCmm -> SDoc -pprC (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops +pprC (Cmm tops) = vcat $ intersperse blankLine $ map pprTop tops -- -- top level procs @@ -107,7 +107,7 @@ [] -> empty -- the first block doesn't get a label: (BasicBlock _ stmts : rest) -> vcat [ - text "", + blankLine, extern_decls, (if (externallyVisibleCLabel clbl) then mkFN_ else mkIF_) (pprCLabel clbl) <+> lbrace, diff -ruN ghc-6.12.1/compiler/cmm/PprCmm.hs ghc-6.13.20091231/compiler/cmm/PprCmm.hs --- ghc-6.12.1/compiler/cmm/PprCmm.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/cmm/PprCmm.hs 2009-12-31 10:14:17.000000000 -0800 @@ -115,7 +115,7 @@ ----------------------------------------------------------------------------- pprCmm :: (Outputable d, Outputable info, Outputable g) => GenCmm d info g -> SDoc -pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops +pprCmm (Cmm tops) = vcat $ intersperse blankLine $ map pprTop tops -- -------------------------------------------------------------------------- -- Top level `procedure' blocks. @@ -506,9 +506,8 @@ pprLit lit = case lit of CmmInt i rep -> hcat [ (if i < 0 then parens else id)(integer i) - , (if rep == wordWidth - then empty - else space <> dcolon <+> ppr rep) ] + , ppUnless (rep == wordWidth) $ + space <> dcolon <+> ppr rep ] CmmFloat f rep -> hsep [ rational f, dcolon, ppr rep ] CmmLabel clbl -> pprCLabel clbl diff -ruN ghc-6.12.1/compiler/cmm/ZipCfgCmmRep.hs ghc-6.13.20091231/compiler/cmm/ZipCfgCmmRep.hs --- ghc-6.12.1/compiler/cmm/ZipCfgCmmRep.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/cmm/ZipCfgCmmRep.hs 2009-12-31 10:14:17.000000000 -0800 @@ -114,13 +114,13 @@ -- the call goes into a loop. } -data MidCallTarget -- The target of a MidUnsafeCall - = ForeignTarget -- A foreign procedure - CmmExpr -- Its address - ForeignConvention -- Its calling convention +data MidCallTarget -- The target of a MidUnsafeCall + = ForeignTarget -- A foreign procedure + CmmExpr -- Its address + ForeignConvention -- Its calling convention - | PrimTarget -- A possibly-side-effecting machine operation - CallishMachOp -- Which one + | PrimTarget -- A possibly-side-effecting machine operation + CallishMachOp -- Which one deriving Eq data Convention @@ -277,8 +277,8 @@ foldRegsUsed f z (ForeignTarget e _) = foldRegsUsed f z e instance UserOfSlots MidCallTarget where + foldSlotsUsed f z (ForeignTarget e _) = foldSlotsUsed f z e foldSlotsUsed _f z (PrimTarget _) = z - foldSlotsUsed f z (ForeignTarget e _) = foldSlotsUsed f z e instance (UserOfLocalRegs a) => UserOfLocalRegs (Maybe a) where foldRegsUsed f z (Just x) = foldRegsUsed f z x @@ -459,10 +459,9 @@ -- call "ccall" foo(x, y)[r1, r2]; -- ToDo ppr volatile MidForeignCall safety target results args -> - hsep [ if null results - then empty - else parens (commafy $ map ppr results) <+> equals, - ppr_safety safety, + hsep [ ppUnless (null results) $ + parens (commafy $ map ppr results) <+> equals, + ppr_safety safety, ptext $ sLit "call", ppr_call_target target <> parens (commafy $ map ppr args) <> semi] @@ -485,7 +484,8 @@ ppr_call_target :: MidCallTarget -> SDoc ppr_call_target (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn -ppr_call_target (PrimTarget op) = ppr (CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False IsFunction)) +ppr_call_target (PrimTarget op) = + ppr (CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False IsFunction)) ppr_target :: CmmExpr -> SDoc ppr_target t@(CmmLit _) = ppr t diff -ruN ghc-6.12.1/compiler/cmm/ZipDataflow.hs ghc-6.13.20091231/compiler/cmm/ZipDataflow.hs --- ghc-6.12.1/compiler/cmm/ZipDataflow.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/cmm/ZipDataflow.hs 2009-12-31 10:14:17.000000000 -0800 @@ -570,7 +570,7 @@ (BlockId -> Bool) -> LastOutFacts a -> df a () mk_set_or_save is_local (LastOutFacts l) = mapM_ set_or_save_one l where set_or_save_one (id, a) = - if is_local id then setFact id a else pprTrace "addLastOutFact" (ppr $ length l) $ addLastOutFact (id, a) + if is_local id then setFact id a else addLastOutFact (id, a) @@ -980,7 +980,7 @@ dump_things :: Bool -dump_things = True +dump_things = False my_trace :: String -> SDoc -> a -> a my_trace = if dump_things then pprTrace else \_ _ a -> a diff -ruN ghc-6.12.1/compiler/codeGen/CgCallConv.hs ghc-6.13.20091231/compiler/codeGen/CgCallConv.hs --- ghc-6.12.1/compiler/codeGen/CgCallConv.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/codeGen/CgCallConv.hs 2009-12-31 10:14:17.000000000 -0800 @@ -45,6 +45,7 @@ import Bitmap import Util import StaticFlags +import Module import FastString import Outputable import Unique @@ -209,7 +210,7 @@ -- don't forget the zero case constructSlowCall [] - = (mkRtsApFastLabel (sLit "stg_ap_0"), [], []) + = (mkRtsApFastLabel (fsLit "stg_ap_0"), [], []) constructSlowCall amodes = (stg_ap_pat, these, rest) @@ -224,31 +225,31 @@ slowArgs [] = [] slowArgs amodes = (NonPtrArg, mkLblExpr stg_ap_pat) : args ++ slowArgs rest where (arg_pat, args, rest) = matchSlowPattern amodes - stg_ap_pat = mkRtsRetInfoLabel arg_pat + stg_ap_pat = mkCmmRetInfoLabel rtsPackageId arg_pat matchSlowPattern :: [(CgRep,CmmExpr)] - -> (LitString, [(CgRep,CmmExpr)], [(CgRep,CmmExpr)]) + -> (FastString, [(CgRep,CmmExpr)], [(CgRep,CmmExpr)]) matchSlowPattern amodes = (arg_pat, these, rest) where (arg_pat, n) = slowCallPattern (map fst amodes) (these, rest) = splitAt n amodes -- These cases were found to cover about 99% of all slow calls: -slowCallPattern :: [CgRep] -> (LitString, Int) -slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (sLit "stg_ap_pppppp", 6) -slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (sLit "stg_ap_ppppp", 5) -slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: _) = (sLit "stg_ap_pppp", 4) -slowCallPattern (PtrArg: PtrArg: PtrArg: VoidArg: _) = (sLit "stg_ap_pppv", 4) -slowCallPattern (PtrArg: PtrArg: PtrArg: _) = (sLit "stg_ap_ppp", 3) -slowCallPattern (PtrArg: PtrArg: VoidArg: _) = (sLit "stg_ap_ppv", 3) -slowCallPattern (PtrArg: PtrArg: _) = (sLit "stg_ap_pp", 2) -slowCallPattern (PtrArg: VoidArg: _) = (sLit "stg_ap_pv", 2) -slowCallPattern (PtrArg: _) = (sLit "stg_ap_p", 1) -slowCallPattern (VoidArg: _) = (sLit "stg_ap_v", 1) -slowCallPattern (NonPtrArg: _) = (sLit "stg_ap_n", 1) -slowCallPattern (FloatArg: _) = (sLit "stg_ap_f", 1) -slowCallPattern (DoubleArg: _) = (sLit "stg_ap_d", 1) -slowCallPattern (LongArg: _) = (sLit "stg_ap_l", 1) -slowCallPattern _ = panic "CgStackery.slowCallPattern" +slowCallPattern :: [CgRep] -> (FastString, Int) +slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_pppppp", 6) +slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_ppppp", 5) +slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_pppp", 4) +slowCallPattern (PtrArg: PtrArg: PtrArg: VoidArg: _) = (fsLit "stg_ap_pppv", 4) +slowCallPattern (PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_ppp", 3) +slowCallPattern (PtrArg: PtrArg: VoidArg: _) = (fsLit "stg_ap_ppv", 3) +slowCallPattern (PtrArg: PtrArg: _) = (fsLit "stg_ap_pp", 2) +slowCallPattern (PtrArg: VoidArg: _) = (fsLit "stg_ap_pv", 2) +slowCallPattern (PtrArg: _) = (fsLit "stg_ap_p", 1) +slowCallPattern (VoidArg: _) = (fsLit "stg_ap_v", 1) +slowCallPattern (NonPtrArg: _) = (fsLit "stg_ap_n", 1) +slowCallPattern (FloatArg: _) = (fsLit "stg_ap_f", 1) +slowCallPattern (DoubleArg: _) = (fsLit "stg_ap_d", 1) +slowCallPattern (LongArg: _) = (fsLit "stg_ap_l", 1) +slowCallPattern _ = panic "CgStackery.slowCallPattern" ------------------------------------------------------------------------- -- diff -ruN ghc-6.12.1/compiler/codeGen/CgClosure.lhs ghc-6.13.20091231/compiler/codeGen/CgClosure.lhs --- ghc-6.12.1/compiler/codeGen/CgClosure.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/codeGen/CgClosure.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -155,8 +155,7 @@ -- Node points to it... let name = idName bndr - is_elem = isIn "cgRhsClosure" - bndr_is_a_fv = bndr `is_elem` fvs + bndr_is_a_fv = bndr `elem` fvs reduced_fvs | bndr_is_a_fv = fvs `minusList` [bndr] | otherwise = fvs @@ -561,7 +560,10 @@ -- so that the garbage collector can find them -- This must be done *before* the info table pointer is overwritten, -- because the old info table ptr is needed for reversion - ; emitRtsCallWithVols (sLit "newCAF") [CmmHinted (CmmReg nodeReg) AddrHint] [node] False + ; emitRtsCallWithVols rtsPackageId (fsLit "newCAF") + [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint, + CmmHinted (CmmReg nodeReg) AddrHint ] + [node] False -- node is live, so save it. -- Overwrite the closure with a (static) indirection diff -ruN ghc-6.12.1/compiler/codeGen/CgCon.lhs ghc-6.13.20091231/compiler/codeGen/CgCon.lhs --- ghc-6.12.1/compiler/codeGen/CgCon.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/codeGen/CgCon.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -46,6 +46,7 @@ import Outputable import ListSetOps import Util +import Module import FastString import StaticFlags \end{code} @@ -164,13 +165,21 @@ Because of this, we use can safely return an addressing mode. +We don't support this optimisation when compiling into Windows DLLs yet +because they don't support cross package data references well. + \begin{code} + + buildDynCon binder _ con [arg_amode] | maybeIntLikeCon con +#if defined(mingw32_TARGET_OS) + , not opt_PIC +#endif , (_, CmmLit (CmmInt val _)) <- arg_amode , let val_int = (fromIntegral val) :: Int , val_int <= mAX_INTLIKE && val_int >= mIN_INTLIKE - = do { let intlike_lbl = mkRtsGcPtrLabel (sLit "stg_INTLIKE_closure") + = do { let intlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_INTLIKE_closure") offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize + 1) -- INTLIKE closures consist of a header and one word payload intlike_amode = CmmLit (cmmLabelOffW intlike_lbl offsetW) @@ -178,14 +187,18 @@ buildDynCon binder _ con [arg_amode] | maybeCharLikeCon con +#if defined(mingw32_TARGET_OS) + , not opt_PIC +#endif , (_, CmmLit (CmmInt val _)) <- arg_amode , let val_int = (fromIntegral val) :: Int , val_int <= mAX_CHARLIKE && val_int >= mIN_CHARLIKE - = do { let charlike_lbl = mkRtsGcPtrLabel (sLit "stg_CHARLIKE_closure") + = do { let charlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_CHARLIKE_closure") offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize + 1) -- CHARLIKE closures consist of a header and one word payload charlike_amode = CmmLit (cmmLabelOffW charlike_lbl offsetW) ; returnFC (taggedStableIdInfo binder charlike_amode (mkConLFInfo con) con) } + \end{code} Now the general case. diff -ruN ghc-6.12.1/compiler/codeGen/CgExtCode.hs ghc-6.13.20091231/compiler/codeGen/CgExtCode.hs --- ghc-6.12.1/compiler/codeGen/CgExtCode.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/compiler/codeGen/CgExtCode.hs 2009-12-31 10:14:17.000000000 -0800 @@ -0,0 +1,231 @@ +-- | Our extended FCode monad. + +-- We add a mapping from names to CmmExpr, to support local variable names in +-- the concrete C-- code. The unique supply of the underlying FCode monad +-- is used to grab a new unique for each local variable. + +-- In C--, a local variable can be declared anywhere within a proc, +-- and it scopes from the beginning of the proc to the end. Hence, we have +-- to collect declarations as we parse the proc, and feed the environment +-- back in circularly (to avoid a two-pass algorithm). + +module CgExtCode ( + ExtFCode(..), + ExtCode, + Named(..), Env, + + loopDecls, + getEnv, + + newLocal, + newLabel, + newFunctionName, + newImport, + + lookupLabel, + lookupName, + + code, + code2, + nopEC, + stmtEC, + stmtsEC, + getCgStmtsEC, + getCgStmtsEC', + forkLabelledCodeEC +) + +where + +import CgMonad + +import CLabel +import Cmm + +import BasicTypes +import BlockId +import FastString +import Module +import UniqFM +import Unique + + +-- | The environment contains variable definitions or blockids. +data Named + = Var CmmExpr -- ^ Holds CmmLit(CmmLabel ..) which gives the label type, + -- eg, RtsLabel, ForeignLabel, CmmLabel etc. + + | Fun PackageId -- ^ A function name from this package + | Label BlockId -- ^ A blockid of some code or data. + +-- | An environment of named things. +type Env = UniqFM Named + +-- | Local declarations that are in scope during code generation. +type Decls = [(FastString,Named)] + +-- | Does a computation in the FCode monad, with a current environment +-- and a list of local declarations. Returns the resulting list of declarations. +newtype ExtFCode a + = EC { unEC :: Env -> Decls -> FCode (Decls, a) } + +type ExtCode = ExtFCode () + +returnExtFC :: a -> ExtFCode a +returnExtFC a = EC $ \_ s -> return (s, a) + +thenExtFC :: ExtFCode a -> (a -> ExtFCode b) -> ExtFCode b +thenExtFC (EC m) k = EC $ \e s -> do (s',r) <- m e s; unEC (k r) e s' + +instance Monad ExtFCode where + (>>=) = thenExtFC + return = returnExtFC + + +-- | Takes the variable decarations and imports from the monad +-- and makes an environment, which is looped back into the computation. +-- In this way, we can have embedded declarations that scope over the whole +-- procedure, and imports that scope over the entire module. +-- Discards the local declaration contained within decl' +-- +loopDecls :: ExtFCode a -> ExtFCode a +loopDecls (EC fcode) = + EC $ \e globalDecls -> do + (_, a) <- fixC (\ ~(decls, _) -> fcode (addListToUFM e (decls ++ globalDecls)) globalDecls) + return (globalDecls, a) + + +-- | Get the current environment from the monad. +getEnv :: ExtFCode Env +getEnv = EC $ \e s -> return (s, e) + + +-- | Add a new variable to the list of local declarations. +-- The CmmExpr says where the value is stored. +addVarDecl :: FastString -> CmmExpr -> ExtCode +addVarDecl var expr + = EC $ \_ s -> return ((var, Var expr):s, ()) + +-- | Add a new label to the list of local declarations. +addLabel :: FastString -> BlockId -> ExtCode +addLabel name block_id + = EC $ \_ s -> return ((name, Label block_id):s, ()) + + +-- | Create a fresh local variable of a given type. +newLocal + :: CmmType -- ^ data type + -> FastString -- ^ name of variable + -> ExtFCode LocalReg -- ^ register holding the value + +newLocal ty name = do + u <- code newUnique + let reg = LocalReg u ty + addVarDecl name (CmmReg (CmmLocal reg)) + return reg + + +-- | Allocate a fresh label. +newLabel :: FastString -> ExtFCode BlockId +newLabel name = do + u <- code newUnique + addLabel name (BlockId u) + return (BlockId u) + + +-- | Add add a local function to the environment. +newFunctionName + :: FastString -- ^ name of the function + -> PackageId -- ^ package of the current module + -> ExtCode + +newFunctionName name pkg + = EC $ \_ s -> return ((name, Fun pkg):s, ()) + + +-- | Add an imported foreign label to the list of local declarations. +-- If this is done at the start of the module the declaration will scope +-- over the whole module. +-- CLabel's labelDynamic classifies these labels as dynamic, hence the +-- code generator emits PIC code for them. +newImport :: (Maybe PackageId, FastString) -> ExtFCode () +newImport (Nothing, name) + = addVarDecl name (CmmLit (CmmLabel (mkForeignLabel name Nothing True IsFunction))) + +newImport (Just pkg, name) + = addVarDecl name (CmmLit (CmmLabel (mkCmmCodeLabel pkg name))) + +-- | Lookup the BlockId bound to the label with this name. +-- If one hasn't been bound yet, create a fresh one based on the +-- Unique of the name. +lookupLabel :: FastString -> ExtFCode BlockId +lookupLabel name = do + env <- getEnv + return $ + case lookupUFM env name of + Just (Label l) -> l + _other -> BlockId (newTagUnique (getUnique name) 'L') + + +-- | Lookup the location of a named variable. +-- Unknown names are treated as if they had been 'import'ed from the runtime system. +-- This saves us a lot of bother in the RTS sources, at the expense of +-- deferring some errors to link time. +lookupName :: FastString -> ExtFCode CmmExpr +lookupName name = do + env <- getEnv + return $ + case lookupUFM env name of + Just (Var e) -> e + Just (Fun pkg) -> CmmLit (CmmLabel (mkCmmCodeLabel pkg name)) + _other -> CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId name)) + + +-- | Lift an FCode computation into the ExtFCode monad +code :: FCode a -> ExtFCode a +code fc = EC $ \_ s -> do + r <- fc + return (s, r) + + +code2 :: (FCode (Decls,b) -> FCode ((Decls,b),c)) -> ExtFCode b -> ExtFCode c +code2 f (EC ec) + = EC $ \e s -> do + ((s', _),c) <- f (ec e s) + return (s',c) + + +-- | Do nothing in the ExtFCode monad. +nopEC :: ExtFCode () +nopEC = code nopC + + +-- | Accumulate a CmmStmt into the monad state. +stmtEC :: CmmStmt -> ExtFCode () +stmtEC stmt = code (stmtC stmt) + + +-- | Accumulate some CmmStmts into the monad state. +stmtsEC :: [CmmStmt] -> ExtFCode () +stmtsEC stmts = code (stmtsC stmts) + + +-- | Get the generated statements out of the monad state. +getCgStmtsEC :: ExtFCode a -> ExtFCode CgStmts +getCgStmtsEC = code2 getCgStmts' + + +-- | Get the generated statements, and the return value out of the monad state. +getCgStmtsEC' :: ExtFCode a -> ExtFCode (a, CgStmts) +getCgStmtsEC' = code2 (\m -> getCgStmts' m >>= f) + where f ((decl, b), c) = return ((decl, b), (b, c)) + + +-- | Emit a chunk of code outside the instruction stream, +-- and return its block id. +forkLabelledCodeEC :: ExtFCode a -> ExtFCode BlockId +forkLabelledCodeEC ec = do + stmts <- getCgStmtsEC ec + code (forkCgStmts stmts) + + diff -ruN ghc-6.12.1/compiler/codeGen/CgForeignCall.hs ghc-6.13.20091231/compiler/codeGen/CgForeignCall.hs --- ghc-6.12.1/compiler/codeGen/CgForeignCall.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/codeGen/CgForeignCall.hs 2009-12-31 10:14:17.000000000 -0800 @@ -33,6 +33,7 @@ import Constants import StaticFlags import Outputable +import Module import FastString import BasicTypes @@ -144,8 +145,8 @@ emitLoadThreadState suspendThread, resumeThread :: CmmExpr -suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "suspendThread"))) -resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "resumeThread"))) +suspendThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "suspendThread"))) +resumeThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "resumeThread"))) -- we might need to load arguments into temporaries before diff -ruN ghc-6.12.1/compiler/codeGen/CgHeapery.lhs ghc-6.13.20091231/compiler/codeGen/CgHeapery.lhs --- ghc-6.12.1/compiler/codeGen/CgHeapery.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/codeGen/CgHeapery.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -41,6 +41,7 @@ import TyCon import CostCentre import Util +import Module import Constants import Outputable import FastString @@ -346,7 +347,7 @@ ; setRealHp hpHw ; code } where - rts_label PolyAlt = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_unpt_r1"))) + rts_label PolyAlt = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_unpt_r1"))) -- Do *not* enter R1 after a heap check in -- a polymorphic case. It might be a function -- and the entry code for a function (currently) @@ -360,14 +361,14 @@ rts_label (PrimAlt tc) = CmmLit $ CmmLabel $ case primRepToCgRep (tyConPrimRep tc) of - VoidArg -> mkRtsCodeLabel (sLit "stg_gc_noregs") - FloatArg -> mkRtsCodeLabel (sLit "stg_gc_f1") - DoubleArg -> mkRtsCodeLabel (sLit "stg_gc_d1") - LongArg -> mkRtsCodeLabel (sLit "stg_gc_l1") + VoidArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_noregs") + FloatArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_f1") + DoubleArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_d1") + LongArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_l1") -- R1 is boxed but unlifted: - PtrArg -> mkRtsCodeLabel (sLit "stg_gc_unpt_r1") + PtrArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_unpt_r1") -- R1 is unboxed: - NonPtrArg -> mkRtsCodeLabel (sLit "stg_gc_unbx_r1") + NonPtrArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_unbx_r1") rts_label (UbxTupAlt _) = panic "altHeapCheck" \end{code} @@ -405,7 +406,7 @@ assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9 VNonGcPtr)) -- Ho ho ho! (CmmLit (mkWordCLit liveness)) liveness = mkRegLiveness regs ptrs nptrs - rts_label = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_ut"))) + rts_label = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_ut"))) \end{code} @@ -514,7 +515,7 @@ = do_checks' bytes (CmmLit (mkIntCLit 0)) True False noStmts stg_gc_enter1 stg_gc_gen :: CmmExpr -stg_gc_gen = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_gen"))) +stg_gc_gen = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_gen"))) stg_gc_enter1 :: CmmExpr stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1) \end{code} diff -ruN ghc-6.12.1/compiler/codeGen/CgMonad.lhs ghc-6.13.20091231/compiler/codeGen/CgMonad.lhs --- ghc-6.12.1/compiler/codeGen/CgMonad.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/codeGen/CgMonad.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -47,7 +47,7 @@ Sequel(..), -- ToDo: unabstract? -- ideally we wouldn't export these, but some other modules access internal state - getState, setState, getInfoDown, getDynFlags, getThisPackage, + getState, setState, getInfoDown, getDynFlags, getThisPackage, -- more localised access to monad state getStkUsage, setStkUsage, diff -ruN ghc-6.12.1/compiler/codeGen/CgPrimOp.hs ghc-6.13.20091231/compiler/codeGen/CgPrimOp.hs --- ghc-6.12.1/compiler/codeGen/CgPrimOp.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/codeGen/CgPrimOp.hs 2009-12-31 10:14:18.000000000 -0800 @@ -23,6 +23,7 @@ import CmmUtils import PrimOp import SMRep +import Module import Constants import Outputable import FastString @@ -122,7 +123,7 @@ NoC_SRT -- No SRT b/c we do PlayRisky CmmMayReturn where - newspark = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "newSpark"))) + newspark = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark"))) emitPrimOp [res] ReadMutVarOp [mutv] _ = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize gcWord)) @@ -570,9 +571,21 @@ doWritePtrArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> Code doWritePtrArrayOp addr idx val - = do stmtC (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) - mkBasicIndexedWrite arrPtrsHdrSize Nothing bWord addr idx val - + = do mkBasicIndexedWrite arrPtrsHdrSize Nothing bWord addr idx val + stmtC (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) + -- the write barrier. We must write a byte into the mark table: + -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N] + stmtC $ CmmStore ( + cmmOffsetExpr + (cmmOffsetExprW (cmmOffsetB addr arrPtrsHdrSize) + (loadArrPtrsSize addr)) + (CmmMachOp mo_wordUShr [idx, + CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)]) + ) (CmmLit (CmmInt 1 W8)) + +loadArrPtrsSize :: CmmExpr -> CmmExpr +loadArrPtrsSize addr = CmmLoad (cmmOffsetB addr off) bWord + where off = fixedHdrSize*wORD_SIZE + oFFSET_StgMutArrPtrs_ptrs mkBasicIndexedRead :: ByteOff -> Maybe MachOp -> CmmType -> LocalReg -> CmmExpr -> CmmExpr -> Code diff -ruN ghc-6.12.1/compiler/codeGen/CgProf.hs ghc-6.13.20091231/compiler/codeGen/CgProf.hs --- ghc-6.12.1/compiler/codeGen/CgProf.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/codeGen/CgProf.hs 2009-12-31 10:14:17.000000000 -0800 @@ -47,6 +47,7 @@ import StgSyn import StaticFlags import FastString +import Module import Constants -- Lots of field offsets import Outputable @@ -65,7 +66,7 @@ -- Address of current CCS variable, for storing into curCCSAddr :: CmmExpr -curCCSAddr = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CCCS"))) +curCCSAddr = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCCS"))) mkCCostCentre :: CostCentre -> CmmLit mkCCostCentre cc = CmmLabel (mkCCLabel cc) @@ -260,7 +261,7 @@ stmtC $ CmmStore curCCSAddr (costCentreFrom closure) enter_ccs_fun :: CmmExpr -> Code -enter_ccs_fun stack = emitRtsCall (sLit "EnterFunCCS") [CmmHinted stack AddrHint] False +enter_ccs_fun stack = emitRtsCall rtsPackageId (fsLit "EnterFunCCS") [CmmHinted stack AddrHint] False -- ToDo: vols enter_ccs_fsub :: Code @@ -273,7 +274,7 @@ -- entering via a PAP. enteringPAP :: Integer -> Code enteringPAP n - = stmtC (CmmStore (CmmLit (CmmLabel (mkRtsDataLabel (sLit "entering_PAP")))) + = stmtC (CmmStore (CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "entering_PAP")))) (CmmLit (CmmInt n cIntWidth))) ifProfiling :: Code -> Code @@ -389,12 +390,12 @@ cC_LIST, cC_ID :: CmmExpr -cC_LIST = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CC_LIST"))) -cC_ID = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CC_ID"))) +cC_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_LIST"))) +cC_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_ID"))) cCS_LIST, cCS_ID :: CmmExpr -cCS_LIST = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CCS_LIST"))) -cCS_ID = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CCS_ID"))) +cCS_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_LIST"))) +cCS_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_ID"))) -- --------------------------------------------------------------------------- -- Set the current cost centre stack @@ -413,7 +414,8 @@ pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> Code pushCostCentre result ccs cc = emitRtsCallWithResult result AddrHint - (sLit "PushCostCentre") [CmmHinted ccs AddrHint, + rtsPackageId + (fsLit "PushCostCentre") [CmmHinted ccs AddrHint, CmmHinted (CmmLit (mkCCostCentre cc)) AddrHint] False @@ -479,7 +481,7 @@ loadEra :: CmmExpr loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth) - [CmmLoad (mkLblExpr (mkRtsDataLabel $ sLit("era"))) cInt] + [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId $ fsLit("era"))) cInt] ldvWord :: CmmExpr -> CmmExpr -- Takes the address of a closure, and returns diff -ruN ghc-6.12.1/compiler/codeGen/CgTicky.hs ghc-6.13.20091231/compiler/codeGen/CgTicky.hs --- ghc-6.12.1/compiler/codeGen/CgTicky.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/codeGen/CgTicky.hs 2009-12-31 10:14:17.000000000 -0800 @@ -117,19 +117,19 @@ -- Ticky stack frames tickyPushUpdateFrame, tickyUpdateFrameOmitted :: Code -tickyPushUpdateFrame = ifTicky $ bumpTickyCounter (sLit "UPDF_PUSHED_ctr") -tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (sLit "UPDF_OMITTED_ctr") +tickyPushUpdateFrame = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr") +tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr") -- ----------------------------------------------------------------------------- -- Ticky entries tickyEnterDynCon, tickyEnterDynThunk, tickyEnterStaticCon, tickyEnterStaticThunk, tickyEnterViaNode :: Code -tickyEnterDynCon = ifTicky $ bumpTickyCounter (sLit "ENT_DYN_CON_ctr") -tickyEnterDynThunk = ifTicky $ bumpTickyCounter (sLit "ENT_DYN_THK_ctr") -tickyEnterStaticCon = ifTicky $ bumpTickyCounter (sLit "ENT_STATIC_CON_ctr") -tickyEnterStaticThunk = ifTicky $ bumpTickyCounter (sLit "ENT_STATIC_THK_ctr") -tickyEnterViaNode = ifTicky $ bumpTickyCounter (sLit "ENT_VIA_NODE_ctr") +tickyEnterDynCon = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr") +tickyEnterDynThunk = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_THK_ctr") +tickyEnterStaticCon = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr") +tickyEnterStaticThunk = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_THK_ctr") +tickyEnterViaNode = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr") tickyEnterThunk :: ClosureInfo -> Code tickyEnterThunk cl_info @@ -140,15 +140,15 @@ tickyBlackHole updatable = ifTicky (bumpTickyCounter ctr) where - ctr | updatable = sLit "UPD_BH_SINGLE_ENTRY_ctr" - | otherwise = sLit "UPD_BH_UPDATABLE_ctr" + ctr | updatable = fsLit "UPD_BH_SINGLE_ENTRY_ctr" + | otherwise = fsLit "UPD_BH_UPDATABLE_ctr" tickyUpdateBhCaf :: ClosureInfo -> Code tickyUpdateBhCaf cl_info = ifTicky (bumpTickyCounter ctr) where - ctr | closureUpdReqd cl_info = sLit "UPD_CAF_BH_SINGLE_ENTRY_ctr" - | otherwise = sLit "UPD_CAF_BH_UPDATABLE_ctr" + ctr | closureUpdReqd cl_info = fsLit "UPD_CAF_BH_SINGLE_ENTRY_ctr" + | otherwise = fsLit "UPD_CAF_BH_UPDATABLE_ctr" tickyEnterFun :: ClosureInfo -> Code tickyEnterFun cl_info @@ -159,8 +159,8 @@ ; bumpTickyCounter' (cmmLabelOffB fun_ctr_lbl oFFSET_StgEntCounter_entry_count) } where - ctr | isStaticClosure cl_info = sLit "ENT_STATIC_FUN_DIRECT_ctr" - | otherwise = sLit "ENT_DYN_FUN_DIRECT_ctr" + ctr | isStaticClosure cl_info = fsLit "ENT_STATIC_FUN_DIRECT_ctr" + | otherwise = fsLit "ENT_DYN_FUN_DIRECT_ctr" registerTickyCtr :: CLabel -> Code -- Register a ticky counter @@ -183,25 +183,25 @@ , CmmStore (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_registeredp)) (CmmLit (mkIntCLit 1)) ] - ticky_entry_ctrs = mkLblExpr (mkRtsDataLabel (sLit "ticky_entry_ctrs")) + ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs")) tickyReturnOldCon, tickyReturnNewCon :: Arity -> Code tickyReturnOldCon arity - = ifTicky $ do { bumpTickyCounter (sLit "RET_OLD_ctr") - ; bumpHistogram (sLit "RET_OLD_hst") arity } + = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr") + ; bumpHistogram (fsLit "RET_OLD_hst") arity } tickyReturnNewCon arity - = ifTicky $ do { bumpTickyCounter (sLit "RET_NEW_ctr") - ; bumpHistogram (sLit "RET_NEW_hst") arity } + = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr") + ; bumpHistogram (fsLit "RET_NEW_hst") arity } tickyUnboxedTupleReturn :: Int -> Code tickyUnboxedTupleReturn arity - = ifTicky $ do { bumpTickyCounter (sLit "RET_UNBOXED_TUP_ctr") - ; bumpHistogram (sLit "RET_UNBOXED_TUP_hst") arity } + = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr") + ; bumpHistogram (fsLit "RET_UNBOXED_TUP_hst") arity } tickyVectoredReturn :: Int -> Code tickyVectoredReturn family_size - = ifTicky $ do { bumpTickyCounter (sLit "VEC_RETURN_ctr") - ; bumpHistogram (sLit "RET_VEC_RETURN_hst") family_size } + = ifTicky $ do { bumpTickyCounter (fsLit "VEC_RETURN_ctr") + ; bumpHistogram (fsLit "RET_VEC_RETURN_hst") family_size } -- ----------------------------------------------------------------------------- -- Ticky calls @@ -209,10 +209,10 @@ -- Ticks at a *call site*: tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs, tickyUnknownCall :: Code -tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (sLit "KNOWN_CALL_TOO_FEW_ARGS_ctr") -tickyKnownCallExact = ifTicky $ bumpTickyCounter (sLit "KNOWN_CALL_ctr") -tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter (sLit "KNOWN_CALL_EXTRA_ARGS_ctr") -tickyUnknownCall = ifTicky $ bumpTickyCounter (sLit "UNKNOWN_CALL_ctr") +tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr") +tickyKnownCallExact = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_ctr") +tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_EXTRA_ARGS_ctr") +tickyUnknownCall = ifTicky $ bumpTickyCounter (fsLit "UNKNOWN_CALL_ctr") -- Tick for the call pattern at slow call site (i.e. in addition to -- tickyUnknownCall, tickyKnownCallExtraArgs, etc.) @@ -292,9 +292,9 @@ (CmmLit (cmmLabelOffB ticky_ctr oFFSET_StgEntCounter_allocs)) hp, -- Bump ALLOC_HEAP_ctr - addToMemLbl cLongWidth (mkRtsDataLabel $ sLit "ALLOC_HEAP_ctr") 1, + addToMemLbl cLongWidth (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_ctr") 1, -- Bump ALLOC_HEAP_tot - addToMemLbl cLongWidth (mkRtsDataLabel $ sLit "ALLOC_HEAP_tot") hp] } + addToMemLbl cLongWidth (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_tot") hp] } -- ----------------------------------------------------------------------------- -- Ticky utils @@ -308,14 +308,14 @@ addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n -- All the ticky-ticky counters are declared "unsigned long" in C -bumpTickyCounter :: LitString -> Code -bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkRtsDataLabel lbl) 0) +bumpTickyCounter :: FastString -> Code +bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkCmmDataLabel rtsPackageId lbl) 0) bumpTickyCounter' :: CmmLit -> Code -- krc: note that we're incrementing the _entry_count_ field of the ticky counter bumpTickyCounter' lhs = stmtC (addToMemLong (CmmLit lhs) 1) -bumpHistogram :: LitString -> Int -> Code +bumpHistogram :: FastString -> Int -> Code bumpHistogram _lbl _n -- = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLong)) = return () -- TEMP SPJ Apr 07 diff -ruN ghc-6.12.1/compiler/codeGen/CgUtils.hs ghc-6.13.20091231/compiler/codeGen/CgUtils.hs --- ghc-6.12.1/compiler/codeGen/CgUtils.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/codeGen/CgUtils.hs 2009-12-31 10:14:17.000000000 -0800 @@ -67,6 +67,7 @@ import ForeignCall import ClosureInfo import StgSyn (SRT(..)) +import Module import Literal import Digraph import ListSetOps @@ -331,28 +332,39 @@ ; labelC join_id } -emitRtsCall :: LitString -> [CmmHinted CmmExpr] -> Bool -> Code -emitRtsCall fun args safe = emitRtsCall' [] fun args Nothing safe + +-- | Emit code to call a Cmm function. +emitRtsCall + :: PackageId -- ^ package the function is in + -> FastString -- ^ name of function + -> [CmmHinted CmmExpr] -- ^ function args + -> Bool -- ^ whether this is a safe call + -> Code -- ^ cmm code + +emitRtsCall pkg fun args safe = emitRtsCall' [] pkg fun args Nothing safe -- The 'Nothing' says "save all global registers" -emitRtsCallWithVols :: LitString -> [CmmHinted CmmExpr] -> [GlobalReg] -> Bool -> Code -emitRtsCallWithVols fun args vols safe - = emitRtsCall' [] fun args (Just vols) safe - -emitRtsCallWithResult :: LocalReg -> ForeignHint -> LitString - -> [CmmHinted CmmExpr] -> Bool -> Code -emitRtsCallWithResult res hint fun args safe - = emitRtsCall' [CmmHinted res hint] fun args Nothing safe +emitRtsCallWithVols :: PackageId -> FastString -> [CmmHinted CmmExpr] -> [GlobalReg] -> Bool -> Code +emitRtsCallWithVols pkg fun args vols safe + = emitRtsCall' [] pkg fun args (Just vols) safe + +emitRtsCallWithResult + :: LocalReg -> ForeignHint + -> PackageId -> FastString + -> [CmmHinted CmmExpr] -> Bool -> Code +emitRtsCallWithResult res hint pkg fun args safe + = emitRtsCall' [CmmHinted res hint] pkg fun args Nothing safe -- Make a call to an RTS C procedure emitRtsCall' :: [CmmHinted LocalReg] - -> LitString + -> PackageId + -> FastString -> [CmmHinted CmmExpr] -> Maybe [GlobalReg] -> Bool -- True <=> CmmSafe call -> Code -emitRtsCall' res fun args vols safe = do +emitRtsCall' res pkg fun args vols safe = do safety <- if safe then getSRTInfo >>= (return . CmmSafe) else return CmmUnsafe @@ -362,7 +374,7 @@ where (caller_save, caller_load) = callerSaveVolatileRegs vols target = CmmCallee fun_expr CCallConv - fun_expr = mkLblExpr (mkRtsCodeLabel fun) + fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun) ----------------------------------------------------------------------------- -- diff -ruN ghc-6.12.1/compiler/codeGen/StgCmmBind.hs ghc-6.13.20091231/compiler/codeGen/StgCmmBind.hs --- ghc-6.12.1/compiler/codeGen/StgCmmBind.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/codeGen/StgCmmBind.hs 2009-12-31 10:14:17.000000000 -0800 @@ -494,8 +494,8 @@ | otherwise = nopC where - bh_lbl | is_single_entry = mkRtsDataLabel (sLit "stg_SE_BLACKHOLE_info") - | otherwise = mkRtsDataLabel (sLit "stg_BLACKHOLE_info") + bh_lbl | is_single_entry = mkCmmDataLabel rtsPackageId (fsLit "stg_SE_BLACKHOLE_info") + | otherwise = mkCmmDataLabel rtsPackageId (fsLit "stg_BLACKHOLE_info") -- If we wanted to do eager blackholing with slop filling, -- we'd need to do it at the *end* of a basic block, otherwise @@ -605,7 +605,7 @@ -- so that the garbage collector can find them -- This must be done *before* the info table pointer is overwritten, -- because the old info table ptr is needed for reversion - ; emitRtsCallWithVols (sLit "newCAF") [(CmmReg nodeReg,AddrHint)] [node] False + ; emitRtsCallWithVols rtsPackageId (fsLit "newCAF") [(CmmReg nodeReg,AddrHint)] [node] False -- node is live, so save it. -- Overwrite the closure with a (static) indirection diff -ruN ghc-6.12.1/compiler/codeGen/StgCmmCon.hs ghc-6.13.20091231/compiler/codeGen/StgCmmCon.hs --- ghc-6.12.1/compiler/codeGen/StgCmmCon.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/codeGen/StgCmmCon.hs 2009-12-31 10:14:18.000000000 -0800 @@ -30,6 +30,7 @@ import MkZipCfgCmm (CmmAGraph, mkNop) import SMRep import CostCentre +import Module import Constants import DataCon import FastString @@ -38,8 +39,13 @@ import PrelInfo import Outputable import Util ( lengthIs ) + import Data.Char +#if defined(mingw32_TARGET_OS) +import StaticFlags ( opt_PIC ) +#endif + --------------------------------------------------------------- -- Top-level constructors @@ -146,14 +152,21 @@ to be a literal. Reason: @Char@ like closures have an argument type which is guaranteed in range. -Because of this, we use can safely return an addressing mode. -} +Because of this, we use can safely return an addressing mode. + +We don't support this optimisation when compiling into Windows DLLs yet +because they don't support cross package data references well. +-} buildDynCon binder _cc con [arg] | maybeIntLikeCon con +#if defined(mingw32_TARGET_OS) + , not opt_PIC +#endif , StgLitArg (MachInt val) <- arg , val <= fromIntegral mAX_INTLIKE -- Comparisons at type Integer! , val >= fromIntegral mIN_INTLIKE -- ...ditto... - = do { let intlike_lbl = mkRtsGcPtrLabel (sLit "stg_INTLIKE_closure") + = do { let intlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_INTLIKE_closure") val_int = fromIntegral val :: Int offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize + 1) -- INTLIKE closures consist of a header and one word payload @@ -161,12 +174,15 @@ ; return (litIdInfo binder (mkConLFInfo con) intlike_amode, mkNop) } buildDynCon binder _cc con [arg] - | maybeCharLikeCon con + | maybeCharLikeCon con +#if defined(mingw32_TARGET_OS) + , not opt_PIC +#endif , StgLitArg (MachChar val) <- arg , let val_int = ord val :: Int , val_int <= mAX_CHARLIKE , val_int >= mIN_CHARLIKE - = do { let charlike_lbl = mkRtsGcPtrLabel (sLit "stg_CHARLIKE_closure") + = do { let charlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_CHARLIKE_closure") offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize + 1) -- CHARLIKE closures consist of a header and one word payload charlike_amode = cmmLabelOffW charlike_lbl offsetW diff -ruN ghc-6.12.1/compiler/codeGen/StgCmmExpr.hs ghc-6.13.20091231/compiler/codeGen/StgCmmExpr.hs --- ghc-6.12.1/compiler/codeGen/StgCmmExpr.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/codeGen/StgCmmExpr.hs 2009-12-31 10:14:18.000000000 -0800 @@ -36,8 +36,11 @@ import ForeignCall import Id import PrimOp +import SMRep import TyCon +import Type import CostCentre ( CostCentreStack, currentCCS ) +import Control.Monad (when) import Maybes import Util import FastString @@ -280,24 +283,65 @@ = -} + -- Note [ticket #3132]: we might be looking at a case of a lifted Id + -- that was cast to an unlifted type. The Id will always be bottom, + -- but we don't want the code generator to fall over here. If we + -- just emit an assignment here, the assignment will be + -- type-incorrect Cmm. Hence, we emit the usual enter/return code, + -- (and because bottom must be untagged, it will be entered and the + -- program will crash). + -- The Sequel is a type-correct assignment, albeit bogus. + -- The (dead) continuation loops; it would be better to invoke some kind + -- of panic function here. + -- + -- However, we also want to allow an assignment to be generated + -- in the case when the types are compatible, because this allows + -- some slightly-dodgy but occasionally-useful casts to be used, + -- such as in RtClosureInspect where we cast an HValue to a MutVar# + -- so we can print out the contents of the MutVar#. If we generate + -- code that enters the HValue, then we'll get a runtime panic, because + -- the HValue really is a MutVar#. The types are compatible though, + -- so we can just generate an assignment. +cgCase (StgApp v []) bndr _ alt_type@(PrimAlt _) alts + | isUnLiftedType (idType v) + || reps_compatible + = -- assignment suffices for unlifted types + do { when (not reps_compatible) $ + panic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?" + ; v_info <- getCgIdInfo v + ; emit (mkAssign (CmmLocal (idToReg (NonVoid bndr))) (idInfoToAmode v_info)) + ; _ <- bindArgsToRegs [NonVoid bndr] + ; cgAlts NoGcInAlts (NonVoid bndr) alt_type alts } + where + reps_compatible = idCgRep v == idCgRep bndr + +cgCase scrut@(StgApp v []) _ _ (PrimAlt _) _ + = -- fail at run-time, not compile-time + do { mb_cc <- maybeSaveCostCentre True + ; withSequel (AssignTo [idToReg (NonVoid v)] False) (cgExpr scrut) + ; restoreCurrentCostCentre mb_cc + ; emit $ mkComment $ mkFastString "should be unreachable code" + ; emit $ withFreshLabel "l" (\l -> mkLabel l <*> mkBranch l)} + cgCase scrut bndr srt alt_type alts - = do { up_hp_usg <- getVirtHp -- Upstream heap usage - ; let ret_bndrs = chooseReturnBndrs bndr alt_type alts - alt_regs = map idToReg ret_bndrs - simple_scrut = isSimpleScrut scrut alt_type - gcInAlts | not simple_scrut = True - | isSingleton alts = False - | up_hp_usg > 0 = False - | otherwise = True - gc_plan = if gcInAlts then GcInAlts alt_regs srt else NoGcInAlts - - ; mb_cc <- maybeSaveCostCentre simple_scrut - ; withSequel (AssignTo alt_regs gcInAlts) (cgExpr scrut) - ; restoreCurrentCostCentre mb_cc + = -- the general case + do { up_hp_usg <- getVirtHp -- Upstream heap usage + ; let ret_bndrs = chooseReturnBndrs bndr alt_type alts + alt_regs = map idToReg ret_bndrs + simple_scrut = isSimpleScrut scrut alt_type + gcInAlts | not simple_scrut = True + | isSingleton alts = False + | up_hp_usg > 0 = False + | otherwise = True + gc_plan = if gcInAlts then GcInAlts alt_regs srt else NoGcInAlts + + ; mb_cc <- maybeSaveCostCentre simple_scrut + ; withSequel (AssignTo alt_regs gcInAlts) (cgExpr scrut) + ; restoreCurrentCostCentre mb_cc -- JD: We need Note: [Better Alt Heap Checks] - ; _ <- bindArgsToRegs ret_bndrs - ; cgAlts gc_plan (NonVoid bndr) alt_type alts } + ; _ <- bindArgsToRegs ret_bndrs + ; cgAlts gc_plan (NonVoid bndr) alt_type alts } ----------------- maybeSaveCostCentre :: Bool -> FCode (Maybe LocalReg) diff -ruN ghc-6.12.1/compiler/codeGen/StgCmmForeign.hs ghc-6.13.20091231/compiler/codeGen/StgCmmForeign.hs --- ghc-6.12.1/compiler/codeGen/StgCmmForeign.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/codeGen/StgCmmForeign.hs 2009-12-31 10:14:17.000000000 -0800 @@ -97,9 +97,9 @@ fc = ForeignConvention CCallConv arg_hints result_hints -emitPrimCall :: CmmFormal -> CallishMachOp -> CmmActuals -> FCode () +emitPrimCall :: CmmFormals -> CallishMachOp -> CmmActuals -> FCode () emitPrimCall res op args - = emitForeignCall PlayRisky [res] (PrimTarget op) args NoC_SRT CmmMayReturn + = emitForeignCall PlayRisky res (PrimTarget op) args NoC_SRT CmmMayReturn -- alternative entry point, used by CmmParse emitForeignCall diff -ruN ghc-6.12.1/compiler/codeGen/StgCmmHeap.hs ghc-6.13.20091231/compiler/codeGen/StgCmmHeap.hs --- ghc-6.12.1/compiler/codeGen/StgCmmHeap.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/codeGen/StgCmmHeap.hs 2009-12-31 10:14:17.000000000 -0800 @@ -40,7 +40,8 @@ import TyCon import CostCentre import Outputable -import FastString( LitString, mkFastString, sLit ) +import Module +import FastString( mkFastString, FastString, fsLit ) import Constants @@ -349,11 +350,12 @@ gc_call updfr_sz | arity == 0 = mkJumpGC (CmmReg (CmmGlobal GCEnter1)) arg_exprs updfr_sz | otherwise = case gc_lbl args' of - Just lbl -> mkJumpGC (CmmLit (CmmLabel (mkRtsCodeLabel lbl))) - arg_exprs updfr_sz + Just _lbl -> panic "StgCmmHeap.entryHeapCheck: gc_lbl not finished" + -- mkJumpGC (CmmLit (CmmLabel (mkRtsCodeLabel lbl))) + -- arg_exprs updfr_sz Nothing -> mkCall generic_gc (GC, GC) [] [] updfr_sz - gc_lbl :: [LocalReg] -> Maybe LitString + gc_lbl :: [LocalReg] -> Maybe FastString {- gc_lbl [reg] | isGcPtrType ty = Just (sLit "stg_gc_unpt_r1") -- "stg_gc_fun_1p" @@ -372,7 +374,7 @@ gc_lbl regs = gc_lbl_ptrs (map (isGcPtrType . localRegType) regs) - gc_lbl_ptrs :: [Bool] -> Maybe LitString + gc_lbl_ptrs :: [Bool] -> Maybe FastString -- JD: TEMPORARY -- UNTIL THOSE FUNCTIONS EXIST... --gc_lbl_ptrs [True,True] = Just (sLit "stg_gc_fun_2p") --gc_lbl_ptrs [True,True,True] = Just (sLit "stg_gc_fun_3p") @@ -387,9 +389,10 @@ gc_call updfr_sz | null regs = mkCall generic_gc (GC, GC) [] [] updfr_sz - | Just gc_lbl <- rts_label regs -- Canned call - = mkCall (CmmLit (CmmLabel (mkRtsCodeLabel gc_lbl))) (GC, GC) - regs (map (CmmReg . CmmLocal) regs) updfr_sz + | Just _gc_lbl <- rts_label regs -- Canned call + = panic "StgCmmHeap.altHeapCheck: rts_label not finished" + -- mkCall (CmmLit (CmmLabel (mkRtsCodeLabel gc_lbl))) (GC, GC) + -- regs (map (CmmReg . CmmLocal) regs) updfr_sz | otherwise -- No canned call, and non-empty live vars = mkCall generic_gc (GC, GC) [] [] updfr_sz @@ -413,7 +416,7 @@ generic_gc :: CmmExpr -- The generic GC procedure; no params, no resuls -generic_gc = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_noregs"))) +generic_gc = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_noregs"))) -- JD: TEMPORARY -- UNTIL THOSE FUNCTIONS EXIST... -- generic_gc = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_fun"))) diff -ruN ghc-6.12.1/compiler/codeGen/StgCmm.hs ghc-6.13.20091231/compiler/codeGen/StgCmm.hs --- ghc-6.12.1/compiler/codeGen/StgCmm.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/codeGen/StgCmm.hs 2009-12-31 10:14:17.000000000 -0800 @@ -329,7 +329,8 @@ (dyn_cl_info, arg_things) = layOutDynConstr data_con arg_reps emit_info cl_info ticky_code - = emitClosureAndInfoTable cl_info [] $ mk_code ticky_code + = emitClosureAndInfoTable cl_info NativeDirectCall [] + $ mk_code ticky_code mk_code ticky_code = -- NB: We don't set CC when entering data (WDP 94/06) diff -ruN ghc-6.12.1/compiler/codeGen/StgCmmLayout.hs ghc-6.13.20091231/compiler/codeGen/StgCmmLayout.hs --- ghc-6.12.1/compiler/codeGen/StgCmmLayout.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/codeGen/StgCmmLayout.hs 2009-12-31 10:14:17.000000000 -0800 @@ -63,7 +63,7 @@ import Util import Data.List import Outputable -import FastString ( mkFastString, LitString, sLit ) +import FastString ( mkFastString, FastString, fsLit ) ------------------------------------------------------------------------ -- Call and return sequences @@ -180,29 +180,29 @@ slow_call fun args reps = do call <- getCode $ direct_call "slow_call" (mkRtsApFastLabel rts_fun) arity args reps emit $ mkComment $ mkFastString ("slow_call for " ++ showSDoc (ppr fun) ++ - " with pat " ++ showSDoc (ptext rts_fun)) + " with pat " ++ showSDoc (ftext rts_fun)) emit (mkAssign nodeReg fun <*> call) where (rts_fun, arity) = slowCallPattern reps -- These cases were found to cover about 99% of all slow calls: -slowCallPattern :: [LRep] -> (LitString, Arity) +slowCallPattern :: [LRep] -> (FastString, Arity) -- Returns the generic apply function and arity -slowCallPattern (P: P: P: P: P: P: _) = (sLit "stg_ap_pppppp", 6) -slowCallPattern (P: P: P: P: P: _) = (sLit "stg_ap_ppppp", 5) -slowCallPattern (P: P: P: P: _) = (sLit "stg_ap_pppp", 4) -slowCallPattern (P: P: P: V: _) = (sLit "stg_ap_pppv", 4) -slowCallPattern (P: P: P: _) = (sLit "stg_ap_ppp", 3) -slowCallPattern (P: P: V: _) = (sLit "stg_ap_ppv", 3) -slowCallPattern (P: P: _) = (sLit "stg_ap_pp", 2) -slowCallPattern (P: V: _) = (sLit "stg_ap_pv", 2) -slowCallPattern (P: _) = (sLit "stg_ap_p", 1) -slowCallPattern (V: _) = (sLit "stg_ap_v", 1) -slowCallPattern (N: _) = (sLit "stg_ap_n", 1) -slowCallPattern (F: _) = (sLit "stg_ap_f", 1) -slowCallPattern (D: _) = (sLit "stg_ap_d", 1) -slowCallPattern (L: _) = (sLit "stg_ap_l", 1) -slowCallPattern [] = (sLit "stg_ap_0", 0) +slowCallPattern (P: P: P: P: P: P: _) = (fsLit "stg_ap_pppppp", 6) +slowCallPattern (P: P: P: P: P: _) = (fsLit "stg_ap_ppppp", 5) +slowCallPattern (P: P: P: P: _) = (fsLit "stg_ap_pppp", 4) +slowCallPattern (P: P: P: V: _) = (fsLit "stg_ap_pppv", 4) +slowCallPattern (P: P: P: _) = (fsLit "stg_ap_ppp", 3) +slowCallPattern (P: P: V: _) = (fsLit "stg_ap_ppv", 3) +slowCallPattern (P: P: _) = (fsLit "stg_ap_pp", 2) +slowCallPattern (P: V: _) = (fsLit "stg_ap_pv", 2) +slowCallPattern (P: _) = (fsLit "stg_ap_p", 1) +slowCallPattern (V: _) = (fsLit "stg_ap_v", 1) +slowCallPattern (N: _) = (fsLit "stg_ap_n", 1) +slowCallPattern (F: _) = (fsLit "stg_ap_f", 1) +slowCallPattern (D: _) = (fsLit "stg_ap_d", 1) +slowCallPattern (L: _) = (fsLit "stg_ap_l", 1) +slowCallPattern [] = (fsLit "stg_ap_0", 0) ------------------------------------------------------------------------- @@ -474,17 +474,18 @@ ; let node_points = nodeMustPointToIt lf_info ; arg_regs <- bindArgsToRegs args ; let args' = if node_points then (node : arg_regs) else arg_regs - ; emitClosureAndInfoTable cl_info args' $ body (node, arg_regs) + conv = if nodeMustPointToIt lf_info + then NativeNodeCall else NativeDirectCall + ; emitClosureAndInfoTable cl_info conv args' $ body (node, arg_regs) } -- Data constructors need closures, but not with all the argument handling -- needed for functions. The shared part goes here. -emitClosureAndInfoTable :: ClosureInfo -> [LocalReg] -> FCode () -> FCode () -emitClosureAndInfoTable cl_info args body +emitClosureAndInfoTable :: + ClosureInfo -> Convention -> [LocalReg] -> FCode () -> FCode () +emitClosureAndInfoTable cl_info conv args body = do { info <- mkCmmInfo cl_info ; blks <- getCode body - ; let conv = if nodeMustPointToIt (closureLFInfo cl_info) then NativeNodeCall - else NativeDirectCall ; emitProcWithConvention conv info (infoLblToEntryLbl info_lbl) args blks } where diff -ruN ghc-6.12.1/compiler/codeGen/StgCmmPrim.hs ghc-6.13.20091231/compiler/codeGen/StgCmmPrim.hs --- ghc-6.12.1/compiler/codeGen/StgCmmPrim.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/codeGen/StgCmmPrim.hs 2009-12-31 10:14:18.000000000 -0800 @@ -28,6 +28,7 @@ import PrimOp import SMRep import Constants +import Module import FastString import Outputable @@ -201,7 +202,7 @@ -- later, we might want to inline it. emitCCall [(res,NoHint)] - (CmmLit (CmmLabel (mkRtsCodeLabel (sLit "newSpark")))) + (CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark")))) [(CmmReg (CmmGlobal BaseReg), AddrHint), (arg,AddrHint)] emitPrimOp [res] ReadMutVarOp [mutv] @@ -231,8 +232,8 @@ -- #define touchzh(o) /* nothing */ -emitPrimOp [] TouchOp [_arg] - = nopC +emitPrimOp res@[] TouchOp args@[_arg] + = do emitPrimCall res MO_Touch args -- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a) emitPrimOp [res] ByteArrayContents_Char [arg] @@ -412,9 +413,9 @@ = emit (mkAssign (CmmLocal res) $ CmmMachOp (mop rep wordWidth) [CmmMachOp (mop wordWidth rep) [arg]]) -emitPrimOp [res] op args +emitPrimOp r@[res] op args | Just prim <- callishOp op - = do emitPrimCall res prim args + = do emitPrimCall r prim args | Just mop <- translateOp op = let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) in @@ -635,8 +636,21 @@ doWritePtrArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () doWritePtrArrayOp addr idx val - = do emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) - mkBasicIndexedWrite arrPtrsHdrSize Nothing addr idx val + = do mkBasicIndexedWrite arrPtrsHdrSize Nothing addr idx val + emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) + -- the write barrier. We must write a byte into the mark table: + -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N] + emit $ mkStore ( + cmmOffsetExpr + (cmmOffsetExprW (cmmOffsetB addr arrPtrsHdrSize) + (loadArrPtrsSize addr)) + (CmmMachOp mo_wordUShr [idx, + CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)]) + ) (CmmLit (CmmInt 1 W8)) + +loadArrPtrsSize :: CmmExpr -> CmmExpr +loadArrPtrsSize addr = CmmLoad (cmmOffsetB addr off) bWord + where off = fixedHdrSize*wORD_SIZE + oFFSET_StgMutArrPtrs_ptrs mkBasicIndexedRead :: ByteOff -> Maybe MachOp -> CmmType -> LocalReg -> CmmExpr -> CmmExpr -> FCode () diff -ruN ghc-6.12.1/compiler/codeGen/StgCmmProf.hs ghc-6.13.20091231/compiler/codeGen/StgCmmProf.hs --- ghc-6.12.1/compiler/codeGen/StgCmmProf.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/codeGen/StgCmmProf.hs 2009-12-31 10:14:17.000000000 -0800 @@ -49,6 +49,7 @@ import StgSyn import StaticFlags import FastString +import Module import Constants -- Lots of field offsets import Outputable @@ -73,7 +74,7 @@ -- Address of current CCS variable, for storing into curCCSAddr :: CmmExpr -curCCSAddr = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CCCS"))) +curCCSAddr = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCCS"))) mkCCostCentre :: CostCentre -> CmmLit mkCCostCentre cc = CmmLabel (mkCCLabel cc) @@ -315,7 +316,7 @@ emit $ mkStore curCCSAddr (costCentreFrom closure) enter_ccs_fun :: CmmExpr -> FCode () -enter_ccs_fun stack = emitRtsCall (sLit "EnterFunCCS") [(stack,AddrHint)] False +enter_ccs_fun stack = emitRtsCall rtsPackageId (fsLit "EnterFunCCS") [(stack,AddrHint)] False -- ToDo: vols enter_ccs_fsub :: FCode () @@ -328,7 +329,7 @@ -- entering via a PAP. enteringPAP :: Integer -> FCode () enteringPAP n - = emit (mkStore (CmmLit (CmmLabel (mkRtsDataLabel (sLit "entering_PAP")))) + = emit (mkStore (CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "entering_PAP")))) (CmmLit (CmmInt n cIntWidth))) ifProfiling :: FCode () -> FCode () @@ -447,12 +448,12 @@ cC_LIST, cC_ID :: CmmExpr -cC_LIST = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CC_LIST"))) -cC_ID = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CC_ID"))) +cC_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_LIST"))) +cC_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_ID"))) cCS_LIST, cCS_ID :: CmmExpr -cCS_LIST = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CCS_LIST"))) -cCS_ID = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CCS_ID"))) +cCS_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_LIST"))) +cCS_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_ID"))) -- --------------------------------------------------------------------------- -- Set the current cost centre stack @@ -471,7 +472,8 @@ pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode () pushCostCentre result ccs cc = emitRtsCallWithResult result AddrHint - (sLit "PushCostCentre") [(ccs,AddrHint), + rtsPackageId + (fsLit "PushCostCentre") [(ccs,AddrHint), (CmmLit (mkCCostCentre cc), AddrHint)] False @@ -538,7 +540,7 @@ loadEra :: CmmExpr loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth) - [CmmLoad (mkLblExpr (mkRtsDataLabel (sLit "era"))) cInt] + [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "era"))) cInt] ldvWord :: CmmExpr -> CmmExpr -- Takes the address of a closure, and returns diff -ruN ghc-6.12.1/compiler/codeGen/StgCmmTicky.hs ghc-6.13.20091231/compiler/codeGen/StgCmmTicky.hs --- ghc-6.12.1/compiler/codeGen/StgCmmTicky.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/codeGen/StgCmmTicky.hs 2009-12-31 10:14:17.000000000 -0800 @@ -121,19 +121,19 @@ -- Ticky stack frames tickyPushUpdateFrame, tickyUpdateFrameOmitted :: FCode () -tickyPushUpdateFrame = ifTicky $ bumpTickyCounter (sLit "UPDF_PUSHED_ctr") -tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (sLit "UPDF_OMITTED_ctr") +tickyPushUpdateFrame = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr") +tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr") -- ----------------------------------------------------------------------------- -- Ticky entries tickyEnterDynCon, tickyEnterDynThunk, tickyEnterStaticCon, tickyEnterStaticThunk, tickyEnterViaNode :: FCode () -tickyEnterDynCon = ifTicky $ bumpTickyCounter (sLit "ENT_DYN_CON_ctr") -tickyEnterDynThunk = ifTicky $ bumpTickyCounter (sLit "ENT_DYN_THK_ctr") -tickyEnterStaticCon = ifTicky $ bumpTickyCounter (sLit "ENT_STATIC_CON_ctr") -tickyEnterStaticThunk = ifTicky $ bumpTickyCounter (sLit "ENT_STATIC_THK_ctr") -tickyEnterViaNode = ifTicky $ bumpTickyCounter (sLit "ENT_VIA_NODE_ctr") +tickyEnterDynCon = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr") +tickyEnterDynThunk = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_THK_ctr") +tickyEnterStaticCon = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr") +tickyEnterStaticThunk = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_THK_ctr") +tickyEnterViaNode = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr") tickyEnterThunk :: ClosureInfo -> FCode () tickyEnterThunk cl_info @@ -144,15 +144,15 @@ tickyBlackHole updatable = ifTicky (bumpTickyCounter ctr) where - ctr | updatable = (sLit "UPD_BH_SINGLE_ENTRY_ctr") - | otherwise = (sLit "UPD_BH_UPDATABLE_ctr") + ctr | updatable = (fsLit "UPD_BH_SINGLE_ENTRY_ctr") + | otherwise = (fsLit "UPD_BH_UPDATABLE_ctr") tickyUpdateBhCaf :: ClosureInfo -> FCode () tickyUpdateBhCaf cl_info = ifTicky (bumpTickyCounter ctr) where - ctr | closureUpdReqd cl_info = (sLit "UPD_CAF_BH_SINGLE_ENTRY_ctr") - | otherwise = (sLit "UPD_CAF_BH_UPDATABLE_ctr") + ctr | closureUpdReqd cl_info = (fsLit "UPD_CAF_BH_SINGLE_ENTRY_ctr") + | otherwise = (fsLit "UPD_CAF_BH_UPDATABLE_ctr") tickyEnterFun :: ClosureInfo -> FCode () tickyEnterFun cl_info @@ -163,8 +163,8 @@ ; bumpTickyCounter' (cmmLabelOffB fun_ctr_lbl oFFSET_StgEntCounter_entry_count) } where - ctr | isStaticClosure cl_info = (sLit "ENT_STATIC_FUN_DIRECT_ctr") - | otherwise = (sLit "ENT_DYN_FUN_DIRECT_ctr") + ctr | isStaticClosure cl_info = (fsLit "ENT_STATIC_FUN_DIRECT_ctr") + | otherwise = (fsLit "ENT_DYN_FUN_DIRECT_ctr") registerTickyCtr :: CLabel -> FCode () -- Register a ticky counter @@ -187,25 +187,25 @@ , mkStore (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_registeredp)) (CmmLit (mkIntCLit 1)) ] - ticky_entry_ctrs = mkLblExpr (mkRtsDataLabel (sLit "ticky_entry_ctrs")) + ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs")) tickyReturnOldCon, tickyReturnNewCon :: Arity -> FCode () tickyReturnOldCon arity - = ifTicky $ do { bumpTickyCounter (sLit "RET_OLD_ctr") - ; bumpHistogram (sLit "RET_OLD_hst") arity } + = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr") + ; bumpHistogram (fsLit "RET_OLD_hst") arity } tickyReturnNewCon arity - = ifTicky $ do { bumpTickyCounter (sLit "RET_NEW_ctr") - ; bumpHistogram (sLit "RET_NEW_hst") arity } + = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr") + ; bumpHistogram (fsLit "RET_NEW_hst") arity } tickyUnboxedTupleReturn :: Int -> FCode () tickyUnboxedTupleReturn arity - = ifTicky $ do { bumpTickyCounter (sLit "RET_UNBOXED_TUP_ctr") - ; bumpHistogram (sLit "RET_UNBOXED_TUP_hst") arity } + = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr") + ; bumpHistogram (fsLit "RET_UNBOXED_TUP_hst") arity } tickyVectoredReturn :: Int -> FCode () tickyVectoredReturn family_size - = ifTicky $ do { bumpTickyCounter (sLit "VEC_RETURN_ctr") - ; bumpHistogram (sLit "RET_VEC_RETURN_hst") family_size } + = ifTicky $ do { bumpTickyCounter (fsLit "VEC_RETURN_ctr") + ; bumpHistogram (fsLit "RET_VEC_RETURN_hst") family_size } -- ----------------------------------------------------------------------------- -- Ticky calls @@ -218,13 +218,16 @@ tickySlowCallPat (map argPrimRep (drop arity args)) tickyKnownCallTooFewArgs :: FCode () -tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (sLit "KNOWN_CALL_TOO_FEW_ARGS_ctr") +tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr") + tickyKnownCallExact :: FCode () -tickyKnownCallExact = ifTicky $ bumpTickyCounter (sLit "KNOWN_CALL_ctr") +tickyKnownCallExact = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_ctr") + tickyKnownCallExtraArgs :: FCode () -tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter (sLit "KNOWN_CALL_EXTRA_ARGS_ctr") +tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_EXTRA_ARGS_ctr") + tickyUnknownCall :: FCode () -tickyUnknownCall = ifTicky $ bumpTickyCounter (sLit "UNKNOWN_CALL_ctr") +tickyUnknownCall = ifTicky $ bumpTickyCounter (fsLit "UNKNOWN_CALL_ctr") -- Tick for the call pattern at slow call site (i.e. in addition to -- tickyUnknownCall, tickyKnownCallExtraArgs, etc.) @@ -314,9 +317,9 @@ (CmmLit (cmmLabelOffB ticky_ctr oFFSET_StgEntCounter_allocs)) hp, -- Bump ALLOC_HEAP_ctr - addToMemLbl cLong (mkRtsDataLabel (sLit "ALLOC_HEAP_ctr")) 1, + addToMemLbl cLong (mkCmmDataLabel rtsPackageId (fsLit "ALLOC_HEAP_ctr")) 1, -- Bump ALLOC_HEAP_tot - addToMemLbl cLong (mkRtsDataLabel (sLit "ALLOC_HEAP_tot")) hp] } + addToMemLbl cLong (mkCmmDataLabel rtsPackageId (fsLit "ALLOC_HEAP_tot")) hp] } -- ----------------------------------------------------------------------------- -- Ticky utils @@ -327,14 +330,14 @@ else nopC -- All the ticky-ticky counters are declared "unsigned long" in C -bumpTickyCounter :: LitString -> FCode () -bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkRtsDataLabel lbl) 0) +bumpTickyCounter :: FastString -> FCode () +bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkCmmDataLabel rtsPackageId lbl) 0) bumpTickyCounter' :: CmmLit -> FCode () -- krc: note that we're incrementing the _entry_count_ field of the ticky counter bumpTickyCounter' lhs = emit (addToMem cLong (CmmLit lhs) 1) -bumpHistogram :: LitString -> Int -> FCode () +bumpHistogram :: FastString -> Int -> FCode () bumpHistogram _lbl _n -- = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLongWidth)) = return () -- TEMP SPJ Apr 07 diff -ruN ghc-6.12.1/compiler/codeGen/StgCmmUtils.hs ghc-6.13.20091231/compiler/codeGen/StgCmmUtils.hs --- ghc-6.12.1/compiler/codeGen/StgCmmUtils.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/codeGen/StgCmmUtils.hs 2009-12-31 10:14:17.000000000 -0800 @@ -62,6 +62,7 @@ import Constants import SMRep import StgSyn ( SRT(..) ) +import Module import Literal import Digraph import ListSetOps @@ -283,28 +284,29 @@ -- ------------------------------------------------------------------------- -emitRtsCall :: LitString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () -emitRtsCall fun args safe = emitRtsCall' [] fun args Nothing safe +emitRtsCall :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () +emitRtsCall pkg fun args safe = emitRtsCall' [] pkg fun args Nothing safe -- The 'Nothing' says "save all global registers" -emitRtsCallWithVols :: LitString -> [(CmmExpr,ForeignHint)] -> [GlobalReg] -> Bool -> FCode () -emitRtsCallWithVols fun args vols safe - = emitRtsCall' [] fun args (Just vols) safe +emitRtsCallWithVols :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> [GlobalReg] -> Bool -> FCode () +emitRtsCallWithVols pkg fun args vols safe + = emitRtsCall' [] pkg fun args (Just vols) safe -emitRtsCallWithResult :: LocalReg -> ForeignHint -> LitString +emitRtsCallWithResult :: LocalReg -> ForeignHint -> PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () -emitRtsCallWithResult res hint fun args safe - = emitRtsCall' [(res,hint)] fun args Nothing safe +emitRtsCallWithResult res hint pkg fun args safe + = emitRtsCall' [(res,hint)] pkg fun args Nothing safe -- Make a call to an RTS C procedure emitRtsCall' :: [(LocalReg,ForeignHint)] - -> LitString + -> PackageId + -> FastString -> [(CmmExpr,ForeignHint)] -> Maybe [GlobalReg] -> Bool -- True <=> CmmSafe call -> FCode () -emitRtsCall' res fun args _vols safe +emitRtsCall' res pkg fun args _vols safe = --error "emitRtsCall'" do { updfr_off <- getUpdFrameOff ; emit caller_save @@ -320,7 +322,7 @@ (args', arg_hints) = unzip args (res', res_hints) = unzip res (caller_save, caller_load) = callerSaveVolatileRegs - fun_expr = mkLblExpr (mkRtsCodeLabel fun) + fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun) ----------------------------------------------------------------------------- @@ -498,7 +500,7 @@ newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint]) -- Choose suitable local regs to use for the components -- of an unboxed tuple that we are about to return to --- the Sequel. If the Sequel is a joint point, using the +-- the Sequel. If the Sequel is a join point, using the -- regs it wants will save later assignments. newUnboxedTupleRegs res_ty = ASSERT( isUnboxedTupleType res_ty ) diff -ruN ghc-6.12.1/compiler/coreSyn/CoreArity.lhs ghc-6.13.20091231/compiler/coreSyn/CoreArity.lhs --- ghc-6.12.1/compiler/coreSyn/CoreArity.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/coreSyn/CoreArity.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -8,7 +8,7 @@ \begin{code} -- | Arit and eta expansion module CoreArity ( - manifestArity, exprArity, + manifestArity, exprArity, exprBotStrictness_maybe, exprEtaExpandArity, etaExpand ) where @@ -17,7 +17,7 @@ import CoreSyn import CoreFVs import CoreUtils -import NewDemand +import Demand import TyCon ( isRecursiveTyCon ) import qualified CoreSubst import CoreSubst ( Subst, substBndr, substBndrs, substExpr @@ -138,6 +138,15 @@ = applyStateHack e (arityType dicts_cheap e) where dicts_cheap = dopt Opt_DictsCheap dflags + +exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, StrictSig) +-- A cheap and cheerful function that identifies bottoming functions +-- and gives them a suitable strictness signatures. It's used during +-- float-out +exprBotStrictness_maybe e + = case arityType False e of + AT _ ATop -> Nothing + AT a ABot -> Just (a, mkStrictSig (mkTopDmdType (replicate a topDmd) BotRes)) \end{code} Note [Definition of arity] @@ -273,7 +282,7 @@ 1 + go res (arity-1) else WARN( arity > 0, ppr arity ) 0 -} - | otherwise = WARN( arity > 0, ppr arity ) 0 + | otherwise = WARN( arity > 0, ppr arity <+> ppr ty) 0 \end{code} Note [State hack and bottoming functions] @@ -352,7 +361,7 @@ --------------------------- arityType :: Bool -> CoreExpr -> ArityType arityType _ (Var v) - | Just strict_sig <- idNewStrictness_maybe v + | Just strict_sig <- idStrictness_maybe v , (ds, res) <- splitStrictSig strict_sig , isBotRes res = AT (length ds) ABot -- Function diverges @@ -430,6 +439,13 @@ a subsequent clean-up phase of the Simplifier to de-crapify the result, means you can't really use it in CorePrep, which is painful. +Note [Eta expansion and SCCs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note that SCCs are not treated specially by etaExpand. If we have + etaExpand 2 (\x -> scc "foo" e) + = (\xy -> (scc "foo" e) y) +So the costs of evaluating 'e' (not 'e y') are attributed to "foo" + \begin{code} -- | @etaExpand n us e ty@ returns an expression with -- the same meaning as @e@, but with arity @n@. @@ -444,11 +460,6 @@ etaExpand :: Arity -- ^ Result should have this number of value args -> CoreExpr -- ^ Expression to expand -> CoreExpr --- Note that SCCs are not treated specially. If we have --- etaExpand 2 (\x -> scc "foo" e) --- = (\xy -> (scc "foo" e) y) --- So the costs of evaluating 'e' (not 'e y') are attributed to "foo" - -- etaExpand deals with for-alls. For example: -- etaExpand 1 E -- where E :: forall a. a -> a @@ -468,7 +479,6 @@ go 0 expr = expr go n (Lam v body) | isTyVar v = Lam v (go n body) | otherwise = Lam v (go (n-1) body) - go n (Note InlineMe expr) = Note InlineMe (go n expr) go n (Cast expr co) = Cast (go n expr) co go n expr = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, ppr etas]) $ etaInfoAbs etas (etaInfoApp subst' expr etas) @@ -621,6 +631,6 @@ ty' = substTy subst ty eta_id' = uniqAway (getTvInScope subst) $ mkSysLocal (fsLit "eta") (mkBuiltinUnique n) ty' - subst' = extendTvInScope subst [eta_id'] + subst' = extendTvInScope subst eta_id' \end{code} diff -ruN ghc-6.12.1/compiler/coreSyn/CoreFVs.lhs ghc-6.13.20091231/compiler/coreSyn/CoreFVs.lhs --- ghc-6.12.1/compiler/coreSyn/CoreFVs.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/coreSyn/CoreFVs.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -16,6 +16,7 @@ module CoreFVs ( -- * Free variables of expressions and binding groups exprFreeVars, -- CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars + exprFreeIds, -- CoreExpr -> IdSet -- Find all locally-defined free Ids exprsFreeVars, -- [CoreExpr] -> VarSet bindFreeVars, -- CoreBind -> VarSet @@ -25,7 +26,9 @@ exprFreeNames, exprsFreeNames, -- * Free variables of Rules, Vars and Ids - idRuleVars, idFreeVars, varTypeTyVars, varTypeTcTyVars, + varTypeTyVars, varTypeTcTyVars, + idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars, + idRuleVars, idRuleRhsVars, ruleRhsFreeVars, rulesFreeVars, ruleLhsFreeNames, ruleLhsFreeIds, @@ -71,6 +74,10 @@ exprFreeVars :: CoreExpr -> VarSet exprFreeVars = exprSomeFreeVars isLocalVar +-- | Find all locally-defined free Ids in an expression +exprFreeIds :: CoreExpr -> IdSet -- Find all locally-defined free Ids +exprFreeIds = exprSomeFreeVars isLocalId + -- | Find all locally-defined free Ids or type variables in several expressions exprsFreeVars :: [CoreExpr] -> VarSet exprsFreeVars = foldr (unionVarSet . exprFreeVars) emptyVarSet @@ -194,7 +201,8 @@ --------- rhs_fvs :: (Id,CoreExpr) -> FV -rhs_fvs (bndr, rhs) = expr_fvs rhs `union` someVars (bndrRuleVars bndr) +rhs_fvs (bndr, rhs) = expr_fvs rhs `union` + someVars (bndrRuleAndUnfoldingVars bndr) -- Treat any RULES as extra RHSs of the binding --------- @@ -271,6 +279,7 @@ -- | Those variables free in the both the left right hand sides of a rule ruleFreeVars :: CoreRule -> VarSet +ruleFreeVars (BuiltinRule {}) = noFVs ruleFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs, ru_args = args }) = delFromUFM fvs fn -- Note [Rule free var hack] where @@ -334,8 +343,8 @@ -- (b `delBinderFV` s) removes the binder b from the free variable set s, -- but *adds* to s --- (a) the free variables of b's type --- (b) the idSpecVars of b +-- +-- the free variables of b's type -- -- This is really important for some lambdas: -- In (\x::a -> x) the only mention of "a" is in the binder. @@ -378,14 +387,45 @@ | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars idFreeVars :: Id -> VarSet -idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` varTypeTyVars id +-- Type variables, rule variables, and inline variables +idFreeVars id = ASSERT( isId id) + varTypeTyVars id `unionVarSet` + idRuleAndUnfoldingVars id + +bndrRuleAndUnfoldingVars ::Var -> VarSet +-- A 'let' can bind a type variable, and idRuleVars assumes +-- it's seeing an Id. This function tests first. +bndrRuleAndUnfoldingVars v | isTyVar v = emptyVarSet + | otherwise = idRuleAndUnfoldingVars v + +idRuleAndUnfoldingVars :: Id -> VarSet +idRuleAndUnfoldingVars id = ASSERT( isId id) + idRuleVars id `unionVarSet` + idUnfoldingVars id -bndrRuleVars ::Var -> VarSet -bndrRuleVars v | isTyVar v = emptyVarSet - | otherwise = idRuleVars v - -idRuleVars ::Id -> VarSet +idRuleVars ::Id -> VarSet -- Does *not* include CoreUnfolding vars idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id) + +idRuleRhsVars :: Id -> VarSet -- Does *not* include the CoreUnfolding vars +-- Just the variables free on the *rhs* of a rule +-- See Note [Choosing loop breakers] in Simplify.lhs +idRuleRhsVars id = foldr (unionVarSet . ruleRhsFreeVars) + emptyVarSet + (idCoreRules id) + +idUnfoldingVars :: Id -> VarSet +-- Produce free vars for an unfolding, but NOT for an ordinary +-- (non-inline) unfolding, since it is a dup of the rhs +-- and we'll get exponential behaviour if we look at both unf and rhs! +-- But do look at the *real* unfolding, even for loop breakers, else +-- we might get out-of-scope variables +idUnfoldingVars id + = case realIdUnfolding id of + CoreUnfolding { uf_tmpl = rhs, uf_src = src } + | isInlineRuleSource src + -> exprFreeVars rhs + DFunUnfolding _ args -> exprsFreeVars args + _ -> emptyVarSet \end{code} @@ -436,7 +476,9 @@ rhs2 = freeVars rhs freeVars (Let (NonRec binder rhs) body) - = (freeVarsOf rhs2 `unionFVs` body_fvs `unionFVs` bndrRuleVars binder, + = (freeVarsOf rhs2 + `unionFVs` body_fvs + `unionFVs` bndrRuleAndUnfoldingVars binder, -- Remember any rules; cf rhs_fvs above AnnLet (AnnNonRec binder rhs2) body2) where @@ -452,7 +494,7 @@ rhss2 = map freeVars rhss rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2 - all_fvs = foldr (unionFVs . idRuleVars) rhs_body_fvs binders + all_fvs = foldr (unionFVs . idRuleAndUnfoldingVars) rhs_body_fvs binders -- The "delBinderFV" happens after adding the idSpecVars, -- since the latter may add some of the binders as fvs diff -ruN ghc-6.12.1/compiler/coreSyn/CoreLint.lhs ghc-6.13.20091231/compiler/coreSyn/CoreLint.lhs --- ghc-6.12.1/compiler/coreSyn/CoreLint.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/coreSyn/CoreLint.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -7,15 +7,11 @@ A ``lint'' pass to check for Core correctness \begin{code} -module CoreLint ( - lintCoreBindings, - lintUnfolding, - showPass, endPass, endPassIf, endIteration - ) where +module CoreLint ( lintCoreBindings, lintUnfolding ) where #include "HsVersions.h" -import NewDemand +import Demand import CoreSyn import CoreFVs import CoreUtils @@ -28,62 +24,28 @@ import VarSet import Name import Id -import IdInfo import PprCore import ErrUtils import SrcLoc import Type +import TypeRep import Coercion import TyCon +import Class import BasicTypes import StaticFlags import ListSetOps +import PrelNames import DynFlags import Outputable import FastString import Util +import Control.Monad import Data.Maybe \end{code} %************************************************************************ %* * -\subsection{End pass} -%* * -%************************************************************************ - -@showPass@ and @endPass@ don't really belong here, but it makes a convenient -place for them. They print out stuff before and after core passes, -and do Core Lint when necessary. - -\begin{code} -endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO () -endPass = dumpAndLint dumpIfSet_core - -endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO () -endPassIf cond = dumpAndLint (dumpIf_core cond) - -endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO () -endIteration = dumpAndLint dumpIfSet_dyn - -dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ()) - -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO () -dumpAndLint dump dflags pass_name dump_flag binds - = do - -- Report result size if required - -- This has the side effect of forcing the intermediate to be evaluated - debugTraceMsg dflags 2 $ - (text " Result size =" <+> int (coreBindsSize binds)) - - -- Report verbosely, if required - dump dflags dump_flag pass_name (pprCoreBindings binds) - - -- Type check - lintCoreBindings dflags pass_name binds -\end{code} - - -%************************************************************************ -%* * \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface} %* * %************************************************************************ @@ -122,7 +84,7 @@ However, when linting we need to remember that a=Int, else we might reject a correct program. So we carry a type substitution (in this example [a -> Int]) and apply this substitution before comparing types. The functin - lintTy :: Type -> LintM Type + lintInTy :: Type -> LintM Type returns a substituted type; that's the only reason it returns anything. When we encounter a binder (like x::a) we must apply the substitution @@ -141,11 +103,22 @@ = return () lintCoreBindings dflags whoDunnit binds - = case (initL (lint_binds binds)) of - Nothing -> showPass dflags ("Core Linted result of " ++ whoDunnit) - Just bad_news -> printDump (display bad_news) >> - ghcExit dflags 1 + | isEmptyBag errs + = do { showPass dflags ("Core Linted result of " ++ whoDunnit) + ; unless (isEmptyBag warns || opt_NoDebugOutput) $ printDump $ + (banner "warnings" $$ displayMessageBag warns) + ; return () } + + | otherwise + = do { printDump (vcat [ banner "errors", displayMessageBag errs + , ptext (sLit "*** Offending Program ***") + , pprCoreBindings binds + , ptext (sLit "*** End of Offense ***") ]) + + ; ghcExit dflags 1 } where + (warns, errs) = initL (lint_binds binds) + -- Put all the top-level binders in scope at the start -- This is because transformation rules can bring something -- into use 'unexpectedly' @@ -156,13 +129,12 @@ lint_bind (Rec prs) = mapM_ (lintSingleBinding TopLevel Recursive) prs lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs) - display bad_news - = vcat [ text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"), - bad_news, - ptext (sLit "*** Offending Program ***"), - pprCoreBindings binds, - ptext (sLit "*** End of Offense ***") - ] + banner string = ptext (sLit "*** Core Lint") <+> text string + <+> ptext (sLit ": in result of") <+> text whoDunnit + <+> ptext (sLit "***") + +displayMessageBag :: Bag Message -> SDoc +displayMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) \end{code} %************************************************************************ @@ -181,9 +153,12 @@ -> Maybe Message -- Nothing => OK lintUnfolding locn vars expr - = initL (addLoc (ImportedUnfolding locn) $ - addInScopeVars vars $ - lintCoreExpr expr) + | isEmptyBag errs = Nothing + | otherwise = Just (displayMessageBag errs) + where + (_warns, errs) = initL (addLoc (ImportedUnfolding locn) $ + addInScopeVars vars $ + lintCoreExpr expr) \end{code} %************************************************************************ @@ -214,6 +189,10 @@ -- Check whether binder's specialisations contain any out-of-scope variables ; mapM_ (checkBndrIdInScope binder) bndr_vars + ; when (isNonRuleLoopBreaker (idOccInfo binder) && isInlinePragma (idInlinePragma binder)) + (addWarnL (ptext (sLit "INLINE binder is (non-rule) loop breaker:") <+> ppr binder)) + -- Only non-rule loop breakers inhibit inlining + -- Check whether arity and demand type are consistent (only if demand analysis -- already happened) ; checkL (case maybeDmdTy of @@ -225,11 +204,8 @@ -- the unfolding is a SimplifiableCoreExpr. Give up for now. where binder_ty = idType binder - maybeDmdTy = idNewStrictness_maybe binder - bndr_vars = varSetElems (idFreeVars binder `unionVarSet` wkr_vars) - wkr_vars | workerExists wkr_info = unitVarSet (workerId wkr_info) - | otherwise = emptyVarSet - wkr_info = idWorkerInfo binder + maybeDmdTy = idStrictness_maybe binder + bndr_vars = varSetElems (idFreeVars binder) lintBinder var | isId var = lintIdBndr var $ \_ -> (return ()) | otherwise = return () \end{code} @@ -242,7 +218,13 @@ \begin{code} type InType = Type -- Substitution not yet applied -type OutType = Type -- Substitution has been applied to this +type InVar = Var +type InTyVar = TyVar + +type OutType = Type -- Substitution has been applied to this +type OutVar = Var +type OutTyVar = TyVar +type OutCoVar = CoVar lintCoreExpr :: CoreExpr -> LintM OutType -- The returned type has the substitution from the monad @@ -263,17 +245,10 @@ lintCoreExpr (Lit lit) = return (literalType lit) ---lintCoreExpr (Note (Coerce to_ty from_ty) expr) --- = do { expr_ty <- lintCoreExpr expr --- ; to_ty <- lintTy to_ty --- ; from_ty <- lintTy from_ty --- ; checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty) --- ; return to_ty } - lintCoreExpr (Cast expr co) = do { expr_ty <- lintCoreExpr expr - ; co' <- lintTy co - ; let (from_ty, to_ty) = coercionKind co' + ; co' <- applySubst co + ; (from_ty, to_ty) <- lintCoercion co' ; checkTys from_ty expr_ty (mkCastErr from_ty expr_ty) ; return to_ty } @@ -283,16 +258,14 @@ lintCoreExpr (Let (NonRec tv (Type ty)) body) = -- See Note [Type let] in CoreSyn do { checkL (isTyVar tv) (mkKindErrMsg tv ty) -- Not quite accurate - ; ty' <- lintTy ty - ; kind' <- lintTy (tyVarKind tv) - ; let tv' = setTyVarKind tv kind' - ; checkKinds tv' ty' + ; ty' <- lintInTy ty + ; lintTyBndr tv $ \ tv' -> + addLoc (BodyOfLetRec [tv]) $ + extendSubstL tv' ty' $ do + { checkKinds tv' ty' -- Now extend the substitution so we -- take advantage of it in the body - ; addLoc (BodyOfLetRec [tv]) $ - addInScopeVars [tv'] $ - extendSubstL tv' ty' $ - lintCoreExpr body } + ; lintCoreExpr body } } lintCoreExpr (Let (NonRec bndr rhs) body) = do { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs) @@ -325,8 +298,8 @@ lintCoreExpr e@(Case scrut var alt_ty alts) = -- Check the scrutinee do { scrut_ty <- lintCoreExpr scrut - ; alt_ty <- lintTy alt_ty - ; var_ty <- lintTy (idType var) + ; alt_ty <- lintInTy alt_ty + ; var_ty <- lintInTy (idType var) ; let mb_tc_app = splitTyConApp_maybe (idType var) ; case mb_tc_app of @@ -358,7 +331,7 @@ pass_var f = f var lintCoreExpr (Type ty) - = do { ty' <- lintTy ty + = do { ty' <- lintInTy ty ; return (typeKind ty') } \end{code} @@ -383,46 +356,46 @@ do { res <- lintCoreArg ty a ; lintCoreArgs res args } -lintCoreArg fun_ty (Type arg_ty) = - do { arg_ty <- lintTy arg_ty - ; lintTyApp fun_ty arg_ty } +lintCoreArg fun_ty (Type arg_ty) + | Just (tyvar,body) <- splitForAllTy_maybe fun_ty + = do { arg_ty' <- applySubst arg_ty + ; checkKinds tyvar arg_ty' + ; if isCoVar tyvar then + return body -- Co-vars don't appear in body! + else + return (substTyWith [tyvar] [arg_ty'] body) } + | otherwise + = failWithL (mkTyAppMsg fun_ty arg_ty) -lintCoreArg fun_ty arg = +lintCoreArg fun_ty arg -- Make sure function type matches argument - do { arg_ty <- lintCoreExpr arg - ; let err1 = mkAppMsg fun_ty arg_ty arg - err2 = mkNonFunAppMsg fun_ty arg_ty arg - ; case splitFunTy_maybe fun_ty of - Just (arg,res) -> - do { checkTys arg arg_ty err1 - ; return res } - _ -> addErrL err2 } + = do { arg_ty <- lintCoreExpr arg + ; let err1 = mkAppMsg fun_ty arg_ty arg + err2 = mkNonFunAppMsg fun_ty arg_ty arg + ; case splitFunTy_maybe fun_ty of + Just (arg,res) -> + do { checkTys arg arg_ty err1 + ; return res } + _ -> failWithL err2 } \end{code} \begin{code} +checkKinds :: Var -> OutType -> LintM () -- Both args have had substitution applied -lintTyApp :: OutType -> OutType -> LintM OutType -lintTyApp ty arg_ty - = case splitForAllTy_maybe ty of - Nothing -> addErrL (mkTyAppMsg ty arg_ty) - - Just (tyvar,body) - -> do { checkL (isTyVar tyvar) (mkTyAppMsg ty arg_ty) - ; checkKinds tyvar arg_ty - ; return (substTyWith [tyvar] [arg_ty] body) } - -checkKinds :: Var -> Type -> LintM () checkKinds tyvar arg_ty -- Arg type might be boxed for a function with an uncommitted -- tyvar; notably this is used so that we can give -- error :: forall a:*. String -> a -- and then apply it to both boxed and unboxed types. - = checkL (arg_kind `isSubKind` tyvar_kind) - (mkKindErrMsg tyvar arg_ty) + | isCoVar tyvar = do { (s2,t2) <- lintCoercion arg_ty + ; unless (s1 `coreEqType` s2 && t1 `coreEqType` t2) + (addErrL (mkCoAppErrMsg tyvar arg_ty)) } + | otherwise = do { arg_kind <- lintType arg_ty + ; unless (arg_kind `isSubKind` tyvar_kind) + (addErrL (mkKindErrMsg tyvar arg_ty)) } where tyvar_kind = tyVarKind tyvar - arg_kind | isCoVar tyvar = coercionKindPredTy arg_ty - | otherwise = typeKind arg_ty + (s1,t1) = coVarKind tyvar checkDeadIdOcc :: Id -> LintM () -- Occurrences of an Id should never be dead.... @@ -547,51 +520,227 @@ lintBinder :: Var -> (Var -> LintM a) -> LintM a lintBinder var linterF - | isTyVar var = lint_ty_bndr - | otherwise = lintIdBndr var linterF - where - lint_ty_bndr = do { _ <- lintTy (tyVarKind var) - ; subst <- getTvSubst - ; let (subst', tv') = substTyVarBndr subst var - ; updateTvSubst subst' (linterF tv') } + | isId var = lintIdBndr var linterF + | otherwise = lintTyBndr var linterF + +lintTyBndr :: InTyVar -> (OutTyVar -> LintM a) -> LintM a +lintTyBndr tv thing_inside + = do { subst <- getTvSubst + ; let (subst', tv') = substTyVarBndr subst tv + ; lintTyBndrKind tv' + ; updateTvSubst subst' (thing_inside tv') } -lintIdBndr :: Var -> (Var -> LintM a) -> LintM a +lintIdBndr :: Id -> (Id -> LintM a) -> LintM a -- Do substitution on the type of a binder and add the var with this -- new type to the in-scope set of the second argument -- ToDo: lint its rules + lintIdBndr id linterF = do { checkL (not (isUnboxedTupleType (idType id))) (mkUnboxedTupleMsg id) -- No variable can be bound to an unboxed tuple. - ; lintAndScopeId id $ \id' -> linterF id' - } + ; lintAndScopeId id $ \id' -> linterF id' } lintAndScopeIds :: [Var] -> ([Var] -> LintM a) -> LintM a lintAndScopeIds ids linterF = go ids where go [] = linterF [] - go (id:ids) = do { lintAndScopeId id $ \id -> - lintAndScopeIds ids $ \ids -> - linterF (id:ids) } + go (id:ids) = lintAndScopeId id $ \id -> + lintAndScopeIds ids $ \ids -> + linterF (id:ids) -lintAndScopeId :: Var -> (Var -> LintM a) -> LintM a +lintAndScopeId :: InVar -> (OutVar -> LintM a) -> LintM a lintAndScopeId id linterF - = do { ty <- lintTy (idType id) + = do { ty <- lintInTy (idType id) ; let id' = setIdType id ty - ; addInScopeVars [id'] $ (linterF id') - } + ; addInScopeVar id' $ (linterF id') } +\end{code} + + +%************************************************************************ +%* * +\subsection[lint-monad]{The Lint monad} +%* * +%************************************************************************ -lintTy :: InType -> LintM OutType +\begin{code} +lintInTy :: InType -> LintM OutType -- Check the type, and apply the substitution to it -- See Note [Linting type lets] -- ToDo: check the kind structure of the type -lintTy ty - = do { ty' <- applySubst ty - ; mapM_ checkTyVarInScope (varSetElems (tyVarsOfType ty')) +lintInTy ty + = addLoc (InType ty) $ + do { ty' <- applySubst ty + ; _ <- lintType ty' ; return ty' } -\end{code} +------------------- +lintKind :: Kind -> LintM () +-- Check well-formedness of kinds: *, *->*, etc +lintKind (TyConApp tc []) + | getUnique tc `elem` kindKeys + = return () +lintKind (FunTy k1 k2) + = lintKind k1 >> lintKind k2 +lintKind kind + = addErrL (hang (ptext (sLit "Malformed kind:")) 2 (quotes (ppr kind))) + +------------------- +lintTyBndrKind :: OutTyVar -> LintM () +lintTyBndrKind tv + | isCoVar tv = lintCoVarKind tv + | otherwise = lintKind (tyVarKind tv) + +------------------- +lintCoVarKind :: OutCoVar -> LintM () +-- Check the kind of a coercion binder +lintCoVarKind tv + = do { (ty1,ty2) <- lintSplitCoVar tv + ; k1 <- lintType ty1 + ; k2 <- lintType ty2 + ; unless (k1 `eqKind` k2) + (addErrL (sep [ ptext (sLit "Kind mis-match in coercion kind of:") + , nest 2 (quotes (ppr tv)) + , ppr [k1,k2] ])) } + +------------------- +lintSplitCoVar :: CoVar -> LintM (Type,Type) +lintSplitCoVar cv + = case coVarKind_maybe cv of + Just ts -> return ts + Nothing -> failWithL (sep [ ptext (sLit "Coercion variable with non-equality kind:") + , nest 2 (ppr cv <+> dcolon <+> ppr (tyVarKind cv))]) + +------------------- +lintCoercion :: OutType -> LintM (OutType, OutType) +-- Check the kind of a coercion term, returning the kind +lintCoercion ty@(TyVarTy tv) + = do { checkTyVarInScope tv + ; if isCoVar tv then return (coVarKind tv) + else return (ty, ty) } + +lintCoercion ty@(AppTy ty1 ty2) + = do { (s1,t1) <- lintCoercion ty1 + ; (s2,t2) <- lintCoercion ty2 + ; check_co_app ty (typeKind s1) [s2] + ; return (AppTy s1 s2, AppTy t1 t2) } + +lintCoercion ty@(FunTy ty1 ty2) + = do { (s1,t1) <- lintCoercion ty1 + ; (s2,t2) <- lintCoercion ty2 + ; check_co_app ty (tyConKind funTyCon) [s1, s2] + ; return (FunTy s1 s2, FunTy t1 t2) } + +lintCoercion ty@(TyConApp tc tys) + | Just (ar, rule) <- isCoercionTyCon_maybe tc + = do { unless (tys `lengthAtLeast` ar) (badCo ty) + ; (s,t) <- rule lintType lintCoercion + True (take ar tys) + ; (ss,ts) <- mapAndUnzipM lintCoercion (drop ar tys) + ; check_co_app ty (typeKind s) ss + ; return (mkAppTys s ss, mkAppTys t ts) } + + | not (tyConHasKind tc) -- Just something bizarre like SuperKindTyCon + = badCo ty + + | otherwise + = do { (ss,ts) <- mapAndUnzipM lintCoercion tys + ; check_co_app ty (tyConKind tc) ss + ; return (TyConApp tc ss, TyConApp tc ts) } + +lintCoercion ty@(PredTy (ClassP cls tys)) + = do { (ss,ts) <- mapAndUnzipM lintCoercion tys + ; check_co_app ty (tyConKind (classTyCon cls)) ss + ; return (PredTy (ClassP cls ss), PredTy (ClassP cls ts)) } + +lintCoercion (PredTy (IParam n p_ty)) + = do { (s,t) <- lintCoercion p_ty + ; return (PredTy (IParam n s), PredTy (IParam n t)) } + +lintCoercion ty@(PredTy (EqPred {})) + = failWithL (badEq ty) + +lintCoercion (ForAllTy tv ty) + | isCoVar tv + = do { (co1, co2) <- lintSplitCoVar tv + ; (s1,t1) <- lintCoercion co1 + ; (s2,t2) <- lintCoercion co2 + ; (sr,tr) <- lintCoercion ty + ; return (mkCoPredTy s1 s2 sr, mkCoPredTy t1 t2 tr) } + + | otherwise + = do { lintKind (tyVarKind tv) + ; (s,t) <- addInScopeVar tv (lintCoercion ty) + ; return (ForAllTy tv s, ForAllTy tv t) } + +badCo :: Coercion -> LintM a +badCo co = failWithL (hang (ptext (sLit "Ill-kinded coercion term:")) 2 (ppr co)) + +------------------- +lintType :: OutType -> LintM Kind +lintType (TyVarTy tv) + = do { checkTyVarInScope tv + ; return (tyVarKind tv) } + +lintType ty@(AppTy t1 t2) + = do { k1 <- lintType t1 + ; lint_ty_app ty k1 [t2] } + +lintType ty@(FunTy t1 t2) + = lint_ty_app ty (tyConKind funTyCon) [t1,t2] + +lintType ty@(TyConApp tc tys) + | tyConHasKind tc + = lint_ty_app ty (tyConKind tc) tys + | otherwise + = failWithL (hang (ptext (sLit "Malformed type:")) 2 (ppr ty)) + +lintType (ForAllTy tv ty) + = do { lintTyBndrKind tv + ; addInScopeVar tv (lintType ty) } + +lintType ty@(PredTy (ClassP cls tys)) + = lint_ty_app ty (tyConKind (classTyCon cls)) tys + +lintType (PredTy (IParam _ p_ty)) + = lintType p_ty + +lintType ty@(PredTy (EqPred {})) + = failWithL (badEq ty) + +---------------- +lint_ty_app :: Type -> Kind -> [OutType] -> LintM Kind +lint_ty_app ty k tys + = do { ks <- mapM lintType tys + ; lint_kind_app (ptext (sLit "type") <+> quotes (ppr ty)) k ks } + +---------------- +check_co_app :: Coercion -> Kind -> [OutType] -> LintM () +check_co_app ty k tys + = do { _ <- lint_kind_app (ptext (sLit "coercion") <+> quotes (ppr ty)) + k (map typeKind tys) + ; return () } + +---------------- +lint_kind_app :: SDoc -> Kind -> [Kind] -> LintM Kind +lint_kind_app doc kfn ks = go kfn ks + where + fail_msg = vcat [hang (ptext (sLit "Kind application error in")) 2 doc, + nest 2 (ptext (sLit "Function kind =") <+> ppr kfn), + nest 2 (ptext (sLit "Arg kinds =") <+> ppr ks)] + + go kfn [] = return kfn + go kfn (k:ks) = case splitKindFunTy_maybe kfn of + Nothing -> failWithL fail_msg + Just (kfa, kfb) -> do { unless (k `isSubKind` kfa) + (addErrL fail_msg) + ; go kfb ks } +-------------- +badEq :: Type -> SDoc +badEq ty = hang (ptext (sLit "Unexpected equality predicate:")) + 1 (quotes (ppr ty)) +\end{code} %************************************************************************ %* * @@ -606,8 +755,10 @@ TvSubst -> -- Current type substitution; we also use this -- to keep track of all the variables in scope, -- both Ids and TyVars - Bag Message -> -- Error messages so far - (Maybe a, Bag Message) } -- Result and error messages (if any) + WarnsAndErrs -> -- Error and warning messages so far + (Maybe a, WarnsAndErrs) } -- Result and messages (if any) + +type WarnsAndErrs = (Bag Message, Bag Message) {- Note [Type substitution] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -626,7 +777,7 @@ instance Monad LintM where return x = LintM (\ _ _ errs -> (Just x, errs)) - fail err = LintM (\ loc subst errs -> (Nothing, addErr subst errs (text err) loc)) + fail err = failWithL (text err) m >>= k = LintM (\ loc subst errs -> let (res, errs') = unLintM m loc subst errs in case res of @@ -642,29 +793,38 @@ | AnExpr CoreExpr -- Some expression | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which) | TopLevelBindings + | InType Type -- Inside a type \end{code} \begin{code} -initL :: LintM a -> Maybe Message {- errors -} +initL :: LintM a -> WarnsAndErrs -- Errors and warnings initL m - = case unLintM m [] emptyTvSubst emptyBag of - (_, errs) | isEmptyBag errs -> Nothing - | otherwise -> Just (vcat (punctuate (text "") (bagToList errs))) + = case unLintM m [] emptyTvSubst (emptyBag, emptyBag) of + (_, errs) -> errs \end{code} \begin{code} checkL :: Bool -> Message -> LintM () checkL True _ = return () -checkL False msg = addErrL msg +checkL False msg = failWithL msg -addErrL :: Message -> LintM a -addErrL msg = LintM (\ loc subst errs -> (Nothing, addErr subst errs msg loc)) +failWithL :: Message -> LintM a +failWithL msg = LintM $ \ loc subst (warns,errs) -> + (Nothing, (warns, addMsg subst errs msg loc)) + +addErrL :: Message -> LintM () +addErrL msg = LintM $ \ loc subst (warns,errs) -> + (Just (), (warns, addMsg subst errs msg loc)) + +addWarnL :: Message -> LintM () +addWarnL msg = LintM $ \ loc subst (warns,errs) -> + (Just (), (addMsg subst warns msg loc, errs)) -addErr :: TvSubst -> Bag Message -> Message -> [LintLocInfo] -> Bag Message -addErr subst errs_so_far msg locs +addMsg :: TvSubst -> Bag Message -> Message -> [LintLocInfo] -> Bag Message +addMsg subst msgs msg locs = ASSERT( notNull locs ) - errs_so_far `snocBag` mk_msg msg + msgs `snocBag` mk_msg msg where (loc, cxt1) = dumpLoc (head locs) cxts = [snd (dumpLoc loc) | loc <- locs] @@ -687,12 +847,16 @@ addInScopeVars :: [Var] -> LintM a -> LintM a addInScopeVars vars m | null dups - = LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs) + = LintM (\ loc subst errs -> unLintM m loc (extendTvInScopeList subst vars) errs) | otherwise - = addErrL (dupVars dups) + = failWithL (dupVars dups) where (_, dups) = removeDups compare vars +addInScopeVar :: Var -> LintM a -> LintM a +addInScopeVar var m + = LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst var) errs) + updateTvSubst :: TvSubst -> LintM a -> LintM a updateTvSubst subst' m = LintM (\ loc _ errs -> unLintM m loc subst' errs) @@ -717,7 +881,7 @@ = do { subst <- getTvSubst ; case lookupInScope (getTvInScope subst) id of Just v -> return v - Nothing -> do { _ <- addErrL out_of_scope + Nothing -> do { addErrL out_of_scope ; return id } } where out_of_scope = ppr id <+> ptext (sLit "is out of scope") @@ -783,6 +947,8 @@ = (locn, brackets (ptext (sLit "in an imported unfolding"))) dumpLoc TopLevelBindings = (noSrcLoc, empty) +dumpLoc (InType ty) + = (noSrcLoc, text "In the type" <+> quotes (ppr ty)) pp_binders :: [Var] -> SDoc pp_binders bs = sep (punctuate comma (map pp_binder bs)) @@ -882,6 +1048,14 @@ hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] +mkCoAppErrMsg :: TyVar -> Type -> Message +mkCoAppErrMsg tyvar arg_ty + = vcat [ptext (sLit "Kinds don't match in coercion application:"), + hang (ptext (sLit "Coercion variable:")) + 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)), + hang (ptext (sLit "Arg coercion:")) + 4 (ppr arg_ty <+> dcolon <+> pprEqPred (coercionKind arg_ty))] + mkTyAppMsg :: Type -> Type -> Message mkTyAppMsg ty arg_ty = vcat [text "Illegal type application:", @@ -909,7 +1083,7 @@ mkStrictMsg binder = vcat [hsep [ptext (sLit "Recursive or top-level binder has strict demand info:"), ppr binder], - hsep [ptext (sLit "Binder's demand info:"), ppr (idNewDemandInfo binder)] + hsep [ptext (sLit "Binder's demand info:"), ppr (idDemandInfo binder)] ] mkArityMsg :: Id -> Message @@ -923,7 +1097,7 @@ hsep [ptext (sLit "Binder's strictness signature:"), ppr dmd_ty] ] - where (StrictSig dmd_ty) = idNewStrictness binder + where (StrictSig dmd_ty) = idStrictness binder mkUnboxedTupleMsg :: Id -> Message mkUnboxedTupleMsg binder diff -ruN ghc-6.12.1/compiler/coreSyn/CorePrep.lhs ghc-6.13.20091231/compiler/coreSyn/CorePrep.lhs --- ghc-6.12.1/compiler/coreSyn/CorePrep.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/coreSyn/CorePrep.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -15,12 +15,12 @@ import CoreUtils import CoreArity import CoreFVs -import CoreLint +import CoreMonad ( endPass ) import CoreSyn import Type import Coercion import TyCon -import NewDemand +import Demand import Var import VarSet import VarEnv @@ -147,7 +147,7 @@ floats2 <- corePrepTopBinds implicit_binds return (deFloatTop (floats1 `appendFloats` floats2)) - endPass dflags "CorePrep" Opt_D_dump_prep binds_out + endPass dflags "CorePrep" Opt_D_dump_prep binds_out [] return binds_out corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr @@ -244,7 +244,7 @@ -> UniqSM (CorePrepEnv, Floats) cpeBind top_lvl env (NonRec bndr rhs) = do { (_, bndr1) <- cloneBndr env bndr - ; let is_strict = isStrictDmd (idNewDemandInfo bndr) + ; let is_strict = isStrictDmd (idDemandInfo bndr) is_unlifted = isUnLiftedType (idType bndr) ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive (is_strict || is_unlifted) @@ -497,7 +497,7 @@ ; let v2 = lookupCorePrepEnv env v1 ; return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) } where - stricts = case idNewStrictness v of + stricts = case idStrictness v of StrictSig (DmdType _ demands _) | listLengthCmp demands depth /= GT -> demands -- length demands <= depth @@ -640,7 +640,6 @@ -- want to get this: -- unzip = /\ab \xs. (__inline_me__ ...) a b xs ignoreNote (CoreNote _) = True -ignoreNote InlineMe = True ignoreNote _other = False diff -ruN ghc-6.12.1/compiler/coreSyn/CoreSubst.lhs ghc-6.13.20091231/compiler/coreSyn/CoreSubst.lhs --- ghc-6.12.1/compiler/coreSyn/CoreSubst.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/coreSyn/CoreSubst.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -11,12 +11,12 @@ Subst, TvSubstEnv, IdSubstEnv, InScopeSet, -- ** Substituting into expressions and related types - deShadowBinds, - substTy, substExpr, substBind, substSpec, substWorker, - lookupIdSubst, lookupTvSubst, + deShadowBinds, substSpec, substRulesForImportedIds, + substTy, substExpr, substBind, substUnfolding, + substUnfoldingSource, lookupIdSubst, lookupTvSubst, substIdOcc, -- ** Operations on substitutions - emptySubst, mkEmptySubst, mkSubst, substInScope, isEmptySubst, + emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst, extendIdSubst, extendIdSubstList, extendTvSubst, extendTvSubstList, extendSubst, extendSubstList, zapSubstEnv, extendInScope, extendInScopeList, extendInScopeIds, @@ -24,7 +24,10 @@ -- ** Substituting and cloning binders substBndr, substBndrs, substRecBndrs, - cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs + cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs, + + -- ** Simple expression optimiser + simpleOptExpr ) where #include "HsVersions.h" @@ -32,17 +35,21 @@ import CoreSyn import CoreFVs import CoreUtils +import OccurAnal( occurAnalyseExpr ) import qualified Type import Type ( Type, TvSubst(..), TvSubstEnv ) +import Coercion ( optCoercion ) import VarSet import VarEnv import Id +import Name ( Name ) import Var ( Var, TyVar, setVarUnique ) import IdInfo import Unique import UniqSupply import Maybes +import BasicTypes ( isAlwaysActive ) import Outputable import PprCore () -- Instances import FastString @@ -211,13 +218,22 @@ | Just e <- lookupVarEnv ids v = e | Just v' <- lookupInScope in_scope v = Var v' -- Vital! See Note [Extending the Subst] - | otherwise = WARN( True, ptext (sLit "CoreSubst.lookupIdSubst") <+> ppr v ) + | otherwise = WARN( True, ptext (sLit "CoreSubst.lookupIdSubst") <+> ppr v $$ ppr in_scope ) Var v -- | Find the substitution for a 'TyVar' in the 'Subst' lookupTvSubst :: Subst -> TyVar -> Type lookupTvSubst (Subst _ _ tvs) v = lookupVarEnv tvs v `orElse` Type.mkTyVarTy v +-- | Simultaneously substitute for a bunch of variables +-- No left-right shadowing +-- ie the substitution for (\x \y. e) a1 a2 +-- so neither x nor y scope over a1 a2 +mkOpenSubst :: InScopeSet -> [(Var,CoreArg)] -> Subst +mkOpenSubst in_scope pairs = Subst in_scope + (mkVarEnv [(id,e) | (id, e) <- pairs, isId id]) + (mkVarEnv [(tv,ty) | (tv, Type ty) <- pairs]) + ------------------------------ isInScope :: Var -> Subst -> Bool isInScope v (Subst in_scope _ _) = v `elemInScopeSet` in_scope @@ -275,7 +291,10 @@ go (Lit lit) = Lit lit go (App fun arg) = App (go fun) (go arg) go (Note note e) = Note (go_note note) (go e) - go (Cast e co) = Cast (go e) (substTy subst co) + go (Cast e co) = Cast (go e) (optCoercion (getTvSubst subst) co) + -- Optimise coercions as we go; this is good, for example + -- in the RHS of rules, which are only substituted in + go (Lam bndr body) = Lam bndr' (substExpr subst' body) where (subst', bndr') = substBndr subst bndr @@ -315,6 +334,9 @@ -- -- (Actually, within a single /type/ there might still be shadowing, because -- 'substTy' is a no-op for the empty substitution, but that's probably OK.) +-- +-- [Aug 09] This function is not used in GHC at the moment, but seems so +-- short and simple that I'm going to leave it here deShadowBinds :: [CoreBind] -> [CoreBind] deShadowBinds binds = snd (mapAccumL substBind emptySubst binds) \end{code} @@ -445,8 +467,10 @@ -- | See 'Type.substTy' substTy :: Subst -> Type -> Type -substTy (Subst in_scope _id_env tv_env) ty - = Type.substTy (TvSubst in_scope tv_env) ty +substTy subst ty = Type.substTy (getTvSubst subst) ty + +getTvSubst :: Subst -> TvSubst +getTvSubst (Subst in_scope _id_env tv_env) = TvSubst in_scope tv_env \end{code} @@ -474,49 +498,97 @@ substIdInfo subst new_id info | nothing_to_do = Nothing | otherwise = Just (info `setSpecInfo` substSpec subst new_id old_rules - `setWorkerInfo` substWorker subst old_wrkr - `setUnfoldingInfo` noUnfolding) + `setUnfoldingInfo` substUnfolding subst old_unf) where old_rules = specInfo info - old_wrkr = workerInfo info - nothing_to_do = isEmptySpecInfo old_rules && - not (workerExists old_wrkr) && - not (hasUnfolding (unfoldingInfo info)) + old_unf = unfoldingInfo info + nothing_to_do = isEmptySpecInfo old_rules && isClosedUnfolding old_unf ------------------ --- | Substitutes for the 'Id's within the 'WorkerInfo' -substWorker :: Subst -> WorkerInfo -> WorkerInfo - -- Seq'ing on the returned WorkerInfo is enough to cause all the - -- substitutions to happen completely - -substWorker _ NoWorker - = NoWorker -substWorker subst (HasWorker w a) - = case lookupIdSubst subst w of - Var w1 -> HasWorker w1 a - other -> WARN( not (exprIsTrivial other), text "CoreSubst.substWorker:" <+> ppr w ) - NoWorker -- Worker has got substituted away altogether - -- (This can happen if it's trivial, - -- via postInlineUnconditionally, hence warning) +-- | Substitutes for the 'Id's within an unfolding +substUnfolding :: Subst -> Unfolding -> Unfolding + -- Seq'ing on the returned Unfolding is enough to cause + -- all the substitutions to happen completely +substUnfolding subst (DFunUnfolding con args) + = DFunUnfolding con (map (substExpr subst) args) + +substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src }) + -- Retain an InlineRule! + | not (isInlineRuleSource src) -- Always zap a CoreUnfolding, to save substitution work + = NoUnfolding + | otherwise -- But keep an InlineRule! + = seqExpr new_tmpl `seq` + new_src `seq` + unf { uf_tmpl = new_tmpl, uf_src = new_src } + where + new_tmpl = substExpr subst tmpl + new_src = substUnfoldingSource subst src + +substUnfolding _ unf = unf -- NoUnfolding, OtherCon + +------------------- +substUnfoldingSource :: Subst -> UnfoldingSource -> UnfoldingSource +substUnfoldingSource (Subst in_scope ids _) (InlineWrapper wkr) + | Just wkr_expr <- lookupVarEnv ids wkr + = case wkr_expr of + Var w1 -> InlineWrapper w1 + _other -> WARN( True, text "Interesting! CoreSubst.substWorker1:" <+> ppr wkr + <+> ifPprDebug (equals <+> ppr wkr_expr) ) + -- Note [Worker inlining] + InlineRule -- It's not a wrapper any more, but still inline it! + + | Just w1 <- lookupInScope in_scope wkr = InlineWrapper w1 + | otherwise = WARN( True, text "Interesting! CoreSubst.substWorker2:" <+> ppr wkr ) + -- This can legitimately happen. The worker has been inlined and + -- dropped as dead code, because we don't treat the UnfoldingSource + -- as an "occurrence". + -- Note [Worker inlining] + InlineRule + +substUnfoldingSource _ src = src + +------------------ +substIdOcc :: Subst -> Id -> Id +-- These Ids should not be substituted to non-Ids +substIdOcc subst v = case lookupIdSubst subst v of + Var v' -> v' + other -> pprPanic "substIdOcc" (vcat [ppr v <+> ppr other, ppr subst]) ------------------ -- | Substitutes for the 'Id's within the 'WorkerInfo' given the new function 'Id' substSpec :: Subst -> Id -> SpecInfo -> SpecInfo -substSpec subst new_fn (SpecInfo rules rhs_fvs) - = seqSpecInfo new_rules `seq` new_rules +substSpec subst new_id (SpecInfo rules rhs_fvs) + = seqSpecInfo new_spec `seq` new_spec where - new_name = idName new_fn - new_rules = SpecInfo (map do_subst rules) (substVarSet subst rhs_fvs) + subst_ru_fn = const (idName new_id) + new_spec = SpecInfo (map (substRule subst subst_ru_fn) rules) + (substVarSet subst rhs_fvs) - do_subst rule@(BuiltinRule {}) = rule - do_subst rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs }) - = rule { ru_bndrs = bndrs', - ru_fn = new_name, -- Important: the function may have changed its name! - ru_args = map (substExpr subst') args, - ru_rhs = substExpr subst' rhs } - where - (subst', bndrs') = substBndrs subst bndrs +------------------ +substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule] +substRulesForImportedIds subst rules + = map (substRule subst (\name -> name)) rules + +------------------ +substRule :: Subst -> (Name -> Name) -> CoreRule -> CoreRule + +-- The subst_ru_fn argument is applied to substitute the ru_fn field +-- of the rule: +-- - Rules for *imported* Ids never change ru_fn +-- - Rules for *local* Ids are in the IdInfo for that Id, +-- and the ru_fn field is simply replaced by the new name +-- of the Id + +substRule _ _ rule@(BuiltinRule {}) = rule +substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args + , ru_fn = fn_name, ru_rhs = rhs }) + = rule { ru_bndrs = bndrs', + ru_fn = subst_ru_fn fn_name, + ru_args = map (substExpr subst') args, + ru_rhs = substExpr subst' rhs } + where + (subst', bndrs') = substBndrs subst bndrs ------------------ substVarSet :: Subst -> VarSet -> VarSet @@ -527,3 +599,135 @@ | isId fv = exprFreeVars (lookupIdSubst subst fv) | otherwise = Type.tyVarsOfType (lookupTvSubst subst fv) \end{code} + +Note [Worker inlining] +~~~~~~~~~~~~~~~~~~~~~~ +A worker can get sustituted away entirely. + - it might be trivial + - it might simply be very small +We do not treat an InlWrapper as an 'occurrence' in the occurence +analyser, so it's possible that the worker is not even in scope any more. + +In all all these cases we simply drop the special case, returning to +InlVanilla. The WARN is just so I can see if it happens a lot. + + +%************************************************************************ +%* * + The Very Simple Optimiser +%* * +%************************************************************************ + +\begin{code} +simpleOptExpr :: CoreExpr -> CoreExpr +-- Do simple optimisation on an expression +-- The optimisation is very straightforward: just +-- inline non-recursive bindings that are used only once, +-- or where the RHS is trivial +-- +-- The result is NOT guaranteed occurence-analysed, becuase +-- in (let x = y in ....) we substitute for x; so y's occ-info +-- may change radically + +simpleOptExpr expr + = go init_subst (occurAnalyseExpr expr) + where + init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr)) + -- It's potentially important to make a proper in-scope set + -- Consider let x = ..y.. in \y. ...x... + -- Then we should remember to clone y before substituting + -- for x. It's very unlikely to occur, because we probably + -- won't *be* substituting for x if it occurs inside a + -- lambda. + -- + -- It's a bit painful to call exprFreeVars, because it makes + -- three passes instead of two (occ-anal, and go) + + go subst (Var v) = lookupIdSubst subst v + go subst (App e1 e2) = App (go subst e1) (go subst e2) + go subst (Type ty) = Type (substTy subst ty) + go _ (Lit lit) = Lit lit + go subst (Note note e) = Note note (go subst e) + go subst (Cast e co) = Cast (go subst e) (substTy subst co) + go subst (Let bind body) = go_let subst bind body + go subst (Lam bndr body) = Lam bndr' (go subst' body) + where + (subst', bndr') = substBndr subst bndr + + go subst (Case e b ty as) = Case (go subst e) b' + (substTy subst ty) + (map (go_alt subst') as) + where + (subst', b') = substBndr subst b + + + ---------------------- + go_alt subst (con, bndrs, rhs) = (con, bndrs', go subst' rhs) + where + (subst', bndrs') = substBndrs subst bndrs + + ---------------------- + go_let subst (Rec prs) body + = Let (Rec (reverse rev_prs')) (go subst'' body) + where + (subst', bndrs') = substRecBndrs subst (map fst prs) + (subst'', rev_prs') = foldl do_pr (subst', []) (prs `zip` bndrs') + do_pr (subst, prs) ((b,r), b') = case go_bind subst b r of + Left subst' -> (subst', prs) + Right r' -> (subst, (b',r'):prs) + + go_let subst (NonRec b r) body + = case go_bind subst b r of + Left subst' -> go subst' body + Right r' -> Let (NonRec b' r') (go subst' body) + where + (subst', b') = substBndr subst b + + + ---------------------- + go_bind :: Subst -> Var -> CoreExpr -> Either Subst CoreExpr + -- (go_bind subst old_var old_rhs) + -- either extends subst with (old_var -> new_rhs) + -- or return new_rhs for a binding new_var = new_rhs + go_bind subst b r + | Type ty <- r + , isTyVar b -- let a::* = TYPE ty in + = Left (extendTvSubst subst b (substTy subst ty)) + + | isId b -- let x = e in + , safe_to_inline (idOccInfo b) || exprIsTrivial r' + , isAlwaysActive (idInlineActivation b) -- Note [Inline prag in simplOpt] + = Left (extendIdSubst subst b r') + + | otherwise + = Right r' + where + r' = go subst r + + ---------------------- + -- Unconditionally safe to inline + safe_to_inline :: OccInfo -> Bool + safe_to_inline IAmDead = True + safe_to_inline (OneOcc in_lam one_br _) = not in_lam && one_br + safe_to_inline (IAmALoopBreaker {}) = False + safe_to_inline NoOccInfo = False +\end{code} + +Note [Inline prag in simplOpt] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If there's an INLINE/NOINLINE pragma that restricts the phase in +which the binder can be inlined, we don't inline here; after all, +we don't know what phase we're in. Here's an example + + foo :: Int -> Int -> Int + {-# INLINE foo #-} + foo m n = inner m + where + {-# INLINE [1] inner #-} + inner m = m+n + + bar :: Int -> Int + bar n = foo n 1 + +When inlining 'foo' in 'bar' we want the let-binding for 'inner' +to remain visible until Phase 1 \ No newline at end of file diff -ruN ghc-6.12.1/compiler/coreSyn/CoreSyn.lhs ghc-6.13.20091231/compiler/coreSyn/CoreSyn.lhs --- ghc-6.12.1/compiler/coreSyn/CoreSyn.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/coreSyn/CoreSyn.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -35,16 +35,20 @@ isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar, -- * Unfolding data types - Unfolding(..), UnfoldingGuidance(..), -- Both abstract everywhere but in CoreUnfold.lhs + Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..), + -- Abstract everywhere but in CoreUnfold.lhs -- ** Constructing 'Unfolding's noUnfolding, evaldUnfolding, mkOtherCon, + unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk, -- ** Predicates and deconstruction on 'Unfolding' - unfoldingTemplate, maybeUnfoldingTemplate, otherCons, + unfoldingTemplate, setUnfoldingTemplate, expandUnfolding_maybe, + maybeUnfoldingTemplate, otherCons, unfoldingArity, isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, - isExpandableUnfolding, isCompulsoryUnfolding, - hasUnfolding, hasSomeUnfolding, neverUnfold, + isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding, + isInlineRule, isInlineRule_maybe, isClosedUnfolding, hasSomeUnfolding, + isStableUnfolding, canUnfold, neverUnfoldGuidance, isInlineRuleSource, -- * Strictness seqExpr, seqExprs, seqUnfolding, @@ -57,7 +61,7 @@ -- * Core rule data types CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only - RuleName, + RuleName, IdUnfoldingFun, -- ** Operations on 'CoreRule's seqRules, ruleArity, ruleName, ruleIdName, ruleActivation_maybe, @@ -272,21 +276,7 @@ -- | Allows attaching extra information to points in expressions rather than e.g. identifiers. data Note = SCC CostCentre -- ^ A cost centre annotation for profiling - - | InlineMe -- ^ Instructs the core simplifer to treat the enclosed expression - -- as very small, and inline it at its call sites - | CoreNote String -- ^ A generic core annotation, propagated but not used by GHC - --- NOTE: we also treat expressions wrapped in InlineMe as --- 'cheap' and 'dupable' (in the sense of exprIsCheap, exprIsDupable) --- What this means is that we obediently inline even things that don't --- look like valuse. This is sometimes important: --- {-# INLINE f #-} --- f = g . h --- Here, f looks like a redex, and we aren't going to inline (.) because it's --- inside an INLINE, so it'll stay looking like a redex. Nevertheless, we --- should inline f even inside lambdas. In effect, we should trust the programmer. \end{code} @@ -324,6 +314,8 @@ -- And the right-hand side ru_rhs :: CoreExpr, -- ^ Right hand side of the rule + -- Occurrence info is guaranteed correct + -- See Note [OccInfo in unfoldings and rules] -- Locality ru_local :: Bool -- ^ @True@ iff the fn at the head of the rule is @@ -338,17 +330,22 @@ -- | Built-in rules are used for constant folding -- and suchlike. They have no free variables. | BuiltinRule { - ru_name :: RuleName, -- ^ As above - ru_fn :: Name, -- ^ As above - ru_nargs :: Int, -- ^ Number of arguments that 'ru_try' expects, - -- including type arguments - ru_try :: [CoreExpr] -> Maybe CoreExpr + ru_name :: RuleName, -- ^ As above + ru_fn :: Name, -- ^ As above + ru_nargs :: Int, -- ^ Number of arguments that 'ru_try' consumes, + -- if it fires, including type arguments + ru_try :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr -- ^ This function does the rewrite. It given too many -- arguments, it simply discards them; the returned 'CoreExpr' -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args } -- See Note [Extra args in rule matching] in Rules.lhs +type IdUnfoldingFun = Id -> Unfolding +-- A function that embodies how to unfold an Id if you need +-- to do that in the Rule. The reason we need to pass this info in +-- is that whether an Id is unfoldable depends on the simplifier phase + isBuiltinRule :: CoreRule -> Bool isBuiltinRule (BuiltinRule {}) = True isBuiltinRule _ = False @@ -392,59 +389,118 @@ -- identifier would have if we substituted its definition in for the identifier. -- This type should be treated as abstract everywhere except in "CoreUnfold" data Unfolding - = NoUnfolding -- ^ We have no information about the unfolding + = NoUnfolding -- ^ We have no information about the unfolding - | OtherCon [AltCon] -- ^ It ain't one of these constructors. - -- @OtherCon xs@ also indicates that something has been evaluated - -- and hence there's no point in re-evaluating it. - -- @OtherCon []@ is used even for non-data-type values - -- to indicated evaluated-ness. Notably: - -- - -- > data C = C !(Int -> Int) - -- > case x of { C f -> ... } - -- - -- Here, @f@ gets an @OtherCon []@ unfolding. - - | CompulsoryUnfolding CoreExpr -- ^ There is /no original definition/, - -- so you'd better unfold. - - | CoreUnfolding - CoreExpr - Bool - Bool - Bool - Bool - UnfoldingGuidance + | OtherCon [AltCon] -- ^ It ain't one of these constructors. + -- @OtherCon xs@ also indicates that something has been evaluated + -- and hence there's no point in re-evaluating it. + -- @OtherCon []@ is used even for non-data-type values + -- to indicated evaluated-ness. Notably: + -- + -- > data C = C !(Int -> Int) + -- > case x of { C f -> ... } + -- + -- Here, @f@ gets an @OtherCon []@ unfolding. + + | DFunUnfolding DataCon [CoreExpr] + -- The Unfolding of a DFunId + -- df = /\a1..am. \d1..dn. MkD (op1 a1..am d1..dn) + -- (op2 a1..am d1..dn) + -- where Arity = n, the number of dict args to the dfun + -- The [CoreExpr] are the superclasses and methods [op1,op2], + -- in positional order. + -- They are usually variables, but can be trivial expressions + -- instead (e.g. a type application). + + | CoreUnfolding { -- An unfolding for an Id with no pragma, or perhaps a NOINLINE pragma + -- (For NOINLINE, the phase, if any, is in the InlinePragInfo for this Id.) + uf_tmpl :: CoreExpr, -- Template; occurrence info is correct + uf_src :: UnfoldingSource, -- Where the unfolding came from + uf_is_top :: Bool, -- True <=> top level binding + uf_arity :: Arity, -- Number of value arguments expected + uf_is_value :: Bool, -- exprIsHNF template (cached); it is ok to discard a `seq` on + -- this variable + uf_is_conlike :: Bool, -- True <=> application of constructor or CONLIKE function + -- Cached version of exprIsConLike + uf_is_cheap :: Bool, -- True <=> doesn't waste (much) work to expand inside an inlining + -- Cached version of exprIsCheap + uf_expandable :: Bool, -- True <=> can expand in RULE matching + -- Cached version of exprIsExpandable + uf_guidance :: UnfoldingGuidance -- Tells about the *size* of the template. + } -- ^ An unfolding with redundant cached information. Parameters: -- - -- 1) Template used to perform unfolding; binder-info is correct + -- uf_tmpl: Template used to perform unfolding; + -- NB: Occurrence info is guaranteed correct: + -- see Note [OccInfo in unfoldings and rules] -- - -- 2) Is this a top level binding? + -- uf_is_top: Is this a top level binding? -- - -- 3) 'exprIsHNF' template (cached); it is ok to discard a 'seq' on + -- uf_is_value: 'exprIsHNF' template (cached); it is ok to discard a 'seq' on -- this variable -- - -- 4) Does this waste only a little work if we expand it inside an inlining? + -- uf_is_cheap: Does this waste only a little work if we expand it inside an inlining? -- Basically this is a cached version of 'exprIsCheap' -- - -- 5) Tells us about the /size/ of the unfolding template + -- uf_guidance: Tells us about the /size/ of the unfolding template + +------------------------------------------------ +data UnfoldingSource + = InlineCompulsory -- Something that *has* no binding, so you *must* inline it + -- Only a few primop-like things have this property + -- (see MkId.lhs, calls to mkCompulsoryUnfolding). + -- Inline absolutely always, however boring the context. + + | InlineRule -- From an {-# INLINE #-} pragma; See Note [InlineRules] + + | InlineWrapper Id -- This unfolding is a the wrapper in a + -- worker/wrapper split from the strictness analyser + -- The Id is the worker-id + -- Used to abbreviate the uf_tmpl in interface files + -- which don't need to contain the RHS; + -- it can be derived from the strictness info + + | InlineRhs -- The current rhs of the function + + -- For InlineRhs, the uf_tmpl is replaced each time around + -- For all the others we leave uf_tmpl alone + --- | When unfolding should take place +-- | 'UnfoldingGuidance' says when unfolding should take place data UnfoldingGuidance - = UnfoldNever - | UnfoldIfGoodArgs Int -- and "n" value args + = UnfWhen { -- Inline without thinking about the *size* of the uf_tmpl + -- Used (a) for small *and* cheap unfoldings + -- (b) for INLINE functions + -- See Note [INLINE for small functions] in CoreUnfold + ug_unsat_ok :: Bool, -- True <=> ok to inline even if unsaturated + ug_boring_ok :: Bool -- True <=> ok to inline even if the context is boring + } + + | UnfIfGoodArgs { -- Arose from a normal Id; the info here is the + -- result of a simple analysis of the RHS + + ug_args :: [Int], -- Discount if the argument is evaluated. + -- (i.e., a simplification will definitely + -- be possible). One elt of the list per *value* arg. + + ug_size :: Int, -- The "size" of the unfolding. + + ug_res :: Int -- Scrutinee discount: the discount to substract if the thing is in + } -- a context (case (thing args) of ...), + -- (where there are the right number of arguments.) + + | UnfNever -- The RHS is big, so don't inline it - [Int] -- Discount if the argument is evaluated. - -- (i.e., a simplification will definitely - -- be possible). One elt of the list per *value* arg. - - Int -- The "size" of the unfolding; to be elaborated - -- later. ToDo - - Int -- Scrutinee discount: the discount to substract if the thing is in - -- a context (case (thing args) of ...), - -- (where there are the right number of arguments.) +-- Constants for the UnfWhen constructor +needSaturated, unSaturatedOk :: Bool +needSaturated = False +unSaturatedOk = True +boringCxtNotOk, boringCxtOk :: Bool +boringCxtOk = True +boringCxtNotOk = False + +------------------------------------------------ noUnfolding :: Unfolding -- ^ There is no known 'Unfolding' evaldUnfolding :: Unfolding @@ -457,27 +513,37 @@ mkOtherCon = OtherCon seqUnfolding :: Unfolding -> () -seqUnfolding (CoreUnfolding e top b1 b2 b3 g) - = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` seqGuidance g +seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top, + uf_is_value = b1, uf_is_cheap = b2, + uf_expandable = b3, uf_is_conlike = b4, + uf_arity = a, uf_guidance = g}) + = seqExpr e `seq` top `seq` b1 `seq` a `seq` b2 `seq` b3 `seq` b4 `seq` seqGuidance g + seqUnfolding _ = () seqGuidance :: UnfoldingGuidance -> () -seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` () -seqGuidance _ = () +seqGuidance (UnfIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` () +seqGuidance _ = () \end{code} \begin{code} +isInlineRuleSource :: UnfoldingSource -> Bool +isInlineRuleSource InlineCompulsory = True +isInlineRuleSource InlineRule = True +isInlineRuleSource (InlineWrapper {}) = True +isInlineRuleSource InlineRhs = False + -- | Retrieves the template of an unfolding: panics if none is known unfoldingTemplate :: Unfolding -> CoreExpr -unfoldingTemplate (CoreUnfolding expr _ _ _ _ _) = expr -unfoldingTemplate (CompulsoryUnfolding expr) = expr -unfoldingTemplate _ = panic "getUnfoldingTemplate" +unfoldingTemplate = uf_tmpl + +setUnfoldingTemplate :: Unfolding -> CoreExpr -> Unfolding +setUnfoldingTemplate unf rhs = unf { uf_tmpl = rhs } -- | Retrieves the template of an unfolding if possible maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr -maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _ _) = Just expr -maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr -maybeUnfoldingTemplate _ = Nothing +maybeUnfoldingTemplate (CoreUnfolding { uf_tmpl = expr }) = Just expr +maybeUnfoldingTemplate _ = Nothing -- | The constructors that the unfolding could never be: -- returns @[]@ if no information is available @@ -488,51 +554,131 @@ -- | Determines if it is certainly the case that the unfolding will -- yield a value (something in HNF): returns @False@ if unsure isValueUnfolding :: Unfolding -> Bool -isValueUnfolding (CoreUnfolding _ _ is_evald _ _ _) = is_evald -isValueUnfolding _ = False + -- Returns False for OtherCon +isValueUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald +isValueUnfolding _ = False -- | Determines if it possibly the case that the unfolding will -- yield a value. Unlike 'isValueUnfolding' it returns @True@ -- for 'OtherCon' isEvaldUnfolding :: Unfolding -> Bool -isEvaldUnfolding (OtherCon _) = True -isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _ _) = is_evald -isEvaldUnfolding _ = False + -- Returns True for OtherCon +isEvaldUnfolding (OtherCon _) = True +isEvaldUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald +isEvaldUnfolding _ = False + +-- | @True@ if the unfolding is a constructor application, the application +-- of a CONLIKE function or 'OtherCon' +isConLikeUnfolding :: Unfolding -> Bool +isConLikeUnfolding (OtherCon _) = True +isConLikeUnfolding (CoreUnfolding { uf_is_conlike = con }) = con +isConLikeUnfolding _ = False -- | Is the thing we will unfold into certainly cheap? isCheapUnfolding :: Unfolding -> Bool -isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _ _) = is_cheap -isCheapUnfolding _ = False +isCheapUnfolding (CoreUnfolding { uf_is_cheap = is_cheap }) = is_cheap +isCheapUnfolding _ = False isExpandableUnfolding :: Unfolding -> Bool -isExpandableUnfolding (CoreUnfolding _ _ _ _ is_expable _) = is_expable -isExpandableUnfolding _ = False +isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expable +isExpandableUnfolding _ = False + +expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr +-- Expand an expandable unfolding; this is used in rule matching +-- See Note [Expanding variables] in Rules.lhs +-- The key point here is that CONLIKE things can be expanded +expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs +expandUnfolding_maybe _ = Nothing + +isInlineRule :: Unfolding -> Bool +isInlineRule (CoreUnfolding { uf_src = src }) = isInlineRuleSource src +isInlineRule _ = False + +isInlineRule_maybe :: Unfolding -> Maybe (UnfoldingSource, Bool) +isInlineRule_maybe (CoreUnfolding { uf_src = src, uf_guidance = guide }) + | isInlineRuleSource src + = Just (src, unsat_ok) + where + unsat_ok = case guide of + UnfWhen unsat_ok _ -> unsat_ok + _ -> needSaturated +isInlineRule_maybe _ = Nothing --- | Must this unfolding happen for the code to be executable? isCompulsoryUnfolding :: Unfolding -> Bool -isCompulsoryUnfolding (CompulsoryUnfolding _) = True -isCompulsoryUnfolding _ = False +isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True +isCompulsoryUnfolding _ = False --- | Do we have an available or compulsory unfolding? -hasUnfolding :: Unfolding -> Bool -hasUnfolding (CoreUnfolding _ _ _ _ _ _) = True -hasUnfolding (CompulsoryUnfolding _) = True -hasUnfolding _ = False +isStableUnfolding :: Unfolding -> Bool +-- True of unfoldings that should not be overwritten +-- by a CoreUnfolding for the RHS of a let-binding +isStableUnfolding (CoreUnfolding { uf_src = src }) = isInlineRuleSource src +isStableUnfolding (DFunUnfolding {}) = True +isStableUnfolding _ = False + +unfoldingArity :: Unfolding -> Arity +unfoldingArity (CoreUnfolding { uf_arity = arity }) = arity +unfoldingArity _ = panic "unfoldingArity" + +isClosedUnfolding :: Unfolding -> Bool -- No free variables +isClosedUnfolding (CoreUnfolding {}) = False +isClosedUnfolding _ = True -- | Only returns False if there is no unfolding information available at all hasSomeUnfolding :: Unfolding -> Bool hasSomeUnfolding NoUnfolding = False hasSomeUnfolding _ = True --- | Similar to @not . hasUnfolding@, but also returns @True@ --- if it has an unfolding that says it should never occur -neverUnfold :: Unfolding -> Bool -neverUnfold NoUnfolding = True -neverUnfold (OtherCon _) = True -neverUnfold (CoreUnfolding _ _ _ _ _ UnfoldNever) = True -neverUnfold _ = False +neverUnfoldGuidance :: UnfoldingGuidance -> Bool +neverUnfoldGuidance UnfNever = True +neverUnfoldGuidance _ = False + +canUnfold :: Unfolding -> Bool +canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g) +canUnfold _ = False \end{code} +Note [InlineRules] +~~~~~~~~~~~~~~~~~ +When you say + {-# INLINE f #-} + f x = +you intend that calls (f e) are replaced by [e/x] So we +should capture (\x.) in the Unfolding of 'f', and never meddle +with it. Meanwhile, we can optimise to our heart's content, +leaving the original unfolding intact in Unfolding of 'f'. For example + all xs = foldr (&&) True xs + any p = all . map p {-# INLINE any #-} +We optimise any's RHS fully, but leave the InlineRule saying "all . map p", +which deforests well at the call site. + +So INLINE pragma gives rise to an InlineRule, which captures the original RHS. + +Moreover, it's only used when 'f' is applied to the +specified number of arguments; that is, the number of argument on +the LHS of the '=' sign in the original source definition. +For example, (.) is now defined in the libraries like this + {-# INLINE (.) #-} + (.) f g = \x -> f (g x) +so that it'll inline when applied to two arguments. If 'x' appeared +on the left, thus + (.) f g x = f (g x) +it'd only inline when applied to three arguments. This slightly-experimental +change was requested by Roman, but it seems to make sense. + +See also Note [Inlining an InlineRule] in CoreUnfold. + + +Note [OccInfo in unfoldings and rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In unfoldings and rules, we guarantee that the template is occ-analysed, +so that the occurence info on the binders is correct. This is important, +because the Simplifier does not re-analyse the template when using it. If +the occurrence info is wrong + - We may get more simpifier iterations than necessary, because + once-occ info isn't there + - More seriously, we may get an infinite loop if there's a Rec + without a loop breaker marked + %************************************************************************ %* * diff -ruN ghc-6.12.1/compiler/coreSyn/CoreTidy.lhs ghc-6.13.20091231/compiler/coreSyn/CoreTidy.lhs --- ghc-6.12.1/compiler/coreSyn/CoreTidy.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/coreSyn/CoreTidy.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -153,10 +153,10 @@ -- separate compilation boundaries final_id = new_id `setIdInfo` new_info idinfo = idInfo id - new_info = vanillaIdInfo + new_info = idInfo new_id `setArityInfo` exprArity rhs - `setAllStrictnessInfo` newStrictnessInfo idinfo - `setNewDemandInfo` newDemandInfo idinfo + `setStrictnessInfo` strictnessInfo idinfo + `setDemandInfo` demandInfo idinfo `setInlinePragInfo` inlinePragInfo idinfo -- Override the env we get back from tidyId with the new IdInfo @@ -166,7 +166,7 @@ -- Non-top-level variables tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id) tidyIdBndr env@(tidy_env, var_env) id - = -- do this pattern match strictly, otherwise we end up holding on to + = -- Do this pattern match strictly, otherwise we end up holding on to -- stuff in the OccName. case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> let @@ -174,24 +174,36 @@ -- The SrcLoc isn't important now, -- though we could extract it from the Id -- - -- All nested Ids now have the same IdInfo, namely vanillaIdInfo, - -- which should save some space; except that we hang onto dead-ness - -- (at the moment, solely to make printing tidy core nicer) - -- But note that tidyLetBndr puts some of it back. ty' = tidyType env (idType id) name' = mkInternalName (idUnique id) occ' noSrcSpan id' = mkLocalIdWithInfo name' ty' new_info var_env' = extendVarEnv var_env id id' - new_info | isDeadOcc (idOccInfo id) = deadIdInfo - | otherwise = vanillaIdInfo + + -- Note [Tidy IdInfo] + new_info = vanillaIdInfo `setOccInfo` occInfo old_info + old_info = idInfo id in - ((tidy_env', var_env'), id') + ((tidy_env', var_env'), id') } - -deadIdInfo :: IdInfo -deadIdInfo = vanillaIdInfo `setOccInfo` IAmDead \end{code} +Note [Tidy IdInfo] +~~~~~~~~~~~~~~~~~~ +All nested Ids now have the same IdInfo, namely vanillaIdInfo, which +should save some space; except that we preserve occurrence info for +two reasons: + + (a) To make printing tidy core nicer + + (b) Because we tidy RULES and InlineRules, which may then propagate + via --make into the compilation of the next module, and we want + the benefit of that occurrence analysis when we use the rule or + or inline the function. In particular, it's vital not to lose + loop-breaker info, else we get an infinite inlining loop + +Note that tidyLetBndr puts more IdInfo back. + + \begin{code} (=:) :: a -> (a -> b) -> b m =: k = m `seq` k m diff -ruN ghc-6.12.1/compiler/coreSyn/CoreUnfold.lhs ghc-6.13.20091231/compiler/coreSyn/CoreUnfold.lhs --- ghc-6.12.1/compiler/coreSyn/CoreUnfold.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/coreSyn/CoreUnfold.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -18,12 +18,10 @@ module CoreUnfold ( Unfolding, UnfoldingGuidance, -- Abstract types - noUnfolding, mkTopUnfolding, mkImplicitUnfolding, mkUnfolding, - mkCompulsoryUnfolding, seqUnfolding, - evaldUnfolding, mkOtherCon, otherCons, - unfoldingTemplate, maybeUnfoldingTemplate, - isEvaldUnfolding, isValueUnfolding, isExpandableUnfolding, isCompulsoryUnfolding, - hasUnfolding, hasSomeUnfolding, neverUnfold, + noUnfolding, mkImplicitUnfolding, + mkTopUnfolding, mkUnfolding, mkCoreUnfolding, + mkInlineRule, mkWwInlineRule, + mkCompulsoryUnfolding, mkDFunUnfolding, interestingArg, ArgSummary(..), @@ -32,24 +30,34 @@ callSiteInline, CallCtxt(..), + exprIsConApp_maybe + ) where +#include "HsVersions.h" + import StaticFlags import DynFlags import CoreSyn import PprCore () -- Instances import OccurAnal -import CoreSubst ( Subst, emptySubst, substTy, extendIdSubst, extendTvSubst - , lookupIdSubst, substBndr, substBndrs, substRecBndrs ) +import CoreSubst hiding( substTy ) +import CoreFVs ( exprFreeVars ) import CoreUtils import Id import DataCon +import TyCon import Literal import PrimOp import IdInfo -import Type hiding( substTy, extendTvSubst ) +import BasicTypes ( Arity ) +import TcType ( tcSplitDFunTy ) +import Type +import Coercion import PrelNames +import VarEnv ( mkInScopeSet ) import Bag +import Util import FastTypes import FastString import Outputable @@ -64,53 +72,87 @@ %************************************************************************ \begin{code} -mkTopUnfolding :: CoreExpr -> Unfolding -mkTopUnfolding expr = mkUnfolding True {- Top level -} expr +mkTopUnfolding :: Bool -> CoreExpr -> Unfolding +mkTopUnfolding is_bottoming expr + = mkUnfolding True {- Top level -} is_bottoming expr mkImplicitUnfolding :: CoreExpr -> Unfolding -- For implicit Ids, do a tiny bit of optimising first -mkImplicitUnfolding expr - = CoreUnfolding (simpleOptExpr emptySubst expr) - True - (exprIsHNF expr) - (exprIsCheap expr) - (exprIsExpandable expr) - (calcUnfoldingGuidance opt_UF_CreationThreshold expr) - -mkUnfolding :: Bool -> CoreExpr -> Unfolding -mkUnfolding top_lvl expr - = CoreUnfolding (occurAnalyseExpr expr) - top_lvl - - (exprIsHNF expr) - -- Already evaluated - - (exprIsCheap expr) - -- OK to inline inside a lambda +mkImplicitUnfolding expr = mkTopUnfolding False (simpleOptExpr expr) - (exprIsExpandable expr) - - (calcUnfoldingGuidance opt_UF_CreationThreshold expr) +-- Note [Top-level flag on inline rules] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Slight hack: note that mk_inline_rules conservatively sets the +-- top-level flag to True. It gets set more accurately by the simplifier +-- Simplify.simplUnfolding. + +mkUnfolding :: Bool -> Bool -> CoreExpr -> Unfolding +mkUnfolding top_lvl is_bottoming expr + = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, + uf_src = InlineRhs, + uf_arity = arity, + uf_is_top = top_lvl, + uf_is_value = exprIsHNF expr, + uf_is_conlike = exprIsConLike expr, + uf_expandable = exprIsExpandable expr, + uf_is_cheap = is_cheap, + uf_guidance = guidance } + where + is_cheap = exprIsCheap expr + (arity, guidance) = calcUnfoldingGuidance is_cheap (top_lvl && is_bottoming) + opt_UF_CreationThreshold expr -- Sometimes during simplification, there's a large let-bound thing -- which has been substituted, and so is now dead; so 'expr' contains -- two copies of the thing while the occurrence-analysed expression doesn't - -- Nevertheless, we don't occ-analyse before computing the size because the + -- Nevertheless, we *don't* occ-analyse before computing the size because the -- size computation bales out after a while, whereas occurrence analysis does not. -- -- This can occasionally mean that the guidance is very pessimistic; - -- it gets fixed up next round + -- it gets fixed up next round. And it should be rare, because large + -- let-bound things that are dead are usually caught by preInlineUnconditionally -instance Outputable Unfolding where - ppr NoUnfolding = ptext (sLit "No unfolding") - ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs - ppr (CompulsoryUnfolding e) = ptext (sLit "Compulsory") <+> ppr e - ppr (CoreUnfolding e top hnf cheap expable g) - = ptext (sLit "Unf") <+> sep [ppr top <+> ppr hnf <+> ppr cheap <+> ppr expable <+> ppr g, - ppr e] +mkCoreUnfolding :: Bool -> UnfoldingSource -> CoreExpr + -> Arity -> UnfoldingGuidance -> Unfolding +-- Occurrence-analyses the expression before capturing it +mkCoreUnfolding top_lvl src expr arity guidance + = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, + uf_src = src, + uf_arity = arity, + uf_is_top = top_lvl, + uf_is_value = exprIsHNF expr, + uf_is_conlike = exprIsConLike expr, + uf_is_cheap = exprIsCheap expr, + uf_expandable = exprIsExpandable expr, + uf_guidance = guidance } + +mkDFunUnfolding :: DataCon -> [Id] -> Unfolding +mkDFunUnfolding con ops = DFunUnfolding con (map Var ops) + +mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding +mkWwInlineRule id expr arity + = mkCoreUnfolding True (InlineWrapper id) + (simpleOptExpr expr) arity + (UnfWhen unSaturatedOk boringCxtNotOk) mkCompulsoryUnfolding :: CoreExpr -> Unfolding -mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded - = CompulsoryUnfolding (occurAnalyseExpr expr) +mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded + = mkCoreUnfolding True InlineCompulsory + expr 0 -- Arity of unfolding doesn't matter + (UnfWhen unSaturatedOk boringCxtOk) + +mkInlineRule :: Bool -> CoreExpr -> Arity -> Unfolding +mkInlineRule unsat_ok expr arity + = mkCoreUnfolding True InlineRule -- Note [Top-level flag on inline rules] + expr' arity + (UnfWhen unsat_ok boring_ok) + where + expr' = simpleOptExpr expr + boring_ok = case calcUnfoldingGuidance True -- Treat as cheap + False -- But not bottoming + (arity+1) expr' of + (_, UnfWhen _ boring_ok) -> boring_ok + _other -> boringCxtNotOk + -- See Note [INLINE for small functions] \end{code} @@ -121,75 +163,40 @@ %************************************************************************ \begin{code} -instance Outputable UnfoldingGuidance where - ppr UnfoldNever = ptext (sLit "NEVER") - ppr (UnfoldIfGoodArgs v cs size discount) - = hsep [ ptext (sLit "IF_ARGS"), int v, - brackets (hsep (map int cs)), - int size, - int discount ] -\end{code} - - -\begin{code} calcUnfoldingGuidance - :: Int -- bomb out if size gets bigger than this - -> CoreExpr -- expression to look at - -> UnfoldingGuidance -calcUnfoldingGuidance bOMB_OUT_SIZE expr - = case collect_val_bndrs expr of { (inline, val_binders, body) -> + :: Bool -- True <=> the rhs is cheap, or we want to treat it + -- as cheap (INLINE things) + -> Bool -- True <=> this is a top-level unfolding for a + -- diverging function; don't inline this + -> Int -- Bomb out if size gets bigger than this + -> CoreExpr -- Expression to look at + -> (Arity, UnfoldingGuidance) +calcUnfoldingGuidance expr_is_cheap top_bot bOMB_OUT_SIZE expr + = case collectBinders expr of { (bndrs, body) -> let - n_val_binders = length val_binders - - max_inline_size = n_val_binders+2 - -- The idea is that if there is an INLINE pragma (inline is True) - -- and there's a big body, we give a size of n_val_binders+2. This - -- This is just enough to fail the no-size-increase test in callSiteInline, - -- so that INLINE things don't get inlined into entirely boring contexts, - -- but no more. + val_bndrs = filter isId bndrs + n_val_bndrs = length val_bndrs + guidance + = case (sizeExpr (iUnbox bOMB_OUT_SIZE) val_bndrs body) of + TooBig -> UnfNever + SizeIs size cased_bndrs scrut_discount + | uncondInline n_val_bndrs (iBox size) && expr_is_cheap + -> UnfWhen needSaturated boringCxtOk + + | top_bot -- See Note [Do not inline top-level bottoming functions] + -> UnfNever + + | otherwise + -> UnfIfGoodArgs { ug_args = map (discount cased_bndrs) val_bndrs + , ug_size = iBox size + , ug_res = iBox scrut_discount } + + discount cbs bndr + = foldlBag (\acc (b',n) -> if bndr==b' then acc+n else acc) + 0 cbs in - case (sizeExpr (iUnbox bOMB_OUT_SIZE) val_binders body) of - - TooBig - | not inline -> UnfoldNever - -- A big function with an INLINE pragma must - -- have an UnfoldIfGoodArgs guidance - | otherwise -> UnfoldIfGoodArgs n_val_binders - (map (const 0) val_binders) - max_inline_size 0 - - SizeIs size cased_args scrut_discount - -> UnfoldIfGoodArgs - n_val_binders - (map discount_for val_binders) - final_size - (iBox scrut_discount) - where - boxed_size = iBox size - - final_size | inline = boxed_size `min` max_inline_size - | otherwise = boxed_size - - -- Sometimes an INLINE thing is smaller than n_val_binders+2. - -- A particular case in point is a constructor, which has size 1. - -- We want to inline this regardless, hence the `min` - - discount_for b = foldlBag (\acc (b',n) -> if b==b' then acc+n else acc) - 0 cased_args - } - where - collect_val_bndrs e = go False [] e - -- We need to be a bit careful about how we collect the - -- value binders. In ptic, if we see - -- __inline_me (\x y -> e) - -- We want to say "2 value binders". Why? So that - -- we take account of information given for the arguments - - go _ rev_vbs (Note InlineMe e) = go True rev_vbs e - go inline rev_vbs (Lam b e) | isId b = go inline (b:rev_vbs) e - | otherwise = go inline rev_vbs e - go inline rev_vbs e = (inline, reverse rev_vbs, e) + (n_val_bndrs, guidance) } \end{code} Note [Computing the size of an expression] @@ -214,6 +221,7 @@ -------------- 0 42# 0 x + 0 True 2 f x 1 Just x 4 f (g x) @@ -222,18 +230,37 @@ a function call to account for. Notice also that constructor applications are very cheap, because exposing them to a caller is so valuable. -Thing to watch out for -* We inline *unconditionally* if inlined thing is smaller (using sizeExpr) - than the thing it's replacing. Notice that +Note [Do not inline top-level bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The FloatOut pass has gone to some trouble to float out calls to 'error' +and similar friends. See Note [Bottoming floats] in SetLevels. +Do not re-inline them! But we *do* still inline if they are very small +(the uncondInline stuff). + + +Note [Unconditional inlining] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We inline *unconditionally* if inlined thing is smaller (using sizeExpr) +than the thing it's replacing. Notice that (f x) --> (g 3) -- YES, unconditionally (f x) --> x : [] -- YES, *even though* there are two -- arguments to the cons x --> g 3 -- NO x --> Just v -- NO - It's very important not to unconditionally replace a variable by - a non-atomic term. +It's very important not to unconditionally replace a variable by +a non-atomic term. + +\begin{code} +uncondInline :: Arity -> Int -> Bool +-- Inline unconditionally if there no size increase +-- Size of call is arity (+1 for the function) +-- See Note [Unconditional inlining] +uncondInline arity size + | arity == 0 = size == 0 + | otherwise = size <= arity + 1 +\end{code} \begin{code} @@ -248,45 +275,35 @@ sizeExpr bOMB_OUT_SIZE top_args expr = size_up expr where + size_up (Cast e _) = size_up e + size_up (Note _ e) = size_up e size_up (Type _) = sizeZero -- Types cost nothing size_up (Lit lit) = sizeN (litSize lit) - size_up (Var f) = size_up_call f 0 -- Make sure we get constructor + size_up (Var f) = size_up_call f [] -- Make sure we get constructor -- discounts even on nullary constructors - size_up (Cast e _) = size_up e - - size_up (Note InlineMe _) = sizeOne -- Inline notes make it look very small - -- This can be important. If you have an instance decl like this: - -- instance Foo a => Foo [a] where - -- {-# INLINE op1, op2 #-} - -- op1 = ... - -- op2 = ... - -- then we'll get a dfun which is a pair of two INLINE lambdas - size_up (Note _ body) = size_up body -- Other notes cost nothing size_up (App fun (Type _)) = size_up fun - size_up (App fun arg) = size_up_app fun [arg] - `addSize` nukeScrutDiscount (size_up arg) + size_up (App fun arg) = size_up arg `addSizeNSD` + size_up_app fun [arg] size_up (Lam b e) | isId b = lamScrutDiscount (size_up e `addSizeN` 1) | otherwise = size_up e size_up (Let (NonRec binder rhs) body) - = nukeScrutDiscount (size_up rhs) `addSize` - size_up body `addSizeN` + = size_up rhs `addSizeNSD` + size_up body `addSizeN` (if isUnLiftedType (idType binder) then 0 else 1) -- For the allocation -- If the binder has an unlifted type there is no allocation size_up (Let (Rec pairs) body) - = nukeScrutDiscount rhs_size `addSize` - size_up body `addSizeN` - length pairs -- For the allocation - where - rhs_size = foldr (addSize . size_up . snd) sizeZero pairs + = foldr (addSizeNSD . size_up . snd) + (size_up body `addSizeN` length pairs) -- (length pairs) for the allocation + pairs size_up (Case (Var v) _ _ alts) | v `elem` top_args -- We are scrutinising an argument variable - = alts_size (foldr addSize sizeOne alt_sizes) -- The 1 is for the case itself + = alts_size (foldr1 addAltSize alt_sizes) (foldr1 maxSize alt_sizes) -- Good to inline if an arg is scrutinised, because -- that may eliminate allocation in the caller @@ -296,9 +313,9 @@ -- alts_size tries to compute a good discount for -- the case when we are scrutinising an argument variable - alts_size (SizeIs tot tot_disc _tot_scrut) -- Size of all alternatives - (SizeIs max _max_disc max_scrut) -- Size of biggest alternative - = SizeIs tot (unitBag (v, iBox (_ILIT(1) +# tot -# max)) `unionBags` tot_disc) max_scrut + alts_size (SizeIs tot tot_disc tot_scrut) -- Size of all alternatives + (SizeIs max _ _) -- Size of biggest alternative + = SizeIs tot (unitBag (v, iBox (_ILIT(2) +# tot -# max)) `unionBags` tot_disc) tot_scrut -- If the variable is known, we produce a discount that -- will take us back to 'max', the size of the largest alternative -- The 1+ is a little discount for reduced allocation in the caller @@ -308,38 +325,43 @@ alts_size tot_size _ = tot_size - size_up (Case e _ _ alts) = foldr (addSize . size_up_alt) - (nukeScrutDiscount (size_up e)) - alts - `addSizeN` 1 -- Add 1 for the case itself + size_up (Case e _ _ alts) = size_up e `addSizeNSD` + foldr (addAltSize . size_up_alt) sizeZero alts -- We don't charge for the case itself -- It's a strict thing, and the price of the call -- is paid by scrut. Also consider -- case f x of DEFAULT -> e -- This is just ';'! Don't charge for it. + -- + -- Moreover, we charge one per alternative. ------------ -- size_up_app is used when there's ONE OR MORE value args size_up_app (App fun arg) args | isTypeArg arg = size_up_app fun args - | otherwise = size_up_app fun (arg:args) - `addSize` nukeScrutDiscount (size_up arg) - size_up_app (Var fun) args = size_up_call fun (length args) + | otherwise = size_up arg `addSizeNSD` + size_up_app fun (arg:args) + size_up_app (Var fun) args = size_up_call fun args size_up_app other args = size_up other `addSizeN` length args ------------ - size_up_call :: Id -> Int -> ExprSize - size_up_call fun n_val_args + size_up_call :: Id -> [CoreExpr] -> ExprSize + size_up_call fun val_args = case idDetails fun of FCallId _ -> sizeN opt_UF_DearOp - DataConWorkId dc -> conSize dc n_val_args - PrimOpId op -> primOpSize op n_val_args - _ -> funSize top_args fun n_val_args + DataConWorkId dc -> conSize dc (length val_args) + PrimOpId op -> primOpSize op (length val_args) + ClassOpId _ -> classOpSize top_args val_args + _ -> funSize top_args fun (length val_args) ------------ - size_up_alt (_con, _bndrs, rhs) = size_up rhs + size_up_alt (_con, _bndrs, rhs) = size_up rhs `addSizeN` 1 -- Don't charge for args, so that wrappers look cheap -- (See comments about wrappers with Case) + -- + -- IMPORATANT: *do* charge 1 for the alternative, else we + -- find that giant case nests are treated as practically free + -- A good example is Foreign.C.Error.errrnoToIOError ------------ -- These addSize things have to be here because @@ -347,10 +369,22 @@ addSizeN TooBig _ = TooBig addSizeN (SizeIs n xs d) m = mkSizeIs bOMB_OUT_SIZE (n +# iUnbox m) xs d - addSize TooBig _ = TooBig - addSize _ TooBig = TooBig - addSize (SizeIs n1 xs d1) (SizeIs n2 ys d2) - = mkSizeIs bOMB_OUT_SIZE (n1 +# n2) (xs `unionBags` ys) (d1 +# d2) + -- addAltSize is used to add the sizes of case alternatives + addAltSize TooBig _ = TooBig + addAltSize _ TooBig = TooBig + addAltSize (SizeIs n1 xs d1) (SizeIs n2 ys d2) + = mkSizeIs bOMB_OUT_SIZE (n1 +# n2) + (xs `unionBags` ys) + (d1 +# d2) -- Note [addAltSize result discounts] + + -- This variant ignores the result discount from its LEFT argument + -- It's used when the second argument isn't part of the result + addSizeNSD TooBig _ = TooBig + addSizeNSD _ TooBig = TooBig + addSizeNSD (SizeIs n1 xs _) (SizeIs n2 ys d2) + = mkSizeIs bOMB_OUT_SIZE (n1 +# n2) + (xs `unionBags` ys) + d2 -- Ignore d1 \end{code} \begin{code} @@ -365,6 +399,22 @@ -- Key point: if x |-> 4, then x must inline unconditionally -- (eg via case binding) +classOpSize :: [Id] -> [CoreExpr] -> ExprSize +-- See Note [Conlike is interesting] +classOpSize _ [] + = sizeZero +classOpSize top_args (arg1 : other_args) + = SizeIs (iUnbox size) arg_discount (_ILIT(0)) + where + size = 2 + length other_args + -- If the class op is scrutinising a lambda bound dictionary then + -- give it a discount, to encourage the inlining of this function + -- The actual discount is rather arbitrarily chosen + arg_discount = case arg1 of + Var dict | dict `elem` top_args + -> unitBag (dict, opt_UF_DictDiscount) + _other -> emptyBag + funSize :: [Id] -> Id -> Int -> ExprSize -- Size for functions that are not constructors or primops -- Note [Function applications] @@ -394,7 +444,7 @@ conSize :: DataCon -> Int -> ExprSize conSize dc n_val_args - | n_val_args == 0 = SizeIs (_ILIT(0)) emptyBag (_ILIT(1)) + | n_val_args == 0 = SizeIs (_ILIT(0)) emptyBag (_ILIT(1)) -- Like variables | isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (iUnbox n_val_args +# _ILIT(1)) | otherwise = SizeIs (_ILIT(1)) emptyBag (iUnbox n_val_args +# _ILIT(1)) -- Treat a constructors application as size 1, regardless of how @@ -440,16 +490,50 @@ -- Ditto (augment t (\cn -> e) ys) should cost only the cost of -- e plus ys. The -2 accounts for the \cn -nukeScrutDiscount :: ExprSize -> ExprSize -nukeScrutDiscount (SizeIs n vs _) = SizeIs n vs (_ILIT(0)) -nukeScrutDiscount TooBig = TooBig - -- When we return a lambda, give a discount if it's used (applied) lamScrutDiscount :: ExprSize -> ExprSize lamScrutDiscount (SizeIs n vs _) = SizeIs n vs (iUnbox opt_UF_FunAppDiscount) lamScrutDiscount TooBig = TooBig \end{code} +Note [addAltSize result discounts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When adding the size of alternatives, we *add* the result discounts +too, rather than take the *maximum*. For a multi-branch case, this +gives a discount for each branch that returns a constructor, making us +keener to inline. I did try using 'max' instead, but it makes nofib +'rewrite' and 'puzzle' allocate significantly more, and didn't make +binary sizes shrink significantly either. + +Note [Discounts and thresholds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Constants for discounts and thesholds are defined in main/StaticFlags, +all of form opt_UF_xxxx. They are: + +opt_UF_CreationThreshold (45) + At a definition site, if the unfolding is bigger than this, we + may discard it altogether + +opt_UF_UseThreshold (6) + At a call site, if the unfolding, less discounts, is smaller than + this, then it's small enough inline + +opt_UF_KeennessFactor (1.5) + Factor by which the discounts are multiplied before + subtracting from size + +opt_UF_DictDiscount (1) + The discount for each occurrence of a dictionary argument + as an argument of a class method. Should be pretty small + else big functions may get inlined + +opt_UF_FunAppDiscount (6) + Discount for a function argument that is applied. Quite + large, because if we inline we avoid the higher-order call. + +opt_UF_DearOp (4) + The size of a foreign call or not-dupable PrimOp + Note [Function applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -491,69 +575,51 @@ maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 ># n2 = s1 | otherwise = s2 -sizeZero, sizeOne :: ExprSize +sizeZero :: ExprSize sizeN :: Int -> ExprSize sizeZero = SizeIs (_ILIT(0)) emptyBag (_ILIT(0)) -sizeOne = SizeIs (_ILIT(1)) emptyBag (_ILIT(0)) sizeN n = SizeIs (iUnbox n) emptyBag (_ILIT(0)) \end{code} - - %************************************************************************ %* * \subsection[considerUnfolding]{Given all the info, do (not) do the unfolding} %* * %************************************************************************ -We have very limited information about an unfolding expression: (1)~so -many type arguments and so many value arguments expected---for our -purposes here, we assume we've got those. (2)~A ``size'' or ``cost,'' -a single integer. (3)~An ``argument info'' vector. For this, what we -have at the moment is a Boolean per argument position that says, ``I -will look with great favour on an explicit constructor in this -position.'' (4)~The ``discount'' to subtract if the expression -is being scrutinised. - -Assuming we have enough type- and value arguments (if not, we give up -immediately), then we see if the ``discounted size'' is below some -(semi-arbitrary) threshold. It works like this: for every argument -position where we're looking for a constructor AND WE HAVE ONE in our -hands, we get a (again, semi-arbitrary) discount [proportion to the -number of constructors in the type being scrutinized]. - -If we're in the context of a scrutinee ( \tr{(case of A .. -> ...;.. )}) -and the expression in question will evaluate to a constructor, we use -the computed discount size *for the result only* rather than -computing the argument discounts. Since we know the result of -the expression is going to be taken apart, discounting its size -is more accurate (see @sizeExpr@ above for how this discount size -is computed). - -We use this one to avoid exporting inlinings that we ``couldn't possibly -use'' on the other side. Can be overridden w/ flaggery. -Just the same as smallEnoughToInline, except that it has no actual arguments. +We use 'couldBeSmallEnoughToInline' to avoid exporting inlinings that +we ``couldn't possibly use'' on the other side. Can be overridden w/ +flaggery. Just the same as smallEnoughToInline, except that it has no +actual arguments. \begin{code} couldBeSmallEnoughToInline :: Int -> CoreExpr -> Bool -couldBeSmallEnoughToInline threshold rhs = case calcUnfoldingGuidance threshold rhs of - UnfoldNever -> False - _ -> True - -certainlyWillInline :: Unfolding -> Bool - -- Sees if the unfolding is pretty certain to inline -certainlyWillInline (CoreUnfolding _ _ _ is_cheap _ (UnfoldIfGoodArgs n_vals _ size _)) - = is_cheap && size - (n_vals+1) <= opt_UF_UseThreshold -certainlyWillInline _ - = False +couldBeSmallEnoughToInline threshold rhs + = case calcUnfoldingGuidance False False threshold rhs of + (_, UnfNever) -> False + _ -> True +---------------- smallEnoughToInline :: Unfolding -> Bool -smallEnoughToInline (CoreUnfolding _ _ _ _ _ (UnfoldIfGoodArgs _ _ size _)) +smallEnoughToInline (CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_size = size}}) = size <= opt_UF_UseThreshold smallEnoughToInline _ = False + +---------------- +certainlyWillInline :: Unfolding -> Bool + -- Sees if the unfolding is pretty certain to inline +certainlyWillInline (CoreUnfolding { uf_is_cheap = is_cheap, uf_arity = n_vals, uf_guidance = guidance }) + = case guidance of + UnfNever -> False + UnfWhen {} -> True + UnfIfGoodArgs { ug_size = size} + -> is_cheap && size - (n_vals +1) <= opt_UF_UseThreshold + +certainlyWillInline _ + = False \end{code} %************************************************************************ @@ -580,8 +646,8 @@ \begin{code} callSiteInline :: DynFlags - -> Bool -- True <=> the Id can be inlined -> Id -- The Id + -> Unfolding -- Its unfolding (if active) -> Bool -- True if there are are no arguments at all (incl type args) -> [ArgSummary] -- One for each value arg; True if it is interesting -> CallCtxt -- True <=> continuation is interesting @@ -595,11 +661,13 @@ data CallCtxt = BoringCtxt - | ArgCtxt Bool -- We're somewhere in the RHS of function with rules - -- => be keener to inline - Int -- We *are* the argument of a function with this arg discount - -- => be keener to inline - -- INVARIANT: ArgCtxt False 0 ==> BoringCtxt + | ArgCtxt -- We are somewhere in the argument of a function + Bool -- True <=> we're somewhere in the RHS of function with rules + -- False <=> we *are* the argument of a function with non-zero + -- arg discount + -- OR + -- we *are* the RHS of a let Note [RHS of lets] + -- In both cases, be a little keener to inline | ValAppCtxt -- We're applied to at least one value arg -- This arises when we have ((f x |> co) y) @@ -609,99 +677,80 @@ -- that decomposes its scrutinee instance Outputable CallCtxt where - ppr BoringCtxt = ptext (sLit "BoringCtxt") - ppr (ArgCtxt _ _) = ptext (sLit "ArgCtxt") - ppr CaseCtxt = ptext (sLit "CaseCtxt") - ppr ValAppCtxt = ptext (sLit "ValAppCtxt") - -callSiteInline dflags active_inline id lone_variable arg_infos cont_info - = case idUnfolding id of { - NoUnfolding -> Nothing ; - OtherCon _ -> Nothing ; - - CompulsoryUnfolding unf_template -> Just unf_template ; - -- CompulsoryUnfolding => there is no top-level binding - -- for these things, so we must inline it. - -- Only a couple of primop-like things have - -- compulsory unfoldings (see MkId.lhs). - -- We don't allow them to be inactive - - CoreUnfolding unf_template is_top is_value is_cheap is_expable guidance -> - + ppr BoringCtxt = ptext (sLit "BoringCtxt") + ppr (ArgCtxt rules) = ptext (sLit "ArgCtxt") <+> ppr rules + ppr CaseCtxt = ptext (sLit "CaseCtxt") + ppr ValAppCtxt = ptext (sLit "ValAppCtxt") + +callSiteInline dflags id unfolding lone_variable arg_infos cont_info + = case unfolding of { + NoUnfolding -> Nothing ; + OtherCon _ -> Nothing ; + DFunUnfolding {} -> Nothing ; -- Never unfold a DFun + CoreUnfolding { uf_tmpl = unf_template, uf_is_top = is_top, uf_is_value = is_value, + uf_is_cheap = is_cheap, uf_arity = uf_arity, uf_guidance = guidance } -> + -- uf_arity will typically be equal to (idArity id), + -- but may be less for InlineRules let + n_val_args = length arg_infos + saturated = n_val_args >= uf_arity + result | yes_or_no = Just unf_template | otherwise = Nothing - n_val_args = length arg_infos + interesting_args = any nonTriv arg_infos + -- NB: (any nonTriv arg_infos) looks at the + -- over-saturated args too which is "wrong"; + -- but if over-saturated we inline anyway. + + -- some_benefit is used when the RHS is small enough + -- and the call has enough (or too many) value + -- arguments (ie n_val_args >= arity). But there must + -- be *something* interesting about some argument, or the + -- result context, to make it worth inlining + some_benefit + | not saturated = interesting_args -- Under-saturated + -- Note [Unsaturated applications] + | n_val_args > uf_arity = True -- Over-saturated + | otherwise = interesting_args -- Saturated + || interesting_saturated_call + + interesting_saturated_call + = case cont_info of + BoringCtxt -> not is_top && uf_arity > 0 -- Note [Nested functions] + CaseCtxt -> not (lone_variable && is_value) -- Note [Lone variables] + ArgCtxt {} -> uf_arity > 0 -- Note [Inlining in ArgCtxt] + ValAppCtxt -> True -- Note [Cast then apply] - yes_or_no = active_inline && is_cheap && consider_safe - -- We consider even the once-in-one-branch - -- occurrences, because they won't all have been - -- caught by preInlineUnconditionally. In particular, - -- if the occurrence is once inside a lambda, and the - -- rhs is cheap but not a manifest lambda, then - -- pre-inline will not have inlined it for fear of - -- invalidating the occurrence info in the rhs. - - consider_safe - -- consider_safe decides whether it's a good idea to - -- inline something, given that there's no - -- work-duplication issue (the caller checks that). + (yes_or_no, extra_doc) = case guidance of - UnfoldNever -> False - UnfoldIfGoodArgs n_vals_wanted arg_discounts size res_discount - | uncond_inline -> True - | otherwise -> some_benefit && small_enough && inline_enough_args - - where - -- Inline unconditionally if there no size increase - -- Size of call is n_vals_wanted (+1 for the function) - uncond_inline - | n_vals_wanted == 0 = size == 0 - | otherwise = enough_args && (size <= n_vals_wanted + 1) - - enough_args = n_val_args >= n_vals_wanted - inline_enough_args = - not (dopt Opt_InlineIfEnoughArgs dflags) || enough_args - - - some_benefit = any nonTriv arg_infos || really_interesting_cont - -- There must be something interesting - -- about some argument, or the result - -- context, to make it worth inlining - - -- NB: (any nonTriv arg_infos) looks at the over-saturated - -- args too which is wrong; but if over-saturated - -- we'll probably inline anyway. - - really_interesting_cont - | n_val_args < n_vals_wanted = False -- Too few args - | n_val_args == n_vals_wanted = interesting_saturated_call - | otherwise = True -- Extra args - -- really_interesting_cont tells if the result of the - -- call is in an interesting context. - - interesting_saturated_call - = case cont_info of - BoringCtxt -> not is_top && n_vals_wanted > 0 -- Note [Nested functions] - CaseCtxt -> not lone_variable || not is_value -- Note [Lone variables] - ArgCtxt {} -> n_vals_wanted > 0 -- Note [Inlining in ArgCtxt] - ValAppCtxt -> True -- Note [Cast then apply] - - small_enough = (size - discount) <= opt_UF_UseThreshold - discount = computeDiscount n_vals_wanted arg_discounts - res_discount arg_infos cont_info + UnfNever -> (False, empty) + + UnfWhen unsat_ok boring_ok -> ( (unsat_ok || saturated) + && (boring_ok || some_benefit) + , empty ) + -- For the boring_ok part see Note [INLINE for small functions] + + UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size } + -> ( is_cheap && some_benefit && small_enough + , (text "discounted size =" <+> int discounted_size) ) + where + discounted_size = size - discount + small_enough = discounted_size <= opt_UF_UseThreshold + discount = computeDiscount uf_arity arg_discounts + res_discount arg_infos cont_info in - if dopt Opt_D_dump_inlinings dflags then + if (dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags) then pprTrace ("Considering inlining: " ++ showSDoc (ppr id)) - (vcat [text "active:" <+> ppr active_inline, - text "arg infos" <+> ppr arg_infos, + (vcat [text "arg infos" <+> ppr arg_infos, + text "uf arity" <+> ppr uf_arity, text "interesting continuation" <+> ppr cont_info, + text "some_benefit" <+> ppr some_benefit, text "is value:" <+> ppr is_value, text "is cheap:" <+> ppr is_cheap, - text "is expandable:" <+> ppr is_expable, text "guidance" <+> ppr guidance, + extra_doc, text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"]) result else @@ -709,6 +758,53 @@ } \end{code} +Note [RHS of lets] +~~~~~~~~~~~~~~~~~~ +Be a tiny bit keener to inline in the RHS of a let, because that might +lead to good thing later + f y = (y,y,y) + g y = let x = f y in ...(case x of (a,b,c) -> ...) ... +We'd inline 'f' if the call was in a case context, and it kind-of-is, +only we can't see it. So we treat the RHS of a let as not-totally-boring. + +Note [Unsaturated applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When a call is not saturated, we *still* inline if one of the +arguments has interesting structure. That's sometimes very important. +A good example is the Ord instance for Bool in Base: + + Rec { + $fOrdBool =GHC.Classes.D:Ord + @ Bool + ... + $cmin_ajX + + $cmin_ajX [Occ=LoopBreaker] :: Bool -> Bool -> Bool + $cmin_ajX = GHC.Classes.$dmmin @ Bool $fOrdBool + } + +But the defn of GHC.Classes.$dmmin is: + + $dmmin :: forall a. GHC.Classes.Ord a => a -> a -> a + {- Arity: 3, HasNoCafRefs, Strictness: SLL, + Unfolding: (\ @ a $dOrd :: GHC.Classes.Ord a x :: a y :: a -> + case @ a GHC.Classes.<= @ a $dOrd x y of wild { + GHC.Bool.False -> y GHC.Bool.True -> x }) -} + +We *really* want to inline $dmmin, even though it has arity 3, in +order to unravel the recursion. + + +Note [INLINE for small functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider {-# INLINE f #-} + f x = Just x + g y = f y +Then f's RHS is no larger than its LHS, so we should inline it +into even the most boring context. (We do so if there is no INLINE +pragma!) + + Note [Things to watch] ~~~~~~~~~~~~~~~~~~~~~~ * { y = I# 3; x = y `cast` co; ...case (x `cast` co) of ... } @@ -720,6 +816,21 @@ Make sure that x does not inline unconditionally! Lest we get extra allocation. +Note [Inlining an InlineRule] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An InlineRules is used for + (a) programmer INLINE pragmas + (b) inlinings from worker/wrapper + +For (a) the RHS may be large, and our contract is that we *only* inline +when the function is applied to all the arguments on the LHS of the +source-code defn. (The uf_arity in the rule.) + +However for worker/wrapper it may be worth inlining even if the +arity is not satisfied (as we do in the CoreUnfolding case) so we don't +require saturation. + + Note [Nested functions] ~~~~~~~~~~~~~~~~~~~~~~~ If a function has a nested defn we also record some-benefit, on the @@ -744,7 +855,7 @@ Note [Inlining in ArgCtxt] ~~~~~~~~~~~~~~~~~~~~~~~~~~ -The condition (n_vals_wanted > 0) here is very important, because otherwise +The condition (arity > 0) here is very important, because otherwise we end up inlining top-level stuff into useless places; eg x = I# 3# f = \y. g x @@ -755,16 +866,23 @@ slow-down). The motivation was test eyeball/inline1.hs; but that seems to work ok now. +NOTE: arguably, we should inline in ArgCtxt only if the result of the +call is at least CONLIKE. At least for the cases where we use ArgCtxt +for the RHS of a 'let', we only profit from the inlining if we get a +CONLIKE thing (modulo lets). + Note [Lone variables] ~~~~~~~~~~~~~~~~~~~~~ The "lone-variable" case is important. I spent ages messing about with unsatisfactory varaints, but this is nice. The idea is that if a variable appears all alone - as an arg of lazy fn, or rhs Stop - as scrutinee of a case Select - as arg of a strict fn ArgOf + + as an arg of lazy fn, or rhs BoringCtxt + as scrutinee of a case CaseCtxt + as arg of a fn ArgCtxt AND it is bound to a value + then we should not inline it (unless there is some other reason, e.g. is is the sole occurrence). That is what is happening at the use of 'lone_variable' in 'interesting_saturated_call'. @@ -798,6 +916,11 @@ important: in the NDP project, 'bar' generates a closure data structure rather than a list. + So the non-inlining of lone_variables should only apply if the + unfolding is regarded as cheap; because that is when exprIsConApp_maybe + looks through the unfolding. Hence the "&& is_cheap" in the + InlineRule branch. + * Even a type application or coercion isn't a lone variable. Consider case $fMonadST @ RealWorld of { :DMonad a b c -> c } @@ -840,7 +963,7 @@ CaseCtxt -> res_discount _other -> 4 `min` res_discount -- res_discount can be very large when a function returns - -- construtors; but we only want to invoke that large discount + -- constructors; but we only want to invoke that large discount -- when there's a case continuation. -- Otherwise we, rather arbitrarily, threshold it. Yuk. -- But we want to aovid inlining large functions that return @@ -873,10 +996,21 @@ If it's saturated and f hasn't inlined, then it's probably not going to now! +Note [Conlike is interesting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f d = ...((*) d x y)... + ... f (df d')... +where df is con-like. Then we'd really like to inline 'f' so that the +rule for (*) (df d) can fire. To do this + a) we give a discount for being an argument of a class-op (eg (*) d) + b) we say that a con-like argument (eg (df d)) is interesting + \begin{code} data ArgSummary = TrivArg -- Nothing interesting | NonTrivArg -- Arg has structure | ValueArg -- Arg is a con-app or PAP + -- ..or con-like. Note [Conlike is interesting] interestingArg :: CoreExpr -> ArgSummary -- See Note [Interesting arguments] @@ -885,13 +1019,15 @@ -- n is # value args to which the expression is applied go (Lit {}) _ = ValueArg go (Var v) n - | isDataConWorkId v = ValueArg + | isConLikeId v = ValueArg -- Experimenting with 'conlike' rather that + -- data constructors here | idArity v > n = ValueArg -- Catches (eg) primops with arity but no unfolding | n > 0 = NonTrivArg -- Saturated or unknown call - | evald_unfolding = ValueArg -- n==0; look for a value + | conlike_unfolding = ValueArg -- n==0; look for an interesting unfolding + -- See Note [Conlike is interesting] | otherwise = TrivArg -- n==0, no useful unfolding where - evald_unfolding = isEvaldUnfolding (idUnfolding v) + conlike_unfolding = isConLikeUnfolding (idUnfolding v) go (Type _) _ = TrivArg go (App fn (Type _)) n = go fn n @@ -910,75 +1046,171 @@ nonTriv _ = True \end{code} - %************************************************************************ %* * - The Very Simple Optimiser + exprIsConApp_maybe %* * %************************************************************************ +Note [exprIsConApp_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~ +exprIsConApp_maybe is a very important function. There are two principal +uses: + * case e of { .... } + * cls_op e, where cls_op is a class operation + +In both cases you want to know if e is of form (C e1..en) where C is +a data constructor. + +However e might not *look* as if \begin{code} -simpleOptExpr :: Subst -> CoreExpr -> CoreExpr --- Return an occur-analysed and slightly optimised expression --- The optimisation is very straightforward: just --- inline non-recursive bindings that are used only once, --- or wheere the RHS is trivial +-- | Returns @Just (dc, [t1..tk], [x1..xn])@ if the argument expression is +-- a *saturated* constructor application of the form @dc t1..tk x1 .. xn@, +-- where t1..tk are the *universally-qantified* type args of 'dc' +exprIsConApp_maybe :: IdUnfoldingFun -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr]) + +exprIsConApp_maybe id_unf (Note _ expr) + = exprIsConApp_maybe id_unf expr + -- We ignore all notes. For example, + -- case _scc_ "foo" (C a b) of + -- C a b -> e + -- should be optimised away, but it will be only if we look + -- through the SCC note. + +exprIsConApp_maybe id_unf (Cast expr co) + = -- Here we do the KPush reduction rule as described in the FC paper + -- The transformation applies iff we have + -- (C e1 ... en) `cast` co + -- where co :: (T t1 .. tn) ~ to_ty + -- The left-hand one must be a T, because exprIsConApp returned True + -- but the right-hand one might not be. (Though it usually will.) + + case exprIsConApp_maybe id_unf expr of { + Nothing -> Nothing ; + Just (dc, _dc_univ_args, dc_args) -> + + let (_from_ty, to_ty) = coercionKind co + dc_tc = dataConTyCon dc + in + case splitTyConApp_maybe to_ty of { + Nothing -> Nothing ; + Just (to_tc, to_tc_arg_tys) + | dc_tc /= to_tc -> Nothing + -- These two Nothing cases are possible; we might see + -- (C x y) `cast` (g :: T a ~ S [a]), + -- where S is a type function. In fact, exprIsConApp + -- will probably not be called in such circumstances, + -- but there't nothing wrong with it + + | otherwise -> + let + tc_arity = tyConArity dc_tc + dc_univ_tyvars = dataConUnivTyVars dc + dc_ex_tyvars = dataConExTyVars dc + arg_tys = dataConRepArgTys dc + + dc_eqs :: [(Type,Type)] -- All equalities from the DataCon + dc_eqs = [(mkTyVarTy tv, ty) | (tv,ty) <- dataConEqSpec dc] ++ + [getEqPredTys eq_pred | eq_pred <- dataConEqTheta dc] + + (ex_args, rest1) = splitAtList dc_ex_tyvars dc_args + (co_args, val_args) = splitAtList dc_eqs rest1 + + -- Make the "theta" from Fig 3 of the paper + gammas = decomposeCo tc_arity co + theta = zipOpenTvSubst (dc_univ_tyvars ++ dc_ex_tyvars) + (gammas ++ stripTypeArgs ex_args) + + -- Cast the existential coercion arguments + cast_co (ty1, ty2) (Type co) + = Type $ mkSymCoercion (substTy theta ty1) + `mkTransCoercion` co + `mkTransCoercion` (substTy theta ty2) + cast_co _ other_arg = pprPanic "cast_co" (ppr other_arg) + new_co_args = zipWith cast_co dc_eqs co_args + + -- Cast the value arguments (which include dictionaries) + new_val_args = zipWith cast_arg arg_tys val_args + cast_arg arg_ty arg = mkCoerce (substTy theta arg_ty) arg + in +#ifdef DEBUG + let dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tyvars, + ppr arg_tys, ppr dc_args, ppr _dc_univ_args, + ppr ex_args, ppr val_args] + in + ASSERT2( coreEqType _from_ty (mkTyConApp dc_tc _dc_univ_args), dump_doc ) + ASSERT2( all isTypeArg (ex_args ++ co_args), dump_doc ) + ASSERT2( equalLength val_args arg_tys, dump_doc ) +#endif + + Just (dc, to_tc_arg_tys, ex_args ++ new_co_args ++ new_val_args) + }} -simpleOptExpr subst expr - = go subst (occurAnalyseExpr expr) +exprIsConApp_maybe id_unf expr + = analyse expr [] where - go subst (Var v) = lookupIdSubst subst v - go subst (App e1 e2) = App (go subst e1) (go subst e2) - go subst (Type ty) = Type (substTy subst ty) - go _ (Lit lit) = Lit lit - go subst (Note note e) = Note note (go subst e) - go subst (Cast e co) = Cast (go subst e) (substTy subst co) - go subst (Let bind body) = go_bind subst bind body - go subst (Lam bndr body) = Lam bndr' (go subst' body) - where - (subst', bndr') = substBndr subst bndr - - go subst (Case e b ty as) = Case (go subst e) b' - (substTy subst ty) - (map (go_alt subst') as) - where - (subst', b') = substBndr subst b - - - ---------------------- - go_alt subst (con, bndrs, rhs) = (con, bndrs', go subst' rhs) - where - (subst', bndrs') = substBndrs subst bndrs - - ---------------------- - go_bind subst (Rec prs) body = Let (Rec (bndrs' `zip` rhss')) - (go subst' body) - where - (bndrs, rhss) = unzip prs - (subst', bndrs') = substRecBndrs subst bndrs - rhss' = map (go subst') rhss - - go_bind subst (NonRec b r) body = go_nonrec subst b (go subst r) body - - ---------------------- - go_nonrec subst b (Type ty') body - | isTyVar b = go (extendTvSubst subst b ty') body - -- let a::* = TYPE ty in - go_nonrec subst b r' body - | isId b -- let x = e in - , exprIsTrivial r' || safe_to_inline (idOccInfo b) - = go (extendIdSubst subst b r') body - go_nonrec subst b r' body - = Let (NonRec b' r') (go subst' body) - where - (subst', b') = substBndr subst b - - ---------------------- - -- Unconditionally safe to inline - safe_to_inline :: OccInfo -> Bool - safe_to_inline IAmDead = True - safe_to_inline (OneOcc in_lam one_br _) = not in_lam && one_br - safe_to_inline (IAmALoopBreaker {}) = False - safe_to_inline NoOccInfo = False -\end{code} \ No newline at end of file + analyse (App fun arg) args = analyse fun (arg:args) + analyse fun@(Lam {}) args = beta fun [] args + + analyse (Var fun) args + | Just con <- isDataConWorkId_maybe fun + , is_saturated + , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars con) args + = Just (con, stripTypeArgs univ_ty_args, rest_args) + + -- Look through dictionary functions; see Note [Unfolding DFuns] + | DFunUnfolding con ops <- unfolding + , is_saturated + , let (dfun_tvs, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun) + subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args)) + = Just (con, substTys subst dfun_res_tys, + [mkApps op args | op <- ops]) + + -- Look through unfoldings, but only cheap ones, because + -- we are effectively duplicating the unfolding + | Just rhs <- expandUnfolding_maybe unfolding + = -- pprTrace "expanding" (ppr fun $$ ppr rhs) $ + analyse rhs args + where + is_saturated = count isValArg args == idArity fun + unfolding = id_unf fun + + analyse _ _ = Nothing + + ----------- + beta (Lam v body) pairs (arg : args) + | isTypeArg arg + = beta body ((v,arg):pairs) args + + beta (Lam {}) _ _ -- Un-saturated, or not a type lambda + = Nothing + + beta fun pairs args + = case analyse (substExpr subst fun) args of + Nothing -> -- pprTrace "Bale out! exprIsConApp_maybe" doc $ + Nothing + Just ans -> -- pprTrace "Woo-hoo! exprIsConApp_maybe" doc $ + Just ans + where + subst = mkOpenSubst (mkInScopeSet (exprFreeVars fun)) pairs + -- doc = vcat [ppr fun, ppr expr, ppr pairs, ppr args] + + +stripTypeArgs :: [CoreExpr] -> [Type] +stripTypeArgs args = ASSERT2( all isTypeArg args, ppr args ) + [ty | Type ty <- args] +\end{code} + +Note [Unfolding DFuns] +~~~~~~~~~~~~~~~~~~~~~~ +DFuns look like + + df :: forall a b. (Eq a, Eq b) -> Eq (a,b) + df a b d_a d_b = MkEqD (a,b) ($c1 a b d_a d_b) + ($c2 a b d_a d_b) + +So to split it up we just need to apply the ops $c1, $c2 etc +to the very same args as the dfun. It takes a little more work +to compute the type arguments to the dictionary constructor. + diff -ruN ghc-6.12.1/compiler/coreSyn/CoreUtils.lhs ghc-6.13.20091231/compiler/coreSyn/CoreUtils.lhs --- ghc-6.12.1/compiler/coreSyn/CoreUtils.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/coreSyn/CoreUtils.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -16,7 +16,7 @@ -- | Commonly useful utilites for manipulating the Core language module CoreUtils ( -- * Constructing expressions - mkInlineMe, mkSCC, mkCoerce, mkCoerceI, + mkSCC, mkCoerce, mkCoerceI, bindNonRec, needsCaseBinding, mkAltExpr, mkPiType, mkPiTypes, @@ -26,9 +26,8 @@ -- * Properties of expressions exprType, coreAltType, coreAltsType, exprIsDupable, exprIsTrivial, exprIsCheap, exprIsExpandable, - exprIsHNF,exprOkForSpeculation, exprIsBig, - exprIsConApp_maybe, exprIsBottom, - rhsIsStatic, + exprIsHNF, exprOkForSpeculation, exprIsBig, exprIsConLike, + rhsIsStatic, isCheapApp, isExpandableApp, -- * Expression and bindings size coreBindsSize, exprSize, @@ -37,7 +36,7 @@ hashExpr, -- * Equality - cheapEqExpr, + cheapEqExpr, eqExpr, eqExprX, -- * Manipulating data constructors and types applyTypeToArgs, applyTypeToArg, @@ -62,7 +61,7 @@ import PrimOp import Id import IdInfo -import NewDemand +import TcType ( isPredTy ) import Type import Coercion import TyCon @@ -193,47 +192,6 @@ %* * %************************************************************************ -mkNote removes redundant coercions, and SCCs where possible - -\begin{code} -#ifdef UNUSED -mkNote :: Note -> CoreExpr -> CoreExpr -mkNote (SCC cc) expr = mkSCC cc expr -mkNote InlineMe expr = mkInlineMe expr -mkNote note expr = Note note expr -#endif -\end{code} - -Drop trivial InlineMe's. This is somewhat important, because if we have an unfolding -that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may -not be *applied* to anything. - -We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper -bindings like - fw = ... - f = inline_me (coerce t fw) -As usual, the inline_me prevents the worker from getting inlined back into the wrapper. -We want the split, so that the coerces can cancel at the call site. - -However, we can get left with tiresome type applications. Notably, consider - f = /\ a -> let t = e in (t, w) -Then lifting the let out of the big lambda gives - t' = /\a -> e - f = /\ a -> let t = inline_me (t' a) in (t, w) -The inline_me is to stop the simplifier inlining t' right back -into t's RHS. In the next phase we'll substitute for t (since -its rhs is trivial) and *then* we could get rid of the inline_me. -But it hardly seems worth it, so I don't bother. - -\begin{code} --- | Wraps the given expression in an inlining hint unless the expression --- is trivial in some sense, so that doing so would usually hurt us -mkInlineMe :: CoreExpr -> CoreExpr -mkInlineMe e@(Var _) = e -mkInlineMe e@(Note InlineMe _) = e -mkInlineMe e = Note InlineMe e -\end{code} - \begin{code} -- | Wrap the given expression in the coercion, dropping identity coercions and coalescing nested coercions mkCoerceI :: CoercionI -> CoreExpr -> CoreExpr @@ -253,7 +211,7 @@ -- if to_ty `coreEqType` from_ty -- then expr -- else - ASSERT2(from_ty `coreEqType` (exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ ppr (coercionKindPredTy co)) + WARN(not (from_ty `coreEqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ pprEqPred (coercionKind co)) (Cast expr co) \end{code} @@ -418,13 +376,14 @@ filters down the matching alternatives in Simplify.rebuildCase. - %************************************************************************ %* * -\subsection{Figuring out things about expressions} + exprIsTrivial %* * %************************************************************************ +Note [exprIsTrivial] +~~~~~~~~~~~~~~~~~~~~ @exprIsTrivial@ is true of expressions we are unconditionally happy to duplicate; simple variables and constants, and type applications. Note that primop Ids aren't considered @@ -465,6 +424,14 @@ \end{code} +%************************************************************************ +%* * + exprIsDupable +%* * +%************************************************************************ + +Note [exprIsDupable] +~~~~~~~~~~~~~~~~~~~~ @exprIsDupable@ is true of expressions that can be duplicated at a modest cost in code size. This will only happen in different case branches, so there's no issue about duplicating work. @@ -478,12 +445,11 @@ \begin{code} exprIsDupable :: CoreExpr -> Bool -exprIsDupable (Type _) = True -exprIsDupable (Var _) = True -exprIsDupable (Lit lit) = litIsDupable lit -exprIsDupable (Note InlineMe _) = True -exprIsDupable (Note _ e) = exprIsDupable e -exprIsDupable (Cast e _) = exprIsDupable e +exprIsDupable (Type _) = True +exprIsDupable (Var _) = True +exprIsDupable (Lit lit) = litIsDupable lit +exprIsDupable (Note _ e) = exprIsDupable e +exprIsDupable (Cast e _) = exprIsDupable e exprIsDupable expr = go expr 0 where @@ -497,6 +463,14 @@ dupAppSize = 4 -- Size of application we are prepared to duplicate \end{code} +%************************************************************************ +%* * + exprIsCheap, exprIsExpandable +%* * +%************************************************************************ + +Note [exprIsCheap] +~~~~~~~~~~~~~~~~~~ @exprIsCheap@ looks at a Core expression and returns \tr{True} if it is obviously in weak head normal form, or is cheap to get to WHNF. [Note that that's not the same as exprIsDupable; an expression might be @@ -526,28 +500,37 @@ because sharing will make sure it is only evaluated once. \begin{code} -exprIsCheap' :: (Id -> Bool) -> CoreExpr -> Bool -exprIsCheap' _ (Lit _) = True -exprIsCheap' _ (Type _) = True -exprIsCheap' _ (Var _) = True -exprIsCheap' _ (Note InlineMe _) = True -exprIsCheap' is_conlike (Note _ e) = exprIsCheap' is_conlike e -exprIsCheap' is_conlike (Cast e _) = exprIsCheap' is_conlike e -exprIsCheap' is_conlike (Lam x e) = isRuntimeVar x - || exprIsCheap' is_conlike e -exprIsCheap' is_conlike (Case e _ _ alts) = exprIsCheap' is_conlike e && - and [exprIsCheap' is_conlike rhs | (_,_,rhs) <- alts] +exprIsCheap :: CoreExpr -> Bool +exprIsCheap = exprIsCheap' isCheapApp + +exprIsExpandable :: CoreExpr -> Bool +exprIsExpandable = exprIsCheap' isExpandableApp -- See Note [CONLIKE pragma] in BasicTypes + + +exprIsCheap' :: (Id -> Int -> Bool) -> CoreExpr -> Bool +exprIsCheap' _ (Lit _) = True +exprIsCheap' _ (Type _) = True +exprIsCheap' _ (Var _) = True +exprIsCheap' good_app (Note _ e) = exprIsCheap' good_app e +exprIsCheap' good_app (Cast e _) = exprIsCheap' good_app e +exprIsCheap' good_app (Lam x e) = isRuntimeVar x + || exprIsCheap' good_app e + +exprIsCheap' good_app (Case e _ _ alts) = exprIsCheap' good_app e && + and [exprIsCheap' good_app rhs | (_,_,rhs) <- alts] -- Experimentally, treat (case x of ...) as cheap -- (and case __coerce x etc.) -- This improves arities of overloaded functions where -- there is only dictionary selection (no construction) involved -exprIsCheap' is_conlike (Let (NonRec x _) e) - | isUnLiftedType (idType x) = exprIsCheap' is_conlike e + +exprIsCheap' good_app (Let (NonRec x _) e) + | isUnLiftedType (idType x) = exprIsCheap' good_app e | otherwise = False - -- strict lets always have cheap right hand sides, - -- and do no allocation. + -- Strict lets always have cheap right hand sides, + -- and do no allocation, so just look at the body + -- Non-strict lets do allocation so we don't treat them as cheap -exprIsCheap' is_conlike other_expr -- Applications and variables +exprIsCheap' good_app other_expr -- Applications and variables = go other_expr [] where -- Accumulate value arguments, then decide @@ -558,14 +541,12 @@ -- (f t1 t2 t3) counts as WHNF go (Var f) args = case idDetails f of - RecSelId {} -> go_sel args - ClassOpId _ -> go_sel args - PrimOpId op -> go_primop op args - - _ | is_conlike f -> go_pap args - | length args < idArity f -> go_pap args - - _ -> isBottomingId f + RecSelId {} -> go_sel args + ClassOpId {} -> go_sel args + PrimOpId op -> go_primop op args + _ | good_app f (length args) -> go_pap args + | isBottomingId f -> True + | otherwise -> False -- Application of a function which -- always gives bottom; we treat this as cheap -- because it certainly doesn't need to be shared! @@ -580,25 +561,58 @@ -- We'll put up with one constructor application, but not dozens -------------- - go_primop op args = primOpIsCheap op && all (exprIsCheap' is_conlike) args + go_primop op args = primOpIsCheap op && all (exprIsCheap' good_app) args -- In principle we should worry about primops -- that return a type variable, since the result -- might be applied to something, but I'm not going -- to bother to check the number of args -------------- - go_sel [arg] = exprIsCheap' is_conlike arg -- I'm experimenting with making record selection + go_sel [arg] = exprIsCheap' good_app arg -- I'm experimenting with making record selection go_sel _ = False -- look cheap, so we will substitute it inside a -- lambda. Particularly for dictionary field selection. -- BUT: Take care with (sel d x)! The (sel d) might be cheap, but -- there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1) -exprIsCheap :: CoreExpr -> Bool -exprIsCheap = exprIsCheap' isDataConWorkId +isCheapApp :: Id -> Int -> Bool +isCheapApp fn n_val_args + = isDataConWorkId fn + || n_val_args < idArity fn + +isExpandableApp :: Id -> Int -> Bool +isExpandableApp fn n_val_args + = isConLikeId fn + || n_val_args < idArity fn + || go n_val_args (idType fn) + where + -- See if all the arguments are PredTys (implicit params or classes) + -- If so we'll regard it as expandable; see Note [Expandable overloadings] + go 0 _ = True + go n_val_args ty + | Just (_, ty) <- splitForAllTy_maybe ty = go n_val_args ty + | Just (arg, ty) <- splitFunTy_maybe ty + , isPredTy arg = go (n_val_args-1) ty + | otherwise = False +\end{code} + +Note [Expandable overloadings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose the user wrote this + {-# RULE forall x. foo (negate x) = h x #-} + f x = ....(foo (negate x)).... +He'd expect the rule to fire. But since negate is overloaded, we might +get this: + f = \d -> let n = negate d in \x -> ...foo (n x)... +So we treat the application of a function (negate in this case) to a +*dictionary* as expandable. In effect, every function is CONLIKE when +it's applied only to dictionaries. -exprIsExpandable :: CoreExpr -> Bool -exprIsExpandable = exprIsCheap' isConLikeId -\end{code} + +%************************************************************************ +%* * + exprOkForSpeculation +%* * +%************************************************************************ \begin{code} -- | 'exprOkForSpeculation' returns True of an expression that is: @@ -641,6 +655,11 @@ && not (isTickBoxOp v) exprOkForSpeculation (Note _ e) = exprOkForSpeculation e exprOkForSpeculation (Cast e _) = exprOkForSpeculation e + +exprOkForSpeculation (Case e _ _ alts) + = exprOkForSpeculation e -- Note [exprOkForSpeculation: case expressions] + && all (\(_,_,rhs) -> exprOkForSpeculation rhs) alts + exprOkForSpeculation other_expr = case collectArgs other_expr of (Var f, args) -> spec_ok (idDetails f) args @@ -665,6 +684,10 @@ -- A bit conservative: we don't really need -- to care about lazy arguments, but this is easy + spec_ok (DFunId new_type) _ = not new_type + -- DFuns terminate, unless the dict is implemented with a newtype + -- in which case they may not + spec_ok _ _ = False -- | True of dyadic operators that can fail only if the second arg is zero! @@ -681,39 +704,57 @@ isDivOp _ = False \end{code} -\begin{code} --- | True of expressions that are guaranteed to diverge upon execution -exprIsBottom :: CoreExpr -> Bool -exprIsBottom e = go 0 e - where - -- n is the number of args - go n (Note _ e) = go n e - go n (Cast e _) = go n e - go n (Let _ e) = go n e - go _ (Case e _ _ _) = go 0 e -- Just check the scrut - go n (App e _) = go (n+1) e - go n (Var v) = idAppIsBottom v n - go _ (Lit _) = False - go _ (Lam _ _) = False - go _ (Type _) = False +Note [exprOkForSpeculation: case expressions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -idAppIsBottom :: Id -> Int -> Bool -idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args -\end{code} +It's always sound for exprOkForSpeculation to return False, and we +don't want it to take too long, so it bales out on complicated-looking +terms. Notably lets, which can be stacked very deeply; and in any +case the argument of exprOkForSpeculation is usually in a strict context, +so any lets will have been floated away. + +However, we keep going on case-expressions. An example like this one +showed up in DPH code: + foo :: Int -> Int + foo 0 = 0 + foo n = (if n < 5 then 1 else 2) `seq` foo (n-1) + +If exprOkForSpeculation doesn't look through case expressions, you get this: + T.$wfoo = + \ (ww :: GHC.Prim.Int#) -> + case ww of ds { + __DEFAULT -> case (case <# ds 5 of _ { + GHC.Bool.False -> lvl1; + GHC.Bool.True -> lvl}) + of _ { __DEFAULT -> + T.$wfoo (GHC.Prim.-# ds_XkE 1) }; + 0 -> 0 + } + +The inner case is redundant, and should be nuked. -\begin{code} --- | This returns true for expressions that are certainly /already/ +%************************************************************************ +%* * + exprIsHNF, exprIsConLike +%* * +%************************************************************************ + +\begin{code} +-- Note [exprIsHNF] +-- ~~~~~~~~~~~~~~~~ +-- | exprIsHNF returns true for expressions that are certainly /already/ -- evaluated to /head/ normal form. This is used to decide whether it's ok -- to change: -- -- > case x of _ -> e -- --- into: +-- into: -- -- > e -- -- and to decide whether it's safe to discard a 'seq'. +-- -- So, it does /not/ treat variables as evaluated, unless they say they are. -- However, it /does/ treat partial applications and constructor applications -- as values, even if their arguments are non-trivial, provided the argument @@ -722,7 +763,7 @@ -- > (:) (f x) (map f xs) -- > map (...redex...) -- --- Because 'seq' on such things completes immediately. +-- because 'seq' on such things completes immediately. -- -- For unlifted argument types, we have to be careful: -- @@ -732,36 +773,62 @@ -- happen: see "CoreSyn#let_app_invariant". This invariant states that arguments of -- unboxed type must be ok-for-speculation (or trivial). exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP -exprIsHNF (Var v) -- NB: There are no value args at this point - = isDataConWorkId v -- Catches nullary constructors, +exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding +\end{code} + +\begin{code} +-- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as +-- data constructors. Conlike arguments are considered interesting by the +-- inliner. +exprIsConLike :: CoreExpr -> Bool -- True => lambda, conlike, PAP +exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding + +-- | Returns true for values or value-like expressions. These are lambdas, +-- constructors / CONLIKE functions (as determined by the function argument) +-- or PAPs. +-- +exprIsHNFlike :: (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool +exprIsHNFlike is_con is_con_unf = is_hnf_like + where + is_hnf_like (Var v) -- NB: There are no value args at this point + = is_con v -- Catches nullary constructors, -- so that [] and () are values, for example - || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings - || isEvaldUnfolding (idUnfolding v) + || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings + || is_con_unf (idUnfolding v) -- Check the thing's unfolding; it might be bound to a value - -- A worry: what if an Id's unfolding is just itself: - -- then we could get an infinite loop... - -exprIsHNF (Lit _) = True -exprIsHNF (Type _) = True -- Types are honorary Values; - -- we don't mind copying them -exprIsHNF (Lam b e) = isRuntimeVar b || exprIsHNF e -exprIsHNF (Note _ e) = exprIsHNF e -exprIsHNF (Cast e _) = exprIsHNF e -exprIsHNF (App e (Type _)) = exprIsHNF e -exprIsHNF (App e a) = app_is_value e [a] -exprIsHNF _ = False - --- There is at least one value argument -app_is_value :: CoreExpr -> [CoreArg] -> Bool -app_is_value (Var fun) args - = idArity fun > valArgCount args -- Under-applied function - || isDataConWorkId fun -- or data constructor -app_is_value (Note _ f) as = app_is_value f as -app_is_value (Cast f _) as = app_is_value f as -app_is_value (App f a) as = app_is_value f (a:as) -app_is_value _ _ = False + -- We don't look through loop breakers here, which is a bit conservative + -- but otherwise I worry that if an Id's unfolding is just itself, + -- we could get an infinite loop + + is_hnf_like (Lit _) = True + is_hnf_like (Type _) = True -- Types are honorary Values; + -- we don't mind copying them + is_hnf_like (Lam b e) = isRuntimeVar b || is_hnf_like e + is_hnf_like (Note _ e) = is_hnf_like e + is_hnf_like (Cast e _) = is_hnf_like e + is_hnf_like (App e (Type _)) = is_hnf_like e + is_hnf_like (App e a) = app_is_value e [a] + is_hnf_like (Let _ e) = is_hnf_like e -- Lazy let(rec)s don't affect us + is_hnf_like _ = False + + -- There is at least one value argument + app_is_value :: CoreExpr -> [CoreArg] -> Bool + app_is_value (Var fun) args + = idArity fun > valArgCount args -- Under-applied function + || is_con fun -- or constructor-like + app_is_value (Note _ f) as = app_is_value f as + app_is_value (Cast f _) as = app_is_value f as + app_is_value (App f a) as = app_is_value f (a:as) + app_is_value _ _ = False \end{code} + +%************************************************************************ +%* * + Instantiating data constructors +%* * +%************************************************************************ + These InstPat functions go here to avoid circularity between DataCon and Id \begin{code} @@ -854,130 +921,11 @@ mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcSpan arg_ids = zipWith3 mk_id_var id_uniqs id_fss arg_tys --- | Returns @Just (dc, [x1..xn])@ if the argument expression is --- a constructor application of the form @dc x1 .. xn@ -exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr]) -exprIsConApp_maybe (Cast expr co) - = -- Here we do the KPush reduction rule as described in the FC paper - case exprIsConApp_maybe expr of { - Nothing -> Nothing ; - Just (dc, dc_args) -> - - -- The transformation applies iff we have - -- (C e1 ... en) `cast` co - -- where co :: (T t1 .. tn) ~ (T s1 ..sn) - -- That is, with a T at the top of both sides - -- The left-hand one must be a T, because exprIsConApp returned True - -- but the right-hand one might not be. (Though it usually will.) - - let (from_ty, to_ty) = coercionKind co - (from_tc, from_tc_arg_tys) = splitTyConApp from_ty - -- The inner one must be a TyConApp - in - case splitTyConApp_maybe to_ty of { - Nothing -> Nothing ; - Just (to_tc, to_tc_arg_tys) - | from_tc /= to_tc -> Nothing - -- These two Nothing cases are possible; we might see - -- (C x y) `cast` (g :: T a ~ S [a]), - -- where S is a type function. In fact, exprIsConApp - -- will probably not be called in such circumstances, - -- but there't nothing wrong with it - - | otherwise -> - let - tc_arity = tyConArity from_tc - - (univ_args, rest1) = splitAt tc_arity dc_args - (ex_args, rest2) = splitAt n_ex_tvs rest1 - (co_args_spec, rest3) = splitAt n_cos_spec rest2 - (co_args_theta, val_args) = splitAt n_cos_theta rest3 - - arg_tys = dataConRepArgTys dc - dc_univ_tyvars = dataConUnivTyVars dc - dc_ex_tyvars = dataConExTyVars dc - dc_eq_spec = dataConEqSpec dc - dc_eq_theta = dataConEqTheta dc - dc_tyvars = dc_univ_tyvars ++ dc_ex_tyvars - n_ex_tvs = length dc_ex_tyvars - n_cos_spec = length dc_eq_spec - n_cos_theta = length dc_eq_theta - - -- Make the "theta" from Fig 3 of the paper - gammas = decomposeCo tc_arity co - new_tys = gammas ++ map (\ (Type t) -> t) ex_args - theta = zipOpenTvSubst dc_tyvars new_tys - - -- First we cast the existential coercion arguments - cast_co_spec (tv, ty) co - = cast_co_theta (mkEqPred (mkTyVarTy tv, ty)) co - cast_co_theta eqPred (Type co) - | (ty1, ty2) <- getEqPredTys eqPred - = Type $ mkSymCoercion (substTy theta ty1) - `mkTransCoercion` co - `mkTransCoercion` (substTy theta ty2) - new_co_args = zipWith cast_co_spec dc_eq_spec co_args_spec ++ - zipWith cast_co_theta dc_eq_theta co_args_theta - - -- ...and now value arguments - new_val_args = zipWith cast_arg arg_tys val_args - cast_arg arg_ty arg = mkCoerce (substTy theta arg_ty) arg - - in - ASSERT( length univ_args == tc_arity ) - ASSERT2( from_tc == dataConTyCon dc, ppr expr $$ ppr co $$ ppr from_tc $$ ppr dc $$ ppr (dataConTyCon dc) ) - ASSERT( and (zipWith coreEqType [t | Type t <- univ_args] from_tc_arg_tys) ) - ASSERT( all isTypeArg (univ_args ++ ex_args) ) - ASSERT2( equalLength val_args arg_tys, ppr dc $$ ppr dc_tyvars $$ ppr dc_ex_tyvars $$ ppr arg_tys $$ ppr dc_args $$ ppr univ_args $$ ppr ex_args $$ ppr val_args $$ ppr arg_tys ) - - Just (dc, map Type to_tc_arg_tys ++ ex_args ++ new_co_args ++ new_val_args) - }} - -{- --- We do not want to tell the world that we have a --- Cons, to *stop* Case of Known Cons, which removes --- the TickBox. -exprIsConApp_maybe (Note (TickBox {}) expr) - = Nothing -exprIsConApp_maybe (Note (BinaryTickBox {}) expr) - = Nothing --} - -exprIsConApp_maybe (Note _ expr) - = exprIsConApp_maybe expr - -- We ignore InlineMe notes in case we have - -- x = __inline_me__ (a,b) - -- All part of making sure that INLINE pragmas never hurt - -- Marcin tripped on this one when making dictionaries more inlinable - -- - -- In fact, we ignore all notes. For example, - -- case _scc_ "foo" (C a b) of - -- C a b -> e - -- should be optimised away, but it will be only if we look - -- through the SCC note. - -exprIsConApp_maybe expr = analyse (collectArgs expr) - where - analyse (Var fun, args) - | Just con <- isDataConWorkId_maybe fun, - count isValArg args == dataConRepArity con - = Just (con,args) - - -- Look through unfoldings, but only cheap ones, because - -- we are effectively duplicating the unfolding - analyse (Var fun, []) - | let unf = idUnfolding fun, - isExpandableUnfolding unf - = exprIsConApp_maybe (unfoldingTemplate unf) - - analyse _ = Nothing \end{code} - - %************************************************************************ %* * -\subsection{Equality} + Equality %* * %************************************************************************ @@ -1000,17 +948,100 @@ = e1 `cheapEqExpr` e2 && t1 `coreEqCoercion` t2 cheapEqExpr _ _ = False +\end{code} +\begin{code} exprIsBig :: Expr b -> Bool -- ^ Returns @True@ of expressions that are too big to be compared by 'cheapEqExpr' exprIsBig (Lit _) = False exprIsBig (Var _) = False exprIsBig (Type _) = False +exprIsBig (Lam _ e) = exprIsBig e exprIsBig (App f a) = exprIsBig f || exprIsBig a exprIsBig (Cast e _) = exprIsBig e -- Hopefully coercions are not too big! exprIsBig _ = True \end{code} +\begin{code} +eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool +-- Compares for equality, modulo alpha +eqExpr in_scope e1 e2 + = eqExprX id_unf (mkRnEnv2 in_scope) e1 e2 + where + id_unf _ = noUnfolding -- Don't expand +\end{code} + +\begin{code} +eqExprX :: IdUnfoldingFun -> RnEnv2 -> CoreExpr -> CoreExpr -> Bool +-- ^ Compares expressions for equality, modulo alpha. +-- Does /not/ look through newtypes or predicate types +-- Used in rule matching, and also CSE + +eqExprX id_unfolding_fun env e1 e2 + = go env e1 e2 + where + go env (Var v1) (Var v2) + | rnOccL env v1 == rnOccR env v2 + = True + + -- The next two rules expand non-local variables + -- C.f. Note [Expanding variables] in Rules.lhs + -- and Note [Do not expand locally-bound variables] in Rules.lhs + go env (Var v1) e2 + | not (locallyBoundL env v1) + , Just e1' <- expandUnfolding_maybe (id_unfolding_fun (lookupRnInScope env v1)) + = go (nukeRnEnvL env) e1' e2 + + go env e1 (Var v2) + | not (locallyBoundR env v2) + , Just e2' <- expandUnfolding_maybe (id_unfolding_fun (lookupRnInScope env v2)) + = go (nukeRnEnvR env) e1 e2' + + go _ (Lit lit1) (Lit lit2) = lit1 == lit2 + go env (Type t1) (Type t2) = tcEqTypeX env t1 t2 + go env (Cast e1 co1) (Cast e2 co2) = tcEqTypeX env co1 co2 && go env e1 e2 + go env (App f1 a1) (App f2 a2) = go env f1 f2 && go env a1 a2 + go env (Note n1 e1) (Note n2 e2) = go_note n1 n2 && go env e1 e2 + + go env (Lam b1 e1) (Lam b2 e2) + = tcEqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination + && go (rnBndr2 env b1 b2) e1 e2 + + go env (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2) + = go env r1 r2 -- No need to check binder types, since RHSs match + && go (rnBndr2 env v1 v2) e1 e2 + + go env (Let (Rec ps1) e1) (Let (Rec ps2) e2) + = all2 (go env') rs1 rs2 && go env' e1 e2 + where + (bs1,rs1) = unzip ps1 + (bs2,rs2) = unzip ps2 + env' = rnBndrs2 env bs1 bs2 + + go env (Case e1 b1 _ a1) (Case e2 b2 _ a2) + = go env e1 e2 + && tcEqTypeX env (idType b1) (idType b2) + && all2 (go_alt (rnBndr2 env b1 b2)) a1 a2 + + go _ _ _ = False + + ----------- + go_alt env (c1, bs1, e1) (c2, bs2, e2) + = c1 == c2 && go (rnBndrs2 env bs1 bs2) e1 e2 + + ----------- + go_note (SCC cc1) (SCC cc2) = cc1 == cc2 + go_note (CoreNote s1) (CoreNote s2) = s1 == s2 + go_note _ _ = False +\end{code} + +Auxiliary functions + +\begin{code} +locallyBoundL, locallyBoundR :: RnEnv2 -> Var -> Bool +locallyBoundL rn_env v = inRnEnvL rn_env v +locallyBoundR rn_env v = inRnEnvR rn_env v +\end{code} %************************************************************************ @@ -1038,7 +1069,6 @@ noteSize :: Note -> Int noteSize (SCC cc) = cc `seq` 1 -noteSize InlineMe = 1 noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations varSize :: Var -> Int @@ -1194,7 +1224,7 @@ -- This is a bit like CoreUtils.exprIsHNF, with the following differences: -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC) -- --- b) (C x xs), where C is a contructors is updatable if the application is +-- b) (C x xs), where C is a contructor is updatable if the application is -- dynamic -- -- c) don't look through unfolding of f in (f x). diff -ruN ghc-6.12.1/compiler/coreSyn/MkCore.lhs ghc-6.13.20091231/compiler/coreSyn/MkCore.lhs --- ghc-6.12.1/compiler/coreSyn/MkCore.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/coreSyn/MkCore.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -18,8 +18,7 @@ mkChunkified, -- * Constructing small tuples - mkCoreVarTup, mkCoreVarTupTy, - mkCoreTup, mkCoreTupTy, + mkCoreVarTup, mkCoreVarTupTy, mkCoreTup, -- * Constructing big tuples mkBigCoreVarTup, mkBigCoreVarTupTy, @@ -337,7 +336,7 @@ -- | Bulid the type of a small tuple that holds the specified variables mkCoreVarTupTy :: [Id] -> Type -mkCoreVarTupTy ids = mkCoreTupTy (map idType ids) +mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids) -- | Build a small tuple holding the specified expressions mkCoreTup :: [CoreExpr] -> CoreExpr @@ -346,12 +345,6 @@ mkCoreTup cs = mkConApp (tupleCon Boxed (length cs)) (map (Type . exprType) cs ++ cs) --- | Build the type of a small tuple that holds the specified type of thing -mkCoreTupTy :: [Type] -> Type -mkCoreTupTy [ty] = ty -mkCoreTupTy tys = mkTupleTy Boxed (length tys) tys - - -- | Build a big tuple holding the specified variables mkBigCoreVarTup :: [Id] -> CoreExpr mkBigCoreVarTup ids = mkBigCoreTup (map Var ids) @@ -366,7 +359,7 @@ -- | Build the type of a big tuple that holds the specified type of thing mkBigCoreTupTy :: [Type] -> Type -mkBigCoreTupTy = mkChunkified mkCoreTupTy +mkBigCoreTupTy = mkChunkified mkBoxedTupleTy \end{code} %************************************************************************ @@ -410,7 +403,7 @@ mk_tup_sel vars_s the_var = mkSmallTupleSelector group the_var tpl_v $ mk_tup_sel (chunkify tpl_vs) tpl_v where - tpl_tys = [mkCoreTupTy (map idType gp) | gp <- vars_s] + tpl_tys = [mkBoxedTupleTy (map idType gp) | gp <- vars_s] tpl_vs = mkTemplateLocals tpl_tys [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s, the_var `elem` gp ] @@ -471,7 +464,7 @@ one_tuple_case chunk_vars (us, vs, body) = let (us1, us2) = splitUniqSupply us scrut_var = mkSysLocal (fsLit "ds") (uniqFromSupply us1) - (mkCoreTupTy (map idType chunk_vars)) + (mkBoxedTupleTy (map idType chunk_vars)) body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var) in (us2, scrut_var:vs, body') \end{code} diff -ruN ghc-6.12.1/compiler/coreSyn/MkExternalCore.lhs ghc-6.13.20091231/compiler/coreSyn/MkExternalCore.lhs --- ghc-6.12.1/compiler/coreSyn/MkExternalCore.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/coreSyn/MkExternalCore.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -160,7 +160,6 @@ return $ C.Case scrut (make_vbind v) (make_ty ty) newAlts make_exp (Note (SCC _) e) = make_exp e >>= (return . C.Note "SCC") -- temporary make_exp (Note (CoreNote s) e) = make_exp e >>= (return . C.Note s) -- hdaume: core annotations -make_exp (Note InlineMe e) = make_exp e >>= (return . C.Note "InlineMe") make_exp _ = error "MkExternalCore died: make_exp" make_alt :: CoreAlt -> CoreM C.Alt diff -ruN ghc-6.12.1/compiler/coreSyn/PprCore.lhs ghc-6.13.20091231/compiler/coreSyn/PprCore.lhs --- ghc-6.12.1/compiler/coreSyn/PprCore.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/coreSyn/PprCore.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -17,20 +17,17 @@ import Var import Id import IdInfo -import NewDemand -#ifdef OLD_STRICTNESS -import Id -import IdInfo -#endif - +import Demand import DataCon import TyCon import Type import Coercion +import StaticFlags import BasicTypes import Util import Outputable import FastString +import Data.Maybe \end{code} %************************************************************************ @@ -70,13 +67,16 @@ pprTopBind :: OutputableBndr a => Bind a -> SDoc pprTopBind (NonRec binder expr) - = ppr_binding (binder,expr) $$ text "" + = ppr_binding (binder,expr) $$ blankLine -pprTopBind (Rec binds) +pprTopBind (Rec []) + = ptext (sLit "Rec { }") +pprTopBind (Rec (b:bs)) = vcat [ptext (sLit "Rec {"), - vcat (map ppr_binding binds), + ppr_binding b, + vcat [blankLine $$ ppr_binding b | b <- bs], ptext (sLit "end Rec }"), - text ""] + blankLine] \end{code} \begin{code} @@ -114,9 +114,11 @@ ppr_expr add_par (Cast expr co) = add_par $ sep [pprParendExpr expr, - ptext (sLit "`cast`") <+> parens (pprCo co)] + ptext (sLit "`cast`") <+> pprCo co] where - pprCo co = sep [ppr co, dcolon <+> ppr (coercionKindPredTy co)] + pprCo co | opt_SuppressCoercions = ptext (sLit "...") + | otherwise = parens + $ sep [ppr co, dcolon <+> pprEqPred (coercionKind co)] ppr_expr add_par expr@(Lam _ _) @@ -209,9 +211,6 @@ ppr_expr add_par (Note (SCC cc) expr) = add_par (sep [pprCostCentreCore cc, pprCoreExpr expr]) -ppr_expr add_par (Note InlineMe expr) - = add_par $ ptext (sLit "__inline_me") <+> pprParendExpr expr - ppr_expr add_par (Note (CoreNote s) expr) = add_par $ sep [sep [ptext (sLit "__core_note"), pprHsString (mkFastString s)], @@ -249,11 +248,8 @@ pprCoreBinder :: BindingSite -> Var -> SDoc pprCoreBinder LetBind binder | isTyVar binder = pprKindedTyVarBndr binder - | otherwise - = vcat [sig, pprIdExtras binder, pragmas] - where - sig = pprTypedBinder binder - pragmas = ppIdInfo binder (idInfo binder) + | otherwise = pprTypedBinder binder $$ + ppIdInfo binder (idInfo binder) -- Lambda bound type variables are preceded by "@" pprCoreBinder LambdaBind bndr @@ -284,7 +280,7 @@ -- Print binder with a type or kind signature (not paren'd) pprTypedBinder binder | isTyVar binder = pprKindedTyVarBndr binder - | otherwise = pprIdBndr binder <+> dcolon <+> pprType (idType binder) + | otherwise = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder)) pprKindedTyVarBndr :: TyVar -> SDoc -- Print a type variable binder with its kind (but not if *) @@ -307,58 +303,120 @@ where prag_info = inlinePragInfo info occ_info = occInfo info - dmd_info = newDemandInfo info + dmd_info = demandInfo info lbv_info = lbvarInfo info - no_info = isDefaultInlinePragma prag_info && isNoOcc occ_info && - (case dmd_info of { Nothing -> True; Just d -> isTop d }) && - hasNoLBVarInfo lbv_info - - doc | no_info = empty - | otherwise - = brackets $ hsep [ppr prag_info, ppr occ_info, - ppr dmd_info, ppr lbv_info -#ifdef OLD_STRICTNESS - , ppr (demandInfo id) -#endif - ] + has_prag = not (isDefaultInlinePragma prag_info) + has_occ = not (isNoOcc occ_info) + has_dmd = case dmd_info of { Nothing -> False; Just d -> not (isTop d) } + has_lbv = not (hasNoLBVarInfo lbv_info) + + doc = showAttributes + [ (has_prag, ptext (sLit "InlPrag=") <> ppr prag_info) + , (has_occ, ptext (sLit "Occ=") <> ppr occ_info) + , (has_dmd, ptext (sLit "Dmd=") <> ppr dmd_info) + , (has_lbv , ptext (sLit "Lbv=") <> ppr lbv_info) + ] \end{code} +----------------------------------------------------- +-- IdDetails and IdInfo +----------------------------------------------------- + \begin{code} -pprIdExtras :: Id -> SDoc -pprIdExtras id = pp_scope <> ppr (idDetails id) +ppIdInfo :: Id -> IdInfo -> SDoc +ppIdInfo id info + = showAttributes + [ (True, pp_scope <> ppr (idDetails id)) + , (has_arity, ptext (sLit "Arity=") <> int arity) + , (has_caf_info, ptext (sLit "Caf=") <> ppr caf_info) + , (has_strictness, ptext (sLit "Str=") <> pprStrictness str_info) + , (has_unf, ptext (sLit "Unf=") <> ppr unf_info) + , (not (null rules), ptext (sLit "RULES:") <+> vcat (map pprRule rules)) + ] -- Inline pragma, occ, demand, lbvar info + -- printed out with all binders (when debug is on); + -- see PprCore.pprIdBndr where pp_scope | isGlobalId id = ptext (sLit "GblId") | isExportedId id = ptext (sLit "LclIdX") | otherwise = ptext (sLit "LclId") -ppIdInfo :: Id -> IdInfo -> SDoc -ppIdInfo _ info - = brackets $ - vcat [ ppArityInfo a, - ppWorkerInfo (workerInfo info), - ppCafInfo (cafInfo info), -#ifdef OLD_STRICTNESS - ppStrictnessInfo s, - ppCprInfo m, -#endif - pprNewStrictness (newStrictnessInfo info), - if null rules then empty - else ptext (sLit "RULES:") <+> vcat (map pprRule rules) - -- Inline pragma, occ, demand, lbvar info - -- printed out with all binders (when debug is on); - -- see PprCore.pprIdBndr - ] - where - a = arityInfo info -#ifdef OLD_STRICTNESS - s = strictnessInfo info - m = cprInfo info -#endif + arity = arityInfo info + has_arity = arity /= 0 + + caf_info = cafInfo info + has_caf_info = not (mayHaveCafRefs caf_info) + + str_info = strictnessInfo info + has_strictness = isJust str_info + + unf_info = unfoldingInfo info + has_unf = hasSomeUnfolding unf_info + rules = specInfoRules (specInfo info) + +showAttributes :: [(Bool,SDoc)] -> SDoc +showAttributes stuff + | null docs = empty + | otherwise = brackets (sep (punctuate comma docs)) + where + docs = [d | (True,d) <- stuff] +\end{code} + +----------------------------------------------------- +-- Unfolding and UnfoldingGuidance +----------------------------------------------------- + +\begin{code} +instance Outputable UnfoldingGuidance where + ppr UnfNever = ptext (sLit "NEVER") + ppr (UnfWhen sat_ok boring_ok) + = ptext (sLit "ALWAYS_IF") <> + parens (ptext (sLit "sat_ok=") <> ppr sat_ok <> comma <> + ptext (sLit "boring_ok=") <> ppr boring_ok) + ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount }) + = hsep [ ptext (sLit "IF_ARGS"), + brackets (hsep (map int cs)), + int size, + int discount ] + +instance Outputable UnfoldingSource where + ppr InlineCompulsory = ptext (sLit "Compulsory") + ppr (InlineWrapper w) = ptext (sLit "Worker=") <> ppr w + ppr InlineRule = ptext (sLit "InlineRule") + ppr InlineRhs = ptext (sLit "") + +instance Outputable Unfolding where + ppr NoUnfolding = ptext (sLit "No unfolding") + ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs + ppr (DFunUnfolding con ops) = ptext (sLit "DFun") <+> ppr con + <+> brackets (pprWithCommas pprParendExpr ops) + ppr (CoreUnfolding { uf_src = src + , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf + , uf_is_conlike=conlike, uf_is_cheap=cheap + , uf_expandable=exp, uf_guidance=g, uf_arity=arity}) + = ptext (sLit "Unf") <> braces (pp_info $$ pp_rhs) + where + pp_info = fsep $ punctuate comma + [ ptext (sLit "Src=") <> ppr src + , ptext (sLit "TopLvl=") <> ppr top + , ptext (sLit "Arity=") <> int arity + , ptext (sLit "Value=") <> ppr hnf + , ptext (sLit "ConLike=") <> ppr conlike + , ptext (sLit "Cheap=") <> ppr cheap + , ptext (sLit "Expandable=") <> ppr exp + , ptext (sLit "Guidance=") <> ppr g ] + pp_tmpl = ptext (sLit "Tmpl=") <+> ppr rhs + pp_rhs | isInlineRuleSource src = pp_tmpl + | otherwise = empty + -- Don't print the RHS or we get a quadratic + -- blowup in the size of the printout! \end{code} +----------------------------------------------------- +-- Rules +----------------------------------------------------- \begin{code} instance Outputable CoreRule where diff -ruN ghc-6.12.1/compiler/cprAnalysis/CprAnalyse.lhs ghc-6.13.20091231/compiler/cprAnalysis/CprAnalyse.lhs --- ghc-6.12.1/compiler/cprAnalysis/CprAnalyse.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/cprAnalysis/CprAnalyse.lhs 1969-12-31 16:00:00.000000000 -0800 @@ -1,317 +0,0 @@ -% (c) The University of Glasgow 2006 - -\section[CprAnalyse]{Identify functions that always return a -constructed product result} - -\begin{code} -#ifndef OLD_STRICTNESS -module CprAnalyse ( ) where - -#else - -module CprAnalyse ( cprAnalyse ) where - -#include "HsVersions.h" - -import DynFlags -import CoreLint -import CoreSyn -import CoreUtils -import Id -import IdInfo -import Demand -import VarEnv -import Util -import Outputable - -import Maybe -\end{code} - -This module performs an analysis of a set of Core Bindings for the -Constructed Product Result (CPR) transformation. - -It detects functions that always explicitly (manifestly?) construct a -result value with a product type. A product type is a type which has -only one constructor. For example, tuples and boxed primitive values -have product type. - -We must also ensure that the function's body starts with sufficient -manifest lambdas otherwise loss of sharing can occur. See the comment -in @StrictAnal.lhs@. - -The transformation of bindings to worker/wrapper pairs is done by the -worker-wrapper pass. The worker-wrapper pass splits bindings on the -basis of both strictness and CPR info. If an id has both then it can -combine the transformations so that only one pair is produced. - -The analysis here detects nested CPR information. For example, if a -function returns a constructed pair, the first element of which is a -constructed int, then the analysis will detect nested CPR information -for the int as well. Unfortunately, the current transformations can't -take advantage of the nested CPR information. They have (broken now, -I think) code which will flatten out nested CPR components and rebuild -them in the wrapper, but enabling this would lose laziness. It is -possible to make use of the nested info: if we knew that a caller was -strict in that position then we could create a specialized version of -the function which flattened/reconstructed that position. - -It is not known whether this optimisation would be worthwhile. - -So we generate and carry round nested CPR information, but before -using this info to guide the creation of workers and wrappers we map -all components of a CPRInfo to NoCprInfo. - - -Data types -~~~~~~~~~~ - -Within this module Id's CPR information is represented by -``AbsVal''. When adding this information to the Id's pragma info field -we convert the ``Absval'' to a ``CprInfo'' value. - -Abstract domains consist of a `no information' value (Top), a function -value (Fun) which when applied to an argument returns a new AbsVal -(note the argument is not used in any way), , for product types, a -corresponding length tuple (Tuple) of abstract values. And finally, -Bot. Bot is not a proper abstract value but a generic bottom is -useful for calculating fixpoints and representing divergent -computations. Note that we equate Bot and Fun^n Bot (n > 0), and -likewise for Top. This saves a lot of delving in types to keep -everything exactly correct. - -Since functions abstract to constant functions we could just -represent them by the abstract value of their result. However, it -turns out (I know - I tried!) that this requires a lot of type -manipulation and the code is more straightforward if we represent -functions by an abstract constant function. - -\begin{code} -data AbsVal = Top -- Not a constructed product - - | Fun AbsVal -- A function that takes an argument - -- and gives AbsVal as result. - - | Tuple -- A constructed product of values - - | Bot -- Bot'tom included for convenience - -- we could use appropriate Tuple Vals - deriving (Eq,Show) - --- For pretty debugging -instance Outputable AbsVal where - ppr Top = ptext (sLit "Top") - ppr (Fun r) = ptext (sLit "Fun->") <> (parens.ppr) r - ppr Tuple = ptext (sLit "Tuple ") - ppr Bot = ptext (sLit "Bot") - - --- lub takes the lowest upper bound of two abstract values, standard. -lub :: AbsVal -> AbsVal -> AbsVal -lub Bot a = a -lub a Bot = a -lub Top a = Top -lub a Top = Top -lub Tuple Tuple = Tuple -lub (Fun l) (Fun r) = Fun (lub l r) -lub l r = panic "CPR Analysis tried to take the lub of a function and a tuple" - - -\end{code} - -The environment maps Ids to their abstract CPR value. - -\begin{code} - -type CPREnv = VarEnv AbsVal - -initCPREnv = emptyVarEnv - -\end{code} - -Programs -~~~~~~~~ - -Take a list of core bindings and return a new list with CPR function -ids decorated with their CprInfo pragmas. - -\begin{code} - -cprAnalyse :: DynFlags -> [CoreBind] -> IO [CoreBind] -cprAnalyse dflags binds - = do { - showPass dflags "Constructed Product analysis" ; - let { binds_plus_cpr = do_prog binds } ; - endPass dflags "Constructed Product analysis" - Opt_D_dump_cpranal binds_plus_cpr - return binds_plus_cpr - } - where - do_prog :: [CoreBind] -> [CoreBind] - do_prog binds = snd $ mapAccumL cprAnalBind initCPREnv binds -\end{code} - -The cprAnal functions take binds/expressions and an environment which -gives CPR info for visible ids and returns a new bind/expression -with ids decorated with their CPR info. - -\begin{code} --- Return environment extended with info from this binding -cprAnalBind :: CPREnv -> CoreBind -> (CPREnv, CoreBind) -cprAnalBind rho (NonRec b e) - | isImplicitId b -- Don't touch the CPR info on constructors, selectors etc - = (rho, NonRec b e) - | otherwise - = (extendVarEnv rho b absval, NonRec b' e') - where - (e', absval) = cprAnalExpr rho e - b' = addIdCprInfo b e' absval - -cprAnalBind rho (Rec prs) - = (final_rho, Rec (map do_pr prs)) - where - do_pr (b,e) = (b', e') - where - b' = addIdCprInfo b e' absval - (e', absval) = cprAnalExpr final_rho e - - -- When analyzing mutually recursive bindings the iterations to find - -- a fixpoint is bounded by the number of bindings in the group. - -- for simplicity we just iterate that number of times. - final_rho = nTimes (length prs) do_one_pass init_rho - init_rho = rho `extendVarEnvList` [(b,Bot) | (b,e) <- prs] - - do_one_pass :: CPREnv -> CPREnv - do_one_pass rho = foldl (\ rho (b,e) -> extendVarEnv rho b (snd (cprAnalExpr rho e))) - rho prs - - -cprAnalExpr :: CPREnv -> CoreExpr -> (CoreExpr, AbsVal) - --- If Id will always diverge when given sufficient arguments then --- we can just set its abs val to Bot. Any other CPR info --- from other paths will then dominate, which is what we want. --- Check in rho, if not there it must be imported, so check --- the var's idinfo. -cprAnalExpr rho e@(Var v) - | isBottomingId v = (e, Bot) - | otherwise = (e, case lookupVarEnv rho v of - Just a_val -> a_val - Nothing -> getCprAbsVal v) - --- Literals are unboxed -cprAnalExpr rho (Lit l) = (Lit l, Top) - --- For apps we don't care about the argument's abs val. This --- app will return a constructed product if the function does. We strip --- a Fun from the functions abs val, unless the argument is a type argument --- or it is already Top or Bot. -cprAnalExpr rho (App fun arg@(Type _)) - = (App fun_cpr arg, fun_res) - where - (fun_cpr, fun_res) = cprAnalExpr rho fun - -cprAnalExpr rho (App fun arg) - = (App fun_cpr arg_cpr, res_res) - where - (fun_cpr, fun_res) = cprAnalExpr rho fun - (arg_cpr, _) = cprAnalExpr rho arg - res_res = case fun_res of - Fun res_res -> res_res - Top -> Top - Bot -> Bot - Tuple -> WARN( True, ppr (App fun arg) ) Top - -- This really should not happen! - - --- Map arguments to Top (we aren't constructing them) --- Return the abstract value of the body, since functions --- are represented by the CPR value of their result, and --- add a Fun for this lambda.. -cprAnalExpr rho (Lam b body) | isTyVar b = (Lam b body_cpr, body_aval) - | otherwise = (Lam b body_cpr, Fun body_aval) - where - (body_cpr, body_aval) = cprAnalExpr (extendVarEnv rho b Top) body - -cprAnalExpr rho (Let bind body) - = (Let bind' body', body_aval) - where - (rho', bind') = cprAnalBind rho bind - (body', body_aval) = cprAnalExpr rho' body - -cprAnalExpr rho (Case scrut bndr alts) - = (Case scrut_cpr bndr alts_cpr, alts_aval) - where - (scrut_cpr, scrut_aval) = cprAnalExpr rho scrut - (alts_cpr, alts_aval) = cprAnalCaseAlts (extendVarEnv rho bndr scrut_aval) alts - -cprAnalExpr rho (Note n exp) - = (Note n exp_cpr, expr_aval) - where - (exp_cpr, expr_aval) = cprAnalExpr rho exp - -cprAnalExpr rho (Type t) - = (Type t, Top) - -cprAnalCaseAlts :: CPREnv -> [CoreAlt] -> ([CoreAlt], AbsVal) -cprAnalCaseAlts rho alts - = foldr anal_alt ([], Bot) alts - where - anal_alt :: CoreAlt -> ([CoreAlt], AbsVal) -> ([CoreAlt], AbsVal) - anal_alt (con, binds, exp) (done, aval) - = ((con,binds,exp_cpr) : done, exp_aval `lub` aval) - where (exp_cpr, exp_aval) = cprAnalExpr rho' exp - rho' = rho `extendVarEnvList` (zip binds (repeat Top)) - - -addIdCprInfo :: Id -> CoreExpr -> AbsVal -> Id -addIdCprInfo bndr rhs absval - | useful_info && ok_to_add = setIdCprInfo bndr cpr_info - | otherwise = bndr - where - cpr_info = absToCprInfo absval - useful_info = case cpr_info of { ReturnsCPR -> True; NoCPRInfo -> False } - - ok_to_add = case absval of - Fun _ -> idArity bndr >= n_fun_tys absval - -- Enough visible lambdas - - Tuple -> exprIsHNF rhs || isStrict (idDemandInfo bndr) - -- If the rhs is a value, and returns a constructed product, - -- it will be inlined at usage sites, so we give it a Tuple absval - -- If it isn't a value, we won't inline it (code/work dup worries), so - -- we discard its absval. - -- - -- Also, if the strictness analyser has figured out that it's strict, - -- the let-to-case transformation will happen, so again it's good. - -- (CPR analysis runs before the simplifier has had a chance to do - -- the let-to-case transform.) - -- This made a big difference to PrelBase.modInt, which had something like - -- modInt = \ x -> let r = ... -> I# v in - -- ...body strict in r... - -- r's RHS isn't a value yet; but modInt returns r in various branches, so - -- if r doesn't have the CPR property then neither does modInt - - _ -> False - - n_fun_tys :: AbsVal -> Int - n_fun_tys (Fun av) = 1 + n_fun_tys av - n_fun_tys other = 0 - - -absToCprInfo :: AbsVal -> CprInfo -absToCprInfo Tuple = ReturnsCPR -absToCprInfo (Fun r) = absToCprInfo r -absToCprInfo _ = NoCPRInfo - - --- Cpr Info doesn't store the number of arguments a function has, so the caller --- must take care to add the appropriate number of Funs. -getCprAbsVal v = case idCprInfo v of - NoCPRInfo -> Top - ReturnsCPR -> nTimes arity Fun Tuple - where - arity = idArity v - -- Imported (non-nullary) constructors will have the CPR property - -- in their IdInfo, so no need to look at their unfolding -#endif /* OLD_STRICTNESS */ -\end{code} diff -ruN ghc-6.12.1/compiler/deSugar/Coverage.lhs ghc-6.13.20091231/compiler/deSugar/Coverage.lhs --- ghc-6.12.1/compiler/deSugar/Coverage.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/deSugar/Coverage.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -742,9 +742,9 @@ start = srcSpanStart pos end = srcSpanEnd pos hpcPos = toHpcPos ( srcLocLine start - , srcLocCol start + 1 + , srcLocCol start , srcLocLine end - , srcLocCol end + , srcLocCol end - 1 ) hpcSrcSpan :: SrcSpan diff -ruN ghc-6.12.1/compiler/deSugar/Desugar.lhs ghc-6.13.20091231/compiler/deSugar/Desugar.lhs --- ghc-6.12.1/compiler/deSugar/Desugar.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/deSugar/Desugar.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -27,10 +27,8 @@ import Module import RdrName import NameSet -import VarSet import Rules -import CoreLint -import CoreFVs +import CoreMonad ( endPass ) import ErrUtils import Outputable import SrcLoc @@ -107,7 +105,7 @@ { -- Add export flags to bindings keep_alive <- readIORef keep_var ; let final_prs = addExportFlags target export_set - keep_alive all_prs ds_rules + keep_alive all_prs ds_binds = [Rec final_prs] -- Notice that we put the whole lot in a big Rec, even the foreign binds -- When compiling PrelFloat, which defines data Float = F# Float# @@ -116,7 +114,7 @@ -- things into the in-scope set before simplifying; so we get no unfolding for F#! -- Lint result if necessary - ; endPass dflags "Desugar" Opt_D_dump_ds ds_binds + ; endPass dflags "Desugar" Opt_D_dump_ds ds_binds ds_rules -- Dump output ; doIfSet (dopt Opt_D_dump_ds dflags) @@ -206,26 +204,17 @@ -- it's just because the type checker is rather busy already and -- I didn't want to pass in yet another mapping. -addExportFlags :: HscTarget -> NameSet -> NameSet -> [(Id, t)] -> [CoreRule] +addExportFlags :: HscTarget -> NameSet -> NameSet -> [(Id, t)] -> [(Id, t)] -addExportFlags target exports keep_alive prs rules +addExportFlags target exports keep_alive prs = [(add_export bndr, rhs) | (bndr,rhs) <- prs] where add_export bndr | dont_discard bndr = setIdExported bndr | otherwise = bndr - orph_rhs_fvs = unionVarSets [ ruleRhsFreeVars rule - | rule <- rules, - not (isLocalRule rule) ] - -- A non-local rule keeps alive the free vars of its right-hand side. - -- (A "non-local" is one whose head function is not locally defined.) - -- Local rules are (later, after gentle simplification) - -- attached to the Id, and that keeps the rhs free vars alive. - dont_discard bndr = is_exported name || name `elemNameSet` keep_alive - || bndr `elemVarSet` orph_rhs_fvs where name = idName bndr @@ -243,7 +232,7 @@ ppr_ds_rules :: [CoreRule] -> SDoc ppr_ds_rules [] = empty ppr_ds_rules rules - = text "" $$ text "-------------- DESUGARED RULES -----------------" $$ + = blankLine $$ text "-------------- DESUGARED RULES -----------------" $$ pprRules rules \end{code} @@ -260,7 +249,10 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs)) = putSrcSpanDs loc $ do { let bndrs' = [var | RuleBndr (L _ var) <- vars] - ; lhs' <- dsLExpr lhs + + ; lhs' <- unsetOptM Opt_EnableRewriteRules $ + dsLExpr lhs -- Note [Desugaring RULE lhss] + ; rhs' <- dsLExpr rhs -- Substitute the dict bindings eagerly, @@ -273,15 +265,21 @@ -- NB: isLocalId is False of implicit Ids. This is good becuase -- we don't want to attach rules to the bindings of implicit Ids, -- because they don't show up in the bindings until just before code gen - fn_name = idName fn_id - - rule = Rule { ru_name = name, ru_fn = fn_name, ru_act = act, - ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs', - ru_rough = roughTopNames args, - ru_local = local_rule } + fn_name = idName fn_id + rule = mkRule local_rule name act fn_name bndrs args rhs' ; return (Just rule) } } } where msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar; ignored")) 2 (ppr lhs) \end{code} + +Note [Desugaring RULE left hand sides] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For the LHS of a RULE we do *not* want to desugar + [x] to build (\cn. x `c` n) +We want to leave explicit lists simply as chains +of cons's. We can achieve that slightly indirectly by +switching off EnableRewriteRules. See DsExpr.dsExplicitList. + +That keeps the desugaring of list comprehensions simple too. diff -ruN ghc-6.12.1/compiler/deSugar/DsArrows.lhs ghc-6.13.20091231/compiler/deSugar/DsArrows.lhs --- ghc-6.12.1/compiler/deSugar/DsArrows.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/deSugar/DsArrows.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -142,7 +142,7 @@ \begin{code} mkCorePairTy :: Type -> Type -> Type -mkCorePairTy t1 t2 = mkCoreTupTy [t1, t2] +mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2] mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr mkCorePairExpr e1 e2 = mkCoreTup [e1, e2] diff -ruN ghc-6.12.1/compiler/deSugar/DsBinds.lhs ghc-6.13.20091231/compiler/deSugar/DsBinds.lhs --- ghc-6.12.1/compiler/deSugar/DsBinds.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/deSugar/DsBinds.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -17,27 +17,30 @@ #include "HsVersions.h" -import {-# SOURCE #-} DsExpr( dsLExpr, dsExpr ) +import {-# SOURCE #-} DsExpr( dsLExpr ) import {-# SOURCE #-} Match( matchWrapper ) import DsMonad import DsGRHSs import DsUtils -import OccurAnal import HsSyn -- lots of things import CoreSyn -- lots of things +import CoreSubst import MkCore import CoreUtils +import CoreArity ( etaExpand ) +import CoreUnfold import CoreFVs -import TcHsSyn ( mkArbitraryType ) -- Mis-placed? import TcType +import TysPrim ( anyTypeOfKind ) import CostCentre import Module import Id import MkId ( seqId ) -import Var ( Var, TyVar ) +import Var ( Var, TyVar, tyVarKind ) +import IdInfo ( vanillaIdInfo ) import VarSet import Rules import VarEnv @@ -48,8 +51,9 @@ import BasicTypes hiding ( TopLevel ) import FastString import StaticFlags ( opt_DsMultiTyVar ) -import Util ( mapSnd, mapAndUnzip, lengthExceeds ) +import Util ( count, lengthExceeds ) +import MonadUtils import Control.Monad import Data.List \end{code} @@ -70,6 +74,7 @@ ------------------------ ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)] + -- scc annotation policy (see below) ds_lhs_binds auto_scc binds = foldM (dsLHsBind auto_scc) [] (bagToList binds) @@ -85,25 +90,30 @@ -> HsBind Id -> DsM [(Id,CoreExpr)] -- Result -dsHsBind _ rest (VarBind var expr) = do - core_expr <- dsLExpr expr +dsHsBind _ rest (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless }) + = do { core_expr <- dsLExpr expr - -- Dictionary bindings are always VarMonoBinds, so - -- we only need do this here - core_expr' <- addDictScc var core_expr - return ((var, core_expr') : rest) - -dsHsBind _ rest (FunBind { fun_id = L _ fun, fun_matches = matches, - fun_co_fn = co_fn, fun_tick = tick, fun_infix = inf }) = do - (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches - body' <- mkOptTickBox tick body - rhs <- dsCoercion co_fn (return (mkLams args body')) - return ((fun,rhs) : rest) - -dsHsBind _ rest (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) = do - body_expr <- dsGuarded grhss ty - sel_binds <- mkSelectorBinds pat body_expr - return (sel_binds ++ rest) + -- Dictionary bindings are always VarBinds, + -- so we only need do this here + ; core_expr' <- addDictScc var core_expr + ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr' + | otherwise = var + + ; return ((var', core_expr') : rest) } + +dsHsBind _ rest + (FunBind { fun_id = L _ fun, fun_matches = matches, + fun_co_fn = co_fn, fun_tick = tick, fun_infix = inf }) + = do { (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches + ; body' <- mkOptTickBox tick body + ; wrap_fn' <- dsCoercion co_fn + ; return ((fun, wrap_fn' (mkLams args body')) : rest) } + +dsHsBind _ rest + (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) + = do { body_expr <- dsGuarded grhss ty + ; sel_binds <- mkSelectorBinds pat body_expr + ; return (sel_binds ++ rest) } {- Note [Rules and inlining] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -132,10 +142,15 @@ dsHsBind auto_scc rest (AbsBinds [] [] exports binds) = do { core_prs <- ds_lhs_binds NoSccs binds ; let env = mkABEnv exports - do_one (lcl_id, rhs) | Just (_, gbl_id, _, prags) <- lookupVarEnv env lcl_id - = addInlinePrags prags gbl_id $ - addAutoScc auto_scc gbl_id rhs - | otherwise = (lcl_id, rhs) + ar_env = mkArityEnv binds + do_one (lcl_id, rhs) + | Just (_, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id + = WARN( not (null spec_prags), ppr gbl_id $$ ppr spec_prags ) -- Not overloaded + makeCorePair gbl_id (lookupArity ar_env lcl_id) + (addAutoScc auto_scc gbl_id rhs) + + | otherwise = (lcl_id, rhs) + locals' = [(lcl_id, Var gbl_id) | (_, gbl_id, lcl_id, _) <- exports] -- Note [Rules and inlining] ; return (map do_one core_prs ++ locals' ++ rest) } @@ -192,62 +207,74 @@ -- see if it has any impact; it is on by default = -- Note [Abstracting over tyvars only] do { core_prs <- ds_lhs_binds NoSccs binds - ; arby_env <- mkArbitraryTypeEnv tyvars exports - ; let (lg_binds, core_prs') = mapAndUnzip do_one core_prs + ; let arby_env = mkArbitraryTypeEnv tyvars exports bndrs = mkVarSet (map fst core_prs) add_lets | core_prs `lengthExceeds` 10 = add_some - | otherwise = mkLets lg_binds - add_some rhs = mkLets [ NonRec b r | NonRec b r <- lg_binds - , b `elemVarSet` fvs] rhs + | otherwise = mkLets + add_some lg_binds rhs = mkLets [ NonRec b r | NonRec b r <- lg_binds + , b `elemVarSet` fvs] rhs where fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs + ar_env = mkArityEnv binds env = mkABEnv exports - do_one (lcl_id, rhs) - | Just (id_tvs, gbl_id, _, prags) <- lookupVarEnv env lcl_id - = (NonRec lcl_id (mkTyApps (Var gbl_id) (mkTyVarTys id_tvs)), - addInlinePrags prags gbl_id $ - addAutoScc auto_scc gbl_id $ - mkLams id_tvs $ - mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv)) - | tv <- tyvars, not (tv `elem` id_tvs)] $ - add_lets rhs) + mk_lg_bind lcl_id gbl_id tyvars + = NonRec (setIdInfo lcl_id vanillaIdInfo) + -- Nuke the IdInfo so that no old unfoldings + -- confuse use (it might mention something not + -- even in scope at the new site + (mkTyApps (Var gbl_id) (mkTyVarTys tyvars)) + + do_one lg_binds (lcl_id, rhs) + | Just (id_tvs, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id + = WARN( not (null spec_prags), ppr gbl_id $$ ppr spec_prags ) -- Not overloaded + (let rhs' = addAutoScc auto_scc gbl_id $ + mkLams id_tvs $ + mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv)) + | tv <- tyvars, not (tv `elem` id_tvs)] $ + add_lets lg_binds rhs + in return (mk_lg_bind lcl_id gbl_id id_tvs, + makeCorePair gbl_id (lookupArity ar_env lcl_id) rhs')) | otherwise - = (NonRec lcl_id (mkTyApps (Var non_exp_gbl_id) (mkTyVarTys tyvars)), - (non_exp_gbl_id, mkLams tyvars (add_lets rhs))) - where - non_exp_gbl_id = setIdType lcl_id (mkForAllTys tyvars (idType lcl_id)) + = do { non_exp_gbl_id <- newUniqueId lcl_id (mkForAllTys tyvars (idType lcl_id)) + ; return (mk_lg_bind lcl_id non_exp_gbl_id tyvars, + (non_exp_gbl_id, mkLams tyvars (add_lets lg_binds rhs))) } + ; (_, core_prs') <- fixDs (\ ~(lg_binds, _) -> mapAndUnzipM (do_one lg_binds) core_prs) ; return (core_prs' ++ rest) } -- Another common case: one exported variable -- Non-recursive bindings come through this way + -- So do self-recursive bindings, and recursive bindings + -- that have been chopped up with type signatures dsHsBind auto_scc rest (AbsBinds all_tyvars dicts [(tyvars, global, local, prags)] binds) - = ASSERT( all (`elem` tyvars) all_tyvars ) do - core_prs <- ds_lhs_binds NoSccs binds - let - -- Always treat the binds as recursive, because the typechecker - -- makes rather mixed-up dictionary bindings - core_bind = Rec core_prs + = ASSERT( all (`elem` tyvars) all_tyvars ) + do { core_prs <- ds_lhs_binds NoSccs binds + + ; let -- Always treat the binds as recursive, because the typechecker + -- makes rather mixed-up dictionary bindings + core_bind = Rec core_prs + inl_arity = lookupArity (mkArityEnv binds) local - mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind) prags - let - (spec_binds, rules) = unzip (catMaybes mb_specs) - global' = addIdSpecialisations global rules - rhs' = mkLams tyvars $ mkLams dicts $ Let core_bind (Var local) - bind = addInlinePrags prags global' $ addAutoScc auto_scc global' rhs' + ; (spec_binds, rules) <- dsSpecs all_tyvars dicts tyvars global + local inl_arity core_bind prags + + ; let global' = addIdSpecialisations global rules + rhs = addAutoScc auto_scc global $ + mkLams tyvars $ mkLams dicts $ Let core_bind (Var local) + main_bind = makeCorePair global' (inl_arity + dictArity dicts) rhs - return (bind : spec_binds ++ rest) + ; return (main_bind : spec_binds ++ rest) } dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds) = do { core_prs <- ds_lhs_binds NoSccs binds ; let env = mkABEnv exports - do_one (lcl_id,rhs) | Just (_, gbl_id, _, prags) <- lookupVarEnv env lcl_id - = addInlinePrags prags lcl_id $ - addAutoScc auto_scc gbl_id rhs + ar_env = mkArityEnv binds + do_one (lcl_id,rhs) | Just (_, gbl_id, _, _prags) <- lookupVarEnv env lcl_id + = (lcl_id, addAutoScc auto_scc gbl_id rhs) | otherwise = (lcl_id,rhs) -- Rec because of mixed-up dictionary bindings @@ -262,18 +289,17 @@ ; poly_tup_id <- newSysLocalDs (exprType poly_tup_expr) - ; let mk_bind ((tyvars, global, local, prags), n) -- locals!!n == local + ; let mk_bind ((tyvars, global, local, spec_prags), n) -- locals!!n == local = -- Need to make fresh locals to bind in the selector, -- because some of the tyvars will be bound to 'Any' - do { ty_args <- mapM mk_ty_arg all_tyvars - ; let substitute = substTyWith all_tyvars ty_args + do { let ty_args = map mk_ty_arg all_tyvars + substitute = substTyWith all_tyvars ty_args ; locals' <- newSysLocalsDs (map substitute local_tys) ; tup_id <- newSysLocalDs (substitute tup_ty) - ; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global - local core_bind) - prags - ; let (spec_binds, rules) = unzip (catMaybes mb_specs) - global' = addIdSpecialisations global rules + ; (spec_binds, rules) <- dsSpecs all_tyvars dicts tyvars global local + (lookupArity ar_env local) core_bind + spec_prags + ; let global' = addIdSpecialisations global rules rhs = mkLams tyvars $ mkLams dicts $ mkTupleSelector locals' (locals' !! n) tup_id $ mkVarApps (mkTyApps (Var poly_tup_id) ty_args) @@ -281,95 +307,197 @@ ; return ((global', rhs) : spec_binds) } where mk_ty_arg all_tyvar - | all_tyvar `elem` tyvars = return (mkTyVarTy all_tyvar) + | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar | otherwise = dsMkArbitraryType all_tyvar ; export_binds_s <- mapM mk_bind (exports `zip` [0..]) - -- don't scc (auto-)annotate the tuple itself. + -- Don't scc (auto-)annotate the tuple itself. ; return ((poly_tup_id, poly_tup_expr) : (concat export_binds_s ++ rest)) } -mkABEnv :: [([TyVar], Id, Id, [LPrag])] -> VarEnv ([TyVar], Id, Id, [LPrag]) +------------------------ +makeCorePair :: Id-> Arity -> CoreExpr -> (Id, CoreExpr) +makeCorePair gbl_id arity rhs + | isInlinePragma (idInlinePragma gbl_id) + -- Add an Unfolding for an INLINE (but not for NOINLINE) + -- And eta-expand the RHS; see Note [Eta-expanding INLINE things] + = (gbl_id `setIdUnfolding` mkInlineRule needSaturated rhs arity, + etaExpand arity rhs) + | otherwise + = (gbl_id, rhs) + +------------------------ +type AbsBindEnv = VarEnv ([TyVar], Id, Id, [LSpecPrag]) + -- Maps the "lcl_id" for an AbsBind to + -- its "gbl_id" and associated pragmas, if any + +mkABEnv :: [([TyVar], Id, Id, [LSpecPrag])] -> AbsBindEnv -- Takes the exports of a AbsBinds, and returns a mapping -- lcl_id -> (tyvars, gbl_id, lcl_id, prags) mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports] +mkArityEnv :: LHsBinds Id -> IdEnv Arity + -- Maps a local to the arity of its definition +mkArityEnv binds = foldrBag (plusVarEnv . lhsBindArity) emptyVarEnv binds + +lhsBindArity :: LHsBind Id -> IdEnv Arity +lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) + = unitVarEnv (unLoc id) (matchGroupArity ms) +lhsBindArity (L _ (AbsBinds { abs_exports = exports + , abs_dicts = dicts + , abs_binds = binds })) + = mkVarEnv [ (gbl, lookupArity ar_env lcl + n_val_dicts) + | (_, gbl, lcl, _) <- exports] + where -- See Note [Nested arities] + ar_env = mkArityEnv binds + n_val_dicts = dictArity dicts + +lhsBindArity _ = emptyVarEnv -- PatBind/VarBind + +dictArity :: [Var] -> Arity +-- Don't count coercion variables in arity +dictArity dicts = count isId dicts + +lookupArity :: IdEnv Arity -> Id -> Arity +lookupArity ar_env id = lookupVarEnv ar_env id `orElse` 0 +\end{code} + +Note [Eta-expanding INLINE things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + foo :: Eq a => a -> a + {-# INLINE foo #-} + foo x = ... + +If (foo d) ever gets floated out as a common sub-expression (which can +happen as a result of method sharing), there's a danger that we never +get to do the inlining, which is a Terribly Bad thing given that the +user said "inline"! + +To avoid this we pre-emptively eta-expand the definition, so that foo +has the arity with which it is declared in the source code. In this +example it has arity 2 (one for the Eq and one for x). Doing this +should mean that (foo d) is a PAP and we don't share it. + +Note [Nested arities] +~~~~~~~~~~~~~~~~~~~~~ +For reasons that are not entirely clear, method bindings come out looking like +this: + + AbsBinds [] [] [$cfromT <= [] fromT] + $cfromT [InlPrag=INLINE] :: T Bool -> Bool + { AbsBinds [] [] [fromT <= [] fromT_1] + fromT :: T Bool -> Bool + { fromT_1 ((TBool b)) = not b } } } + +Note the nested AbsBind. The arity for the InlineRule on $cfromT should be +gotten from the binding for fromT_1. + +It might be better to have just one level of AbsBinds, but that requires more +thought! + +Note [Implementing SPECIALISE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Example: + f :: (Eq a, Ix b) => a -> b -> Bool + {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-} + +From this the typechecker generates + + AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds + + SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX + -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ]) + +Note that wrap_fn can transform *any* function with the right type prefix + forall ab. (Eq a, Ix b) => +regardless of . It's sort of polymorphic in . This is +useful: we use the same wrapper to transform each of the class ops, as +well as the dict. + +From these we generate: + + Rule: forall p, q, (dp:Ix p), (dq:Ix q). + f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq + + Spec bind: f_spec = wrap_fn (/\ab \d1 d2. Let binds in f_mono) + +Note that + + * The LHS of the rule may mention dictionary *expressions* (eg + $dfIxPair dp dq), and that is essential because the dp, dq are + needed on the RHS. + + * The RHS of f_spec has a *copy* of 'binds', so that it can fully + specialise it. + +\begin{code} +------------------------ +dsSpecs :: [TyVar] -> [DictId] -> [TyVar] + -> Id -> Id -> Arity -- Global, local, arity of local + -> CoreBind -> [LSpecPrag] + -> DsM ( [(Id,CoreExpr)] -- Binding for specialised Ids + , [CoreRule] ) -- Rules for the Global Ids +-- See Note [Implementing SPECIALISE pragmas] +dsSpecs all_tvs dicts tvs poly_id mono_id inl_arity mono_bind prags + = do { pairs <- mapMaybeM spec_one prags + ; let (spec_binds_s, rules) = unzip pairs + ; return (concat spec_binds_s, rules) } + where + spec_one :: LSpecPrag -> DsM (Maybe ([(Id,CoreExpr)], CoreRule)) + spec_one (L loc (SpecPrag spec_co spec_inl)) + = putSrcSpanDs loc $ + do { let poly_name = idName poly_id + ; spec_name <- newLocalName poly_name + ; wrap_fn <- dsCoercion spec_co + ; let ds_spec_expr = wrap_fn (Var poly_id) + ; case decomposeRuleLhs ds_spec_expr of { + Nothing -> do { warnDs (decomp_msg spec_co) + ; return Nothing } ; + + Just (bndrs, _fn, args) -> + + -- Check for dead binders: Note [Unused spec binders] + case filter isDeadBinder bndrs of { + bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing } + | otherwise -> do + + { (spec_unf, unf_pairs) <- specUnfolding wrap_fn (realIdUnfolding poly_id) + + ; let f_body = fix_up (Let mono_bind (Var mono_id)) + spec_ty = exprType ds_spec_expr + spec_id = mkLocalId spec_name spec_ty + `setInlinePragma` inl_prag + `setIdUnfolding` spec_unf + inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id + | otherwise = spec_inl + -- Get the INLINE pragma from SPECIALISE declaration, or, + -- failing that, from the original Id + + spec_id_arity = inl_arity + count isDictId bndrs + + extra_dict_bndrs = [ localiseId d -- See Note [Constant rule dicts] + | d <- varSetElems (exprFreeVars ds_spec_expr) + , isDictId d] + -- Note [Const rule dicts] + + rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name))) + AlwaysActive poly_name + (extra_dict_bndrs ++ bndrs) args + (mkVarApps (Var spec_id) bndrs) + + spec_rhs = wrap_fn (mkLams (tvs ++ dicts) f_body) + spec_pair = makeCorePair spec_id spec_id_arity spec_rhs + + ; return (Just (spec_pair : unf_pairs, rule)) + } } } } -dsSpec :: [TyVar] -> [DictId] -> [TyVar] - -> Id -> Id -- Global, local - -> CoreBind -> LPrag - -> DsM (Maybe ((Id,CoreExpr), -- Binding for specialised Id - CoreRule)) -- Rule for the Global Id - --- Example: --- f :: (Eq a, Ix b) => a -> b -> b --- {-# SPECIALISE f :: Ix b => Int -> b -> b #-} --- --- AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds --- --- SpecPrag (/\b.\(d:Ix b). f Int b dInt d) --- (forall b. Ix b => Int -> b -> b) --- --- Rule: forall b,(d:Ix b). f Int b dInt d = f_spec b d --- --- Spec bind: f_spec = Let f = /\ab \(d1:Eq a)(d2:Ix b). let binds in f_mono --- /\b.\(d:Ix b). in f Int b dInt d --- The idea is that f occurs just once, so it'll be --- inlined and specialised --- --- Given SpecPrag (/\as.\ds. f es) t, we have --- the defn f_spec as ds = let-nonrec f = /\fas\fds. let f_mono = in f_mono --- in f es --- and the RULE forall as, ds. f es = f_spec as ds --- --- It is *possible* that 'es' does not mention all of the dictionaries 'ds' --- (a bit silly, because then the -dsSpec _ _ _ _ _ _ (L _ (InlinePrag {})) - = return Nothing - -dsSpec all_tvs dicts tvs poly_id mono_id mono_bind - (L loc (SpecPrag spec_expr spec_ty inl)) - = putSrcSpanDs loc $ - do { let poly_name = idName poly_id - ; spec_name <- newLocalName poly_name - ; ds_spec_expr <- dsExpr spec_expr - ; case (decomposeRuleLhs ds_spec_expr) of { - Nothing -> do { warnDs decomp_msg; return Nothing } ; - - Just (bndrs, _fn, args) -> - - -- Check for dead binders: Note [Unused spec binders] - case filter isDeadBinder bndrs of { - bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing } - | otherwise -> do - - { f_body <- fix_up (Let mono_bind (Var mono_id)) - - ; let local_poly = setIdNotExported poly_id - -- Very important to make the 'f' non-exported, - -- else it won't be inlined! - spec_id = mkLocalId spec_name spec_ty - spec_rhs = Let (NonRec local_poly poly_f_body) ds_spec_expr - poly_f_body = mkLams (tvs ++ dicts) f_body - - extra_dict_bndrs = [localiseId d -- See Note [Constant rule dicts] - | d <- varSetElems (exprFreeVars ds_spec_expr) - , isDictId d] - -- Note [Const rule dicts] - - rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name))) - AlwaysActive poly_name - (extra_dict_bndrs ++ bndrs) args - (mkVarApps (Var spec_id) bndrs) - ; return (Just (addInlineInfo inl spec_id spec_rhs, rule)) - } } } } - where -- Bind to Any any of all_ptvs that aren't -- relevant for this particular function - fix_up body | null void_tvs = return body - | otherwise = do { void_tys <- mapM dsMkArbitraryType void_tvs - ; return (mkTyApps (mkLams void_tvs body) void_tys) } + fix_up body | null void_tvs = body + | otherwise = mkTyApps (mkLams void_tvs body) $ + map dsMkArbitraryType void_tvs void_tvs = all_tvs \\ tvs @@ -379,31 +507,37 @@ , ptext (sLit "SPECIALISE pragma ignored")] get_pred b = ASSERT( isId b ) expectJust "dsSpec" (tcSplitPredTy_maybe (idType b)) - decomp_msg = hang (ptext (sLit "Specialisation too complicated to desugar; ignored")) - 2 (ppr spec_expr) + decomp_msg spec_co + = hang (ptext (sLit "Specialisation too complicated to desugar; ignored")) + 2 (pprHsWrapper (ppr poly_id) spec_co) -mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> DsM (TyVarEnv Type) +specUnfolding :: (CoreExpr -> CoreExpr) -> Unfolding -> DsM (Unfolding, [(Id,CoreExpr)]) +specUnfolding wrap_fn (DFunUnfolding con ops) + = do { let spec_rhss = map wrap_fn ops + ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss + ; return (DFunUnfolding con (map Var spec_ids), spec_ids `zip` spec_rhss) } +specUnfolding _ _ + = return (noUnfolding, []) + +mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> TyVarEnv Type -- If any of the tyvars is missing from any of the lists in -- the second arg, return a binding in the result mkArbitraryTypeEnv tyvars exports = go emptyVarEnv exports where - go env [] = return env + go env [] = env go env ((ltvs, _, _, _) : exports) - = do { env' <- foldlM extend env [tv | tv <- tyvars - , not (tv `elem` ltvs) - , not (tv `elemVarEnv` env)] - ; go env' exports } + = go env' exports + where + env' = foldl extend env [tv | tv <- tyvars + , not (tv `elem` ltvs) + , not (tv `elemVarEnv` env)] - extend env tv = do { ty <- dsMkArbitraryType tv - ; return (extendVarEnv env tv ty) } + extend env tv = extendVarEnv env tv (dsMkArbitraryType tv) - -dsMkArbitraryType :: TcTyVar -> DsM Type -dsMkArbitraryType tv = mkArbitraryType warn tv - where - warn span msg = putSrcSpanDs span (warnDs msg) +dsMkArbitraryType :: TcTyVar -> Type +dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv) \end{code} Note [Unused spec binders] @@ -433,7 +567,7 @@ {-# SPECIALISE f :: Int -> Int #-} Then we get the SpecPrag - SpecPrag (f Int dInt) Int + SpecPrag (f Int dInt) And from that we want the rule @@ -459,81 +593,31 @@ -- That is, the RULE binders are lambda-bound -- Returns Nothing if the LHS isn't of the expected shape decomposeRuleLhs lhs - = case (decomp emptyVarEnv body) of - Nothing -> Nothing - Just (fn, args) -> Just (bndrs, fn, args) - where - occ_lhs = occurAnalyseExpr lhs - -- The occurrence-analysis does two things - -- (a) identifies unused binders: Note [Unused spec binders] - -- (b) sorts dict bindings into NonRecs - -- so they can be inlined by 'decomp' - (bndrs, body) = collectBinders occ_lhs - - -- Substitute dicts in the LHS args, so that there - -- aren't any lets getting in the way - -- Note that we substitute the function too; we might have this as - -- a LHS: let f71 = M.f Int in f71 - decomp env (Let (NonRec dict rhs) body) - = decomp (extendVarEnv env dict (simpleSubst env rhs)) body - - decomp env (Case scrut bndr ty [(DEFAULT, _, body)]) - | isDeadBinder bndr -- Note [Matching seqId] - = Just (seqId, [Type (idType bndr), Type ty, - simpleSubst env scrut, simpleSubst env body]) - - decomp env body - = case collectArgs (simpleSubst env body) of - (Var fn, args) -> Just (fn, args) - _ -> Nothing - -simpleSubst :: IdEnv CoreExpr -> CoreExpr -> CoreExpr --- Similar to CoreSubst.substExpr, except that --- (a) Takes no account of capture; at this point there is no shadowing --- (b) Can have a GlobalId (imported) in its domain --- (c) Ids only; no types are substituted --- (d) Does not insist (as does CoreSubst.lookupIdSubst) that the --- in-scope set mentions all LocalIds mentioned in the argument of the subst --- --- (b) and (d) are the reasons we can't use CoreSubst --- --- (I had a note that (b) is "no longer relevant", and indeed it doesn't --- look relevant here. Perhaps there was another caller of simpleSubst.) + = case collectArgs body of + (Var fn, args) -> Just (bndrs, fn, args) -simpleSubst subst expr - = go expr - where - go (Var v) = lookupVarEnv subst v `orElse` Var v - go (Cast e co) = Cast (go e) co - go (Type ty) = Type ty - go (Lit lit) = Lit lit - go (App fun arg) = App (go fun) (go arg) - go (Note note e) = Note note (go e) - go (Lam bndr body) = Lam bndr (go body) - go (Let (NonRec bndr rhs) body) = Let (NonRec bndr (go rhs)) (go body) - go (Let (Rec pairs) body) = Let (Rec (mapSnd go pairs)) (go body) - go (Case scrut bndr ty alts) = Case (go scrut) bndr ty - [(c,bs,go r) | (c,bs,r) <- alts] - -addInlinePrags :: [LPrag] -> Id -> CoreExpr -> (Id,CoreExpr) -addInlinePrags prags bndr rhs - = case [inl | L _ (InlinePrag inl) <- prags] of - [] -> (bndr, rhs) - (inl:_) -> addInlineInfo inl bndr rhs - -addInlineInfo :: InlineSpec -> Id -> CoreExpr -> (Id,CoreExpr) -addInlineInfo (Inline prag is_inline) bndr rhs - = (attach_pragma bndr prag, wrap_inline is_inline rhs) + (Case scrut bndr ty [(DEFAULT, _, body)], args) + | isDeadBinder bndr -- Note [Matching seqId] + -> Just (bndrs, seqId, args' ++ args) + where + args' = [Type (idType bndr), Type ty, scrut, body] + + _other -> Nothing -- Unexpected shape where - attach_pragma bndr prag - | isDefaultInlinePragma prag = bndr - | otherwise = bndr `setInlinePragma` prag - - wrap_inline True body = mkInlineMe body - wrap_inline False body = body + (bndrs, body) = collectBinders (simpleOptExpr lhs) + -- simpleOptExpr occurrence-analyses and simplifies the lhs + -- and thereby + -- (a) identifies unused binders: Note [Unused spec binders] + -- (b) sorts dict bindings into NonRecs + -- so they can be inlined by 'decomp' + -- (c) substitute trivial lets so that they don't get in the way + -- Note that we substitute the function too; we might + -- have this as a LHS: let f71 = M.f Int in f71 + -- NB: tcSimplifyRuleLhs is very careful not to generate complicated + -- dictionary expressions that we might have to match \end{code} -Note [Matching seq] +Note [Matching seqId] ~~~~~~~~~~~~~~~~~~~ The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack and this code turns it back into an application of seq! @@ -591,25 +675,19 @@ \begin{code} -dsCoercion :: HsWrapper -> DsM CoreExpr -> DsM CoreExpr -dsCoercion WpHole thing_inside = thing_inside -dsCoercion (WpCompose c1 c2) thing_inside = dsCoercion c1 (dsCoercion c2 thing_inside) -dsCoercion (WpCast co) thing_inside = do { expr <- thing_inside - ; return (Cast expr co) } -dsCoercion (WpLam id) thing_inside = do { expr <- thing_inside - ; return (Lam id expr) } -dsCoercion (WpTyLam tv) thing_inside = do { expr <- thing_inside - ; return (Lam tv expr) } -dsCoercion (WpApp v) thing_inside - | isTyVar v = do { expr <- thing_inside - {- Probably a coercion var -} ; return (App expr (Type (mkTyVarTy v))) } - | otherwise = do { expr <- thing_inside - {- An Id -} ; return (App expr (Var v)) } -dsCoercion (WpTyApp ty) thing_inside = do { expr <- thing_inside - ; return (App expr (Type ty)) } -dsCoercion WpInline thing_inside = do { expr <- thing_inside - ; return (mkInlineMe expr) } -dsCoercion (WpLet bs) thing_inside = do { prs <- dsLHsBinds bs - ; expr <- thing_inside - ; return (Let (Rec prs) expr) } +dsCoercion :: HsWrapper -> DsM (CoreExpr -> CoreExpr) +dsCoercion WpHole = return (\e -> e) +dsCoercion (WpCompose c1 c2) = do { k1 <- dsCoercion c1 + ; k2 <- dsCoercion c2 + ; return (k1 . k2) } +dsCoercion (WpCast co) = return (\e -> Cast e co) +dsCoercion (WpLam id) = return (\e -> Lam id e) +dsCoercion (WpTyLam tv) = return (\e -> Lam tv e) +dsCoercion (WpApp v) | isTyVar v -- Probably a coercion var + = return (\e -> App e (Type (mkTyVarTy v))) + | otherwise + = return (\e -> App e (Var v)) +dsCoercion (WpTyApp ty) = return (\e -> App e (Type ty)) +dsCoercion (WpLet bs) = do { prs <- dsLHsBinds bs + ; return (\e -> Let (Rec prs) e) } \end{code} diff -ruN ghc-6.12.1/compiler/deSugar/DsExpr.lhs ghc-6.13.20091231/compiler/deSugar/DsExpr.lhs --- ghc-6.12.1/compiler/deSugar/DsExpr.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/deSugar/DsExpr.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -43,12 +43,15 @@ import Coercion import CoreSyn import CoreUtils +import CoreFVs import MkCore import DynFlags import StaticFlags import CostCentre import Id +import Var +import VarSet import PrelInfo import DataCon import TysWiredIn @@ -208,7 +211,9 @@ dsExpr (HsIPVar ip) = return (Var (ipNameName ip)) dsExpr (HsLit lit) = dsLit lit dsExpr (HsOverLit lit) = dsOverLit lit -dsExpr (HsWrap co_fn e) = dsCoercion co_fn (dsExpr e) +dsExpr (HsWrap co_fn e) = do { co_fn' <- dsCoercion co_fn + ; e' <- dsExpr e + ; return (co_fn' e') } dsExpr (NegApp expr neg_expr) = App <$> dsExpr neg_expr <*> dsLExpr expr @@ -638,28 +643,40 @@ foldr k z [x] = ... We do not want to generate a build invocation on the LHS of this RULE! +We fix this by disabling rules in rule LHSs, and testing that +flag here; see Note [Desugaring RULE left hand sides] in Desugar + To test this I've added a (static) flag -fsimple-list-literals, which makes all list literals be generated via the simple route. \begin{code} - dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr -- See Note [Desugaring explicit lists] -dsExplicitList elt_ty xs = do - dflags <- getDOptsDs - xs' <- mapM dsLExpr xs - if opt_SimpleListLiterals || not (dopt Opt_EnableRewriteRules dflags) - then return $ mkListExpr elt_ty xs' - else mkBuildExpr elt_ty (mkSplitExplicitList (thisPackage dflags) xs') +dsExplicitList elt_ty xs + = do { dflags <- getDOptsDs + ; xs' <- mapM dsLExpr xs + ; let (dynamic_prefix, static_suffix) = spanTail is_static xs' + ; if opt_SimpleListLiterals -- -fsimple-list-literals + || not (dopt Opt_EnableRewriteRules dflags) -- Rewrite rules off + -- Don't generate a build if there are no rules to eliminate it! + -- See Note [Desugaring RULE left hand sides] in Desugar + || null dynamic_prefix -- Avoid build (\c n. foldr c n xs)! + then return $ mkListExpr elt_ty xs' + else mkBuildExpr elt_ty (mkSplitExplicitList dynamic_prefix static_suffix) } where - mkSplitExplicitList this_package xs' (c, _) (n, n_ty) = do - let (dynamic_prefix, static_suffix) = spanTail (rhsIsStatic this_package) xs' - static_suffix' = mkListExpr elt_ty static_suffix - - folded_static_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) static_suffix' - let build_body = foldr (App . App (Var c)) folded_static_suffix dynamic_prefix - return build_body + is_static :: CoreExpr -> Bool + is_static e = all is_static_var (varSetElems (exprFreeVars e)) + + is_static_var :: Var -> Bool + is_static_var v + | isId v = isExternalName (idName v) -- Top-level things are given external names + | otherwise = False -- Type variables + + mkSplitExplicitList prefix suffix (c, _) (n, n_ty) + = do { let suffix' = mkListExpr elt_ty suffix + ; folded_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) suffix' + ; return (foldr (App . App (Var c)) folded_suffix prefix) } spanTail :: (a -> Bool) -> [a] -> ([a], [a]) spanTail f xs = (reverse rejected, reverse satisfying) @@ -737,8 +754,7 @@ body = noLoc $ HsDo DoExpr rec_stmts return_app body_ty return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets) body_ty = mkAppTy m_ty tup_ty - tup_ty = mkCoreTupTy (map idType tup_ids) - -- mkCoreTupTy deals with singleton case + tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case -- In a do expression, pattern-match failure just calls -- the monadic 'fail' rather than throwing an exception @@ -836,8 +852,7 @@ mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats body = noLoc $ HsDo ctxt rec_stmts return_app body_ty body_ty = mkAppTy m_ty tup_ty - tup_ty = mkCoreTupTy (map idType (later_ids' ++ rec_ids)) - -- mkCoreTupTy deals with singleton case + tup_ty = mkBoxedTupleTy (map idType (later_ids' ++ rec_ids)) -- Deals with singleton case return_app = nlHsApp (nlHsTyApp return_id [tup_ty]) (mkLHsTupleExpr rets) diff -ruN ghc-6.12.1/compiler/deSugar/DsForeign.lhs ghc-6.13.20091231/compiler/deSugar/DsForeign.lhs --- ghc-6.12.1/compiler/deSugar/DsForeign.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/deSugar/DsForeign.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -19,6 +19,7 @@ import HsSyn import DataCon import CoreUtils +import CoreUnfold import Id import Literal import Module @@ -205,9 +206,10 @@ -- Build the wrapper work_app = mkApps (mkVarApps (Var work_id) tvs) val_args wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers - wrap_rhs = mkInlineMe (mkLams (tvs ++ args) wrapper_body) + wrap_rhs = mkLams (tvs ++ args) wrapper_body + fn_id_w_inl = fn_id `setIdUnfolding` mkInlineRule needSaturated wrap_rhs (length args) - return ([(work_id, work_rhs), (fn_id, wrap_rhs)], empty, empty) + return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs)], empty, empty) \end{code} @@ -567,8 +569,8 @@ <> comma <> text "cap") <> semi , assignCResult , ptext (sLit "rts_unlock(cap);") - , if res_hty_is_unit then empty - else if libffi + , ppUnless res_hty_is_unit $ + if libffi then char '*' <> parens (cResType <> char '*') <> ptext (sLit "resp = cret;") else ptext (sLit "return cret;") diff -ruN ghc-6.12.1/compiler/deSugar/DsMeta.hs ghc-6.13.20091231/compiler/deSugar/DsMeta.hs --- ghc-6.12.1/compiler/deSugar/DsMeta.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/deSugar/DsMeta.hs 2009-12-31 10:14:17.000000000 -0800 @@ -36,11 +36,11 @@ -- OccName.varName we do this by removing varName from the import of -- OccName above, making a qualified instance of OccName and using -- OccNameAlias.varName where varName ws previously used in this file. -import qualified OccName +import qualified OccName( isDataOcc, isVarOcc, isTcOcc, varName, tcName ) import Module import Id -import Name +import Name hiding( isVarOcc, isTcOcc, varName, tcName ) import NameEnv import TcType import TyCon @@ -435,35 +435,38 @@ ; return [(loc, sig)] } -rep_inline :: Located Name -> InlineSpec -> SrcSpan +rep_inline :: Located Name + -> InlinePragma -- Never defaultInlinePragma + -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] rep_inline nm ispec loc = do { nm1 <- lookupLOcc nm - ; (_, ispec1) <- rep_InlineSpec ispec + ; ispec1 <- rep_InlinePrag ispec ; pragma <- repPragInl nm1 ispec1 ; return [(loc, pragma)] } -rep_specialise :: Located Name -> LHsType Name -> InlineSpec -> SrcSpan +rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] rep_specialise nm ty ispec loc = do { nm1 <- lookupLOcc nm ; ty1 <- repLTy ty - ; (hasSpec, ispec1) <- rep_InlineSpec ispec - ; pragma <- if hasSpec - then repPragSpecInl nm1 ty1 ispec1 - else repPragSpec nm1 ty1 + ; pragma <- if isDefaultInlinePragma ispec + then repPragSpec nm1 ty1 -- SPECIALISE + else do { ispec1 <- rep_InlinePrag ispec -- SPECIALISE INLINE + ; repPragSpecInl nm1 ty1 ispec1 } ; return [(loc, pragma)] } --- extract all the information needed to build a TH.InlineSpec +-- Extract all the information needed to build a TH.InlinePrag -- -rep_InlineSpec :: InlineSpec -> DsM (Bool, Core TH.InlineSpecQ) -rep_InlineSpec (Inline (InlinePragma activation match) inline) +rep_InlinePrag :: InlinePragma -- Never defaultInlinePragma + -> DsM (Core TH.InlineSpecQ) +rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inline = inline }) | Nothing <- activation1 - = liftM ((,) False) $ repInlineSpecNoPhase inline1 match1 + = repInlineSpecNoPhase inline1 match1 | Just (flag, phase) <- activation1 - = liftM ((,) True) $ repInlineSpecPhase inline1 match1 flag phase + = repInlineSpecPhase inline1 match1 flag phase | otherwise = {- unreachable, but shuts up -W -} panic "rep_InlineSpec" where match1 = coreBool (rep_RuleMatchInfo match) @@ -473,8 +476,8 @@ rep_RuleMatchInfo FunLike = False rep_RuleMatchInfo ConLike = True - rep_Activation NeverActive = Nothing - rep_Activation AlwaysActive = Nothing + rep_Activation NeverActive = Nothing -- We never have NOINLINE/AlwaysActive + rep_Activation AlwaysActive = Nothing -- or INLINE/NeverActive rep_Activation (ActiveBefore phase) = Just (coreBool False, MkC $ mkIntExprInt phase) rep_Activation (ActiveAfter phase) = Just (coreBool True, diff -ruN ghc-6.12.1/compiler/deSugar/DsMonad.lhs ghc-6.13.20091231/compiler/deSugar/DsMonad.lhs --- ghc-6.12.1/compiler/deSugar/DsMonad.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/deSugar/DsMonad.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -9,7 +9,7 @@ module DsMonad ( DsM, mapM, mapAndUnzipM, initDs, initDsTc, fixDs, - foldlM, foldrM, ifOptM, + foldlM, foldrM, ifOptM, unsetOptM, Applicative(..),(<$>), newLocalName, @@ -25,6 +25,8 @@ DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv, + dsLoadModule, + -- Warnings DsWarning, warnDs, failWithDs, @@ -38,6 +40,7 @@ import CoreSyn import HsSyn import TcIface +import LoadIface import RdrName import HscTypes import Bag @@ -218,8 +221,8 @@ \begin{code} -- Make a new Id with the same print name, but different type, and new unique -newUniqueId :: Name -> Type -> DsM Id -newUniqueId id = mkSysLocalM (occNameFS (nameOccName id)) +newUniqueId :: Id -> Type -> DsM Id +newUniqueId id = mkSysLocalM (occNameFS (nameOccName (idName id))) duplicateLocalDs :: Id -> DsM Id duplicateLocalDs old_local @@ -318,3 +321,13 @@ dsExtendMetaEnv menv thing_inside = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside \end{code} + +\begin{code} +dsLoadModule :: SDoc -> Module -> DsM () +dsLoadModule doc mod + = do { env <- getGblEnv + ; setEnvs (ds_if_env env) + (loadSysInterface doc mod >> return ()) + } +\end{code} + diff -ruN ghc-6.12.1/compiler/deSugar/DsUtils.lhs ghc-6.13.20091231/compiler/deSugar/DsUtils.lhs --- ghc-6.12.1/compiler/deSugar/DsUtils.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/deSugar/DsUtils.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -419,7 +419,7 @@ Seq is very, very special! So we recognise it right here, and desugar to case x of _ -> case y of _ -> (# x,y #) -Note [Desugaring seq (2)] cf Trac #2231 +Note [Desugaring seq (2)] cf Trac #2273 ~~~~~~~~~~~~~~~~~~~~~~~~~ Consider let chp = case b of { True -> fst x; False -> 0 } @@ -447,10 +447,14 @@ But that's painful. So the code here does a little hack to make seq more robust: a saturated application of 'seq' is turned *directly* into -the case expression. So we desugar to: +the case expression, thus: + x `seq` e2 ==> case x of x -> e2 -- Note shadowing! + e1 `seq` e2 ==> case x of _ -> e2 + +So we desugar our example to: let chp = case b of { True -> fst x; False -> 0 } case chp of chp { I# -> ...chp... } -Notice the shadowing of the case binder! And now all is well. +And now all is well. The reason it's a hack is because if you define mySeq=seq, the hack won't work on mySeq. @@ -600,7 +604,7 @@ mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id -- A vanilla tuple pattern simply gets its type from its sub-patterns mkVanillaTuplePat pats box - = TuplePat pats box (mkTupleTy box (length pats) (map hsLPatType pats)) + = TuplePat pats box (mkTupleTy box (map hsLPatType pats)) -- The Big equivalents for the source tuple expressions mkBigLHsVarTup :: [Id] -> LHsExpr Id diff -ruN ghc-6.12.1/compiler/deSugar/Match.lhs ghc-6.13.20091231/compiler/deSugar/Match.lhs --- ghc-6.12.1/compiler/deSugar/Match.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/deSugar/Match.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -344,10 +344,11 @@ -- Apply the coercion to the match variable and then match that matchCoercion (var:vars) ty (eqns@(eqn1:_)) = do { let CoPat co pat _ = firstPat eqn1 - ; var' <- newUniqueId (idName var) (hsPatType pat) + ; var' <- newUniqueId var (hsPatType pat) ; match_result <- match (var':vars) ty (map decomposeFirst_Coercion eqns) - ; rhs <- dsCoercion co (return (Var var)) - ; return (mkCoLetMatchResult (NonRec var' rhs) match_result) } + ; co' <- dsCoercion co + ; let rhs' = co' (Var var) + ; return (mkCoLetMatchResult (NonRec var' rhs') match_result) } matchView :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult -- Apply the view function to the match variable and then match that @@ -357,7 +358,7 @@ -- to figure out the type of the fresh variable let ViewPat viewExpr (L _ pat) _ = firstPat eqn1 -- do the rest of the compilation - ; var' <- newUniqueId (idName var) (hsPatType pat) + ; var' <- newUniqueId var (hsPatType pat) ; match_result <- match (var':vars) ty (map decomposeFirst_View eqns) -- compile the view expressions ; viewExpr' <- dsLExpr viewExpr diff -ruN ghc-6.12.1/compiler/ghc.cabal.in ghc-6.13.20091231/compiler/ghc.cabal.in --- ghc-6.12.1/compiler/ghc.cabal.in 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/ghc.cabal.in 2009-12-31 10:14:18.000000000 -0800 @@ -129,7 +129,6 @@ cmm codeGen coreSyn - cprAnalysis deSugar ghci hsSyn @@ -162,7 +161,6 @@ Name NameEnv NameSet - NewDemand OccName RdrName SrcLoc @@ -219,6 +217,7 @@ CgClosure CgCon CgExpr + CgExtCode CgForeignCall CgHeapery CgHpc @@ -265,7 +264,6 @@ MkExternalCore PprCore PprExternalCore - CprAnalyse Check Coverage Desugar @@ -373,9 +371,6 @@ StgLint StgSyn DmdAnal - SaAbsInt - SaLib - StrictAnal WorkWrap WwLib FamInst diff -ruN ghc-6.12.1/compiler/ghc.mk ghc-6.13.20091231/compiler/ghc.mk --- ghc-6.12.1/compiler/ghc.mk 2009-12-10 10:11:33.000000000 -0800 +++ ghc-6.13.20091231/compiler/ghc.mk 2009-12-31 10:14:18.000000000 -0800 @@ -29,6 +29,14 @@ compiler_CONFIG_HS = compiler/main/Config.hs +# This is just to avoid generating a warning when generating deps +# involving RtsFlags.h +compiler_stage1_MKDEPENDC_OPTS = -DMAKING_GHC_BUILD_SYSTEM_DEPENDENCIES +compiler_stage2_MKDEPENDC_OPTS = -DMAKING_GHC_BUILD_SYSTEM_DEPENDENCIES +compiler_stage3_MKDEPENDC_OPTS = -DMAKING_GHC_BUILD_SYSTEM_DEPENDENCIES + +compiler_stage1_C_FILES_NODEPS = compiler/parser/cutils.c + ifneq "$(BINDIST)" "YES" compiler/stage1/package-data.mk : $(compiler_CONFIG_HS) compiler/stage2/package-data.mk : $(compiler_CONFIG_HS) @@ -141,8 +149,7 @@ PLATFORM_H = ghc_boot_platform.h -compiler/stage1/$(PLATFORM_H) : mk/config.mk mk/project.mk - "$(MKDIRHIER)" $(dir $@) +compiler/stage1/$(PLATFORM_H) : mk/config.mk mk/project.mk | $$(dir $$@)/. "$(RM)" $(RM_OPTS) $@ @echo "Creating $@..." @echo "#ifndef __PLATFORM_H__" >$@ @@ -188,8 +195,7 @@ # For stage2 and above, the BUILD platform is the HOST of stage1, and # the HOST platform is the TARGET of stage1. The TARGET remains the same # (stage1 is the cross-compiler, not stage2). -compiler/stage2/$(PLATFORM_H) : mk/config.mk mk/project.mk - "$(MKDIRHIER)" $(dir $@) +compiler/stage2/$(PLATFORM_H) : mk/config.mk mk/project.mk | $$(dir $$@)/. "$(RM)" $(RM_OPTS) $@ @echo "Creating $@..." @echo "#ifndef __PLATFORM_H__" >$@ @@ -417,9 +423,11 @@ # below. # The ProjectPatchLevel > 20000000 iff it's a date. If it's e.g. 6.12.1 # then we don't want to remove it +ifneq "$(CLEANING)" "YES" ifeq "$(shell [ $(ProjectPatchLevel) -gt 20000000 ] && echo YES)" "YES" compiler_stage1_VERSION_MUNGED = YES endif +endif ifeq "$(compiler_stage1_VERSION_MUNGED)" "YES" define compiler_PACKAGE_MAGIC @@ -460,13 +468,13 @@ $(eval $(call build-package,compiler,stage3,2)) endif -$(compiler_stage1_depfile) : compiler/stage1/$(PLATFORM_H) -$(compiler_stage2_depfile) : compiler/stage2/$(PLATFORM_H) -$(compiler_stage3_depfile) : compiler/stage3/$(PLATFORM_H) - -$(compiler_stage1_depfile) : $(includes_H_CONFIG) $(includes_H_PLATFORM) $(includes_GHCCONSTANTS) $(includes_DERIVEDCONSTANTS) $(PRIMOP_BITS) -$(compiler_stage2_depfile) : $(includes_H_CONFIG) $(includes_H_PLATFORM) $(includes_GHCCONSTANTS) $(includes_DERIVEDCONSTANTS) $(PRIMOP_BITS) -$(compiler_stage3_depfile) : $(includes_H_CONFIG) $(includes_H_PLATFORM) $(includes_GHCCONSTANTS) $(includes_DERIVEDCONSTANTS) $(PRIMOP_BITS) +$(compiler_stage1_depfile_haskell) : compiler/stage1/$(PLATFORM_H) +$(compiler_stage2_depfile_haskell) : compiler/stage2/$(PLATFORM_H) +$(compiler_stage3_depfile_haskell) : compiler/stage3/$(PLATFORM_H) + +$(compiler_stage1_depfile_haskell) : $(includes_H_CONFIG) $(includes_H_PLATFORM) $(includes_GHCCONSTANTS) $(includes_DERIVEDCONSTANTS) $(PRIMOP_BITS) +$(compiler_stage2_depfile_haskell) : $(includes_H_CONFIG) $(includes_H_PLATFORM) $(includes_GHCCONSTANTS) $(includes_DERIVEDCONSTANTS) $(PRIMOP_BITS) +$(compiler_stage3_depfile_haskell) : $(includes_H_CONFIG) $(includes_H_PLATFORM) $(includes_GHCCONSTANTS) $(includes_DERIVEDCONSTANTS) $(PRIMOP_BITS) # Every Constants.o object file depends on includes/GHCConstants.h: $(eval $(call compiler-hs-dependency,Constants,$(includes_GHCCONSTANTS) includes/HaskellConstants.hs)) diff -ruN ghc-6.12.1/compiler/hsSyn/Convert.lhs ghc-6.13.20091231/compiler/hsSyn/Convert.lhs --- ghc-6.12.1/compiler/hsSyn/Convert.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/hsSyn/Convert.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -394,20 +394,22 @@ ; ty' <- cvtType ty ; return $ SpecSig nm' ty' (cvtInlineSpec opt_ispec) } -cvtInlineSpec :: Maybe TH.InlineSpec -> Hs.InlineSpec +cvtInlineSpec :: Maybe TH.InlineSpec -> Hs.InlinePragma cvtInlineSpec Nothing - = defaultInlineSpec + = defaultInlinePragma cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation)) - = mkInlineSpec opt_activation' matchinfo inline + = InlinePragma { inl_act = opt_activation', inl_rule = matchinfo, inl_inline = inline } where matchinfo = cvtRuleMatchInfo conlike - opt_activation' = fmap cvtActivation opt_activation + opt_activation' = cvtActivation opt_activation cvtRuleMatchInfo False = FunLike cvtRuleMatchInfo True = ConLike - cvtActivation (False, phase) = ActiveBefore phase - cvtActivation (True , phase) = ActiveAfter phase + cvtActivation Nothing | inline = AlwaysActive + | otherwise = NeverActive + cvtActivation (Just (False, phase)) = ActiveBefore phase + cvtActivation (Just (True , phase)) = ActiveAfter phase --------------------------------------------------- -- Declarations diff -ruN ghc-6.12.1/compiler/hsSyn/HsBinds.lhs ghc-6.13.20091231/compiler/hsSyn/HsBinds.lhs --- ghc-6.12.1/compiler/hsSyn/HsBinds.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/hsSyn/HsBinds.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -16,7 +16,7 @@ module HsBinds where -import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, LHsExpr, +import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr, MatchGroup, pprFunBind, GRHSs, pprPatBind ) import {-# SOURCE #-} HsPat ( LPat ) @@ -130,8 +130,10 @@ } | VarBind { -- Dictionary binding and suchlike - var_id :: idL, -- All VarBinds are introduced by the type checker - var_rhs :: LHsExpr idR -- Located only for consistency + var_id :: idL, -- All VarBinds are introduced by the type checker + var_rhs :: LHsExpr idR, -- Located only for consistency + var_inline :: Bool -- True <=> inline this binding regardless + -- (used for implication constraints only) } | AbsBinds { -- Binds abstraction; TRANSLATION @@ -141,7 +143,7 @@ -- AbsBinds only gets used when idL = idR after renaming, -- but these need to be idL's for the collect... code in HsUtil to have -- the right type - abs_exports :: [([TyVar], idL, idL, [LPrag])], -- (tvs, poly_id, mono_id, prags) + abs_exports :: [([TyVar], idL, idL, [LSpecPrag])], -- (tvs, poly_id, mono_id, prags) abs_binds :: LHsBinds idL -- The dictionary bindings and typechecked user bindings -- mixed up together; you can tell the dict bindings because -- they are all VarBinds @@ -363,7 +365,6 @@ | WpLam Var -- \d. [] the 'd' is a type-class dictionary or coercion variable | WpTyLam TyVar -- \a. [] the 'a' is a type variable (not coercion var) - | WpInline -- inline_me [] Wrap inline around the thing -- Non-empty bindings, so that the identity coercion -- is always exactly WpHole @@ -384,7 +385,6 @@ help it (WpLam id) = sep [ptext (sLit "\\") <> pprBndr LambdaBind id <> dot, it] help it (WpTyLam tv) = sep [ptext (sLit "/\\") <> pprBndr LambdaBind tv <> dot, it] help it (WpLet binds) = sep [ptext (sLit "let") <+> braces (ppr binds), it] - help it WpInline = sep [ptext (sLit "_inline_me_"), it] in -- in debug mode, print the wrapper -- otherwise just print what's inside @@ -452,13 +452,15 @@ -- An inline pragma -- {#- INLINE f #-} | InlineSig (Located name) -- Function name - InlineSpec + InlinePragma -- Never defaultInlinePragma -- A specialisation pragma -- {-# SPECIALISE f :: Int -> Int #-} | SpecSig (Located name) -- Specialise a function or datatype ... (LHsType name) -- ... to these types - InlineSpec + InlinePragma -- The pragma on SPECIALISE_INLINE form + -- If it's just defaultInlinePragma, then we said + -- SPECIALISE, not SPECIALISE_INLINE -- A specialisation pragma for instance declarations only -- {-# SPECIALISE instance Eq [Int] #-} @@ -470,23 +472,14 @@ data FixitySig name = FixitySig (Located name) Fixity -- A Prag conveys pragmas from the type checker to the desugarer -type LPrag = Located Prag -data Prag - = InlinePrag - InlineSpec - - | SpecPrag - (HsExpr Id) -- An expression, of the given specialised type, which - PostTcType -- specialises the polymorphic function - InlineSpec -- Inlining spec for the specialised function - -isInlinePrag :: Prag -> Bool -isInlinePrag (InlinePrag _) = True -isInlinePrag _ = False - -isSpecPrag :: Prag -> Bool -isSpecPrag (SpecPrag {}) = True -isSpecPrag _ = False +type LSpecPrag = Located SpecPrag +data SpecPrag + = SpecPrag + HsWrapper -- An wrapper, that specialises the polymorphic function + InlinePragma -- Inlining spec for the specialised function + +instance Outputable SpecPrag where + ppr (SpecPrag _ p) = ptext (sLit "SpecPrag") <+> ppr p \end{code} \begin{code} @@ -585,10 +578,10 @@ ppr sig = ppr_sig sig ppr_sig :: OutputableBndr name => Sig name -> SDoc -ppr_sig (TypeSig var ty) = pprVarSig (unLoc var) ty -ppr_sig (IdSig id) = pprVarSig id (varType id) +ppr_sig (TypeSig var ty) = pprVarSig (unLoc var) (ppr ty) +ppr_sig (IdSig id) = pprVarSig id (ppr (varType id)) ppr_sig (FixSig fix_sig) = ppr fix_sig -ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec var ty inl) +ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec var (ppr ty) inl) ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> ppr var) ppr_sig (SpecInstSig ty) = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty) @@ -598,14 +591,16 @@ pragBrackets :: SDoc -> SDoc pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}") -pprVarSig :: (Outputable id, Outputable ty) => id -> ty -> SDoc -pprVarSig var ty = sep [ppr var <+> dcolon, nest 2 (ppr ty)] +pprVarSig :: (Outputable id) => id -> SDoc -> SDoc +pprVarSig var pp_ty = sep [ppr var <+> dcolon, nest 2 pp_ty] -pprSpec :: (Outputable id, Outputable ty) => id -> ty -> InlineSpec -> SDoc -pprSpec var ty inl = sep [ptext (sLit "SPECIALIZE") <+> ppr inl <+> pprVarSig var ty] +pprSpec :: (Outputable id) => id -> SDoc -> InlinePragma -> SDoc +pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig var pp_ty + where + pp_inl | isDefaultInlinePragma inl = empty + | otherwise = ppr inl -pprPrag :: Outputable id => id -> LPrag -> SDoc -pprPrag var (L _ (InlinePrag inl)) = ppr inl <+> ppr var -pprPrag var (L _ (SpecPrag _expr ty inl)) = pprSpec var ty inl +pprPrag :: Outputable id => id -> LSpecPrag -> SDoc +pprPrag var (L _ (SpecPrag _expr inl)) = pprSpec var (ptext (sLit "")) inl \end{code} diff -ruN ghc-6.12.1/compiler/hsSyn/HsDecls.lhs ghc-6.13.20091231/compiler/hsSyn/HsDecls.lhs --- ghc-6.12.1/compiler/hsSyn/HsDecls.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/hsSyn/HsDecls.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -225,7 +225,7 @@ ppr_ds foreign_decls] where ppr_ds [] = empty - ppr_ds ds = text "" $$ vcat (map ppr ds) + ppr_ds ds = blankLine $$ vcat (map ppr ds) data SpliceDecl id = SpliceDecl (Located (HsExpr id)) -- Top level splice diff -ruN ghc-6.12.1/compiler/hsSyn/HsExpr.lhs ghc-6.13.20091231/compiler/hsSyn/HsExpr.lhs --- ghc-6.12.1/compiler/hsSyn/HsExpr.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/hsSyn/HsExpr.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -777,8 +777,8 @@ => HsMatchContext idL -> GRHSs idR -> SDoc pprGRHSs ctxt (GRHSs grhss binds) = vcat (map (pprGRHS ctxt . unLoc) grhss) - $$ if isEmptyLocalBinds binds then empty - else text "where" $$ nest 4 (pprBinds binds) + $$ ppUnless (isEmptyLocalBinds binds) + (text "where" $$ nest 4 (pprBinds binds)) pprGRHS :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> GRHS idR -> SDoc @@ -857,12 +857,9 @@ , recS_rec_ids :: [idR] -- Ditto, but these variables are the "recursive" ones, -- that are used before they are bound in the stmts of -- the RecStmt. - -- An Id can be in both groups -- Both sets of Ids are (now) treated monomorphically - -- The only reason they are separate is becuase the DsArrows - -- code uses them separately, and I don't understand it well - -- enough to change it + -- See Note [How RecStmt works] for why they are separate -- Rebindable syntax , recS_bind_fn :: SyntaxExpr idR -- The bind function @@ -912,25 +909,30 @@ Note [How RecStmt works] ~~~~~~~~~~~~~~~~~~~~~~~~ Example: - HsDo [ BindStmt x ex + HsDo [ BindStmt x ex - , RecStmt [a::forall a. a -> a, b] - [a::Int -> Int, c] - [ BindStmt b (return x) - , LetStmt a = ea - , BindStmt c ec ] + , RecStmt { recS_rec_ids = [a, c] + , recS_stmts = [ BindStmt b (return (a,c)) + , LetStmt a = ...b... + , BindStmt c ec ] + , recS_later_ids = [a, b] - , return (a b) ] + , return (a b) ] Here, the RecStmt binds a,b,c; but - Only a,b are used in the stmts *following* the RecStmt, - This 'a' is *polymorphic' - Only a,c are used in the stmts *inside* the RecStmt *before* their bindings - This 'a' is monomorphic -Nota Bene: the two a's have different types, even though they -have the same Name. +Why do we need *both* rec_ids and later_ids? For monads they could be +combined into a single set of variables, but not for arrows. That +follows from the types of the respective feedback operators: + + mfix :: MonadFix m => (a -> m a) -> m a + loop :: ArrowLoop a => a (b,d) (c,d) -> a b c + +* For mfix, the 'a' covers the union of the later_ids and the rec_ids +* For 'loop', 'c' is the later_ids and 'd' is the rec_ids Note [Typing a RecStmt] ~~~~~~~~~~~~~~~~~~~~~~~ diff -ruN ghc-6.12.1/compiler/hsSyn/HsPat.lhs ghc-6.13.20091231/compiler/hsSyn/HsPat.lhs --- ghc-6.12.1/compiler/hsSyn/HsPat.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/hsSyn/HsPat.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -310,7 +310,7 @@ => Outputable (HsRecField id arg) where ppr (HsRecField { hsRecFieldId = f, hsRecFieldArg = arg, hsRecPun = pun }) - = ppr f <+> (if pun then empty else equals <+> ppr arg) + = ppr f <+> (ppUnless pun $ equals <+> ppr arg) -- add parallel array brackets around a document -- diff -ruN ghc-6.12.1/compiler/hsSyn/HsUtils.lhs ghc-6.13.20091231/compiler/hsSyn/HsUtils.lhs --- ghc-6.12.1/compiler/hsSyn/HsUtils.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/hsSyn/HsUtils.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -1,3 +1,4 @@ + % % (c) The University of Glasgow, 1992-2006 % @@ -319,8 +320,12 @@ fun_tick = Nothing } -mkVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id -mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs +mkHsVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id +mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs + +mkVarBind :: id -> LHsExpr id -> LHsBind id +mkVarBind var rhs = L (getLoc rhs) $ + VarBind { var_id = var, var_rhs = rhs, var_inline = False } ------------ mk_easy_FunBind :: SrcSpan -> id -> [LPat id] diff -ruN ghc-6.12.1/compiler/iface/BinIface.hs ghc-6.13.20091231/compiler/iface/BinIface.hs --- ghc-6.12.1/compiler/iface/BinIface.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/iface/BinIface.hs 2009-12-31 10:14:18.000000000 -0800 @@ -17,7 +17,7 @@ import IfaceEnv import HscTypes import BasicTypes -import NewDemand +import Demand import Annotations import IfaceSyn import Module @@ -335,7 +335,7 @@ {-! for StrictnessMark derive: Binary !-} {-! for Activation derive: Binary !-} --- NewDemand +-- Demand {-! for Demand derive: Binary !-} {-! for Demands derive: Binary !-} {-! for DmdResult derive: Binary !-} @@ -600,14 +600,16 @@ else return FunLike instance Binary InlinePragma where - put_ bh (InlinePragma activation match_info) = do - put_ bh activation - put_ bh match_info + put_ bh (InlinePragma a b c) = do + put_ bh a + put_ bh b + put_ bh c get bh = do - act <- get bh - info <- get bh - return (InlinePragma act info) + a <- get bh + b <- get bh + c <- get bh + return (InlinePragma a b c) instance Binary StrictnessMark where put_ bh MarkedStrict = putByte bh 0 @@ -883,6 +885,7 @@ put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14 put_ bh (IfaceTyConApp IfaceUbxTupleKindTc []) = putByte bh 15 put_ bh (IfaceTyConApp IfaceArgTypeKindTc []) = putByte bh 16 + put_ bh (IfaceTyConApp (IfaceAnyTc k) []) = do { putByte bh 17; put_ bh k } -- Generic cases @@ -918,6 +921,7 @@ 14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc []) 15 -> return (IfaceTyConApp IfaceUbxTupleKindTc []) 16 -> return (IfaceTyConApp IfaceArgTypeKindTc []) + 17 -> do { k <- get bh; return (IfaceTyConApp (IfaceAnyTc k) []) } 18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) } _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) } @@ -937,6 +941,7 @@ put_ bh IfaceArgTypeKindTc = putByte bh 10 put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar } put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext } + put_ bh (IfaceAnyTc k) = do { putByte bh 13; put_ bh k } get bh = do h <- getByte bh @@ -952,7 +957,8 @@ 9 -> return IfaceUbxTupleKindTc 10 -> return IfaceArgTypeKindTc 11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) } - _ -> do { ext <- get bh; return (IfaceTc ext) } + 12 -> do { ext <- get bh; return (IfaceTc ext) } + _ -> do { k <- get bh; return (IfaceAnyTc k) } instance Binary IfacePredType where put_ bh (IfaceClassP aa ab) = do @@ -1155,18 +1161,15 @@ put_ bh (HsStrictness ab) = do putByte bh 1 put_ bh ab - put_ bh (HsUnfold ad) = do + put_ bh (HsUnfold lb ad) = do putByte bh 2 + put_ bh lb put_ bh ad put_ bh (HsInline ad) = do putByte bh 3 put_ bh ad put_ bh HsNoCafRefs = do putByte bh 4 - put_ bh (HsWorker ae af) = do - putByte bh 5 - put_ bh ae - put_ bh af get bh = do h <- getByte bh case h of @@ -1174,21 +1177,48 @@ return (HsArity aa) 1 -> do ab <- get bh return (HsStrictness ab) - 2 -> do ad <- get bh - return (HsUnfold ad) + 2 -> do lb <- get bh + ad <- get bh + return (HsUnfold lb ad) 3 -> do ad <- get bh return (HsInline ad) - 4 -> do return HsNoCafRefs - _ -> do ae <- get bh - af <- get bh - return (HsWorker ae af) + _ -> do return HsNoCafRefs + +instance Binary IfaceUnfolding where + put_ bh (IfCoreUnfold e) = do + putByte bh 0 + put_ bh e + put_ bh (IfInlineRule a b e) = do + putByte bh 1 + put_ bh a + put_ bh b + put_ bh e + put_ bh (IfWrapper a n) = do + putByte bh 2 + put_ bh a + put_ bh n + put_ bh (IfDFunUnfold as) = do + putByte bh 3 + put_ bh as + get bh = do + h <- getByte bh + case h of + 0 -> do e <- get bh + return (IfCoreUnfold e) + 1 -> do a <- get bh + b <- get bh + e <- get bh + return (IfInlineRule a b e) + 2 -> do a <- get bh + n <- get bh + return (IfWrapper a n) + _ -> do as <- get bh + return (IfDFunUnfold as) instance Binary IfaceNote where put_ bh (IfaceSCC aa) = do putByte bh 0 put_ bh aa - put_ bh IfaceInlineMe = do - putByte bh 3 put_ bh (IfaceCoreNote s) = do putByte bh 4 put_ bh s @@ -1197,7 +1227,6 @@ case h of 0 -> do aa <- get bh return (IfaceSCC aa) - 3 -> do return IfaceInlineMe 4 -> do ac <- get bh return (IfaceCoreNote ac) _ -> panic ("get IfaceNote " ++ show h) diff -ruN ghc-6.12.1/compiler/iface/IfaceSyn.lhs ghc-6.13.20091231/compiler/iface/IfaceSyn.lhs --- ghc-6.12.1/compiler/iface/IfaceSyn.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/iface/IfaceSyn.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -9,7 +9,8 @@ IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..), IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..), - IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), IfaceIdDetails(..), + IfaceBinding(..), IfaceConAlt(..), + IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..), IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, IfaceInst(..), IfaceFamInst(..), @@ -27,7 +28,7 @@ import IfaceType -import NewDemand +import Demand import Annotations import Class import NameSet @@ -201,15 +202,22 @@ = HsArity Arity | HsStrictness StrictSig | HsInline InlinePragma - | HsUnfold IfaceExpr + | HsUnfold Bool -- True <=> isNonRuleLoopBreaker is true + IfaceUnfolding -- See Note [Expose recursive functions] | HsNoCafRefs - | HsWorker Name Arity -- Worker, if any see IdInfo.WorkerInfo - -- for why we want arity here. - -- NB: we need IfaceExtName (not just OccName) because the worker - -- can simplify to a function in another module. + -- NB: Specialisations and rules come in separately and are -- only later attached to the Id. Partial reason: some are orphans. +data IfaceUnfolding + = IfCoreUnfold IfaceExpr + | IfInlineRule Arity + Bool -- OK to inline even if *un*-saturated + IfaceExpr + | IfWrapper Arity Name -- NB: we need a Name (not just OccName) because the worker + -- can simplify to a function in another module. + | IfDFunUnfold [IfaceExpr] + -------------------------------- data IfaceExpr = IfaceLcl FastString @@ -227,7 +235,6 @@ | IfaceTick Module Int data IfaceNote = IfaceSCC CostCentre - | IfaceInlineMe | IfaceCoreNote String type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr) @@ -250,6 +257,13 @@ data IfaceLetBndr = IfLetBndr FastString IfaceType IfaceIdInfo \end{code} +Note [Expose recursive functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For supercompilation we want to put *all* unfoldings in the interface +file, even for functions that are recursive (or big). So we need to +know when an unfolding belongs to a loop-breaker so that we can refrain +from inlining it (except during supercompilation). + Note [IdInfo on nested let-bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Occasionally we want to preserve IdInfo on nested let bindings. The one @@ -504,10 +518,10 @@ = sep [main_payload, if is_infix then ptext (sLit "Infix") else empty, if has_wrap then ptext (sLit "HasWrapper") else empty, - if null strs then empty - else nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr strs)), - if null fields then empty - else nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))] + ppUnless (null strs) $ + nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr strs)), + ppUnless (null fields) $ + nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))] where main_payload = ppr name <+> dcolon <+> pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau @@ -632,7 +646,6 @@ ------------------ instance Outputable IfaceNote where ppr (IfaceSCC cc) = pprCostCentreCore cc - ppr IfaceInlineMe = ptext (sLit "__inline_me") ppr (IfaceCoreNote s) = ptext (sLit "__core_note") <+> pprHsString (mkFastString s) @@ -652,16 +665,23 @@ instance Outputable IfaceIdInfo where ppr NoInfo = empty - ppr (HasInfo is) = ptext (sLit "{-") <+> fsep (map ppr is) <+> ptext (sLit "-}") + ppr (HasInfo is) = ptext (sLit "{-") <+> pprWithCommas ppr is <+> ptext (sLit "-}") instance Outputable IfaceInfoItem where - ppr (HsUnfold unf) = ptext (sLit "Unfolding:") <+> - parens (pprIfaceExpr noParens unf) + ppr (HsUnfold lb unf) = ptext (sLit "Unfolding") <> ppWhen lb (ptext (sLit "(loop-breaker)")) + <> colon <+> ppr unf ppr (HsInline prag) = ptext (sLit "Inline:") <+> ppr prag ppr (HsArity arity) = ptext (sLit "Arity:") <+> int arity ppr (HsStrictness str) = ptext (sLit "Strictness:") <+> pprIfaceStrictSig str ppr HsNoCafRefs = ptext (sLit "HasNoCafRefs") - ppr (HsWorker w a) = ptext (sLit "Worker:") <+> ppr w <+> int a + +instance Outputable IfaceUnfolding where + ppr (IfCoreUnfold e) = parens (ppr e) + ppr (IfInlineRule a b e) = ptext (sLit "InlineRule:") + <+> parens (ptext (sLit "arity") <+> int a <+> ppr b) + <+> parens (ppr e) + ppr (IfWrapper a wkr) = ptext (sLit "Worker:") <+> ppr wkr <+> parens (ptext (sLit "arity") <+> int a) + ppr (IfDFunUnfold ns) = ptext (sLit "DFun:") <+> brackets (pprWithCommas (pprIfaceExpr parens) ns) -- ----------------------------------------------------------------------------- @@ -775,9 +795,14 @@ freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i freeNamesItem :: IfaceInfoItem -> NameSet -freeNamesItem (HsUnfold u) = freeNamesIfExpr u -freeNamesItem (HsWorker wkr _) = unitNameSet wkr -freeNamesItem _ = emptyNameSet +freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u +freeNamesItem _ = emptyNameSet + +freeNamesIfUnfold :: IfaceUnfolding -> NameSet +freeNamesIfUnfold (IfCoreUnfold e) = freeNamesIfExpr e +freeNamesIfUnfold (IfInlineRule _ _ e) = freeNamesIfExpr e +freeNamesIfUnfold (IfWrapper _ v) = unitNameSet v +freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr vs freeNamesIfExpr :: IfaceExpr -> NameSet freeNamesIfExpr (IfaceExt v) = unitNameSet v diff -ruN ghc-6.12.1/compiler/iface/IfaceType.lhs ghc-6.13.20091231/compiler/iface/IfaceType.lhs --- ghc-6.12.1/compiler/iface/IfaceType.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/iface/IfaceType.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -68,32 +68,41 @@ type IfaceContext = [IfacePredType] --- NB: If you add a data constructor, remember to add a case to --- IfaceSyn.eqIfTc! data IfaceTyCon -- Abbreviations for common tycons with known names = IfaceTc Name -- The common case | IfaceIntTc | IfaceBoolTc | IfaceCharTc | IfaceListTc | IfacePArrTc | IfaceTupTc Boxity Arity + | IfaceAnyTc IfaceKind -- Used for AnyTyCon (see Note [Any Types] in TysPrim) | IfaceLiftedTypeKindTc | IfaceOpenTypeKindTc | IfaceUnliftedTypeKindTc | IfaceUbxTupleKindTc | IfaceArgTypeKindTc - deriving( Eq ) ifaceTyConName :: IfaceTyCon -> Name -ifaceTyConName IfaceIntTc = intTyConName -ifaceTyConName IfaceBoolTc = boolTyConName -ifaceTyConName IfaceCharTc = charTyConName -ifaceTyConName IfaceListTc = listTyConName -ifaceTyConName IfacePArrTc = parrTyConName -ifaceTyConName (IfaceTupTc bx ar) = getName (tupleTyCon bx ar) +ifaceTyConName IfaceIntTc = intTyConName +ifaceTyConName IfaceBoolTc = boolTyConName +ifaceTyConName IfaceCharTc = charTyConName +ifaceTyConName IfaceListTc = listTyConName +ifaceTyConName IfacePArrTc = parrTyConName +ifaceTyConName (IfaceTupTc bx ar) = getName (tupleTyCon bx ar) ifaceTyConName IfaceLiftedTypeKindTc = liftedTypeKindTyConName ifaceTyConName IfaceOpenTypeKindTc = openTypeKindTyConName ifaceTyConName IfaceUnliftedTypeKindTc = unliftedTypeKindTyConName ifaceTyConName IfaceUbxTupleKindTc = ubxTupleKindTyConName ifaceTyConName IfaceArgTypeKindTc = argTypeKindTyConName -ifaceTyConName (IfaceTc ext) = ext +ifaceTyConName (IfaceTc ext) = ext +ifaceTyConName (IfaceAnyTc kind) = pprPanic "ifaceTyConName" (ppr (IfaceAnyTc kind)) + -- Note [The Name of an IfaceAnyTc] \end{code} +Note [The Name of an IfaceAnyTc] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It isn't easy to get the Name of an IfaceAnyTc in a pure way. What you +really need to do is to transform it to a TyCon, and get the Name of that. +But doing so needs the monad. + +In fact, ifaceTyConName is only used for instances and rules, and we don't +expect to instantiate those at these (internal-ish) Any types, so rather +than solve this potential problem now, I'm going to defer it until it happens! %************************************************************************ %* * @@ -312,6 +321,7 @@ toIfaceTyCon :: TyCon -> IfaceTyCon toIfaceTyCon tc | isTupleTyCon tc = IfaceTupTc (tupleTyConBoxity tc) (tyConArity tc) + | isAnyTyCon tc = IfaceAnyTc (toIfaceKind (tyConKind tc)) | otherwise = toIfaceTyCon_name (tyConName tc) toIfaceTyCon_name :: Name -> IfaceTyCon @@ -323,7 +333,8 @@ toIfaceWiredInTyCon :: TyCon -> Name -> IfaceTyCon toIfaceWiredInTyCon tc nm - | isTupleTyCon tc = IfaceTupTc (tupleTyConBoxity tc) (tyConArity tc) + | isTupleTyCon tc = IfaceTupTc (tupleTyConBoxity tc) (tyConArity tc) + | isAnyTyCon tc = IfaceAnyTc (toIfaceKind (tyConKind tc)) | nm == intTyConName = IfaceIntTc | nm == boolTyConName = IfaceBoolTc | nm == charTyConName = IfaceCharTc diff -ruN ghc-6.12.1/compiler/iface/MkIface.lhs ghc-6.13.20091231/compiler/iface/MkIface.lhs --- ghc-6.12.1/compiler/iface/MkIface.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/iface/MkIface.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -54,7 +54,7 @@ import LoadIface import Id import IdInfo -import NewDemand +import Demand import Annotations import CoreSyn import CoreFVs @@ -385,7 +385,7 @@ = do eps <- hscEPS hsc_env let - -- the ABI of a declaration represents everything that is made + -- The ABI of a declaration represents everything that is made -- visible about the declaration that a client can depend on. -- see IfaceDeclABI below. declABI :: IfaceDecl -> IfaceDeclABI @@ -399,7 +399,7 @@ , let out = localOccs $ freeNamesDeclABI abi ] - name_module n = ASSERT( isExternalName n ) nameModule n + name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n localOccs = map (getUnique . getParent . getOccName) . filter ((== this_mod) . name_module) . nameSetToList @@ -589,20 +589,47 @@ dep_pkgs = sortBy (compare `on` packageIdFS) (dep_pkgs d), dep_orphs = sortBy stableModuleCmp (dep_orphs d), dep_finsts = sortBy stableModuleCmp (dep_finsts d) } +\end{code} + + +%************************************************************************ +%* * + The ABI of an IfaceDecl +%* * +%************************************************************************ + +Note [The ABI of an IfaceDecl] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The ABI of a declaration consists of: + + (a) the full name of the identifier (inc. module and package, + because these are used to construct the symbol name by which + the identifier is known externally). + + (b) the declaration itself, as exposed to clients. That is, the + definition of an Id is included in the fingerprint only if + it is made available as as unfolding in the interface. + + (c) the fixity of the identifier + (d) for Ids: rules + (e) for classes: instances, fixity & rules for methods + (f) for datatypes: instances, fixity & rules for constrs + +Items (c)-(f) are not stored in the IfaceDecl, but instead appear +elsewhere in the interface file. But they are *fingerprinted* with +the Id itself. This is done by grouping (c)-(f) in IfaceDeclExtras, +and fingerprinting that as part of the Id. --- The ABI of a declaration consists of: - -- the full name of the identifier (inc. module and package, because - -- these are used to construct the symbol name by which the - -- identifier is known externally). - -- the fixity of the identifier - -- the declaration itself, as exposed to clients. That is, the - -- definition of an Id is included in the fingerprint only if - -- it is made available as as unfolding in the interface. - -- for Ids: rules - -- for classes: instances, fixity & rules for methods - -- for datatypes: instances, fixity & rules for constrs +\begin{code} type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras) +data IfaceDeclExtras + = IfaceIdExtras Fixity [IfaceRule] + | IfaceDataExtras Fixity [IfaceInstABI] [(Fixity,[IfaceRule])] + | IfaceClassExtras Fixity [IfaceInstABI] [(Fixity,[IfaceRule])] + | IfaceSynExtras Fixity + | IfaceOtherDeclExtras + abiDecl :: IfaceDeclABI -> IfaceDecl abiDecl (_, decl, _) = decl @@ -614,13 +641,6 @@ freeNamesDeclABI (_mod, decl, extras) = freeNamesIfDecl decl `unionNameSets` freeNamesDeclExtras extras -data IfaceDeclExtras - = IfaceIdExtras Fixity [IfaceRule] - | IfaceDataExtras Fixity [IfaceInstABI] [(Fixity,[IfaceRule])] - | IfaceClassExtras Fixity [IfaceInstABI] [(Fixity,[IfaceRule])] - | IfaceSynExtras Fixity - | IfaceOtherDeclExtras - freeNamesDeclExtras :: IfaceDeclExtras -> NameSet freeNamesDeclExtras (IfaceIdExtras _ rules) = unionManyNameSets (map freeNamesIfRule rules) @@ -636,6 +656,7 @@ freeNamesSub :: (Fixity,[IfaceRule]) -> NameSet freeNamesSub (_,rules) = unionManyNameSets (map freeNamesIfRule rules) +-- This instance is used only to compute fingerprints instance Binary IfaceDeclExtras where get _bh = panic "no get for IfaceDeclExtras" put_ bh (IfaceIdExtras fix rules) = do @@ -741,7 +762,7 @@ = mkWarnMsg silly_loc unqual $ ptext (sLit "Orphan rule:") <+> ppr rule where - silly_loc = srcLocSpan (mkSrcLoc (moduleNameFS (moduleName mod)) 1 0) + silly_loc = srcLocSpan (mkSrcLoc (moduleNameFS (moduleName mod)) 1 1) -- We don't have a decent SrcSpan for a Rule, not even the CoreRule -- Could readily be fixed by adding a SrcSpan to CoreRule, if we wanted to @@ -761,17 +782,16 @@ where go (non_orphs, orphs) d | Just occ <- get_key d - = (extendOccEnv_C (\ ds _ -> d:ds) non_orphs occ [d], orphs) + = (extendOccEnv_Acc (:) singleton non_orphs occ d, orphs) | otherwise = (non_orphs, d:orphs) \end{code} -%********************************************************* -%* * -\subsection{Keeping track of what we've slurped, and fingerprints} -%* * -%********************************************************* - +%************************************************************************ +%* * + Keeping track of what we've slurped, and fingerprints +%* * +%************************************************************************ \begin{code} mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> IO [Usage] @@ -1390,12 +1410,12 @@ is_local name = nameIsLocalOrFrom mod name -- Compute orphanhood. See Note [Orphans] in IfaceSyn - (_, _, cls, tys) = tcSplitDFunTy (idType dfun_id) + (_, cls, tys) = tcSplitDFunTy (idType dfun_id) -- Slightly awkward: we need the Class to get the fundeps (tvs, fds) = classTvsFds cls arg_names = [filterNameSet is_local (tyClsNamesOfType ty) | ty <- tys] orph | is_local cls_name = Just (nameOccName cls_name) - | all isJust mb_ns = head mb_ns + | all isJust mb_ns = ASSERT( not (null mb_ns) ) head mb_ns | otherwise = Nothing mb_ns :: [Maybe OccName] -- One for each fundep; a locally-defined name @@ -1442,7 +1462,7 @@ -------------------------- toIfaceIdDetails :: IdDetails -> IfaceIdDetails toIfaceIdDetails VanillaId = IfVanillaId -toIfaceIdDetails DFunId = IfVanillaId +toIfaceIdDetails (DFunId {}) = IfDFunId toIfaceIdDetails (RecSelId { sel_naughty = n , sel_tycon = tc }) = IfRecSelId (toIfaceTyCon tc) n toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other) @@ -1451,7 +1471,9 @@ toIfaceIdInfo :: IdInfo -> [IfaceInfoItem] toIfaceIdInfo id_info = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, - inline_hsinfo, wrkr_hsinfo, unfold_hsinfo] + inline_hsinfo, unfold_hsinfo] + -- NB: strictness must be before unfolding + -- See TcIface.tcUnfolding where ------------ Arity -------------- arity_info = arityInfo id_info @@ -1466,39 +1488,43 @@ ------------ Strictness -------------- -- No point in explicitly exporting TopSig - strict_hsinfo = case newStrictnessInfo id_info of + strict_hsinfo = case strictnessInfo id_info of Just sig | not (isTopSig sig) -> Just (HsStrictness sig) _other -> Nothing - ------------ Worker -------------- - work_info = workerInfo id_info - has_worker = workerExists work_info - wrkr_hsinfo = case work_info of - HasWorker work_id wrap_arity -> - Just (HsWorker ((idName work_id)) wrap_arity) - NoWorker -> Nothing - ------------ Unfolding -------------- - -- The unfolding is redundant if there is a worker - unfold_info = unfoldingInfo id_info - rhs = unfoldingTemplate unfold_info - no_unfolding = neverUnfold unfold_info - -- The CoreTidy phase retains unfolding info iff - -- we want to expose the unfolding, taking into account - -- unconditional NOINLINE, etc. See TidyPgm.addExternal - unfold_hsinfo | no_unfolding = Nothing - | has_worker = Nothing -- Unfolding is implicit - | otherwise = Just (HsUnfold (toIfaceExpr rhs)) + unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info) + loop_breaker = isNonRuleLoopBreaker (occInfo id_info) ------------ Inline prag -------------- inline_prag = inlinePragInfo id_info inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing - | no_unfolding && not has_worker - && isFunLike (inlinePragmaRuleMatchInfo inline_prag) - = Nothing - -- If the iface file give no unfolding info, we - -- don't need to say when inlining is OK! - | otherwise = Just (HsInline inline_prag) + | otherwise = Just (HsInline inline_prag) + +-------------------------- +toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem +toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity + , uf_src = src, uf_guidance = guidance }) + = case src of + InlineWrapper w -> Just (HsUnfold lb (IfWrapper arity (idName w))) + InlineRule {} -> Just (HsUnfold lb (IfInlineRule arity sat (toIfaceExpr rhs))) + _other -> Just (HsUnfold lb (IfCoreUnfold (toIfaceExpr rhs))) + -- Yes, even if guidance is UnfNever, expose the unfolding + -- If we didn't want to expose the unfolding, TidyPgm would + -- have stuck in NoUnfolding. For supercompilation we want + -- to see that unfolding! + where + sat = case guidance of + UnfWhen unsat_ok _ -> unsat_ok + _other -> needSaturated + +toIfUnfolding lb (DFunUnfolding _con ops) + = Just (HsUnfold lb (IfDFunUnfold (map toIfaceExpr ops))) + -- No need to serialise the data constructor; + -- we can recover it from the type of the dfun + +toIfUnfolding _ _ + = Nothing -------------------------- coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule @@ -1555,7 +1581,6 @@ --------------------- toIfaceNote :: Note -> IfaceNote toIfaceNote (SCC cc) = IfaceSCC cc -toIfaceNote InlineMe = IfaceInlineMe toIfaceNote (CoreNote s) = IfaceCoreNote s --------------------- diff -ruN ghc-6.12.1/compiler/iface/TcIface.lhs ghc-6.13.20091231/compiler/iface/TcIface.lhs --- ghc-6.12.1/compiler/iface/TcIface.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/iface/TcIface.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -19,6 +19,7 @@ import IfaceEnv import BuildTyCl import TcRnMonad +import TcType import Type import TypeRep import HscTypes @@ -37,11 +38,15 @@ import TyCon import DataCon import TysWiredIn +import TysPrim ( anyTyConOfKind ) import Var ( TyVar ) +import BasicTypes ( nonRuleLoopBreaker ) import qualified Var import VarEnv import Name import NameEnv +import OccurAnal ( occurAnalyseExpr ) +import Demand ( isBottomingSig ) import Module import LazyUniqFM import UniqSupply @@ -52,7 +57,6 @@ import DynFlags import Util import FastString -import BasicTypes (Arity) import Control.Monad import Data.List @@ -415,7 +419,7 @@ ifIdDetails = details, ifIdInfo = info}) = do { name <- lookupIfaceTop occ_name ; ty <- tcIfaceType iface_type - ; details <- tcIdDetails details + ; details <- tcIdDetails ty details ; info <- tcIdInfo ignore_prags name ty info ; return (AnId (mkGlobalId details name ty info)) } @@ -630,7 +634,7 @@ ; let mb_tcs = map ifTopFreeName args ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs', ru_args = args', - ru_rhs = rhs', + ru_rhs = occurAnalyseExpr rhs', ru_rough = mb_tcs, ru_local = False }) } -- An imported RULE is never for a local Id -- or, even if it is (module loop, perhaps) @@ -884,7 +888,6 @@ tcIfaceExpr (IfaceNote note expr) = do expr' <- tcIfaceExpr expr case note of - IfaceInlineMe -> return (Note InlineMe expr') IfaceSCC cc -> return (Note (SCC cc) expr') IfaceCoreNote n -> return (Note (CoreNote n) expr') @@ -963,10 +966,14 @@ %************************************************************************ \begin{code} -tcIdDetails :: IfaceIdDetails -> IfL IdDetails -tcIdDetails IfVanillaId = return VanillaId -tcIdDetails IfDFunId = return DFunId -tcIdDetails (IfRecSelId tc naughty) +tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails +tcIdDetails _ IfVanillaId = return VanillaId +tcIdDetails ty IfDFunId + = return (DFunId (isNewTyCon (classTyCon cls))) + where + (_, cls, _) = tcSplitDFunTy ty + +tcIdDetails _ (IfRecSelId tc naughty) = do { tc' <- tcIfaceTyCon tc ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) } @@ -982,52 +989,67 @@ init_info = vanillaIdInfo tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo - tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs) - tcPrag info (HsArity arity) = return (info `setArityInfo` arity) - tcPrag info (HsStrictness str) = return (info `setAllStrictnessInfo` Just str) + tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs) + tcPrag info (HsArity arity) = return (info `setArityInfo` arity) + tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` Just str) + tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag) -- The next two are lazy, so they don't transitively suck stuff in - tcPrag info (HsWorker nm arity) = tcWorkerInfo ty info nm arity - tcPrag info (HsInline inline_prag) = return (info `setInlinePragInfo` inline_prag) - tcPrag info (HsUnfold expr) = do - maybe_expr' <- tcPragExpr name expr - let - -- maybe_expr' doesn't get looked at if the unfolding - -- is never inspected; so the typecheck doesn't even happen - unfold_info = case maybe_expr' of - Nothing -> noUnfolding - Just expr' -> mkTopUnfolding expr' - return (info `setUnfoldingInfoLazily` unfold_info) + tcPrag info (HsUnfold lb if_unf) + = do { unf <- tcUnfolding name ty info if_unf + ; let info1 | lb = info `setOccInfo` nonRuleLoopBreaker + | otherwise = info + ; return (info1 `setUnfoldingInfoLazily` unf) } \end{code} \begin{code} -tcWorkerInfo :: Type -> IdInfo -> Name -> Arity -> IfL IdInfo -tcWorkerInfo ty info wkr arity - = do { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr) +tcUnfolding :: Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding +tcUnfolding name _ info (IfCoreUnfold if_expr) + = do { mb_expr <- tcPragExpr name if_expr + ; return (case mb_expr of + Nothing -> NoUnfolding + Just expr -> mkTopUnfolding is_bottoming expr) } + where + -- Strictness should occur before unfolding! + is_bottoming = case strictnessInfo info of + Just sig -> isBottomingSig sig + Nothing -> False + +tcUnfolding name _ _ (IfInlineRule arity unsat_ok if_expr) + = do { mb_expr <- tcPragExpr name if_expr + ; return (case mb_expr of + Nothing -> NoUnfolding + Just expr -> mkInlineRule unsat_ok expr arity) } - -- We return without testing maybe_wkr_id, but as soon as info is - -- looked at we will test it. That's ok, because its outside the - -- knot; and there seems no big reason to further defer the - -- tcIfaceId lookup. (Contrast with tcPragExpr, where postponing walking - -- over the unfolding until it's actually used does seem worth while.) +tcUnfolding name ty info (IfWrapper arity wkr) + = do { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr) ; us <- newUniqueSupply - ; return (case mb_wkr_id of - Nothing -> info - Just wkr_id -> add_wkr_info us wkr_id info) } + Nothing -> noUnfolding + Just wkr_id -> make_inline_rule wkr_id us) } where - doc = text "Worker for" <+> ppr wkr - add_wkr_info us wkr_id info - = info `setUnfoldingInfoLazily` mk_unfolding us wkr_id - `setWorkerInfo` HasWorker wkr_id arity - - mk_unfolding us wkr_id = mkTopUnfolding (initUs_ us (mkWrapper ty strict_sig) wkr_id) - - -- We are relying here on strictness info always appearing - -- before worker info, fingers crossed .... - strict_sig = case newStrictnessInfo info of + doc = text "Worker for" <+> ppr name + + make_inline_rule wkr_id us + = mkWwInlineRule wkr_id + (initUs_ us (mkWrapper ty strict_sig) wkr_id) + arity + + -- Again we rely here on strictness info always appearing + -- before unfolding + strict_sig = case strictnessInfo info of Just sig -> sig Nothing -> pprPanic "Worker info but no strictness for" (ppr wkr) + +tcUnfolding name dfun_ty _ (IfDFunUnfold ops) + = do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops + ; return (case mb_ops1 of + Nothing -> noUnfolding + Just ops1 -> DFunUnfolding data_con ops1) } + where + doc = text "Class ops for dfun" <+> ppr name + (_, cls, _) = tcSplitDFunTy dfun_ty + data_con = classDataCon cls \end{code} For unfoldings we try to do the job lazily, so that we never type check @@ -1122,6 +1144,8 @@ tcIfaceTyCon IfaceListTc = tcWiredInTyCon listTyCon tcIfaceTyCon IfacePArrTc = tcWiredInTyCon parrTyCon tcIfaceTyCon (IfaceTupTc bx ar) = tcWiredInTyCon (tupleTyCon bx ar) +tcIfaceTyCon (IfaceAnyTc kind) = do { tc_kind <- tcIfaceType kind + ; tcWiredInTyCon (anyTyConOfKind tc_kind) } tcIfaceTyCon (IfaceTc name) = do { thing <- tcIfaceGlobal name ; return (check_tc (tyThingTyCon thing)) } where @@ -1198,7 +1222,7 @@ tc_info [] = vanillaIdInfo tc_info (HsInline p : i) = tc_info i `setInlinePragInfo` p tc_info (HsArity a : i) = tc_info i `setArityInfo` a - tc_info (HsStrictness s : i) = tc_info i `setAllStrictnessInfo` Just s + tc_info (HsStrictness s : i) = tc_info i `setStrictnessInfo` Just s tc_info (other : i) = pprTrace "tcIfaceLetBndr: discarding unexpected IdInfo" (ppr other) (tc_info i) diff -ruN ghc-6.12.1/compiler/main/Annotations.lhs ghc-6.13.20091231/compiler/main/Annotations.lhs --- ghc-6.12.1/compiler/main/Annotations.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/main/Annotations.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -12,7 +12,8 @@ -- * AnnEnv for collecting and querying Annotations AnnEnv, - mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv, findAnns + mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv, findAnns, + deserializeAnns ) where import Name @@ -62,6 +63,8 @@ ppr (NamedTarget nm) = text "Named target" <+> ppr nm ppr (ModuleTarget mod) = text "Module target" <+> ppr mod +instance Outputable Annotation where + ppr ann = ppr (ann_target ann) -- | A collection of annotations newtype AnnEnv = MkAnnEnv (UniqFM [Serialized]) @@ -88,4 +91,11 @@ findAnns deserialize (MkAnnEnv ann_env) = (mapMaybe (fromSerialized deserialize)) . (lookupWithDefaultUFM ann_env []) -\end{code} \ No newline at end of file + +-- | Deserialize all annotations of a given type. This happens lazily, that is +-- no deserialization will take place until the [a] is actually demanded and +-- the [a] can also be empty (the UniqFM is not filtered). +deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> UniqFM [a] +deserializeAnns deserialize (MkAnnEnv ann_env) + = mapUFM (mapMaybe (fromSerialized deserialize)) ann_env +\end{code} diff -ruN ghc-6.12.1/compiler/main/DriverMkDepend.hs ghc-6.13.20091231/compiler/main/DriverMkDepend.hs --- ghc-6.12.1/compiler/main/DriverMkDepend.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/main/DriverMkDepend.hs 2009-12-31 10:14:17.000000000 -0800 @@ -352,7 +352,7 @@ cycles = [ c | CyclicSCC c <- GHC.topSortModuleGraph True mod_summaries Nothing ] pp_cycles = vcat [ (ptext (sLit "---------- Cycle") <+> int n <+> ptext (sLit "----------")) - $$ pprCycle c $$ text "" + $$ pprCycle c $$ blankLine | (n,c) <- [1..] `zip` cycles ] pprCycle :: [ModSummary] -> SDoc diff -ruN ghc-6.12.1/compiler/main/DriverPipeline.hs ghc-6.13.20091231/compiler/main/DriverPipeline.hs --- ghc-6.12.1/compiler/main/DriverPipeline.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/main/DriverPipeline.hs 2009-12-31 10:14:18.000000000 -0800 @@ -974,14 +974,13 @@ then [] else [ "-ffloat-store" ]) ++ #endif + -- gcc's -fstrict-aliasing allows two accesses to memory -- to be considered non-aliasing if they have different types. -- This interacts badly with the C code we generate, which is -- very weakly typed, being derived from C--. ["-fno-strict-aliasing"] - - liftIO $ SysTools.runCc dflags ( -- force the C compiler to interpret this file as C when -- compiling .hc files, by adding the -x c option. @@ -997,6 +996,18 @@ ++ map SysTools.Option ( md_c_flags ++ pic_c_flags + +#if defined(mingw32_TARGET_OS) + -- Stub files generated for foreign exports references the runIO_closure + -- and runNonIO_closure symbols, which are defined in the base package. + -- These symbols are imported into the stub.c file via RtsAPI.h, and the + -- way we do the import depends on whether we're currently compiling + -- the base package or not. + ++ (if thisPackage dflags == basePackageId + then [ "-DCOMPILING_BASE_PACKAGE" ] + else []) +#endif + #ifdef sparc_TARGET_ARCH -- We only support SparcV9 and better because V8 lacks an atomic CAS -- instruction. Note that the user can still override this @@ -1417,7 +1428,7 @@ let thread_opts | WayThreaded `elem` ways = [ -#if !defined(mingw32_TARGET_OS) && !defined(freebsd_TARGET_OS) +#if !defined(mingw32_TARGET_OS) && !defined(freebsd_TARGET_OS) && !defined(haiku_TARGET_OS) "-lpthread" #endif #if defined(osf3_TARGET_OS) @@ -1436,6 +1447,12 @@ ] ++ map SysTools.Option ( md_c_flags + +#ifdef mingw32_TARGET_OS + -- Permit the linker to auto link _symbol to _imp_symbol. + -- This lets us link against DLLs without needing an "import library". + ++ ["-Wl,--enable-auto-import"] +#endif ++ o_files ++ extra_ld_inputs ++ lib_path_opts @@ -1591,6 +1608,11 @@ ++ map (SysTools.FileOption "") o_files ++ map SysTools.Option ( md_c_flags + + -- Permit the linker to auto link _symbol to _imp_symbol + -- This lets us link against DLLs without needing an "import library" + ++ ["-Wl,--enable-auto-import"] + ++ extra_ld_inputs ++ lib_path_opts ++ extra_ld_opts @@ -1621,16 +1643,22 @@ -- later, so that it will not complain about the use of the option -- -undefined dynamic_lookup above. -- -install_name - -- Causes the dynamic linker to ignore the DYLD_LIBRARY_PATH when loading - -- this lib and instead look for it at its absolute path. - -- When installing the .dylibs (see target.mk), we'll change that path to - -- point to the place they are installed. Therefore, we won't have to set - -- up DYLD_LIBRARY_PATH specifically for ghc. + -- Mac OS/X stores the path where a dynamic library is (to be) installed + -- in the library itself. It's called the "install name" of the library. + -- Then any library or executable that links against it before it's + -- installed will search for it in its ultimate install location. By + -- default we set the install name to the absolute path at build time, but + -- it can be overridden by the -dylib-install-name option passed to ghc. + -- Cabal does this. ----------------------------------------------------------------------------- let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } - pwd <- getCurrentDirectory + instName <- case dylibInstallName dflags of + Just n -> return n + Nothing -> do + pwd <- getCurrentDirectory + return $ pwd `combine` output_fn SysTools.runLink dflags ([ SysTools.Option verb , SysTools.Option "-dynamiclib" @@ -1640,7 +1668,8 @@ ++ map SysTools.Option ( md_c_flags ++ o_files - ++ [ "-undefined", "dynamic_lookup", "-single_module", "-Wl,-macosx_version_min","-Wl,10.5", "-install_name " ++ (pwd output_fn) ] + ++ [ "-undefined", "dynamic_lookup", "-single_module", "-Wl,-macosx_version_min","-Wl,10.5", + "-Wl,-read_only_relocs,suppress", "-install_name", instName ] ++ extra_ld_inputs ++ lib_path_opts ++ extra_ld_opts diff -ruN ghc-6.12.1/compiler/main/DynFlags.hs ghc-6.13.20091231/compiler/main/DynFlags.hs --- ghc-6.12.1/compiler/main/DynFlags.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/main/DynFlags.hs 2009-12-31 10:14:18.000000000 -0800 @@ -46,13 +46,6 @@ -- ** DynFlag C compiler options machdepCCOpts, picCCOpts, - -- * Configuration of the core-to-core passes - CoreToDo(..), - SimplifierMode(..), - SimplifierSwitch(..), - FloatOutSwitches(..), - getCoreToDo, - -- * Configuration of the stg-to-stg passes StgToDo(..), getStgToDo, @@ -258,18 +251,19 @@ | Opt_PackageImports | Opt_NewQualifiedOperators | Opt_ExplicitForAll + | Opt_AlternativeLayoutRule | Opt_PrintExplicitForalls -- optimisation opts | Opt_Strictness | Opt_FullLaziness + | Opt_FloatIn + | Opt_Specialise | Opt_StaticArgumentTransformation | Opt_CSE | Opt_LiberateCase | Opt_SpecConstr - | Opt_IgnoreInterfacePragmas - | Opt_OmitInterfacePragmas | Opt_DoLambdaEtaExpansion | Opt_IgnoreAsserts | Opt_DoEtaReduction @@ -277,12 +271,16 @@ | Opt_UnboxStrictFields | Opt_MethodSharing | Opt_DictsCheap - | Opt_InlineIfEnoughArgs | Opt_EnableRewriteRules -- Apply rewrite rules during simplification | Opt_Vectorise | Opt_RegsGraph -- do graph coloring register allocation | Opt_RegsIterative -- do iterative coalescing graph coloring register allocation + -- Interface files + | Opt_IgnoreInterfacePragmas + | Opt_OmitInterfacePragmas + | Opt_ExposeAllUnfoldings + -- profiling opts | Opt_AutoSccsOnAllToplevs | Opt_AutoSccsOnExportedToplevs @@ -338,17 +336,16 @@ data DynFlags = DynFlags { ghcMode :: GhcMode, ghcLink :: GhcLink, - coreToDo :: Maybe [CoreToDo], -- reserved for -Ofile - stgToDo :: Maybe [StgToDo], -- similarly hscTarget :: HscTarget, hscOutName :: String, -- ^ Name of the output file extCoreName :: String, -- ^ Name of the .hcr output file - verbosity :: Int, -- ^ Verbosity level: see "DynFlags#verbosity_levels" + verbosity :: Int, -- ^ Verbosity level: see Note [Verbosity levels] optLevel :: Int, -- ^ Optimisation level simplPhases :: Int, -- ^ Number of simplifier phases maxSimplIterations :: Int, -- ^ Max simplifier iterations - shouldDumpSimplPhase :: SimplifierMode -> Bool, + shouldDumpSimplPhase :: Maybe String, ruleCheck :: Maybe String, + strictnessBefore :: [Int], -- ^ Additional demand analysis specConstrThreshold :: Maybe Int, -- ^ Threshold for SpecConstr specConstrCount :: Maybe Int, -- ^ Max number of specialisations for any one function @@ -378,6 +375,7 @@ -- paths etc. objectDir :: Maybe String, + dylibInstallName :: Maybe String, hiDir :: Maybe String, stubDir :: Maybe String, @@ -592,8 +590,6 @@ DynFlags { ghcMode = CompManager, ghcLink = LinkBinary, - coreToDo = Nothing, - stgToDo = Nothing, hscTarget = defaultHscTarget, hscOutName = "", extCoreName = "", @@ -601,11 +597,13 @@ optLevel = 0, simplPhases = 2, maxSimplIterations = 4, - shouldDumpSimplPhase = const False, + shouldDumpSimplPhase = Nothing, ruleCheck = Nothing, specConstrThreshold = Just 200, specConstrCount = Just 3, liberateCaseThreshold = Just 200, + strictnessBefore = [], + #ifndef OMIT_NATIVE_CODEGEN targetPlatform = defaultTargetPlatform, #endif @@ -621,6 +619,7 @@ thisPackage = mainPackageId, objectDir = Nothing, + dylibInstallName = Nothing, hiDir = Nothing, stubDir = Nothing, @@ -726,9 +725,8 @@ } {- - #verbosity_levels# - Verbosity levels: - +Note [Verbosity levels] +~~~~~~~~~~~~~~~~~~~~~~~ 0 | print errors & warnings only 1 | minimal verbosity: print "compiling M ... done." for each module. 2 | equivalent to -dshow-passes @@ -763,7 +761,7 @@ | verbosity dflags >= 3 = "-v" | otherwise = "" -setObjectDir, setHiDir, setStubDir, setOutputDir, +setObjectDir, setHiDir, setStubDir, setOutputDir, setDylibInstallName, setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode, setPgmP, setPgmL, setPgmF, setPgmc, setPgmm, setPgms, setPgma, setPgml, setPgmdll, setPgmwindres, addOptL, addOptP, addOptF, addOptc, addOptm, addOpta, addOptl, addOptwindres, @@ -778,6 +776,7 @@ -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file -- \#included from the .hc file when compiling with -fvia-C. setOutputDir f = setObjectDir f . setHiDir f . setStubDir f +setDylibInstallName f d = d{ dylibInstallName = Just f} setObjectSuf f d = d{ objectSuf = f} setHiSuf f d = d{ hiSuf = f} @@ -893,6 +892,8 @@ , ([1,2], Opt_Strictness) , ([1,2], Opt_CSE) , ([1,2], Opt_FullLaziness) + , ([1,2], Opt_Specialise) + , ([1,2], Opt_FloatIn) , ([2], Opt_LiberateCase) , ([2], Opt_SpecConstr) @@ -966,242 +967,6 @@ ] -- ----------------------------------------------------------------------------- --- CoreToDo: abstraction of core-to-core passes to run. - -data CoreToDo -- These are diff core-to-core passes, - -- which may be invoked in any order, - -- as many times as you like. - - = CoreDoSimplify -- The core-to-core simplifier. - SimplifierMode - [SimplifierSwitch] - -- Each run of the simplifier can take a different - -- set of simplifier-specific flags. - | CoreDoFloatInwards - | CoreDoFloatOutwards FloatOutSwitches - | CoreLiberateCase - | CoreDoPrintCore - | CoreDoStaticArgs - | CoreDoStrictness - | CoreDoWorkerWrapper - | CoreDoSpecialising - | CoreDoSpecConstr - | CoreDoOldStrictness - | CoreDoGlomBinds - | CoreCSE - | CoreDoRuleCheck Int{-CompilerPhase-} String -- Check for non-application of rules - -- matching this string - | CoreDoVectorisation PackageId - | CoreDoNothing -- Useful when building up - | CoreDoPasses [CoreToDo] -- lists of these things - - -data SimplifierMode -- See comments in SimplMonad - = SimplGently - | SimplPhase Int [String] - -instance Outputable SimplifierMode where - ppr SimplGently = ptext (sLit "gentle") - ppr (SimplPhase n ss) = int n <+> brackets (text (concat $ intersperse "," ss)) - - -data SimplifierSwitch - = MaxSimplifierIterations Int - | NoCaseOfCase - - -data FloatOutSwitches = FloatOutSwitches { - floatOutLambdas :: Bool, -- ^ True <=> float lambdas to top level - floatOutConstants :: Bool -- ^ True <=> float constants to top level, - -- even if they do not escape a lambda - } - -instance Outputable FloatOutSwitches where - ppr = pprFloatOutSwitches - -pprFloatOutSwitches :: FloatOutSwitches -> SDoc -pprFloatOutSwitches sw = pp_not (floatOutLambdas sw) <+> text "lambdas" <> comma - <+> pp_not (floatOutConstants sw) <+> text "constants" - where - pp_not True = empty - pp_not False = text "not" - --- | Switches that specify the minimum amount of floating out --- gentleFloatOutSwitches :: FloatOutSwitches --- gentleFloatOutSwitches = FloatOutSwitches False False - --- | Switches that do not specify floating out of lambdas, just of constants -constantsOnlyFloatOutSwitches :: FloatOutSwitches -constantsOnlyFloatOutSwitches = FloatOutSwitches False True - - --- The core-to-core pass ordering is derived from the DynFlags: -runWhen :: Bool -> CoreToDo -> CoreToDo -runWhen True do_this = do_this -runWhen False _ = CoreDoNothing - -runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo -runMaybe (Just x) f = f x -runMaybe Nothing _ = CoreDoNothing - -getCoreToDo :: DynFlags -> [CoreToDo] -getCoreToDo dflags - | Just todo <- coreToDo dflags = todo -- set explicitly by user - | otherwise = core_todo - where - opt_level = optLevel dflags - phases = simplPhases dflags - max_iter = maxSimplIterations dflags - strictness = dopt Opt_Strictness dflags - full_laziness = dopt Opt_FullLaziness dflags - cse = dopt Opt_CSE dflags - spec_constr = dopt Opt_SpecConstr dflags - liberate_case = dopt Opt_LiberateCase dflags - rule_check = ruleCheck dflags - static_args = dopt Opt_StaticArgumentTransformation dflags - - maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase) - - simpl_phase phase names iter - = CoreDoPasses - [ CoreDoSimplify (SimplPhase phase names) [ - MaxSimplifierIterations iter - ], - maybe_rule_check phase - ] - - vectorisation - = runWhen (dopt Opt_Vectorise dflags) - $ CoreDoPasses [ simpl_gently, CoreDoVectorisation (dphPackage dflags) ] - - - -- By default, we have 2 phases before phase 0. - - -- Want to run with inline phase 2 after the specialiser to give - -- maximum chance for fusion to work before we inline build/augment - -- in phase 1. This made a difference in 'ansi' where an - -- overloaded function wasn't inlined till too late. - - -- Need phase 1 so that build/augment get - -- inlined. I found that spectral/hartel/genfft lost some useful - -- strictness in the function sumcode' if augment is not inlined - -- before strictness analysis runs - simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter - | phase <- [phases, phases-1 .. 1] ] - - - -- initial simplify: mk specialiser happy: minimum effort please - simpl_gently = CoreDoSimplify SimplGently [ - -- Simplify "gently" - -- Don't inline anything till full laziness has bitten - -- In particular, inlining wrappers inhibits floating - -- e.g. ...(case f x of ...)... - -- ==> ...(case (case x of I# x# -> fw x#) of ...)... - -- ==> ...(case x of I# x# -> case fw x# of ...)... - -- and now the redex (f x) isn't floatable any more - -- Similarly, don't apply any rules until after full - -- laziness. Notably, list fusion can prevent floating. - - NoCaseOfCase, -- Don't do case-of-case transformations. - -- This makes full laziness work better - MaxSimplifierIterations max_iter - ] - - core_todo = - if opt_level == 0 then - [vectorisation, - simpl_phase 0 ["final"] max_iter] - else {- opt_level >= 1 -} [ - - -- We want to do the static argument transform before full laziness as it - -- may expose extra opportunities to float things outwards. However, to fix - -- up the output of the transformation we need at do at least one simplify - -- after this before anything else - runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]), - - -- We run vectorisation here for now, but we might also try to run - -- it later - vectorisation, - - -- initial simplify: mk specialiser happy: minimum effort please - simpl_gently, - - -- Specialisation is best done before full laziness - -- so that overloaded functions have all their dictionary lambdas manifest - CoreDoSpecialising, - - runWhen full_laziness (CoreDoFloatOutwards constantsOnlyFloatOutSwitches), - -- Was: gentleFloatOutSwitches - -- I have no idea why, but not floating constants to top level is - -- very bad in some cases. - -- Notably: p_ident in spectral/rewrite - -- Changing from "gentle" to "constantsOnly" improved - -- rewrite's allocation by 19%, and made 0.0% difference - -- to any other nofib benchmark - - CoreDoFloatInwards, - - simpl_phases, - - -- Phase 0: allow all Ids to be inlined now - -- This gets foldr inlined before strictness analysis - - -- At least 3 iterations because otherwise we land up with - -- huge dead expressions because of an infelicity in the - -- simpifier. - -- let k = BIG in foldr k z xs - -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs - -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs - -- Don't stop now! - simpl_phase 0 ["main"] (max max_iter 3), - - -#ifdef OLD_STRICTNESS - CoreDoOldStrictness, -#endif - runWhen strictness (CoreDoPasses [ - CoreDoStrictness, - CoreDoWorkerWrapper, - CoreDoGlomBinds, - simpl_phase 0 ["post-worker-wrapper"] max_iter - ]), - - runWhen full_laziness - (CoreDoFloatOutwards constantsOnlyFloatOutSwitches), - -- nofib/spectral/hartel/wang doubles in speed if you - -- do full laziness late in the day. It only happens - -- after fusion and other stuff, so the early pass doesn't - -- catch it. For the record, the redex is - -- f_el22 (f_el21 r_midblock) - - - runWhen cse CoreCSE, - -- We want CSE to follow the final full-laziness pass, because it may - -- succeed in commoning up things floated out by full laziness. - -- CSE used to rely on the no-shadowing invariant, but it doesn't any more - - CoreDoFloatInwards, - - maybe_rule_check 0, - - -- Case-liberation for -O2. This should be after - -- strictness analysis and the simplification which follows it. - runWhen liberate_case (CoreDoPasses [ - CoreLiberateCase, - simpl_phase 0 ["post-liberate-case"] max_iter - ]), -- Run the simplifier after LiberateCase to vastly - -- reduce the possiblility of shadowing - -- Reason: see Note [Shadowing] in SpecConstr.lhs - - runWhen spec_constr CoreDoSpecConstr, - - maybe_rule_check 0, - - -- Final clean-up simplification: - simpl_phase 0 ["final"] max_iter - ] - --- ----------------------------------------------------------------------------- -- StgToDo: abstraction of stg-to-stg passes to run. data StgToDo @@ -1212,8 +977,7 @@ getStgToDo :: DynFlags -> [StgToDo] getStgToDo dflags - | Just todo <- stgToDo dflags = todo -- set explicitly by user - | otherwise = todo2 + = todo2 where stg_stats = dopt Opt_StgStats dflags @@ -1301,6 +1065,7 @@ Supported , Flag "dynload" (HasArg (upd . parseDynLibLoaderMode)) Supported + , Flag "dylib-install-name" (HasArg (upd . setDylibInstallName)) Supported ------- Libraries --------------------------------------------------- , Flag "L" (Prefix addLibraryPath ) Supported @@ -1452,7 +1217,8 @@ Supported , Flag "dsource-stats" (setDumpFlag Opt_D_source_stats) Supported - , Flag "dverbose-core2core" (NoArg setVerboseCore2Core) + , Flag "dverbose-core2core" (NoArg (do { setVerbosity (Just 2) + ; setVerboseCore2Core })) Supported , Flag "dverbose-stg2stg" (setDumpFlag Opt_D_verbose_stg2stg) Supported @@ -1555,6 +1321,10 @@ (IntSuffix $ \n -> upd $ \dfs -> dfs{ ctxtStkDepth = n }) Supported + , Flag "fstrictness-before" + (IntSuffix (\n -> upd (\dfs -> dfs{ strictnessBefore = n : strictnessBefore dfs }))) + Supported + ------ Profiling ---------------------------------------------------- -- XXX Should the -f* flags be deprecated? @@ -1692,6 +1462,8 @@ ( "warn-wrong-do-bind", Opt_WarnWrongDoBind, const Supported ), ( "print-explicit-foralls", Opt_PrintExplicitForalls, const Supported ), ( "strictness", Opt_Strictness, const Supported ), + ( "specialise", Opt_Specialise, const Supported ), + ( "float-in", Opt_FloatIn, const Supported ), ( "static-argument-transformation", Opt_StaticArgumentTransformation, const Supported ), ( "full-laziness", Opt_FullLaziness, const Supported ), ( "liberate-case", Opt_LiberateCase, const Supported ), @@ -1699,6 +1471,7 @@ ( "cse", Opt_CSE, const Supported ), ( "ignore-interface-pragmas", Opt_IgnoreInterfacePragmas, const Supported ), ( "omit-interface-pragmas", Opt_OmitInterfacePragmas, const Supported ), + ( "expose-all-unfoldings", Opt_ExposeAllUnfoldings, const Supported ), ( "do-lambda-eta-expansion", Opt_DoLambdaEtaExpansion, const Supported ), ( "ignore-asserts", Opt_IgnoreAsserts, const Supported ), ( "do-eta-reduction", Opt_DoEtaReduction, const Supported ), @@ -1706,7 +1479,6 @@ ( "unbox-strict-fields", Opt_UnboxStrictFields, const Supported ), ( "method-sharing", Opt_MethodSharing, const Supported ), ( "dicts-cheap", Opt_DictsCheap, const Supported ), - ( "inline-if-enough-args", Opt_InlineIfEnoughArgs, const Supported ), ( "excess-precision", Opt_ExcessPrecision, const Supported ), ( "eager-blackholing", Opt_EagerBlackHoling, const Supported ), ( "asm-mangling", Opt_DoAsmMangling, const Supported ), @@ -1824,6 +1596,7 @@ -- On by default (which is not strictly H98): ( "MonoPatBinds", Opt_MonoPatBinds, const Supported ), ( "ExplicitForAll", Opt_ExplicitForAll, const Supported ), + ( "AlternativeLayoutRule", Opt_AlternativeLayoutRule, const Supported ), ( "MonoLocalBinds", Opt_MonoLocalBinds, const Supported ), ( "RelaxedPolyRec", Opt_RelaxedPolyRec, const Supported ), ( "ExtendedDefaultRules", Opt_ExtendedDefaultRules, const Supported ), @@ -2001,7 +1774,8 @@ -------------------------- setDumpFlag :: DynFlag -> OptKind DynP setDumpFlag dump_flag - = NoArg (setDynFlag dump_flag >> when want_recomp forceRecompile) + = NoArg (do { setDynFlag dump_flag + ; when want_recomp forceRecompile }) where -- Certain dumpy-things are really interested in what's going -- on during recompilation checking, so in those cases we @@ -2020,41 +1794,16 @@ force_recomp dfs = isOneShot (ghcMode dfs) setVerboseCore2Core :: DynP () -setVerboseCore2Core = do setDynFlag Opt_D_verbose_core2core - forceRecompile - upd (\s -> s { shouldDumpSimplPhase = const True }) +setVerboseCore2Core = do forceRecompile + setDynFlag Opt_D_verbose_core2core + upd (\dfs -> dfs { shouldDumpSimplPhase = Nothing }) + setDumpSimplPhases :: String -> DynP () setDumpSimplPhases s = do forceRecompile - upd (\s -> s { shouldDumpSimplPhase = spec }) + upd (\dfs -> dfs { shouldDumpSimplPhase = Just spec }) where - spec :: SimplifierMode -> Bool - spec = join (||) - . map (join (&&) . map match . split ':') - . split ',' - $ case s of - '=' : s' -> s' - _ -> s - - join :: (Bool -> Bool -> Bool) - -> [SimplifierMode -> Bool] - -> SimplifierMode -> Bool - join _ [] = const True - join op ss = foldr1 (\f g x -> f x `op` g x) ss - - match :: String -> SimplifierMode -> Bool - match "" = const True - match s = case reads s of - [(n,"")] -> phase_num n - _ -> phase_name s - - phase_num :: Int -> SimplifierMode -> Bool - phase_num n (SimplPhase k _) = n == k - phase_num _ _ = False - - phase_name :: String -> SimplifierMode -> Bool - phase_name s SimplGently = s == "gentle" - phase_name s (SimplPhase _ ss) = s `elem` ss + spec = case s of { ('=' : s') -> s'; _ -> s } setVerbosity :: Maybe Int -> DynP () setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 }) @@ -2129,7 +1878,6 @@ }) `dopt_set` Opt_DictsCheap `dopt_unset` Opt_MethodSharing - `dopt_set` Opt_InlineIfEnoughArgs data DPHBackend = DPHPar | DPHSeq diff -ruN ghc-6.12.1/compiler/main/ErrUtils.lhs ghc-6.13.20091231/compiler/main/ErrUtils.lhs --- ghc-6.12.1/compiler/main/ErrUtils.lhs 2009-12-10 10:11:33.000000000 -0800 +++ ghc-6.13.20091231/compiler/main/ErrUtils.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -231,10 +231,10 @@ mkDumpDoc :: String -> SDoc -> SDoc mkDumpDoc hdr doc - = vcat [text "", + = vcat [blankLine, line <+> text hdr <+> line, doc, - text ""] + blankLine] where line = text (replicate 20 '=') diff -ruN ghc-6.12.1/compiler/main/GHC.hs ghc-6.13.20091231/compiler/main/GHC.hs --- ghc-6.12.1/compiler/main/GHC.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/main/GHC.hs 2009-12-31 10:14:18.000000000 -0800 @@ -2580,7 +2580,7 @@ getTokenStream :: GhcMonad m => Module -> m [Located Token] getTokenStream mod = do (sourceFile, source, flags) <- getModuleSourceAndFlags mod - let startLoc = mkSrcLoc (mkFastString sourceFile) 0 0 + let startLoc = mkSrcLoc (mkFastString sourceFile) 1 1 case lexTokenStream source startLoc flags of POk _ ts -> return ts PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err) @@ -2591,7 +2591,7 @@ getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)] getRichTokenStream mod = do (sourceFile, source, flags) <- getModuleSourceAndFlags mod - let startLoc = mkSrcLoc (mkFastString sourceFile) 0 0 + let startLoc = mkSrcLoc (mkFastString sourceFile) 1 1 case lexTokenStream source startLoc flags of POk _ ts -> return $ addSourceToTokens startLoc source ts PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err) @@ -2622,7 +2622,7 @@ showRichTokenStream :: [(Located Token, String)] -> String showRichTokenStream ts = go startLoc ts "" where sourceFile = srcSpanFile (getLoc . fst . head $ ts) - startLoc = mkSrcLoc sourceFile 0 0 + startLoc = mkSrcLoc sourceFile 1 1 go _ [] = id go loc ((L span _, str):ts) | not (isGoodSrcSpan span) = go loc ts diff -ruN ghc-6.12.1/compiler/main/HeaderInfo.hs ghc-6.13.20091231/compiler/main/HeaderInfo.hs --- ghc-6.12.1/compiler/main/HeaderInfo.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/main/HeaderInfo.hs 2009-12-31 10:14:18.000000000 -0800 @@ -55,7 +55,7 @@ -> m ([Located (ImportDecl RdrName)], [Located (ImportDecl RdrName)], Located ModuleName) -- ^ The source imports, normal imports, and the module name. getImports dflags buf filename source_filename = do - let loc = mkSrcLoc (mkFastString filename) 1 0 + let loc = mkSrcLoc (mkFastString filename) 1 1 case unP parseHeader (mkPState buf loc dflags) of PFailed span err -> parseError span err POk pst rdr_module -> do @@ -70,7 +70,7 @@ case rdr_module of L _ (HsModule mb_mod _ imps _ _ _) -> let - main_loc = mkSrcLoc (mkFastString source_filename) 1 0 + main_loc = mkSrcLoc (mkFastString source_filename) 1 1 mod = mb_mod `orElse` L (srcLocSpan main_loc) mAIN_NAME (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc) @@ -109,7 +109,7 @@ buf <- hGetStringBufferBlock handle blockSize unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False where - loc = mkSrcLoc (mkFastString filename) 1 0 + loc = mkSrcLoc (mkFastString filename) 1 1 lazyLexBuf :: Handle -> PState -> Bool -> IO [Located Token] lazyLexBuf handle state eof = do @@ -141,7 +141,7 @@ getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token] getToks dflags filename buf = lexAll (pragState dflags buf loc) where - loc = mkSrcLoc (mkFastString filename) 1 0 + loc = mkSrcLoc (mkFastString filename) 1 1 lexAll state = case unP (lexer return) state of POk _ t@(L _ ITeof) -> [t] diff -ruN ghc-6.12.1/compiler/main/HscMain.lhs ghc-6.13.20091231/compiler/main/HscMain.lhs --- ghc-6.12.1/compiler/main/HscMain.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/main/HscMain.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -183,7 +183,7 @@ Just b -> return b Nothing -> liftIO $ hGetStringBuffer src_filename - let loc = mkSrcLoc (mkFastString src_filename) 1 0 + let loc = mkSrcLoc (mkFastString src_filename) 1 1 case unP parseModule (mkPState buf loc dflags) of PFailed span err -> @@ -789,11 +789,8 @@ -> HpcInfo -> IO [Cmm] tryNewCodeGen hsc_env this_mod data_tycons imported_mods - cost_centre_info stg_binds hpc_info - | not (dopt Opt_TryNewCodeGen (hsc_dflags hsc_env)) - = return [] - | otherwise - = do { let dflags = hsc_dflags hsc_env + cost_centre_info stg_binds hpc_info = + do { let dflags = hsc_dflags hsc_env ; prog <- StgCmm.codeGen dflags this_mod data_tycons imported_mods cost_centre_info stg_binds hpc_info ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen" @@ -987,7 +984,7 @@ buf <- liftIO $ stringToStringBuffer str - let loc = mkSrcLoc (fsLit "") 1 0 + let loc = mkSrcLoc (fsLit "") 1 1 case unP parser (mkPState buf loc dflags) of diff -ruN ghc-6.12.1/compiler/main/HscTypes.lhs ghc-6.13.20091231/compiler/main/HscTypes.lhs --- ghc-6.12.1/compiler/main/HscTypes.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/main/HscTypes.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -978,9 +978,7 @@ mg_insts :: ![Instance], -- ^ Class instances declared in this module mg_fam_insts :: ![FamInst], -- ^ Family instances declared in this module mg_rules :: ![CoreRule], -- ^ Before the core pipeline starts, contains - -- rules declared in this module. After the core - -- pipeline starts, it is changed to contain all - -- known rules for those things imported + -- See Note [Overall plumbing for rules] in Rules.lhs mg_binds :: ![CoreBind], -- ^ Bindings for this module mg_foreign :: !ForeignStubs, -- ^ Foreign exports declared in this module mg_warns :: !Warnings, -- ^ Warnings declared in the module @@ -1986,7 +1984,6 @@ \begin{code} -- | Vectorisation information for 'ModGuts', 'ModDetails' and 'ExternalPackageState'. --- All of this information is always tidy, even in ModGuts. data VectInfo = VectInfo { vectInfoVar :: VarEnv (Var , Var ), -- ^ @(f, f_v)@ keyed on @f@ diff -ruN ghc-6.12.1/compiler/main/Packages.lhs ghc-6.13.20091231/compiler/main/Packages.lhs --- ghc-6.12.1/compiler/main/Packages.lhs 2009-12-10 10:11:33.000000000 -0800 +++ ghc-6.13.20091231/compiler/main/Packages.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -556,12 +556,12 @@ in listToFM shadowed where check (shadowed,pkgmap) pkg - | Just oldpkg <- lookupUFM pkgmap (packageConfigId pkg), - let + | Just oldpkg <- lookupUFM pkgmap (packageConfigId pkg) + , let ipid_new = installedPackageId pkg - ipid_old = installedPackageId oldpkg, + ipid_old = installedPackageId oldpkg -- - ipid_old /= ipid_new + , ipid_old /= ipid_new = if ipid_old `elem` preferred then ( (ipid_new, ShadowedBy ipid_old) : shadowed, pkgmap ) else ( (ipid_old, ShadowedBy ipid_new) : shadowed, pkgmap' ) diff -ruN ghc-6.12.1/compiler/main/StaticFlagParser.hs ghc-6.13.20091231/compiler/main/StaticFlagParser.hs --- ghc-6.12.1/compiler/main/StaticFlagParser.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/main/StaticFlagParser.hs 2009-12-31 10:14:17.000000000 -0800 @@ -122,6 +122,7 @@ ------ Debugging ---------------------------------------------------- , Flag "dppr-debug" (PassFlag addOpt) Supported , Flag "dsuppress-uniques" (PassFlag addOpt) Supported + , Flag "dsuppress-coercions" (PassFlag addOpt) Supported , Flag "dppr-user-length" (AnySuffix addOpt) Supported , Flag "dopt-fuel" (AnySuffix addOpt) Supported , Flag "dno-debug-output" (PassFlag addOpt) Supported diff -ruN ghc-6.12.1/compiler/main/StaticFlags.hs ghc-6.13.20091231/compiler/main/StaticFlags.hs --- ghc-6.12.1/compiler/main/StaticFlags.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/main/StaticFlags.hs 2009-12-31 10:14:18.000000000 -0800 @@ -22,6 +22,7 @@ -- Output style options opt_PprUserLength, opt_SuppressUniques, + opt_SuppressCoercions, opt_PprStyle_Debug, opt_NoDebugOutput, @@ -50,6 +51,7 @@ opt_UF_CreationThreshold, opt_UF_UseThreshold, opt_UF_FunAppDiscount, + opt_UF_DictDiscount, opt_UF_KeenessFactor, opt_UF_DearOp, @@ -183,6 +185,8 @@ -- debugging opts opt_SuppressUniques :: Bool opt_SuppressUniques = lookUp (fsLit "-dsuppress-uniques") +opt_SuppressCoercions :: Bool +opt_SuppressCoercions = lookUp (fsLit "-dsuppress-coercions") opt_PprStyle_Debug :: Bool opt_PprStyle_Debug = lookUp (fsLit "-dppr-debug") opt_PprUserLength :: Int @@ -249,23 +253,26 @@ opt_SimplExcessPrecision = lookUp (fsLit "-fexcess-precision") -- Unfolding control -opt_UF_CreationThreshold :: Int -opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (45::Int) -opt_UF_UseThreshold :: Int -opt_UF_UseThreshold = lookup_def_int "-funfolding-use-threshold" (6::Int) -- Discounts can be big -opt_UF_FunAppDiscount :: Int -opt_UF_FunAppDiscount = lookup_def_int "-funfolding-fun-discount" (6::Int) -- It's great to inline a fn +-- See Note [Discounts and thresholds] in CoreUnfold + +opt_UF_CreationThreshold, opt_UF_UseThreshold :: Int +opt_UF_DearOp, opt_UF_FunAppDiscount, opt_UF_DictDiscount :: Int opt_UF_KeenessFactor :: Float -opt_UF_KeenessFactor = lookup_def_float "-funfolding-keeness-factor" (1.5::Float) -opt_UF_DearOp :: Int -opt_UF_DearOp = ( 4 :: Int) +opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (45::Int) +opt_UF_UseThreshold = lookup_def_int "-funfolding-use-threshold" (6::Int) +opt_UF_FunAppDiscount = lookup_def_int "-funfolding-fun-discount" (6::Int) +opt_UF_DictDiscount = lookup_def_int "-funfolding-dict-discount" (1::Int) +opt_UF_KeenessFactor = lookup_def_float "-funfolding-keeness-factor" (1.5::Float) +opt_UF_DearOp = ( 4 :: Int) -- Related to linking opt_PIC :: Bool #if darwin_TARGET_OS && x86_64_TARGET_ARCH opt_PIC = True +#elif darwin_TARGET_OS +opt_PIC = lookUp (fsLit "-fPIC") || not opt_Static #else opt_PIC = lookUp (fsLit "-fPIC") #endif diff -ruN ghc-6.12.1/compiler/main/TidyPgm.lhs ghc-6.13.20091231/compiler/main/TidyPgm.lhs --- ghc-6.12.1/compiler/main/TidyPgm.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/main/TidyPgm.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -16,10 +16,9 @@ import CoreUnfold import CoreFVs import CoreTidy -import PprCore -import CoreLint +import CoreMonad import CoreUtils -import CoreArity ( exprArity ) +import CoreArity ( exprArity, exprBotStrictness_maybe ) import Class ( classSelIds ) import VarEnv import VarSet @@ -27,9 +26,9 @@ import Id import IdInfo import InstEnv -import NewDemand +import Demand import BasicTypes -import Name +import Name hiding (varName) import NameSet import IfaceEnv import NameEnv @@ -50,8 +49,9 @@ \end{code} -Constructing the TypeEnv, Instances, Rules from which the ModIface is -constructed, and which goes on to subsequent modules in --make mode. +Constructing the TypeEnv, Instances, Rules, VectInfo from which the +ModIface is constructed, and which goes on to subsequent modules in +--make mode. Most of the interface file is obtained simply by serialising the TypeEnv. One important consequence is that if the *interface file* @@ -296,28 +296,23 @@ mg_hpc_info = hpc_info, mg_modBreaks = modBreaks }) - = do { let dflags = hsc_dflags hsc_env - ; showPass dflags "Tidy Core" - - ; let { omit_prags = dopt Opt_OmitInterfacePragmas dflags + = do { let { dflags = hsc_dflags hsc_env + ; omit_prags = dopt Opt_OmitInterfacePragmas dflags + ; expose_all = dopt Opt_ExposeAllUnfoldings dflags ; th = dopt Opt_TemplateHaskell dflags } + ; showPass dflags "Tidy Core" ; let { implicit_binds = getImplicitBinds type_env } ; (unfold_env, tidy_occ_env) - <- chooseExternalIds hsc_env mod omit_prags binds implicit_binds + <- chooseExternalIds hsc_env mod omit_prags expose_all + binds implicit_binds imp_rules - ; let { ext_rules - | omit_prags = [] - | otherwise = findExternalRules binds imp_rules unfold_env - -- findExternalRules filters imp_rules to avoid binders that - -- aren't externally visible; but the externally-visible binders - -- are computed (by findExternalIds) assuming that all orphan - -- rules are exported (they get their Exported flag set in the desugarer) - -- So in fact we may export more than we need. - -- (It's a sort of mutual recursion.) - } + ; let { ext_rules = findExternalRules omit_prags binds imp_rules unfold_env } + -- Glom together imp_rules and rules currently attached to binders + -- Then pick just the ones we need to expose + -- See Note [Which rules to expose] ; let { (tidy_env, tidy_binds) = tidyTopBinds hsc_env unfold_env tidy_occ_env binds } @@ -339,17 +334,15 @@ -- and indeed it does, but if omit_prags is on, ext_rules is -- empty + ; tidy_vect_info = tidyVectInfo tidy_env vect_info + -- See Note [Injecting implicit bindings] ; all_tidy_binds = implicit_binds ++ tidy_binds ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env) } - ; endPass dflags "Tidy Core" Opt_D_dump_simpl all_tidy_binds - ; dumpIfSet_core dflags Opt_D_dump_simpl - "Tidy Core Rules" - (pprRules tidy_rules) - + ; endPass dflags "Tidy Core" Opt_D_dump_simpl all_tidy_binds tidy_rules ; let dir_imp_mods = moduleEnvKeys dir_imps ; return (CgGuts { cg_module = mod, @@ -364,10 +357,10 @@ ModDetails { md_types = tidy_type_env, md_rules = tidy_rules, md_insts = tidy_insts, - md_fam_insts = fam_insts, + md_vect_info = tidy_vect_info, + md_fam_insts = fam_insts, md_exports = exports, - md_anns = anns, -- are already tidy - md_vect_info = vect_info -- + md_anns = anns -- are already tidy }) } @@ -476,6 +469,29 @@ tidy_dfun (instanceDFunId ispec) \end{code} +\begin{code} +tidyVectInfo :: TidyEnv -> VectInfo -> VectInfo +tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars + , vectInfoPADFun = pas + , vectInfoIso = isos }) + = info { vectInfoVar = tidy_vars + , vectInfoPADFun = tidy_pas + , vectInfoIso = tidy_isos } + where + tidy_vars = mkVarEnv + $ map tidy_var_mapping + $ varEnvElts vars + + tidy_pas = mapNameEnv tidy_snd_var pas + tidy_isos = mapNameEnv tidy_snd_var isos + + tidy_var_mapping (from, to) = (from', (from', lookup_var to)) + where from' = lookup_var from + tidy_snd_var (x, var) = (x, lookup_var var) + + lookup_var var = lookupWithDefaultVarEnv var_env var var +\end{code} + %************************************************************************ %* * @@ -539,7 +555,7 @@ implicit_ids _ = [] get_defn :: Id -> CoreBind - get_defn id = NonRec id (unfoldingTemplate (idUnfolding id)) + get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id)) \end{code} @@ -553,45 +569,49 @@ \begin{code} type UnfoldEnv = IdEnv (Name{-new name-}, Bool {-show unfolding-}) - -- maps each top-level Id to its new Name (the Id is tidied in step 2) - -- The Unique is unchanged. If the new Id is external, it will be + -- Maps each top-level Id to its new Name (the Id is tidied in step 2) + -- The Unique is unchanged. If the new Name is external, it will be -- visible in the interface file. -- -- Bool => expose unfolding or not. chooseExternalIds :: HscEnv -> Module - -> Bool + -> Bool -> Bool -> [CoreBind] -> [CoreBind] + -> [CoreRule] -> IO (UnfoldEnv, TidyOccEnv) -- Step 1 from the notes above -chooseExternalIds hsc_env mod omit_prags binds implicit_binds - = do - (unfold_env1,occ_env1) - <- search (zip sorted_exports sorted_exports) emptyVarEnv init_occ_env - let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders - tidy_internal internal_ids unfold_env1 occ_env1 +chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules + = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env + ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders + ; tidy_internal internal_ids unfold_env1 occ_env1 } where nc_var = hsc_NC hsc_env - -- the exports, sorted by OccName. This is a deterministic list of - -- Ids (i.e. it's the same list every time this module is compiled), - -- in contrast to the bindings, which are ordered - -- non-deterministically. - -- - -- This list will serve as a starting point for finding a + -- init_ext_ids is the intial list of Ids that should be + -- externalised. It serves as the starting point for finding a -- deterministic, tidy, renaming for all external Ids in this -- module. - sorted_exports = sortBy (compare `on` getOccName) $ - filter isExportedId binders + -- + -- It is sorted, so that it has adeterministic order (i.e. it's the + -- same list every time this module is compiled), in contrast to the + -- bindings, which are ordered non-deterministically. + init_work_list = zip init_ext_ids init_ext_ids + init_ext_ids = sortBy (compare `on` getOccName) $ + filter is_external binders + + -- An Id should be external if either (a) it is exported or + -- (b) it appears in the RHS of a local rule for an imported Id. + -- See Note [Which rules to expose] + is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars + rule_rhs_vars = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet imp_id_rules - binders = bindersOfBinds binds + binders = bindersOfBinds binds implicit_binders = bindersOfBinds implicit_binds - - bind_env :: IdEnv (Id,CoreExpr) - bind_env = mkVarEnv (zip (map fst bs) bs) where bs = flattenBinds binds + binder_set = mkVarSet binders avoids = [getOccName name | bndr <- binders ++ implicit_binders, let name = idName bndr, @@ -616,7 +636,12 @@ init_occ_env = initTidyOccEnv avoids - search :: [(Id,Id)] -- (external id, referrring id) + search :: [(Id,Id)] -- The work-list: (external id, referrring id) + -- Make a tidy, external Name for the external id, + -- add it to the UnfoldEnv, and do the same for the + -- transitive closure of Ids it refers to + -- The referring id is used to generate a tidy + --- name for the external id -> UnfoldEnv -- id -> (new Name, show_unfold) -> TidyOccEnv -- occ env for choosing new Names -> IO (UnfoldEnv, TidyOccEnv) @@ -628,19 +653,19 @@ | otherwise = do (occ_env', name') <- tidyTopName mod nc_var (Just referrer) occ_env idocc let - (id, rhs) = expectJust (showSDoc (text "chooseExternalIds: " <> - ppr idocc)) $ - lookupVarEnv bind_env idocc - -- NB. idocc might be an *occurrence* of an Id, whereas we want - -- the Id from the binding site, because only the latter is - -- guaranteed to have the unfolding attached. This is why we - -- keep binding site Ids in the bind_env. (new_ids, show_unfold) | omit_prags = ([], False) - | otherwise = addExternal id rhs - unfold_env' = extendVarEnv unfold_env id (name',show_unfold) - referrer' | isExportedId id = id - | otherwise = referrer + | otherwise = addExternal expose_all refined_id + + -- 'idocc' is an *occurrence*, but we need to see the + -- unfolding in the *definition*; so look up in binder_set + refined_id = case lookupVarSet binder_set idocc of + Just id -> id + Nothing -> WARN( True, ppr idocc ) idocc + + unfold_env' = extendVarEnv unfold_env idocc (name',show_unfold) + referrer' | isExportedId refined_id = refined_id + | otherwise = referrer -- search (zip new_ids (repeat referrer') ++ rest) unfold_env' occ_env' @@ -652,45 +677,45 @@ let unfold_env' = extendVarEnv unfold_env id (name',False) tidy_internal ids unfold_env' occ_env' -addExternal :: Id -> CoreExpr -> ([Id],Bool) -addExternal id rhs = (new_needed_ids, show_unfold) +addExternal :: Bool -> Id -> ([Id],Bool) +addExternal expose_all id = (new_needed_ids, show_unfold) where new_needed_ids = unfold_ids ++ filter (\id -> isLocalId id && not (id `elemVarSet` unfold_set)) - (varSetElems worker_ids ++ - varSetElems spec_ids) -- XXX non-det ordering + (varSetElems spec_ids) -- XXX non-det ordering idinfo = idInfo id - dont_inline = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo)) + never_active = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo)) loop_breaker = isNonRuleLoopBreaker (occInfo idinfo) - bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig) + bottoming_fn = isBottomingSig (strictnessInfo idinfo `orElse` topSig) spec_ids = specInfoFreeVars (specInfo idinfo) - worker_info = workerInfo idinfo -- Stuff to do with the Id's unfolding - -- The simplifier has put an up-to-date unfolding - -- in the IdInfo, but the RHS will do just as well - unfolding = unfoldingInfo idinfo - rhs_is_small = not (neverUnfold unfolding) - -- We leave the unfolding there even if there is a worker -- In GHCI the unfolding is used by importers - -- When writing an interface file, we omit the unfolding - -- if there is a worker - show_unfold = not bottoming_fn && -- Not necessary - not dont_inline && - not loop_breaker && - rhs_is_small -- Small enough - - (unfold_set, unfold_ids) - | show_unfold = freeVarsInDepthFirstOrder rhs - | otherwise = (emptyVarSet, []) - - worker_ids = case worker_info of - HasWorker work_id _ -> unitVarSet work_id - _otherwise -> emptyVarSet + show_unfold = isJust mb_unfold_ids + (unfold_set, unfold_ids) = mb_unfold_ids `orElse` (emptyVarSet, []) + mb_unfold_ids :: Maybe (IdSet, [Id]) -- Nothing => don't unfold + mb_unfold_ids = case unfoldingInfo idinfo of + CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src, uf_guidance = guide } + | show_unfolding src guide + -> Just (exprFvsInOrder unf_rhs) + DFunUnfolding _ ops -> Just (exprsFvsInOrder ops) + _ -> Nothing + + show_unfolding unf_source unf_guidance + = expose_all -- 'expose_all' says to expose all + -- unfoldings willy-nilly + + || isInlineRuleSource unf_source -- Always expose things whose + -- source is an inline rule + + || not (bottoming_fn -- No need to inline bottom functions + || never_active -- Or ones that say not to + || loop_breaker -- Or that are loop breakers + || neverUnfoldGuidance unf_guidance) -- We want a deterministic free-variable list. exprFreeVars gives us -- a VarSet, which is in a non-deterministic order when converted to a @@ -699,11 +724,15 @@ -- -- Note [choosing external names] -freeVarsInDepthFirstOrder :: CoreExpr -> (VarSet, [Id]) -freeVarsInDepthFirstOrder e = - case dffvExpr e of - DFFV m -> case m emptyVarSet [] of - (set,ids,_) -> (set,ids) +exprFvsInOrder :: CoreExpr -> (VarSet, [Id]) +exprFvsInOrder e = run (dffvExpr e) + +exprsFvsInOrder :: [CoreExpr] -> (VarSet, [Id]) +exprsFvsInOrder es = run (mapM_ dffvExpr es) + +run :: DFFV () -> (VarSet, [Id]) +run (DFFV m) = case m emptyVarSet [] of + (set,ids,_) -> (set,ids) newtype DFFV a = DFFV (VarSet -> [Var] -> (VarSet,[Var],a)) @@ -823,15 +852,17 @@ \end{code} \begin{code} -findExternalRules :: [CoreBind] - -> [CoreRule] -- Non-local rules (i.e. ones for imported fns) +findExternalRules :: Bool -- Omit pragmas + -> [CoreBind] + -> [CoreRule] -- Local rules for imported fns -> UnfoldEnv -- Ids that are exported, so we need their rules -> [CoreRule] -- The complete rules are gotten by combining - -- a) the non-local rules + -- a) local rules for imported Ids -- b) rules embedded in the top-level Ids -findExternalRules binds non_local_rules unfold_env - = filter (not . internal_rule) (non_local_rules ++ local_rules) +findExternalRules omit_prags binds imp_id_rules unfold_env + | omit_prags = [] + | otherwise = filterOut internal_rule (imp_id_rules ++ local_rules) where local_rules = [ rule | id <- bindersOfBinds binds, @@ -850,7 +881,14 @@ | otherwise = False \end{code} - +Note [Which rules to expose] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +findExternalRules filters imp_rules to avoid binders that +aren't externally visible; but the externally-visible binders +are computed (by findExternalIds) assuming that all orphan +rules are externalised (see init_ext_ids in function +'search'). So in fact we may export more than we need. +(It's a sort of mutual recursion.) %************************************************************************ %* * @@ -945,29 +983,14 @@ -- in the IdInfo of one early in the group tidyTopPair show_unfold rhs_tidy_env caf_info name' (bndr, rhs) - = (bndr', rhs') + = (bndr1, rhs1) where - bndr' = mkGlobalId details name' ty' idinfo' - details = idDetails bndr -- Preserve the IdDetails - ty' = tidyTopType (idType bndr) - rhs' = tidyExpr rhs_tidy_env rhs - idinfo = idInfo bndr - idinfo' = tidyTopIdInfo (isExternalName name') - idinfo unfold_info worker_info - arity caf_info - - unfold_info | show_unfold = mkTopUnfolding rhs' - | otherwise = noUnfolding - worker_info = tidyWorker rhs_tidy_env show_unfold (workerInfo idinfo) - - -- Usually the Id will have an accurate arity on it, because - -- the simplifier has just run, but not always. - -- One case I found was when the last thing the simplifier - -- did was to let-bind a non-atomic argument and then float - -- it to the top level. So it seems more robust just to - -- fix it here. - arity = exprArity rhs - + bndr1 = mkGlobalId details name' ty' idinfo' + details = idDetails bndr -- Preserve the IdDetails + ty' = tidyTopType (idType bndr) + rhs1 = tidyExpr rhs_tidy_env rhs + idinfo' = tidyTopIdInfo rhs_tidy_env name' rhs rhs1 (idInfo bndr) + show_unfold caf_info -- tidyTopIdInfo creates the final IdInfo for top-level -- binders. There are two delicate pieces: @@ -981,38 +1004,53 @@ -- occurrences of the binders in RHSs, and hence to occurrences in -- unfoldings, which are inside Ids imported by GHCi. Ditto RULES. -- CoreToStg makes use of this when constructing SRTs. -tidyTopIdInfo :: Bool -> IdInfo -> Unfolding - -> WorkerInfo -> ArityInfo -> CafInfo - -> IdInfo -tidyTopIdInfo is_external idinfo unfold_info worker_info arity caf_info +tidyTopIdInfo :: TidyEnv -> Name -> CoreExpr -> CoreExpr + -> IdInfo -> Bool -> CafInfo -> IdInfo +tidyTopIdInfo rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info | not is_external -- For internal Ids (not externally visible) = vanillaIdInfo -- we only need enough info for code generation -- Arity and strictness info are enough; -- c.f. CoreTidy.tidyLetBndr - `setCafInfo` caf_info - `setArityInfo` arity - `setAllStrictnessInfo` newStrictnessInfo idinfo + `setCafInfo` caf_info + `setArityInfo` arity + `setStrictnessInfo` final_sig | otherwise -- Externally-visible Ids get the whole lot = vanillaIdInfo `setCafInfo` caf_info `setArityInfo` arity - `setAllStrictnessInfo` newStrictnessInfo idinfo - `setInlinePragInfo` inlinePragInfo idinfo + `setStrictnessInfo` final_sig + `setOccInfo` robust_occ_info + `setInlinePragInfo` (inlinePragInfo idinfo) `setUnfoldingInfo` unfold_info - `setWorkerInfo` worker_info -- NB: we throw away the Rules -- They have already been extracted by findExternalRules + where + is_external = isExternalName name - - ------------- Worker -------------- -tidyWorker :: TidyEnv -> Bool -> WorkerInfo -> WorkerInfo -tidyWorker _tidy_env _show_unfold NoWorker - = NoWorker -tidyWorker tidy_env show_unfold (HasWorker work_id wrap_arity) - | show_unfold = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity - | otherwise = NoWorker + --------- OccInfo ------------ + robust_occ_info = zapFragileOcc (occInfo idinfo) + -- It's important to keep loop-breaker information + -- when we are doing -fexpose-all-unfoldings + + --------- Strictness ------------ + final_sig | Just sig <- strictnessInfo idinfo + = WARN( _bottom_hidden sig, ppr name ) Just sig + | Just (_, sig) <- mb_bot_str = Just sig + | otherwise = Nothing + + -- If the cheap-and-cheerful bottom analyser can see that + -- the RHS is bottom, it should jolly well be exposed + _bottom_hidden id_sig = case mb_bot_str of + Nothing -> False + Just (arity, _) -> not (appIsBottom id_sig arity) + + mb_bot_str = exprBotStrictness_maybe orig_rhs + + --------- Unfolding ------------ + unf_info = unfoldingInfo idinfo + unfold_info | show_unfold = tidyUnfolding rhs_tidy_env tidy_rhs final_sig unf_info + | otherwise = noUnfolding -- NB: do *not* expose the worker if show_unfold is off, -- because that means this thing is a loop breaker or -- marked NOINLINE or something like that @@ -1026,6 +1064,39 @@ -- In this case, show_unfold will be false (we don't expose unfoldings -- for bottoming functions), but we might still have a worker/wrapper -- split (see Note [Worker-wrapper for bottoming functions] in WorkWrap.lhs + + --------- Arity ------------ + -- Usually the Id will have an accurate arity on it, because + -- the simplifier has just run, but not always. + -- One case I found was when the last thing the simplifier + -- did was to let-bind a non-atomic argument and then float + -- it to the top level. So it seems more robust just to + -- fix it here. + arity = exprArity orig_rhs + + + +------------ Unfolding -------------- +tidyUnfolding :: TidyEnv -> CoreExpr -> Maybe StrictSig -> Unfolding -> Unfolding +tidyUnfolding tidy_env _ _ (DFunUnfolding con ids) + = DFunUnfolding con (map (tidyExpr tidy_env) ids) +tidyUnfolding tidy_env tidy_rhs strict_sig + unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src }) + | isInlineRuleSource src + = unf { uf_tmpl = tidyExpr tidy_env unf_rhs, -- Preserves OccInfo + uf_src = tidyInl tidy_env src } + | otherwise + = mkTopUnfolding is_bot tidy_rhs + where + is_bot = case strict_sig of + Just sig -> isBottomingSig sig + Nothing -> False + +tidyUnfolding _ _ _ unf = unf + +tidyInl :: TidyEnv -> UnfoldingSource -> UnfoldingSource +tidyInl tidy_env (InlineWrapper w) = InlineWrapper (tidyVarOcc tidy_env w) +tidyInl _ inl_info = inl_info \end{code} %************************************************************************ diff -ruN ghc-6.12.1/compiler/nativeGen/AsmCodeGen.lhs ghc-6.13.20091231/compiler/nativeGen/AsmCodeGen.lhs --- ghc-6.12.1/compiler/nativeGen/AsmCodeGen.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/nativeGen/AsmCodeGen.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -72,6 +72,7 @@ import RegClass import NCGMonad +import BlockId import Cmm import CmmOpt ( cmmMiniInline, cmmMachOpFold ) import PprCmm @@ -630,10 +631,17 @@ where -- find all the blocks that just consist of a jump that can be -- shorted. - (shortcut_blocks, others) = partitionWith split blocks - split (BasicBlock id [insn]) | Just dest <- canShortcut insn - = Left (id,dest) - split other = Right other + -- Don't completely eliminate loops here -- that can leave a dangling jump! + (_, shortcut_blocks, others) = foldl split (emptyBlockSet, [], []) blocks + split (s, shortcut_blocks, others) b@(BasicBlock id [insn]) + | Just (DestBlockId dest) <- canShortcut insn, + (elemBlockSet dest s) || dest == id -- loop checks + = (s, shortcut_blocks, b : others) + split (s, shortcut_blocks, others) (BasicBlock id [insn]) + | Just dest <- canShortcut insn + = (extendBlockSet s id, (id,dest) : shortcut_blocks, others) + split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others) + -- build a mapping from BlockId to JumpDest for shorting branches mapping = foldl add emptyUFM shortcut_blocks diff -ruN ghc-6.12.1/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs ghc-6.13.20091231/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs --- ghc-6.12.1/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs 2009-12-31 10:14:17.000000000 -0800 @@ -57,11 +57,11 @@ -- | so we can put regs in UniqSets instance Uniquable Reg where getUnique (Reg c i) - = mkUnique 'R' + = mkRegSingleUnique $ fromEnum c * 1000 + i getUnique (RegSub s (Reg c i)) - = mkUnique 'S' + = mkRegSubUnique $ fromEnum s * 10000 + fromEnum c * 1000 + i getUnique (RegSub _ (RegSub _ _)) diff -ruN ghc-6.12.1/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs ghc-6.13.20091231/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs --- ghc-6.12.1/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs 2009-12-31 10:14:17.000000000 -0800 @@ -436,15 +436,15 @@ instance Uniquable Store where getUnique (SReg r) | RegReal (RealRegSingle i) <- r - = mkUnique 'R' i + = mkRegSingleUnique i | RegReal (RealRegPair r1 r2) <- r - = mkUnique 'P' (r1 * 65535 + r2) + = mkRegPairUnique (r1 * 65535 + r2) | otherwise = error "RegSpillClean.getUnique: found virtual reg during spill clean, only real regs expected." - getUnique (SSlot i) = mkUnique 'S' i + getUnique (SSlot i) = mkRegSubUnique i -- [SLPJ] I hope "SubUnique" is ok instance Outputable Store where ppr (SSlot i) = text "slot" <> int i diff -ruN ghc-6.12.1/compiler/nativeGen/RegClass.hs ghc-6.13.20091231/compiler/nativeGen/RegClass.hs --- ghc-6.12.1/compiler/nativeGen/RegClass.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/nativeGen/RegClass.hs 2009-12-31 10:14:17.000000000 -0800 @@ -21,9 +21,9 @@ instance Uniquable RegClass where - getUnique RcInteger = mkUnique 'L' 0 - getUnique RcFloat = mkUnique 'L' 1 - getUnique RcDouble = mkUnique 'L' 2 + getUnique RcInteger = mkRegClassUnique 0 + getUnique RcFloat = mkRegClassUnique 1 + getUnique RcDouble = mkRegClassUnique 2 instance Outputable RegClass where ppr RcInteger = Outputable.text "I" diff -ruN ghc-6.12.1/compiler/nativeGen/Reg.hs ghc-6.13.20091231/compiler/nativeGen/Reg.hs --- ghc-6.12.1/compiler/nativeGen/Reg.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/nativeGen/Reg.hs 2009-12-31 10:14:17.000000000 -0800 @@ -125,8 +125,8 @@ instance Uniquable RealReg where getUnique reg = case reg of - RealRegSingle i -> mkUnique 'S' i - RealRegPair r1 r2 -> mkUnique 'P' (r1 * 65536 + r2) + RealRegSingle i -> mkRegSingleUnique i + RealRegPair r1 r2 -> mkRegPairUnique (r1 * 65536 + r2) instance Outputable RealReg where ppr reg diff -ruN ghc-6.12.1/compiler/nativeGen/X86/Instr.hs ghc-6.13.20091231/compiler/nativeGen/X86/Instr.hs --- ghc-6.12.1/compiler/nativeGen/X86/Instr.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/nativeGen/X86/Instr.hs 2009-12-31 10:14:17.000000000 -0800 @@ -28,6 +28,8 @@ import Constants (rESERVED_C_STACK_BYTES) import CLabel +import UniqSet +import Unique -- Size of a PPC memory address, in bytes. -- @@ -799,12 +801,13 @@ canShortcut :: Instr -> Maybe JumpDest -canShortcut (JXX ALWAYS id) = Just (DestBlockId id) -canShortcut (JMP (OpImm imm)) = Just (DestImm imm) -canShortcut _ = Nothing +canShortcut (JXX ALWAYS id) = Just (DestBlockId id) +canShortcut (JMP (OpImm imm)) = Just (DestImm imm) +canShortcut _ = Nothing --- The helper ensures that we don't follow cycles. +-- This helper shortcuts a sequence of branches. +-- The blockset helps avoid following cycles. shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr shortcutJump fn insn = shortcutJump' fn emptyBlockSet insn where shortcutJump' fn seen insn@(JXX cc id) = @@ -820,10 +823,10 @@ shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic shortcutStatic fn (CmmStaticLit (CmmLabel lab)) | Just uq <- maybeAsmTemp lab - = CmmStaticLit (CmmLabel (shortBlockId fn (BlockId uq))) + = CmmStaticLit (CmmLabel (shortBlockId fn emptyUniqSet (BlockId uq))) shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) | Just uq <- maybeAsmTemp lbl1 - = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn (BlockId uq)) lbl2 off) + = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn emptyUniqSet (BlockId uq)) lbl2 off) -- slightly dodgy, we're ignoring the second label, but this -- works with the way we use CmmLabelDiffOff for jump tables now. @@ -832,12 +835,14 @@ shortBlockId :: (BlockId -> Maybe JumpDest) + -> UniqSet Unique -> BlockId -> CLabel -shortBlockId fn blockid@(BlockId uq) = - case fn blockid of - Nothing -> mkAsmTempLabel uq - Just (DestBlockId blockid') -> shortBlockId fn blockid' - Just (DestImm (ImmCLbl lbl)) -> lbl - _other -> panic "shortBlockId" +shortBlockId fn seen blockid@(BlockId uq) = + case (elementOfUniqSet uq seen, fn blockid) of + (True, _) -> mkAsmTempLabel uq + (_, Nothing) -> mkAsmTempLabel uq + (_, Just (DestBlockId blockid')) -> shortBlockId fn (addOneToUniqSet seen uq) blockid' + (_, Just (DestImm (ImmCLbl lbl))) -> lbl + (_, _other) -> panic "shortBlockId" diff -ruN ghc-6.12.1/compiler/parser/Lexer.hs ghc-6.13.20091231/compiler/parser/Lexer.hs --- ghc-6.12.1/compiler/parser/Lexer.hs 2009-12-10 12:13:28.000000000 -0800 +++ ghc-6.13.20091231/compiler/parser/Lexer.hs 2009-12-31 12:35:22.000000000 -0800 @@ -1,23 +1,23 @@ {-# OPTIONS -fglasgow-exts -cpp #-} {-# LINE 33 "compiler/parser/Lexer.x" #-} -{-# OPTIONS -Wwarn -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details --- --- Note that Alex itself generates code with with some unused bindings and --- without type signatures, so removing the flag might not be possible. +-- XXX The above flags turn off warnings in the generated code: +{-# OPTIONS_GHC -fno-warn-unused-matches #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +-- But alex still generates some code that causes the "lazy unlifted bindings" +-- warning, and old compilers don't know about it so we can't easily turn +-- it off, so for now we use the sledge hammer: +{-# OPTIONS_GHC -w #-} {-# OPTIONS_GHC -funbox-strict-fields #-} module Lexer ( Token(..), lexer, pragState, mkPState, PState(..), P(..), ParseResult(..), getSrcLoc, - getPState, + getPState, getDynFlags, withThisPackage, failLocMsgP, failSpanMsgP, srcParseFail, - getMessages, + getMessages, popContext, pushCurrentContext, setLastToken, setSrcLoc, getLexState, popLexState, pushLexState, extension, standaloneDerivingEnabled, bangPatEnabled, @@ -33,6 +33,7 @@ import SrcLoc import UniqFM import DynFlags +import Module import Ctype import Util ( readRational ) @@ -76,7 +77,7 @@ alex_deflt = AlexA# "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x69\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1c\x00\x1d\x00\x1a\x00\x1b\x00\x1a\x00\x1a\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\x2b\x00\x2c\x00\x2b\x00\x2b\x00\x2d\x00\x2e\x00\x2d\x00\x2e\x00\x34\x00\x35\x00\x34\x00\x36\x00\x34\x00\x34\x00\x35\x00\x36\x00\x39\x00\x3a\x00\x39\x00\x3a\x00\x37\x00\x38\x00\x37\x00\x37\x00\x38\x00\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x51\x00\x51\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# alex_accept = listArray (0::Int,240) [[],[(AlexAcc (alex_action_13))],[(AlexAcc (alex_action_17))],[(AlexAcc (alex_action_18))],[(AlexAcc (alex_action_19))],[],[],[(AlexAcc (alex_action_24))],[],[],[],[],[],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_1))],[(AlexAccPred (alex_action_2) (isNormalComment ))],[(AlexAccPred (alex_action_2) (isNormalComment )),(AlexAcc (alex_action_24))],[(AlexAccPred (alex_action_2) (isNormalComment ))],[(AlexAccPred (alex_action_2) (isNormalComment ))],[(AlexAccPred (alex_action_14) (notFollowedBy '-' ))],[],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_64))],[(AlexAcc (alex_action_64))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAccPred (alex_action_8) (atEOL ))],[(AlexAccPred (alex_action_8) (atEOL )),(AlexAcc (alex_action_24))],[(AlexAccPred (alex_action_8) (atEOL ))],[(AlexAccPred (alex_action_8) (atEOL ))],[],[(AlexAcc (alex_action_24))],[],[],[(AlexAcc (alex_action_78))],[(AlexAccPred (alex_action_7) (atEOL ))],[(AlexAccPred (alex_action_7) (atEOL )),(AlexAcc (alex_action_24))],[(AlexAccPred (alex_action_7) (atEOL ))],[(AlexAccPred (alex_action_7) (atEOL )),(AlexAcc (alex_action_78))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_4))],[(AlexAccPred (alex_action_5) (ifExtension (not . haddockEnabled) ))],[(AlexAccPred (alex_action_5) (ifExtension (not . haddockEnabled) )),(AlexAcc (alex_action_24))],[(AlexAccPred (alex_action_5) (ifExtension (not . haddockEnabled) )),(AlexAcc (alex_action_33))],[(AlexAccPred (alex_action_5) (ifExtension (not . haddockEnabled) )),(AlexAcc (alex_action_35))],[(AlexAccPred (alex_action_5) (ifExtension (not . haddockEnabled) )),(AlexAccPred (alex_action_37) (ifExtension haddockEnabled ))],[(AlexAccPred (alex_action_5) (ifExtension (not . haddockEnabled) ))],[(AlexAccPred (alex_action_5) (ifExtension (not . haddockEnabled) )),(AlexAcc (alex_action_24))],[(AlexAccPred (alex_action_5) (ifExtension (not . haddockEnabled) )),(AlexAcc (alex_action_35))],[(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_6))],[(AlexAccPred (alex_action_7) (atEOL ))],[(AlexAccPred (alex_action_7) (atEOL )),(AlexAcc (alex_action_24))],[(AlexAccPred (alex_action_7) (atEOL )),(AlexAcc (alex_action_78))],[(AlexAccPred (alex_action_7) (atEOL ))],[(AlexAccPred (alex_action_7) (atEOL )),(AlexAcc (alex_action_24))],[(AlexAccPred (alex_action_7) (atEOL )),(AlexAcc (alex_action_78))],[(AlexAccSkip)],[(AlexAccPred (alex_action_10) (alexPrevCharIs '\n'))],[(AlexAccPred (alex_action_10) (alexPrevCharIs '\n'))],[],[],[],[(AlexAccSkipPred (alexPrevCharIs '\n'))],[],[],[],[],[],[],[],[(AlexAccSkipPred (alexPrevCharIs '\n'))],[],[],[(AlexAccSkip)],[(AlexAccPred (alex_action_16) (alexPrevCharIs '\n'))],[(AlexAccPred (alex_action_16) (alexPrevCharIs '\n'))],[],[],[],[(AlexAcc (alex_action_20))],[(AlexAccPred (alex_action_21) (known_pragma linePrags ))],[(AlexAccPred (alex_action_21) (known_pragma linePrags )),(AlexAcc (alex_action_24))],[(AlexAccPred (alex_action_21) (known_pragma linePrags )),(AlexAccPred (alex_action_29) (known_pragma oneWordPrags )),(AlexAccPred (alex_action_30) (known_pragma ignoredPrags )),(AlexAccPred (alex_action_32) (known_pragma fileHeaderPrags ))],[(AlexAccPred (alex_action_21) (known_pragma linePrags )),(AlexAccPred (alex_action_29) (known_pragma oneWordPrags )),(AlexAccPred (alex_action_30) (known_pragma ignoredPrags )),(AlexAccPred (alex_action_34) (known_pragma fileHeaderPrags ))],[],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_36))],[(AlexAcc (alex_action_36))],[],[(AlexAcc (alex_action_24))],[],[],[(AlexAcc (alex_action_22))],[(AlexAcc (alex_action_23))],[],[],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_26))],[],[],[(AlexAcc (alex_action_27))],[(AlexAcc (alex_action_27))],[],[],[(AlexAccPred (alex_action_28) (known_pragma twoWordPrags ))],[],[(AlexAcc (alex_action_31))],[],[(AlexAcc (alex_action_78))],[],[(AlexAcc (alex_action_78))],[(AlexAccPred (alex_action_38) (ifExtension haddockEnabled ))],[],[(AlexAccPred (alex_action_39) (ifExtension parrEnabled ))],[(AlexAcc (alex_action_59))],[(AlexAccPred (alex_action_40) (ifExtension parrEnabled ))],[(AlexAcc (alex_action_79))],[(AlexAccPred (alex_action_41) (ifExtension thEnabled ))],[(AlexAccPred (alex_action_42) (ifExtension thEnabled ))],[],[(AlexAccPred (alex_action_43) (ifExtension thEnabled ))],[],[(AlexAccPred (alex_action_44) (ifExtension thEnabled ))],[],[(AlexAccPred (alex_action_45) (ifExtension thEnabled ))],[],[(AlexAccPred (alex_action_46) (ifExtension thEnabled ))],[(AlexAcc (alex_action_78))],[(AlexAccPred (alex_action_47) (ifExtension thEnabled ))],[(AlexAccPred (alex_action_47) (ifExtension thEnabled ))],[(AlexAcc (alex_action_78))],[(AlexAccPred (alex_action_48) (ifExtension thEnabled ))],[(AlexAccPred (alex_action_49) (ifExtension qqEnabled ))],[],[],[],[(AlexAccPred (alex_action_50) (ifExtension arrowsEnabled `alexAndPred` notFollowedBySymbol ))],[(AlexAcc (alex_action_57))],[(AlexAccPred (alex_action_51) (ifExtension arrowsEnabled ))],[(AlexAccPred (alex_action_52) (ifExtension ipEnabled ))],[(AlexAccPred (alex_action_52) (ifExtension ipEnabled ))],[(AlexAcc (alex_action_78))],[(AlexAccPred (alex_action_53) (ifExtension unboxedTuplesEnabled `alexAndPred` notFollowedBySymbol ))],[(AlexAccPred (alex_action_54) (ifExtension unboxedTuplesEnabled ))],[(AlexAccPred (alex_action_55) (ifExtension genericsEnabled ))],[(AlexAccPred (alex_action_56) (ifExtension genericsEnabled ))],[(AlexAcc (alex_action_57))],[(AlexAcc (alex_action_58))],[(AlexAcc (alex_action_59))],[(AlexAcc (alex_action_60))],[(AlexAcc (alex_action_61))],[(AlexAcc (alex_action_62))],[(AlexAcc (alex_action_63))],[(AlexAcc (alex_action_65))],[(AlexAcc (alex_action_66))],[(AlexAcc (alex_action_66))],[(AlexAcc (alex_action_66))],[(AlexAcc (alex_action_66))],[],[],[(AlexAcc (alex_action_67))],[(AlexAcc (alex_action_67))],[(AlexAcc (alex_action_69))],[(AlexAcc (alex_action_69))],[(AlexAcc (alex_action_67))],[(AlexAcc (alex_action_67))],[(AlexAcc (alex_action_69))],[(AlexAcc (alex_action_69))],[(AlexAcc (alex_action_68))],[(AlexAcc (alex_action_68))],[(AlexAcc (alex_action_68))],[(AlexAcc (alex_action_68))],[(AlexAccPred (alex_action_70) (ifExtension magicHashEnabled ))],[(AlexAccPred (alex_action_71) (ifExtension magicHashEnabled ))],[(AlexAccPred (alex_action_72) (ifExtension magicHashEnabled ))],[(AlexAccPred (alex_action_73) (ifExtension magicHashEnabled ))],[(AlexAccPred (alex_action_74) (ifExtension oldQualOps ))],[(AlexAccPred (alex_action_74) (ifExtension oldQualOps ))],[(AlexAccPred (alex_action_75) (ifExtension oldQualOps ))],[(AlexAccPred (alex_action_75) (ifExtension oldQualOps ))],[(AlexAccPred (alex_action_76) (ifExtension newQualOps ))],[],[],[],[(AlexAccPred (alex_action_77) (ifExtension newQualOps ))],[],[],[(AlexAcc (alex_action_78))],[(AlexAcc (alex_action_78))],[(AlexAcc (alex_action_79))],[(AlexAcc (alex_action_80))],[(AlexAcc (alex_action_80))],[(AlexAcc (alex_action_81))],[],[(AlexAcc (alex_action_82))],[],[(AlexAcc (alex_action_83))],[(AlexAcc (alex_action_83))],[(AlexAcc (alex_action_83))],[],[],[],[],[],[(AlexAccPred (alex_action_84) (ifExtension magicHashEnabled ))],[(AlexAccPred (alex_action_85) (ifExtension magicHashEnabled ))],[(AlexAccPred (alex_action_86) (ifExtension magicHashEnabled ))],[(AlexAccPred (alex_action_87) (ifExtension magicHashEnabled ))],[],[],[(AlexAccPred (alex_action_88) (ifExtension magicHashEnabled ))],[],[],[(AlexAccPred (alex_action_89) (ifExtension magicHashEnabled ))],[],[],[(AlexAccPred (alex_action_90) (ifExtension magicHashEnabled ))],[(AlexAccPred (alex_action_91) (ifExtension magicHashEnabled ))],[(AlexAccPred (alex_action_92) (ifExtension magicHashEnabled ))],[(AlexAccPred (alex_action_93) (ifExtension magicHashEnabled ))],[],[],[],[],[],[],[],[],[(AlexAccPred (alex_action_94) (ifExtension magicHashEnabled ))],[(AlexAcc (alex_action_95))],[(AlexAcc (alex_action_96))]] -{-# LINE 415 "compiler/parser/Lexer.x" #-} +{-# LINE 416 "compiler/parser/Lexer.x" #-} -- ----------------------------------------------------------------------------- -- The token type @@ -365,6 +366,14 @@ ,("→", ITrarrow, unicodeSyntaxEnabled) ,("â†", ITlarrow, unicodeSyntaxEnabled) ,("⋯", ITdotdot, unicodeSyntaxEnabled) + + ,("⤙", ITlarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) + ,("⤚", ITrarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) + ,("⤛", ITLarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) + ,("⤜", ITRarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) + + ,("★", ITstar, unicodeSyntaxEnabled) + -- ToDo: ideally, → and ∷ should be "specials", so that they cannot -- form part of a large operator. This would let us have a better -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe). @@ -402,21 +411,23 @@ begin code _span _str _len = do pushLexState code; lexToken pop :: Action -pop _span _buf _len = do popLexState; lexToken +pop _span _buf _len = do _ <- popLexState + lexToken pop_and :: Action -> Action -pop_and act span buf len = do popLexState; act span buf len +pop_and act span buf len = do _ <- popLexState + act span buf len {-# INLINE nextCharIs #-} nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool nextCharIs buf p = not (atEnd buf) && p (currentChar buf) notFollowedBy :: Char -> AlexAccPred Int -notFollowedBy char _ _ _ (AI _ _ buf) +notFollowedBy char _ _ _ (AI _ buf) = nextCharIs buf (/=char) notFollowedBySymbol :: AlexAccPred Int -notFollowedBySymbol _ _ _ (AI _ _ buf) +notFollowedBySymbol _ _ _ (AI _ buf) = nextCharIs buf (`notElem` "!#$%&*+./<=>?@\\^|-~") -- We must reject doc comments as being ordinary comments everywhere. @@ -425,7 +436,7 @@ -- valid in all states, but the doc-comment rules are only valid in -- the non-layout states. isNormalComment :: AlexAccPred Int -isNormalComment bits _ _ (AI _ _ buf) +isNormalComment bits _ _ (AI _ buf) | haddockEnabled bits = notFollowedByDocOrPragma | otherwise = nextCharIs buf (/='#') where @@ -436,12 +447,12 @@ spaceAndP buf p = p buf || nextCharIs buf (==' ') && p (snd (nextChar buf)) {- -haddockDisabledAnd p bits _ _ (AI _ _ buf) +haddockDisabledAnd p bits _ _ (AI _ buf) = if haddockEnabled bits then False else (p buf) -} atEOL :: AlexAccPred Int -atEOL _ _ _ (AI _ _ buf) = atEnd buf || currentChar buf == '\n' +atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n' ifExtension :: (Int -> Bool) -> AlexAccPred Int ifExtension pred bits _ _ _ = pred bits @@ -527,7 +538,7 @@ withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (Located Token)) -> P (Located Token) withLexedDocType lexDocComment = do - input@(AI _ _ buf) <- getInput + input@(AI _ buf) <- getInput case prevChar buf ' ' of '|' -> lexDocComment input ITdocCommentNext False '^' -> lexDocComment input ITdocCommentPrev False @@ -544,12 +555,12 @@ -- RULES pragmas turn on the forall and '.' keywords, and we turn them -- off again at the end of the pragma. rulePrag :: Action -rulePrag span _ _ = do +rulePrag span _buf _len = do setExts (.|. bit inRulePragBit) return (L span ITrules_prag) endPrag :: Action -endPrag span _ _ = do +endPrag span _buf _len = do setExts (.&. complement (bit inRulePragBit)) return (L span ITclose_prag) @@ -561,32 +572,20 @@ -- it writes the wrong token length to the parser state. This function is -- called afterwards, so it can just update the state. --- This is complicated by the fact that Haddock tokens can span multiple lines, --- which is something that the original lexer didn't account for. --- I have added last_line_len in the parser state which represents the length --- of the part of the token that is on the last line. It is now used for layout --- calculation in pushCurrentContext instead of last_len. last_len is, like it --- was before, the full length of the token, and it is now only used for error --- messages. /Waern - docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer -> SrcSpan -> P (Located Token) docCommentEnd input commentAcc docType buf span = do setInput input - let (AI loc last_offs nextBuf) = input + let (AI loc nextBuf) = input comment = reverse commentAcc span' = mkSrcSpan (srcSpanStart span) loc last_len = byteDiff buf nextBuf - last_line_len = if (last_offs - last_len < 0) - then last_offs - else last_len - - span `seq` setLastToken span' last_len last_line_len + span `seq` setLastToken span' last_len return (L span' (docType comment)) errBrace :: AlexInput -> SrcSpan -> P a -errBrace (AI end _ _) span = failLocMsgP (srcSpanStart span) end "unterminated `{-'" +errBrace (AI end _) span = failLocMsgP (srcSpanStart span) end "unterminated `{-'" open_brace, close_brace :: Action open_brace span _str _len = do @@ -724,22 +723,31 @@ return (L span ITvccurly) EQ -> do --trace "layout: inserting ';'" $ do - popLexState + _ <- popLexState return (L span ITsemi) GT -> do - popLexState + _ <- popLexState lexToken -- certain keywords put us in the "layout" state, where we might -- add an opening curly brace. maybe_layout :: Token -> P () -maybe_layout ITdo = pushLexState layout_do -maybe_layout ITmdo = pushLexState layout_do -maybe_layout ITof = pushLexState layout -maybe_layout ITlet = pushLexState layout -maybe_layout ITwhere = pushLexState layout -maybe_layout ITrec = pushLexState layout -maybe_layout _ = return () +maybe_layout t = do -- If the alternative layout rule is enabled then + -- we never create an implicit layout context here. + -- Layout is handled XXX instead. + -- The code for closing implicit contexts, or + -- inserting implicit semi-colons, is therefore + -- irrelevant as it only applies in an implicit + -- context. + alr <- extension alternativeLayoutRule + unless alr $ f t + where f ITdo = pushLexState layout_do + f ITmdo = pushLexState layout_do + f ITof = pushLexState layout + f ITlet = pushLexState layout + f ITwhere = pushLexState layout + f ITrec = pushLexState layout + f _ = return () -- Pushing a new implicit layout context. If the indentation of the -- next token is not greater than the previous layout context, then @@ -752,8 +760,9 @@ -- new_layout_context :: Bool -> Action new_layout_context strict span _buf _len = do - popLexState - (AI _ offset _) <- getInput + _ <- popLexState + (AI l _) <- getInput + let offset = srcLocCol l ctx <- getContext case ctx of Layout prev_off : _ | @@ -769,7 +778,7 @@ do_layout_left :: Action do_layout_left span _buf _len = do - popLexState + _ <- popLexState pushLexState bol -- we must be at the start of a line return (L span ITvccurly) @@ -779,17 +788,18 @@ setLine :: Int -> Action setLine code span buf len = do let line = parseUnsignedInteger buf len 10 octDecDigit - setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 0) + setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) -- subtract one: the line number refers to the *following* line - popLexState + _ <- popLexState pushLexState code lexToken setFile :: Int -> Action setFile code span buf len = do let file = lexemeToFastString (stepOn buf) (len-2) + setAlrLastLoc noSrcSpan setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span)) - popLexState + _ <- popLexState pushLexState code lexToken @@ -816,7 +826,7 @@ = case alexGetChar i of Just (c,i') | c == x -> isString i' xs _other -> False - err (AI end _ _) = failLocMsgP (srcSpanStart span) end "unterminated options pragma" + err (AI end _) = failLocMsgP (srcSpanStart span) end "unterminated options pragma" -- ----------------------------------------------------------------------------- @@ -834,7 +844,7 @@ lex_string s = do i <- getInput case alexGetChar' i of - Nothing -> lit_error + Nothing -> lit_error i Just ('"',i) -> do setInput i @@ -859,21 +869,25 @@ Just ('\\',i) | Just ('&',i) <- next -> do setInput i; lex_string s - | Just (c,i) <- next, is_space c -> do + | Just (c,i) <- next, c <= '\x7f' && is_space c -> do + -- is_space only works for <= '\x7f' (#3751) setInput i; lex_stringgap s where next = alexGetChar' i - Just (c, i) -> do - c' <- lex_char c i - lex_string (c':s) + Just (c, i1) -> do + case c of + '\\' -> do setInput i1; c' <- lex_escape; lex_string (c':s) + c | isAny c -> do setInput i1; lex_string (c:s) + _other -> lit_error i lex_stringgap :: String -> P Token lex_stringgap s = do - c <- getCharOrFail + i <- getInput + c <- getCharOrFail i case c of '\\' -> lex_string s c | is_space c -> lex_stringgap s - _other -> lit_error + _other -> lit_error i lex_char_tok :: Action @@ -887,24 +901,25 @@ i1 <- getInput -- Look ahead to first character let loc = srcSpanStart span case alexGetChar' i1 of - Nothing -> lit_error + Nothing -> lit_error i1 - Just ('\'', i2@(AI end2 _ _)) -> do -- We've seen '' + Just ('\'', i2@(AI end2 _)) -> do -- We've seen '' th_exts <- extension thEnabled if th_exts then do setInput i2 return (L (mkSrcSpan loc end2) ITtyQuote) - else lit_error + else lit_error i1 - Just ('\\', i2@(AI _end2 _ _)) -> do -- We've seen 'backslash + Just ('\\', i2@(AI _end2 _)) -> do -- We've seen 'backslash setInput i2 lit_ch <- lex_escape - mc <- getCharOrFail -- Trailing quote + i3 <- getInput + mc <- getCharOrFail i3 -- Trailing quote if mc == '\'' then finish_char_tok loc lit_ch - else do setInput i2; lit_error + else lit_error i3 - Just (c, i2@(AI _end2 _ _)) - | not (isAny c) -> lit_error + Just (c, i2@(AI _end2 _)) + | not (isAny c) -> lit_error i1 | otherwise -> -- We've seen 'x, where x is a valid character @@ -917,39 +932,33 @@ -- (including the possibility of EOF) -- If TH is on, just parse the quote only th_exts <- extension thEnabled - let (AI end _ _) = i1 + let (AI end _) = i1 if th_exts then return (L (mkSrcSpan loc end) ITvarQuote) - else do setInput i2; lit_error + else lit_error i2 finish_char_tok :: SrcLoc -> Char -> P (Located Token) finish_char_tok loc ch -- We've already seen the closing quote -- Just need to check for trailing # = do magicHash <- extension magicHashEnabled - i@(AI end _ _) <- getInput + i@(AI end _) <- getInput if magicHash then do case alexGetChar' i of - Just ('#',i@(AI end _ _)) -> do + Just ('#',i@(AI end _)) -> do setInput i return (L (mkSrcSpan loc end) (ITprimchar ch)) _other -> return (L (mkSrcSpan loc end) (ITchar ch)) - else do + else do return (L (mkSrcSpan loc end) (ITchar ch)) -lex_char :: Char -> AlexInput -> P Char -lex_char c inp = do - case c of - '\\' -> do setInput inp; lex_escape - c | isAny c -> do setInput inp; return c - _other -> lit_error - isAny :: Char -> Bool isAny c | c > '\x7f' = isPrint c | otherwise = is_any c lex_escape :: P Char lex_escape = do - c <- getCharOrFail + i0 <- getInput + c <- getCharOrFail i0 case c of 'a' -> return '\a' 'b' -> return '\b' @@ -961,10 +970,11 @@ '\\' -> return '\\' '"' -> return '\"' '\'' -> return '\'' - '^' -> do c <- getCharOrFail + '^' -> do i1 <- getInput + c <- getCharOrFail i1 if c >= '@' && c <= '_' then return (chr (ord c - ord '@')) - else lit_error + else lit_error i1 'x' -> readNum is_hexdigit 16 hexDigit 'o' -> readNum is_octdigit 8 octDecDigit @@ -973,10 +983,10 @@ c1 -> do i <- getInput case alexGetChar' i of - Nothing -> lit_error + Nothing -> lit_error i0 Just (c2,i2) -> case alexGetChar' i2 of - Nothing -> do setInput i2; lit_error + Nothing -> do lit_error i0 Just (c3,i3) -> let str = [c1,c2,c3] in case [ (c,rest) | (p,c) <- silly_escape_chars, @@ -987,15 +997,15 @@ (escape_char,_:_):_ -> do setInput i2 return escape_char - [] -> lit_error + [] -> lit_error i0 readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char readNum is_digit base conv = do i <- getInput - c <- getCharOrFail + c <- getCharOrFail i if is_digit c then readNum2 is_digit base conv (conv c) - else do setInput i; lit_error + else lit_error i readNum2 :: (Char -> Bool) -> Int -> (Char -> Int) -> Int -> P Char readNum2 is_digit base conv i = do @@ -1008,7 +1018,7 @@ _other -> do if i >= 0 && i <= 0x10FFFF then do setInput input; return (chr i) - else lit_error + else lit_error input silly_escape_chars :: [(String, Char)] silly_escape_chars = [ @@ -1052,12 +1062,11 @@ -- the position of the error in the buffer. This is so that we can report -- a correct location to the user, but also so we can detect UTF-8 decoding -- errors if they occur. -lit_error :: P a -lit_error = lexError "lexical error in string/character literal" +lit_error :: AlexInput -> P a +lit_error i = do setInput i; lexError "lexical error in string/character literal" -getCharOrFail :: P Char -getCharOrFail = do - i <- getInput +getCharOrFail :: AlexInput -> P Char +getCharOrFail i = do case alexGetChar' i of Nothing -> lexError "unexpected end-of-file in string/character literal" Just (c,i) -> do setInput i; return c @@ -1081,7 +1090,7 @@ lex_quasiquote s = do i <- getInput case alexGetChar' i of - Nothing -> lit_error + Nothing -> lit_error i Just ('\\',i) | Just ('|',i) <- next -> do @@ -1132,15 +1141,26 @@ dflags :: DynFlags, messages :: Messages, last_loc :: SrcSpan, -- pos of previous token - last_offs :: !Int, -- offset of the previous token from the - -- beginning of the current line. - -- \t is equal to 8 spaces. last_len :: !Int, -- len of previous token - last_line_len :: !Int, loc :: SrcLoc, -- current loc (end of prev token + 1) extsBitmap :: !Int, -- bitmap that determines permitted extensions context :: [LayoutContext], - lex_state :: [Int] + lex_state :: [Int], + -- Used in the alternative layout rule: + -- These tokens are the next ones to be sent out. They are + -- just blindly emitted, without the rule looking at them again: + alr_pending_implicit_tokens :: [Located Token], + -- This is the next token to be considered or, if it is Nothing, + -- we need to get the next token from the input stream: + alr_next_token :: Maybe (Located Token), + -- This is what we consider to be the locatino of the last token + -- emitted: + alr_last_loc :: SrcSpan, + -- The stack of layout contexts: + alr_context :: [ALRContext], + -- Are we expecting a '{'? If it's Just, then the ALRLayout tells + -- us what sort of layout the '{' will open: + alr_expecting_ocurly :: Maybe ALRLayout } -- last_loc and last_len are used when generating error messages, -- and in pushCurrentContext only. Sigh, if only Happy passed the @@ -1148,6 +1168,13 @@ -- Getting rid of last_loc would require finding another way to -- implement pushCurrentContext (which is only called from one place). +data ALRContext = ALRNoLayout Bool{- does it contain commas? -} + | ALRLayout ALRLayout Int +data ALRLayout = ALRLayoutLet + | ALRLayoutWhere + | ALRLayoutOf + | ALRLayoutDo + newtype P a = P { unP :: PState -> ParseResult a } instance Monad P where @@ -1179,6 +1206,14 @@ getPState :: P PState getPState = P $ \s -> POk s s +getDynFlags :: P DynFlags +getDynFlags = P $ \s -> POk s (dflags s) + +withThisPackage :: (PackageId -> a) -> P a +withThisPackage f + = do pkg <- liftM thisPackage getDynFlags + return $ f pkg + extension :: (Int -> Bool) -> P Bool extension p = P $ \s -> POk s (p $! extsBitmap s) @@ -1194,27 +1229,25 @@ getSrcLoc :: P SrcLoc getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc -setLastToken :: SrcSpan -> Int -> Int -> P () -setLastToken loc len line_len = P $ \s -> POk s { +setLastToken :: SrcSpan -> Int -> P () +setLastToken loc len = P $ \s -> POk s { last_loc=loc, - last_len=len, - last_line_len=line_len -} () + last_len=len + } () -data AlexInput = AI SrcLoc {-#UNPACK#-}!Int StringBuffer +data AlexInput = AI SrcLoc StringBuffer alexInputPrevChar :: AlexInput -> Char -alexInputPrevChar (AI _ _ buf) = prevChar buf '\n' +alexInputPrevChar (AI _ buf) = prevChar buf '\n' alexGetChar :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar (AI loc ofs s) +alexGetChar (AI loc s) | atEnd s = Nothing - | otherwise = adj_c `seq` loc' `seq` ofs' `seq` s' `seq` + | otherwise = adj_c `seq` loc' `seq` s' `seq` --trace (show (ord c)) $ - Just (adj_c, (AI loc' ofs' s')) + Just (adj_c, (AI loc' s')) where (c,s') = nextChar s loc' = advanceSrcLoc loc c - ofs' = advanceOffs c ofs non_graphic = '\x0' upper = '\x1' @@ -1260,25 +1293,19 @@ -- This version does not squash unicode characters, it is used when -- lexing strings. alexGetChar' :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar' (AI loc ofs s) +alexGetChar' (AI loc s) | atEnd s = Nothing - | otherwise = c `seq` loc' `seq` ofs' `seq` s' `seq` + | otherwise = c `seq` loc' `seq` s' `seq` --trace (show (ord c)) $ - Just (c, (AI loc' ofs' s')) + Just (c, (AI loc' s')) where (c,s') = nextChar s loc' = advanceSrcLoc loc c - ofs' = advanceOffs c ofs - -advanceOffs :: Char -> Int -> Int -advanceOffs '\n' _ = 0 -advanceOffs '\t' offs = (offs `quot` 8 + 1) * 8 -advanceOffs _ offs = offs + 1 getInput :: P AlexInput -getInput = P $ \s@PState{ loc=l, last_offs=o, buffer=b } -> POk s (AI l o b) +getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (AI l b) setInput :: AlexInput -> P () -setInput (AI l o b) = P $ \s -> POk s{ loc=l, last_offs=o, buffer=b } () +setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } () pushLexState :: Int -> P () pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} () @@ -1289,6 +1316,42 @@ getLexState :: P Int getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls +popNextToken :: P (Maybe (Located Token)) +popNextToken + = P $ \s@PState{ alr_next_token = m } -> + POk (s {alr_next_token = Nothing}) m + +setAlrLastLoc :: SrcSpan -> P () +setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) () + +getAlrLastLoc :: P SrcSpan +getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l + +getALRContext :: P [ALRContext] +getALRContext = P $ \s@(PState {alr_context = cs}) -> POk s cs + +setALRContext :: [ALRContext] -> P () +setALRContext cs = P $ \s -> POk (s {alr_context = cs}) () + +setNextToken :: Located Token -> P () +setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) () + +popPendingImplicitToken :: P (Maybe (Located Token)) +popPendingImplicitToken + = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> + case ts of + [] -> POk s Nothing + (t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t) + +setPendingImplicitTokens :: [Located Token] -> P () +setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) () + +getAlrExpectingOCurly :: P (Maybe ALRLayout) +getAlrExpectingOCurly = P $ \s@(PState {alr_expecting_ocurly = b}) -> POk s b + +setAlrExpectingOCurly :: Maybe ALRLayout -> P () +setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) () + -- for reasons of efficiency, flags indicating language extensions (eg, -- -fglasgow-exts or -XParr) are represented by a bitmap stored in an unboxed -- integer @@ -1338,6 +1401,8 @@ newQualOpsBit = 21 -- Haskell' qualified operator syntax, e.g. Prelude.(+) recBit :: Int recBit = 22 -- rec +alternativeLayoutRuleBit :: Int +alternativeLayoutRuleBit = 23 always :: Int -> Bool always _ = True @@ -1379,6 +1444,8 @@ newQualOps flags = testBit flags newQualOpsBit oldQualOps :: Int -> Bool oldQualOps flags = not (newQualOps flags) +alternativeLayoutRule :: Int -> Bool +alternativeLayoutRule flags = testBit flags alternativeLayoutRuleBit -- PState for parsing options pragmas -- @@ -1389,13 +1456,16 @@ messages = emptyMessages, dflags = dynflags, last_loc = mkSrcSpan loc loc, - last_offs = 0, last_len = 0, - last_line_len = 0, loc = loc, extsBitmap = 0, context = [], - lex_state = [bol, option_prags, 0] + lex_state = [bol, option_prags, 0], + alr_pending_implicit_tokens = [], + alr_next_token = Nothing, + alr_last_loc = noSrcSpan, + alr_context = [], + alr_expecting_ocurly = Nothing } @@ -1408,14 +1478,17 @@ dflags = flags, messages = emptyMessages, last_loc = mkSrcSpan loc loc, - last_offs = 0, last_len = 0, - last_line_len = 0, loc = loc, extsBitmap = fromIntegral bitmap, context = [], - lex_state = [bol, 0] + lex_state = [bol, 0], -- we begin in the layout state if toplev_layout is set + alr_pending_implicit_tokens = [], + alr_next_token = Nothing, + alr_last_loc = noSrcSpan, + alr_context = [], + alr_expecting_ocurly = Nothing } where bitmap = genericsBit `setBitIf` dopt Opt_Generics flags @@ -1440,6 +1513,7 @@ .|. transformComprehensionsBit `setBitIf` dopt Opt_TransformListComp flags .|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags .|. newQualOpsBit `setBitIf` dopt Opt_NewQualifiedOperators flags + .|. alternativeLayoutRuleBit `setBitIf` dopt Opt_AlternativeLayoutRule flags -- setBitIf :: Int -> Bool -> Int b `setBitIf` cond | cond = bit b @@ -1472,14 +1546,15 @@ -- This is only used at the outer level of a module when the 'module' -- keyword is missing. pushCurrentContext :: P () -pushCurrentContext = P $ \ s@PState{ last_offs=offs, last_line_len=len, context=ctx } -> - POk s{context = Layout (offs-len) : ctx} () ---trace ("off: " ++ show offs ++ ", len: " ++ show len) $ POk s{context = Layout (offs-len) : ctx} () +pushCurrentContext = P $ \ s@PState{ last_loc=loc, context=ctx } -> + POk s{context = Layout (srcSpanStartCol loc) : ctx} () getOffside :: P Ordering -getOffside = P $ \s@PState{last_offs=offs, context=stk} -> +getOffside = P $ \s@PState{last_loc=loc, context=stk} -> + let offs = srcSpanStartCol loc in let ord = case stk of - (Layout n:_) -> compare offs n + (Layout n:_) -> --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $ + compare offs n _ -> GT in POk s ord @@ -1511,7 +1586,7 @@ lexError :: String -> P a lexError str = do loc <- getSrcLoc - (AI end _ buf) <- getInput + (AI end buf) <- getInput reportLexError loc end buf str -- ----------------------------------------------------------------------------- @@ -1520,30 +1595,199 @@ lexer :: (Located Token -> P a) -> P a lexer cont = do - tok@(L _span _tok__) <- lexToken --- trace ("token: " ++ show tok__) $ do + alr <- extension alternativeLayoutRule + let lexTokenFun = if alr then lexTokenAlr else lexToken + tok@(L _span _tok__) <- lexTokenFun + --trace ("token: " ++ show _tok__) $ do cont tok +lexTokenAlr :: P (Located Token) +lexTokenAlr = do mPending <- popPendingImplicitToken + t <- case mPending of + Nothing -> + do mNext <- popNextToken + t <- case mNext of + Nothing -> lexToken + Just next -> return next + alternativeLayoutRuleToken t + Just t -> + return t + setAlrLastLoc (getLoc t) + case unLoc t of + ITwhere -> setAlrExpectingOCurly (Just ALRLayoutWhere) + ITlet -> setAlrExpectingOCurly (Just ALRLayoutLet) + ITof -> setAlrExpectingOCurly (Just ALRLayoutOf) + ITdo -> setAlrExpectingOCurly (Just ALRLayoutDo) + _ -> return () + return t + +alternativeLayoutRuleToken :: Located Token -> P (Located Token) +alternativeLayoutRuleToken t + = do context <- getALRContext + lastLoc <- getAlrLastLoc + mExpectingOCurly <- getAlrExpectingOCurly + let thisLoc = getLoc t + thisCol = srcSpanStartCol thisLoc + newLine = (lastLoc == noSrcSpan) + || (srcSpanStartLine thisLoc > srcSpanEndLine lastLoc) + case (unLoc t, context, mExpectingOCurly) of + -- This case handles a GHC extension to the original H98 + -- layout rule... + (ITocurly, _, Just _) -> + do setAlrExpectingOCurly Nothing + setALRContext (ALRNoLayout (containsCommas ITocurly) : context) + return t + -- ...and makes this case unnecessary + {- + -- I think our implicit open-curly handling is slightly + -- different to John's, in how it interacts with newlines + -- and "in" + (ITocurly, _, Just _) -> + do setAlrExpectingOCurly Nothing + setNextToken t + lexTokenAlr + -} + (_, ALRLayout _ col : ls, Just expectingOCurly) + | (thisCol > col) || + (thisCol == col && + isNonDecreasingIntentation expectingOCurly) -> + do setAlrExpectingOCurly Nothing + setALRContext (ALRLayout expectingOCurly thisCol : context) + setNextToken t + return (L thisLoc ITocurly) + | otherwise -> + do setAlrExpectingOCurly Nothing + setPendingImplicitTokens [L lastLoc ITccurly] + setNextToken t + return (L lastLoc ITocurly) + (_, _, Just expectingOCurly) -> + do setAlrExpectingOCurly Nothing + setALRContext (ALRLayout expectingOCurly thisCol : context) + setNextToken t + return (L thisLoc ITocurly) + -- We do the [] cases earlier than in the spec, as we + -- have an actual EOF token + (ITeof, ALRLayout _ _ : ls, _) -> + do setALRContext ls + setNextToken t + return (L thisLoc ITccurly) + (ITeof, _, _) -> + return t + -- the other ITeof case omitted; general case below covers it + (ITin, ALRLayout ALRLayoutLet _ : ls, _) + | newLine -> + do setPendingImplicitTokens [t] + setALRContext ls + return (L thisLoc ITccurly) + (_, ALRLayout _ col : ls, _) + | newLine && thisCol == col -> + do setNextToken t + return (L thisLoc ITsemi) + | newLine && thisCol < col -> + do setALRContext ls + setNextToken t + -- Note that we use lastLoc, as we may need to close + -- more layouts, or give a semicolon + return (L lastLoc ITccurly) + (u, _, _) + | isALRopen u -> + do setALRContext (ALRNoLayout (containsCommas u) : context) + return t + (u, _, _) + | isALRclose u -> + case context of + ALRLayout _ _ : ls -> + do setALRContext ls + setNextToken t + return (L thisLoc ITccurly) + ALRNoLayout _ : ls -> + do setALRContext ls + return t + [] -> + -- XXX This is an error in John's code, but + -- it looks reachable to me at first glance + return t + (ITin, ALRLayout ALRLayoutLet _ : ls, _) -> + do setALRContext ls + setPendingImplicitTokens [t] + return (L thisLoc ITccurly) + (ITin, ALRLayout _ _ : ls, _) -> + do setALRContext ls + setNextToken t + return (L thisLoc ITccurly) + -- the other ITin case omitted; general case below covers it + (ITcomma, ALRLayout _ _ : ls, _) + | topNoLayoutContainsCommas ls -> + do setALRContext ls + setNextToken t + return (L thisLoc ITccurly) + (ITwhere, ALRLayout ALRLayoutDo _ : ls, _) -> + do setALRContext ls + setPendingImplicitTokens [t] + return (L thisLoc ITccurly) + -- the other ITwhere case omitted; general case below covers it + (_, _, _) -> return t + +isALRopen :: Token -> Bool +isALRopen ITcase = True +isALRopen ITif = True +isALRopen IToparen = True +isALRopen ITobrack = True +isALRopen ITocurly = True +-- GHC Extensions: +isALRopen IToubxparen = True +isALRopen _ = False + +isALRclose :: Token -> Bool +isALRclose ITof = True +isALRclose ITthen = True +isALRclose ITcparen = True +isALRclose ITcbrack = True +isALRclose ITccurly = True +-- GHC Extensions: +isALRclose ITcubxparen = True +isALRclose _ = False + +isNonDecreasingIntentation :: ALRLayout -> Bool +isNonDecreasingIntentation ALRLayoutDo = True +isNonDecreasingIntentation _ = False + +containsCommas :: Token -> Bool +containsCommas IToparen = True +containsCommas ITobrack = True +-- John doesn't have {} as containing commas, but records contain them, +-- which caused a problem parsing Cabal's Distribution.Simple.InstallDirs +-- (defaultInstallDirs). +containsCommas ITocurly = True +-- GHC Extensions: +containsCommas IToubxparen = True +containsCommas _ = False + +topNoLayoutContainsCommas :: [ALRContext] -> Bool +topNoLayoutContainsCommas [] = False +topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls +topNoLayoutContainsCommas (ALRNoLayout b : _) = b + lexToken :: P (Located Token) lexToken = do - inp@(AI loc1 _ buf) <- getInput + inp@(AI loc1 buf) <- getInput sc <- getLexState exts <- getExts case alexScanUser exts inp sc of AlexEOF -> do let span = mkSrcSpan loc1 loc1 - setLastToken span 0 0 + setLastToken span 0 return (L span ITeof) - AlexError (AI loc2 _ buf) -> + AlexError (AI loc2 buf) -> reportLexError loc1 loc2 buf "lexical error" AlexSkip inp2 _ -> do setInput inp2 lexToken - AlexToken inp2@(AI end _ buf2) _ t -> do + AlexToken inp2@(AI end buf2) _ t -> do setInput inp2 let span = mkSrcSpan loc1 end let bytes = byteDiff buf buf2 - span `seq` setLastToken span bytes bytes + span `seq` setLastToken span bytes t span buf bytes reportLexError :: SrcLoc -> SrcLoc -> StringBuffer -> [Char] -> P a @@ -1606,7 +1850,7 @@ Nothing -> lexError "unknown pragma" known_pragma :: Map String Action -> AlexAccPred Int -known_pragma prags _ _ len (AI _ _ buf) = (isJust $ Map.lookup (clean_pragma (lexemeToString (offsetBytes (- len) buf) len)) prags) +known_pragma prags _ _ len (AI _ buf) = (isJust $ Map.lookup (clean_pragma (lexemeToString (offsetBytes (- len) buf) len)) prags) && (nextCharIs buf (\c -> not (isAlphaNum c || c == '_'))) clean_pragma :: String -> String @@ -1618,7 +1862,7 @@ "noinline" -> "notinline" "specialise" -> "specialize" "constructorlike" -> "conlike" - otherwise -> prag' + _ -> prag' canon_ws s = unwords (map canonical (words s)) diff -ruN ghc-6.12.1/compiler/parser/Lexer.x.source ghc-6.13.20091231/compiler/parser/Lexer.x.source --- ghc-6.12.1/compiler/parser/Lexer.x.source 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/parser/Lexer.x.source 2009-12-31 10:14:18.000000000 -0800 @@ -31,24 +31,24 @@ -- qualified varids. { -{-# OPTIONS -Wwarn -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details --- --- Note that Alex itself generates code with with some unused bindings and --- without type signatures, so removing the flag might not be possible. +-- XXX The above flags turn off warnings in the generated code: +{-# OPTIONS_GHC -fno-warn-unused-matches #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +-- But alex still generates some code that causes the "lazy unlifted bindings" +-- warning, and old compilers don't know about it so we can't easily turn +-- it off, so for now we use the sledge hammer: +{-# OPTIONS_GHC -w #-} {-# OPTIONS_GHC -funbox-strict-fields #-} module Lexer ( Token(..), lexer, pragState, mkPState, PState(..), P(..), ParseResult(..), getSrcLoc, - getPState, + getPState, getDynFlags, withThisPackage, failLocMsgP, failSpanMsgP, srcParseFail, - getMessages, + getMessages, popContext, pushCurrentContext, setLastToken, setSrcLoc, getLexState, popLexState, pushLexState, extension, standaloneDerivingEnabled, bangPatEnabled, @@ -64,6 +64,7 @@ import SrcLoc import UniqFM import DynFlags +import Module import Ctype import Util ( readRational ) @@ -701,6 +702,14 @@ ,("→", ITrarrow, unicodeSyntaxEnabled) ,("â†", ITlarrow, unicodeSyntaxEnabled) ,("⋯", ITdotdot, unicodeSyntaxEnabled) + + ,("⤙", ITlarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) + ,("⤚", ITrarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) + ,("⤛", ITLarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) + ,("⤜", ITRarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) + + ,("★", ITstar, unicodeSyntaxEnabled) + -- ToDo: ideally, → and ∷ should be "specials", so that they cannot -- form part of a large operator. This would let us have a better -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe). @@ -738,21 +747,23 @@ begin code _span _str _len = do pushLexState code; lexToken pop :: Action -pop _span _buf _len = do popLexState; lexToken +pop _span _buf _len = do _ <- popLexState + lexToken pop_and :: Action -> Action -pop_and act span buf len = do popLexState; act span buf len +pop_and act span buf len = do _ <- popLexState + act span buf len {-# INLINE nextCharIs #-} nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool nextCharIs buf p = not (atEnd buf) && p (currentChar buf) notFollowedBy :: Char -> AlexAccPred Int -notFollowedBy char _ _ _ (AI _ _ buf) +notFollowedBy char _ _ _ (AI _ buf) = nextCharIs buf (/=char) notFollowedBySymbol :: AlexAccPred Int -notFollowedBySymbol _ _ _ (AI _ _ buf) +notFollowedBySymbol _ _ _ (AI _ buf) = nextCharIs buf (`notElem` "!#$%&*+./<=>?@\\^|-~") -- We must reject doc comments as being ordinary comments everywhere. @@ -761,7 +772,7 @@ -- valid in all states, but the doc-comment rules are only valid in -- the non-layout states. isNormalComment :: AlexAccPred Int -isNormalComment bits _ _ (AI _ _ buf) +isNormalComment bits _ _ (AI _ buf) | haddockEnabled bits = notFollowedByDocOrPragma | otherwise = nextCharIs buf (/='#') where @@ -772,12 +783,12 @@ spaceAndP buf p = p buf || nextCharIs buf (==' ') && p (snd (nextChar buf)) {- -haddockDisabledAnd p bits _ _ (AI _ _ buf) +haddockDisabledAnd p bits _ _ (AI _ buf) = if haddockEnabled bits then False else (p buf) -} atEOL :: AlexAccPred Int -atEOL _ _ _ (AI _ _ buf) = atEnd buf || currentChar buf == '\n' +atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n' ifExtension :: (Int -> Bool) -> AlexAccPred Int ifExtension pred bits _ _ _ = pred bits @@ -863,7 +874,7 @@ withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (Located Token)) -> P (Located Token) withLexedDocType lexDocComment = do - input@(AI _ _ buf) <- getInput + input@(AI _ buf) <- getInput case prevChar buf ' ' of '|' -> lexDocComment input ITdocCommentNext False '^' -> lexDocComment input ITdocCommentPrev False @@ -880,12 +891,12 @@ -- RULES pragmas turn on the forall and '.' keywords, and we turn them -- off again at the end of the pragma. rulePrag :: Action -rulePrag span _ _ = do +rulePrag span _buf _len = do setExts (.|. bit inRulePragBit) return (L span ITrules_prag) endPrag :: Action -endPrag span _ _ = do +endPrag span _buf _len = do setExts (.&. complement (bit inRulePragBit)) return (L span ITclose_prag) @@ -897,32 +908,20 @@ -- it writes the wrong token length to the parser state. This function is -- called afterwards, so it can just update the state. --- This is complicated by the fact that Haddock tokens can span multiple lines, --- which is something that the original lexer didn't account for. --- I have added last_line_len in the parser state which represents the length --- of the part of the token that is on the last line. It is now used for layout --- calculation in pushCurrentContext instead of last_len. last_len is, like it --- was before, the full length of the token, and it is now only used for error --- messages. /Waern - docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer -> SrcSpan -> P (Located Token) docCommentEnd input commentAcc docType buf span = do setInput input - let (AI loc last_offs nextBuf) = input + let (AI loc nextBuf) = input comment = reverse commentAcc span' = mkSrcSpan (srcSpanStart span) loc last_len = byteDiff buf nextBuf - last_line_len = if (last_offs - last_len < 0) - then last_offs - else last_len - - span `seq` setLastToken span' last_len last_line_len + span `seq` setLastToken span' last_len return (L span' (docType comment)) errBrace :: AlexInput -> SrcSpan -> P a -errBrace (AI end _ _) span = failLocMsgP (srcSpanStart span) end "unterminated `{-'" +errBrace (AI end _) span = failLocMsgP (srcSpanStart span) end "unterminated `{-'" open_brace, close_brace :: Action open_brace span _str _len = do @@ -1060,22 +1059,31 @@ return (L span ITvccurly) EQ -> do --trace "layout: inserting ';'" $ do - popLexState + _ <- popLexState return (L span ITsemi) GT -> do - popLexState + _ <- popLexState lexToken -- certain keywords put us in the "layout" state, where we might -- add an opening curly brace. maybe_layout :: Token -> P () -maybe_layout ITdo = pushLexState layout_do -maybe_layout ITmdo = pushLexState layout_do -maybe_layout ITof = pushLexState layout -maybe_layout ITlet = pushLexState layout -maybe_layout ITwhere = pushLexState layout -maybe_layout ITrec = pushLexState layout -maybe_layout _ = return () +maybe_layout t = do -- If the alternative layout rule is enabled then + -- we never create an implicit layout context here. + -- Layout is handled XXX instead. + -- The code for closing implicit contexts, or + -- inserting implicit semi-colons, is therefore + -- irrelevant as it only applies in an implicit + -- context. + alr <- extension alternativeLayoutRule + unless alr $ f t + where f ITdo = pushLexState layout_do + f ITmdo = pushLexState layout_do + f ITof = pushLexState layout + f ITlet = pushLexState layout + f ITwhere = pushLexState layout + f ITrec = pushLexState layout + f _ = return () -- Pushing a new implicit layout context. If the indentation of the -- next token is not greater than the previous layout context, then @@ -1088,8 +1096,9 @@ -- new_layout_context :: Bool -> Action new_layout_context strict span _buf _len = do - popLexState - (AI _ offset _) <- getInput + _ <- popLexState + (AI l _) <- getInput + let offset = srcLocCol l ctx <- getContext case ctx of Layout prev_off : _ | @@ -1105,7 +1114,7 @@ do_layout_left :: Action do_layout_left span _buf _len = do - popLexState + _ <- popLexState pushLexState bol -- we must be at the start of a line return (L span ITvccurly) @@ -1115,17 +1124,18 @@ setLine :: Int -> Action setLine code span buf len = do let line = parseUnsignedInteger buf len 10 octDecDigit - setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 0) + setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) -- subtract one: the line number refers to the *following* line - popLexState + _ <- popLexState pushLexState code lexToken setFile :: Int -> Action setFile code span buf len = do let file = lexemeToFastString (stepOn buf) (len-2) + setAlrLastLoc noSrcSpan setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span)) - popLexState + _ <- popLexState pushLexState code lexToken @@ -1152,7 +1162,7 @@ = case alexGetChar i of Just (c,i') | c == x -> isString i' xs _other -> False - err (AI end _ _) = failLocMsgP (srcSpanStart span) end "unterminated options pragma" + err (AI end _) = failLocMsgP (srcSpanStart span) end "unterminated options pragma" -- ----------------------------------------------------------------------------- @@ -1170,7 +1180,7 @@ lex_string s = do i <- getInput case alexGetChar' i of - Nothing -> lit_error + Nothing -> lit_error i Just ('"',i) -> do setInput i @@ -1195,21 +1205,25 @@ Just ('\\',i) | Just ('&',i) <- next -> do setInput i; lex_string s - | Just (c,i) <- next, is_space c -> do + | Just (c,i) <- next, c <= '\x7f' && is_space c -> do + -- is_space only works for <= '\x7f' (#3751) setInput i; lex_stringgap s where next = alexGetChar' i - Just (c, i) -> do - c' <- lex_char c i - lex_string (c':s) + Just (c, i1) -> do + case c of + '\\' -> do setInput i1; c' <- lex_escape; lex_string (c':s) + c | isAny c -> do setInput i1; lex_string (c:s) + _other -> lit_error i lex_stringgap :: String -> P Token lex_stringgap s = do - c <- getCharOrFail + i <- getInput + c <- getCharOrFail i case c of '\\' -> lex_string s c | is_space c -> lex_stringgap s - _other -> lit_error + _other -> lit_error i lex_char_tok :: Action @@ -1223,24 +1237,25 @@ i1 <- getInput -- Look ahead to first character let loc = srcSpanStart span case alexGetChar' i1 of - Nothing -> lit_error + Nothing -> lit_error i1 - Just ('\'', i2@(AI end2 _ _)) -> do -- We've seen '' + Just ('\'', i2@(AI end2 _)) -> do -- We've seen '' th_exts <- extension thEnabled if th_exts then do setInput i2 return (L (mkSrcSpan loc end2) ITtyQuote) - else lit_error + else lit_error i1 - Just ('\\', i2@(AI _end2 _ _)) -> do -- We've seen 'backslash + Just ('\\', i2@(AI _end2 _)) -> do -- We've seen 'backslash setInput i2 lit_ch <- lex_escape - mc <- getCharOrFail -- Trailing quote + i3 <- getInput + mc <- getCharOrFail i3 -- Trailing quote if mc == '\'' then finish_char_tok loc lit_ch - else do setInput i2; lit_error + else lit_error i3 - Just (c, i2@(AI _end2 _ _)) - | not (isAny c) -> lit_error + Just (c, i2@(AI _end2 _)) + | not (isAny c) -> lit_error i1 | otherwise -> -- We've seen 'x, where x is a valid character @@ -1253,39 +1268,33 @@ -- (including the possibility of EOF) -- If TH is on, just parse the quote only th_exts <- extension thEnabled - let (AI end _ _) = i1 + let (AI end _) = i1 if th_exts then return (L (mkSrcSpan loc end) ITvarQuote) - else do setInput i2; lit_error + else lit_error i2 finish_char_tok :: SrcLoc -> Char -> P (Located Token) finish_char_tok loc ch -- We've already seen the closing quote -- Just need to check for trailing # = do magicHash <- extension magicHashEnabled - i@(AI end _ _) <- getInput + i@(AI end _) <- getInput if magicHash then do case alexGetChar' i of - Just ('#',i@(AI end _ _)) -> do + Just ('#',i@(AI end _)) -> do setInput i return (L (mkSrcSpan loc end) (ITprimchar ch)) _other -> return (L (mkSrcSpan loc end) (ITchar ch)) - else do + else do return (L (mkSrcSpan loc end) (ITchar ch)) -lex_char :: Char -> AlexInput -> P Char -lex_char c inp = do - case c of - '\\' -> do setInput inp; lex_escape - c | isAny c -> do setInput inp; return c - _other -> lit_error - isAny :: Char -> Bool isAny c | c > '\x7f' = isPrint c | otherwise = is_any c lex_escape :: P Char lex_escape = do - c <- getCharOrFail + i0 <- getInput + c <- getCharOrFail i0 case c of 'a' -> return '\a' 'b' -> return '\b' @@ -1297,10 +1306,11 @@ '\\' -> return '\\' '"' -> return '\"' '\'' -> return '\'' - '^' -> do c <- getCharOrFail + '^' -> do i1 <- getInput + c <- getCharOrFail i1 if c >= '@' && c <= '_' then return (chr (ord c - ord '@')) - else lit_error + else lit_error i1 'x' -> readNum is_hexdigit 16 hexDigit 'o' -> readNum is_octdigit 8 octDecDigit @@ -1309,10 +1319,10 @@ c1 -> do i <- getInput case alexGetChar' i of - Nothing -> lit_error + Nothing -> lit_error i0 Just (c2,i2) -> case alexGetChar' i2 of - Nothing -> do setInput i2; lit_error + Nothing -> do lit_error i0 Just (c3,i3) -> let str = [c1,c2,c3] in case [ (c,rest) | (p,c) <- silly_escape_chars, @@ -1323,15 +1333,15 @@ (escape_char,_:_):_ -> do setInput i2 return escape_char - [] -> lit_error + [] -> lit_error i0 readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char readNum is_digit base conv = do i <- getInput - c <- getCharOrFail + c <- getCharOrFail i if is_digit c then readNum2 is_digit base conv (conv c) - else do setInput i; lit_error + else lit_error i readNum2 :: (Char -> Bool) -> Int -> (Char -> Int) -> Int -> P Char readNum2 is_digit base conv i = do @@ -1344,7 +1354,7 @@ _other -> do if i >= 0 && i <= 0x10FFFF then do setInput input; return (chr i) - else lit_error + else lit_error input silly_escape_chars :: [(String, Char)] silly_escape_chars = [ @@ -1388,12 +1398,11 @@ -- the position of the error in the buffer. This is so that we can report -- a correct location to the user, but also so we can detect UTF-8 decoding -- errors if they occur. -lit_error :: P a -lit_error = lexError "lexical error in string/character literal" +lit_error :: AlexInput -> P a +lit_error i = do setInput i; lexError "lexical error in string/character literal" -getCharOrFail :: P Char -getCharOrFail = do - i <- getInput +getCharOrFail :: AlexInput -> P Char +getCharOrFail i = do case alexGetChar' i of Nothing -> lexError "unexpected end-of-file in string/character literal" Just (c,i) -> do setInput i; return c @@ -1417,7 +1426,7 @@ lex_quasiquote s = do i <- getInput case alexGetChar' i of - Nothing -> lit_error + Nothing -> lit_error i Just ('\\',i) | Just ('|',i) <- next -> do @@ -1468,15 +1477,26 @@ dflags :: DynFlags, messages :: Messages, last_loc :: SrcSpan, -- pos of previous token - last_offs :: !Int, -- offset of the previous token from the - -- beginning of the current line. - -- \t is equal to 8 spaces. last_len :: !Int, -- len of previous token - last_line_len :: !Int, loc :: SrcLoc, -- current loc (end of prev token + 1) extsBitmap :: !Int, -- bitmap that determines permitted extensions context :: [LayoutContext], - lex_state :: [Int] + lex_state :: [Int], + -- Used in the alternative layout rule: + -- These tokens are the next ones to be sent out. They are + -- just blindly emitted, without the rule looking at them again: + alr_pending_implicit_tokens :: [Located Token], + -- This is the next token to be considered or, if it is Nothing, + -- we need to get the next token from the input stream: + alr_next_token :: Maybe (Located Token), + -- This is what we consider to be the locatino of the last token + -- emitted: + alr_last_loc :: SrcSpan, + -- The stack of layout contexts: + alr_context :: [ALRContext], + -- Are we expecting a '{'? If it's Just, then the ALRLayout tells + -- us what sort of layout the '{' will open: + alr_expecting_ocurly :: Maybe ALRLayout } -- last_loc and last_len are used when generating error messages, -- and in pushCurrentContext only. Sigh, if only Happy passed the @@ -1484,6 +1504,13 @@ -- Getting rid of last_loc would require finding another way to -- implement pushCurrentContext (which is only called from one place). +data ALRContext = ALRNoLayout Bool{- does it contain commas? -} + | ALRLayout ALRLayout Int +data ALRLayout = ALRLayoutLet + | ALRLayoutWhere + | ALRLayoutOf + | ALRLayoutDo + newtype P a = P { unP :: PState -> ParseResult a } instance Monad P where @@ -1515,6 +1542,14 @@ getPState :: P PState getPState = P $ \s -> POk s s +getDynFlags :: P DynFlags +getDynFlags = P $ \s -> POk s (dflags s) + +withThisPackage :: (PackageId -> a) -> P a +withThisPackage f + = do pkg <- liftM thisPackage getDynFlags + return $ f pkg + extension :: (Int -> Bool) -> P Bool extension p = P $ \s -> POk s (p $! extsBitmap s) @@ -1530,27 +1565,25 @@ getSrcLoc :: P SrcLoc getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc -setLastToken :: SrcSpan -> Int -> Int -> P () -setLastToken loc len line_len = P $ \s -> POk s { +setLastToken :: SrcSpan -> Int -> P () +setLastToken loc len = P $ \s -> POk s { last_loc=loc, - last_len=len, - last_line_len=line_len -} () + last_len=len + } () -data AlexInput = AI SrcLoc {-#UNPACK#-}!Int StringBuffer +data AlexInput = AI SrcLoc StringBuffer alexInputPrevChar :: AlexInput -> Char -alexInputPrevChar (AI _ _ buf) = prevChar buf '\n' +alexInputPrevChar (AI _ buf) = prevChar buf '\n' alexGetChar :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar (AI loc ofs s) +alexGetChar (AI loc s) | atEnd s = Nothing - | otherwise = adj_c `seq` loc' `seq` ofs' `seq` s' `seq` + | otherwise = adj_c `seq` loc' `seq` s' `seq` --trace (show (ord c)) $ - Just (adj_c, (AI loc' ofs' s')) + Just (adj_c, (AI loc' s')) where (c,s') = nextChar s loc' = advanceSrcLoc loc c - ofs' = advanceOffs c ofs non_graphic = '\x0' upper = '\x1' @@ -1596,25 +1629,19 @@ -- This version does not squash unicode characters, it is used when -- lexing strings. alexGetChar' :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar' (AI loc ofs s) +alexGetChar' (AI loc s) | atEnd s = Nothing - | otherwise = c `seq` loc' `seq` ofs' `seq` s' `seq` + | otherwise = c `seq` loc' `seq` s' `seq` --trace (show (ord c)) $ - Just (c, (AI loc' ofs' s')) + Just (c, (AI loc' s')) where (c,s') = nextChar s loc' = advanceSrcLoc loc c - ofs' = advanceOffs c ofs - -advanceOffs :: Char -> Int -> Int -advanceOffs '\n' _ = 0 -advanceOffs '\t' offs = (offs `quot` 8 + 1) * 8 -advanceOffs _ offs = offs + 1 getInput :: P AlexInput -getInput = P $ \s@PState{ loc=l, last_offs=o, buffer=b } -> POk s (AI l o b) +getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (AI l b) setInput :: AlexInput -> P () -setInput (AI l o b) = P $ \s -> POk s{ loc=l, last_offs=o, buffer=b } () +setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } () pushLexState :: Int -> P () pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} () @@ -1625,6 +1652,42 @@ getLexState :: P Int getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls +popNextToken :: P (Maybe (Located Token)) +popNextToken + = P $ \s@PState{ alr_next_token = m } -> + POk (s {alr_next_token = Nothing}) m + +setAlrLastLoc :: SrcSpan -> P () +setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) () + +getAlrLastLoc :: P SrcSpan +getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l + +getALRContext :: P [ALRContext] +getALRContext = P $ \s@(PState {alr_context = cs}) -> POk s cs + +setALRContext :: [ALRContext] -> P () +setALRContext cs = P $ \s -> POk (s {alr_context = cs}) () + +setNextToken :: Located Token -> P () +setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) () + +popPendingImplicitToken :: P (Maybe (Located Token)) +popPendingImplicitToken + = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> + case ts of + [] -> POk s Nothing + (t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t) + +setPendingImplicitTokens :: [Located Token] -> P () +setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) () + +getAlrExpectingOCurly :: P (Maybe ALRLayout) +getAlrExpectingOCurly = P $ \s@(PState {alr_expecting_ocurly = b}) -> POk s b + +setAlrExpectingOCurly :: Maybe ALRLayout -> P () +setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) () + -- for reasons of efficiency, flags indicating language extensions (eg, -- -fglasgow-exts or -XParr) are represented by a bitmap stored in an unboxed -- integer @@ -1674,6 +1737,8 @@ newQualOpsBit = 21 -- Haskell' qualified operator syntax, e.g. Prelude.(+) recBit :: Int recBit = 22 -- rec +alternativeLayoutRuleBit :: Int +alternativeLayoutRuleBit = 23 always :: Int -> Bool always _ = True @@ -1715,6 +1780,8 @@ newQualOps flags = testBit flags newQualOpsBit oldQualOps :: Int -> Bool oldQualOps flags = not (newQualOps flags) +alternativeLayoutRule :: Int -> Bool +alternativeLayoutRule flags = testBit flags alternativeLayoutRuleBit -- PState for parsing options pragmas -- @@ -1725,13 +1792,16 @@ messages = emptyMessages, dflags = dynflags, last_loc = mkSrcSpan loc loc, - last_offs = 0, last_len = 0, - last_line_len = 0, loc = loc, extsBitmap = 0, context = [], - lex_state = [bol, option_prags, 0] + lex_state = [bol, option_prags, 0], + alr_pending_implicit_tokens = [], + alr_next_token = Nothing, + alr_last_loc = noSrcSpan, + alr_context = [], + alr_expecting_ocurly = Nothing } @@ -1744,14 +1814,17 @@ dflags = flags, messages = emptyMessages, last_loc = mkSrcSpan loc loc, - last_offs = 0, last_len = 0, - last_line_len = 0, loc = loc, extsBitmap = fromIntegral bitmap, context = [], - lex_state = [bol, 0] + lex_state = [bol, 0], -- we begin in the layout state if toplev_layout is set + alr_pending_implicit_tokens = [], + alr_next_token = Nothing, + alr_last_loc = noSrcSpan, + alr_context = [], + alr_expecting_ocurly = Nothing } where bitmap = genericsBit `setBitIf` dopt Opt_Generics flags @@ -1776,6 +1849,7 @@ .|. transformComprehensionsBit `setBitIf` dopt Opt_TransformListComp flags .|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags .|. newQualOpsBit `setBitIf` dopt Opt_NewQualifiedOperators flags + .|. alternativeLayoutRuleBit `setBitIf` dopt Opt_AlternativeLayoutRule flags -- setBitIf :: Int -> Bool -> Int b `setBitIf` cond | cond = bit b @@ -1808,14 +1882,15 @@ -- This is only used at the outer level of a module when the 'module' -- keyword is missing. pushCurrentContext :: P () -pushCurrentContext = P $ \ s@PState{ last_offs=offs, last_line_len=len, context=ctx } -> - POk s{context = Layout (offs-len) : ctx} () ---trace ("off: " ++ show offs ++ ", len: " ++ show len) $ POk s{context = Layout (offs-len) : ctx} () +pushCurrentContext = P $ \ s@PState{ last_loc=loc, context=ctx } -> + POk s{context = Layout (srcSpanStartCol loc) : ctx} () getOffside :: P Ordering -getOffside = P $ \s@PState{last_offs=offs, context=stk} -> +getOffside = P $ \s@PState{last_loc=loc, context=stk} -> + let offs = srcSpanStartCol loc in let ord = case stk of - (Layout n:_) -> compare offs n + (Layout n:_) -> --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $ + compare offs n _ -> GT in POk s ord @@ -1847,7 +1922,7 @@ lexError :: String -> P a lexError str = do loc <- getSrcLoc - (AI end _ buf) <- getInput + (AI end buf) <- getInput reportLexError loc end buf str -- ----------------------------------------------------------------------------- @@ -1856,30 +1931,199 @@ lexer :: (Located Token -> P a) -> P a lexer cont = do - tok@(L _span _tok__) <- lexToken --- trace ("token: " ++ show tok__) $ do + alr <- extension alternativeLayoutRule + let lexTokenFun = if alr then lexTokenAlr else lexToken + tok@(L _span _tok__) <- lexTokenFun + --trace ("token: " ++ show _tok__) $ do cont tok +lexTokenAlr :: P (Located Token) +lexTokenAlr = do mPending <- popPendingImplicitToken + t <- case mPending of + Nothing -> + do mNext <- popNextToken + t <- case mNext of + Nothing -> lexToken + Just next -> return next + alternativeLayoutRuleToken t + Just t -> + return t + setAlrLastLoc (getLoc t) + case unLoc t of + ITwhere -> setAlrExpectingOCurly (Just ALRLayoutWhere) + ITlet -> setAlrExpectingOCurly (Just ALRLayoutLet) + ITof -> setAlrExpectingOCurly (Just ALRLayoutOf) + ITdo -> setAlrExpectingOCurly (Just ALRLayoutDo) + _ -> return () + return t + +alternativeLayoutRuleToken :: Located Token -> P (Located Token) +alternativeLayoutRuleToken t + = do context <- getALRContext + lastLoc <- getAlrLastLoc + mExpectingOCurly <- getAlrExpectingOCurly + let thisLoc = getLoc t + thisCol = srcSpanStartCol thisLoc + newLine = (lastLoc == noSrcSpan) + || (srcSpanStartLine thisLoc > srcSpanEndLine lastLoc) + case (unLoc t, context, mExpectingOCurly) of + -- This case handles a GHC extension to the original H98 + -- layout rule... + (ITocurly, _, Just _) -> + do setAlrExpectingOCurly Nothing + setALRContext (ALRNoLayout (containsCommas ITocurly) : context) + return t + -- ...and makes this case unnecessary + {- + -- I think our implicit open-curly handling is slightly + -- different to John's, in how it interacts with newlines + -- and "in" + (ITocurly, _, Just _) -> + do setAlrExpectingOCurly Nothing + setNextToken t + lexTokenAlr + -} + (_, ALRLayout _ col : ls, Just expectingOCurly) + | (thisCol > col) || + (thisCol == col && + isNonDecreasingIntentation expectingOCurly) -> + do setAlrExpectingOCurly Nothing + setALRContext (ALRLayout expectingOCurly thisCol : context) + setNextToken t + return (L thisLoc ITocurly) + | otherwise -> + do setAlrExpectingOCurly Nothing + setPendingImplicitTokens [L lastLoc ITccurly] + setNextToken t + return (L lastLoc ITocurly) + (_, _, Just expectingOCurly) -> + do setAlrExpectingOCurly Nothing + setALRContext (ALRLayout expectingOCurly thisCol : context) + setNextToken t + return (L thisLoc ITocurly) + -- We do the [] cases earlier than in the spec, as we + -- have an actual EOF token + (ITeof, ALRLayout _ _ : ls, _) -> + do setALRContext ls + setNextToken t + return (L thisLoc ITccurly) + (ITeof, _, _) -> + return t + -- the other ITeof case omitted; general case below covers it + (ITin, ALRLayout ALRLayoutLet _ : ls, _) + | newLine -> + do setPendingImplicitTokens [t] + setALRContext ls + return (L thisLoc ITccurly) + (_, ALRLayout _ col : ls, _) + | newLine && thisCol == col -> + do setNextToken t + return (L thisLoc ITsemi) + | newLine && thisCol < col -> + do setALRContext ls + setNextToken t + -- Note that we use lastLoc, as we may need to close + -- more layouts, or give a semicolon + return (L lastLoc ITccurly) + (u, _, _) + | isALRopen u -> + do setALRContext (ALRNoLayout (containsCommas u) : context) + return t + (u, _, _) + | isALRclose u -> + case context of + ALRLayout _ _ : ls -> + do setALRContext ls + setNextToken t + return (L thisLoc ITccurly) + ALRNoLayout _ : ls -> + do setALRContext ls + return t + [] -> + -- XXX This is an error in John's code, but + -- it looks reachable to me at first glance + return t + (ITin, ALRLayout ALRLayoutLet _ : ls, _) -> + do setALRContext ls + setPendingImplicitTokens [t] + return (L thisLoc ITccurly) + (ITin, ALRLayout _ _ : ls, _) -> + do setALRContext ls + setNextToken t + return (L thisLoc ITccurly) + -- the other ITin case omitted; general case below covers it + (ITcomma, ALRLayout _ _ : ls, _) + | topNoLayoutContainsCommas ls -> + do setALRContext ls + setNextToken t + return (L thisLoc ITccurly) + (ITwhere, ALRLayout ALRLayoutDo _ : ls, _) -> + do setALRContext ls + setPendingImplicitTokens [t] + return (L thisLoc ITccurly) + -- the other ITwhere case omitted; general case below covers it + (_, _, _) -> return t + +isALRopen :: Token -> Bool +isALRopen ITcase = True +isALRopen ITif = True +isALRopen IToparen = True +isALRopen ITobrack = True +isALRopen ITocurly = True +-- GHC Extensions: +isALRopen IToubxparen = True +isALRopen _ = False + +isALRclose :: Token -> Bool +isALRclose ITof = True +isALRclose ITthen = True +isALRclose ITcparen = True +isALRclose ITcbrack = True +isALRclose ITccurly = True +-- GHC Extensions: +isALRclose ITcubxparen = True +isALRclose _ = False + +isNonDecreasingIntentation :: ALRLayout -> Bool +isNonDecreasingIntentation ALRLayoutDo = True +isNonDecreasingIntentation _ = False + +containsCommas :: Token -> Bool +containsCommas IToparen = True +containsCommas ITobrack = True +-- John doesn't have {} as containing commas, but records contain them, +-- which caused a problem parsing Cabal's Distribution.Simple.InstallDirs +-- (defaultInstallDirs). +containsCommas ITocurly = True +-- GHC Extensions: +containsCommas IToubxparen = True +containsCommas _ = False + +topNoLayoutContainsCommas :: [ALRContext] -> Bool +topNoLayoutContainsCommas [] = False +topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls +topNoLayoutContainsCommas (ALRNoLayout b : _) = b + lexToken :: P (Located Token) lexToken = do - inp@(AI loc1 _ buf) <- getInput + inp@(AI loc1 buf) <- getInput sc <- getLexState exts <- getExts case alexScanUser exts inp sc of AlexEOF -> do let span = mkSrcSpan loc1 loc1 - setLastToken span 0 0 + setLastToken span 0 return (L span ITeof) - AlexError (AI loc2 _ buf) -> + AlexError (AI loc2 buf) -> reportLexError loc1 loc2 buf "lexical error" AlexSkip inp2 _ -> do setInput inp2 lexToken - AlexToken inp2@(AI end _ buf2) _ t -> do + AlexToken inp2@(AI end buf2) _ t -> do setInput inp2 let span = mkSrcSpan loc1 end let bytes = byteDiff buf buf2 - span `seq` setLastToken span bytes bytes + span `seq` setLastToken span bytes t span buf bytes reportLexError :: SrcLoc -> SrcLoc -> StringBuffer -> [Char] -> P a @@ -1942,7 +2186,7 @@ Nothing -> lexError "unknown pragma" known_pragma :: Map String Action -> AlexAccPred Int -known_pragma prags _ _ len (AI _ _ buf) = (isJust $ Map.lookup (clean_pragma (lexemeToString (offsetBytes (- len) buf) len)) prags) +known_pragma prags _ _ len (AI _ buf) = (isJust $ Map.lookup (clean_pragma (lexemeToString (offsetBytes (- len) buf) len)) prags) && (nextCharIs buf (\c -> not (isAlphaNum c || c == '_'))) clean_pragma :: String -> String @@ -1954,6 +2198,6 @@ "noinline" -> "notinline" "specialise" -> "specialize" "constructorlike" -> "conlike" - otherwise -> prag' + _ -> prag' canon_ws s = unwords (map canonical (words s)) } diff -ruN ghc-6.12.1/compiler/parser/ParserCore.hs ghc-6.13.20091231/compiler/parser/ParserCore.hs --- ghc-6.12.1/compiler/parser/ParserCore.hs 2009-12-10 12:13:28.000000000 -0800 +++ ghc-6.13.20091231/compiler/parser/ParserCore.hs 2009-12-31 12:35:22.000000000 -0800 @@ -290,21 +290,21 @@ happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\x8f\x01\x8f\x01\x8e\x01\x50\x01\x5c\x01\x93\x01\x86\x01\x08\x01\x5c\x01\x8c\x01\x8c\x01\x1a\x01\x92\x01\x1a\x01\x00\x00\x00\x00\x87\x01\x00\x00\x8d\x01\x91\x01\x21\x00\x00\x00\x00\x00\x81\x01\x84\x01\x00\x00\x21\x00\x08\x00\x08\x01\x1a\x01\x8b\x01\x00\x00\x82\x01\x80\x01\x8a\x01\x7e\x01\x08\x00\x00\x00\x85\x01\x89\x01\x00\x00\x00\x00\x16\x01\x16\x01\x7f\x01\x83\x01\x16\x01\x14\x01\x08\x00\x7c\x01\x7d\x01\x7b\x01\x00\x00\x21\x00\x00\x00\x3d\x01\x7a\x01\x79\x01\x00\x00\x00\x00\x0f\x01\x00\x00\x08\x00\x78\x01\x20\x01\x08\x00\x00\x00\x00\x00\x76\x01\x23\x01\x00\x00\x00\x00\x77\x01\x05\x01\x00\x00\x00\x00\x00\x00\x74\x01\x75\x01\x73\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x01\x00\x00\x00\x00\x00\x00\x08\x01\x72\x01\x01\x01\x71\x01\x6f\x01\xf8\x00\x73\x00\x6e\x01\x70\x01\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x01\x00\x00\x3d\x01\x00\x00\x00\x00\x3d\x01\x73\x00\x6b\x01\x00\x00\x6a\x01\xe9\x00\x66\x01\x69\x01\x68\x01\x67\x01\x64\x01\x38\x00\x20\x01\x38\x00\x08\x00\x6d\x01\x00\x00\x38\x00\x38\x00\x2a\x00\x58\x01\x52\x01\x65\x01\x62\x01\x63\x01\x05\x01\x00\x00\x60\x00\x00\x00\x05\x01\x08\x00\x00\x00\x00\x00\x57\x01\x00\x00\x00\x00\x00\x00\x20\x01\x61\x01\x00\x00\x00\x00\x00\x00\x01\x00\x01\x00\x01\x00\x01\x00\x00\x00\x00\x00\x56\x01\x20\x01\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x5f\x01\x5e\x01\x5d\x01\x5b\x01\xf3\xff\x00\x00\x00\x00\x00\x00\x00\x00\x60\x01\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x01\x00\x00\x59\x01\x54\x01\xec\x00\xa3\x00\x55\x01\x48\x01\x4b\x01\x49\x01\x27\x01\x4e\x01\x41\x01\x20\x01\x20\x01\xec\x00\x00\x00\x47\x01\x20\x01\x00\x00\x20\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# +happyActOffsets = HappyA# "\x86\x01\x86\x01\x82\x01\x81\x01\x3c\x01\x84\x01\x80\x01\x3f\x00\x3c\x01\x7d\x01\x7d\x01\x19\x01\x83\x01\x19\x01\x00\x00\x00\x00\x7c\x01\x00\x00\x7f\x01\x7e\x01\x21\x00\x00\x00\x00\x00\x77\x01\x7b\x01\x00\x00\x21\x00\x08\x00\x3f\x00\x19\x01\x7a\x01\x00\x00\x78\x01\x76\x01\x79\x01\x74\x01\x08\x00\x00\x00\x75\x01\x71\x01\x00\x00\x00\x00\x0a\x01\x0a\x01\x73\x01\x72\x01\x0a\x01\x05\x01\x08\x00\x70\x01\x6f\x01\x6c\x01\x00\x00\x21\x00\x00\x00\x37\x01\x6e\x01\x6d\x01\x00\x00\x00\x00\xf0\x00\x00\x00\x08\x00\x6b\x01\x1b\x01\x08\x00\x00\x00\x00\x00\x68\x01\x28\x01\x00\x00\x00\x00\x6a\x01\x13\x01\x00\x00\x00\x00\x00\x00\x67\x01\x66\x01\x62\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x69\x01\xe8\x00\x60\x01\xfc\x00\x01\x01\x61\x01\x65\x01\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x01\x00\x00\x37\x01\x00\x00\x00\x00\x37\x01\x01\x01\x5e\x01\x00\x00\x5d\x01\x67\x00\x63\x01\x5c\x01\x5b\x01\x5a\x01\x58\x01\x38\x00\x38\x00\x08\x00\x64\x01\x00\x00\x38\x00\x38\x00\x2a\x00\x4f\x01\x4e\x01\x56\x01\x51\x01\x59\x01\x13\x01\x00\x00\xaa\x00\x00\x00\x13\x01\x08\x00\x00\x00\x00\x00\x4d\x01\x00\x00\x00\x00\x00\x00\x1b\x01\x57\x01\x00\x00\x00\x00\x01\x00\x01\x00\x01\x00\x01\x00\x00\x00\x00\x00\x50\x01\x1b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x55\x01\x54\x01\x53\x01\x31\x01\xf3\xff\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x29\x01\x00\x00\x43\x01\x3f\x01\x26\x00\x2d\x01\x24\x01\xf7\x00\x18\x01\x15\x01\x38\x01\xf8\x00\xe5\x00\x1b\x01\x1b\x01\x26\x00\x00\x00\xda\x00\x1b\x01\x00\x00\x1b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\x4d\x01\x00\x00\x45\x01\x00\x00\x53\x01\x00\x00\x37\x01\xfc\x00\x51\x01\x31\x01\x2d\x01\x2b\x01\x00\x00\x29\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x00\x00\xfa\x00\x00\x00\x57\x00\xc5\x00\xd9\x00\x24\x01\x00\x00\x00\x00\xc4\x00\xf4\x00\xcf\x00\x00\x00\xc1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd0\x00\xcc\x00\x00\x00\x00\x00\xbf\x00\x1e\x01\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\xef\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x00\x00\x00\xa0\x00\x00\x00\x6d\x00\x9e\x00\x00\x00\x00\x00\x31\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\x00\x00\x00\x00\x00\x00\xf6\xff\x00\x00\x74\x00\x00\x00\x00\x00\x4b\x00\x3f\x01\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x81\x00\x3c\x01\x00\x00\x00\x00\x50\x00\xf3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x00\x44\x00\xe3\x00\x3a\x00\x00\x00\x00\x00\xe2\x00\x72\x00\xb1\x00\xfa\xff\x00\x00\x00\x00\x00\x00\x00\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x98\x00\x0a\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\x00\xda\x00\xd4\x00\xcd\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x63\x00\x39\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x14\x00\x0d\x00\x5c\x00\x00\x00\x00\x00\x06\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# +happyGotoOffsets = HappyA# "\xf1\x00\x00\x00\xe3\x00\x00\x00\x9f\x00\x00\x00\xdd\x00\x1a\x01\x72\x00\xd0\x00\xce\x00\x35\x01\x00\x00\x32\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\xc3\x00\x00\x00\x1f\x01\xbc\x00\xeb\x00\x30\x01\x00\x00\x00\x00\x71\x00\x8c\x00\x75\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\xcd\x00\x00\x00\x00\x00\xcb\x00\x2a\x01\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\xf6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\x00\x00\x00\xac\x00\x00\x00\x4b\x00\xa1\x00\x00\x00\x00\x00\x31\x00\x61\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x00\x00\xf6\xff\x00\x00\x70\x00\x00\x00\x44\x00\x4a\x01\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf4\x00\x00\x00\x00\x00\xc4\x00\x47\x01\x00\x00\x00\x00\x50\x00\x2e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x00\xe7\x00\x3a\x00\x00\x00\x00\x00\xe6\x00\x7a\x00\x94\x00\xfa\xff\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x00\x00\x00\x00\x7e\x00\x0a\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x00\x00\x00\x00\x00\x00\xe0\x00\xde\x00\xd1\x00\x69\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\xc5\x00\xfb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x14\x00\x0d\x00\x63\x00\x00\x00\x00\x00\x06\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# happyDefActions :: HappyAddr -happyDefActions = HappyA# "\x00\x00\x00\x00\x00\x00\x00\x00\xf5\xff\x00\x00\x00\x00\xdc\xff\xf5\xff\x00\x00\x00\x00\xcd\xff\x00\x00\xcd\xff\xf4\xff\xfe\xff\x00\x00\xd9\xff\x00\x00\x00\x00\x00\x00\xab\xff\xfd\xff\xf9\xff\x00\x00\xd5\xff\x00\x00\x00\x00\xdc\xff\xcd\xff\x00\x00\xcf\xff\x00\x00\x00\x00\xf1\xff\x00\x00\x00\x00\xfb\xff\x00\x00\x00\x00\xcc\xff\xdb\xff\xe8\xff\xe8\xff\xdf\xff\x00\x00\xe8\xff\xcd\xff\x00\x00\xab\xff\x00\x00\xd8\xff\xf8\xff\x00\x00\xda\xff\x00\x00\x00\x00\x00\x00\xe5\xff\xe3\xff\xe8\xff\xe6\xff\x00\x00\xab\xff\x00\x00\x00\x00\xe2\xff\xe1\xff\xef\xff\x00\x00\xf0\xff\xf2\xff\x00\x00\x00\x00\xca\xff\xcb\xff\xc9\xff\x00\x00\xee\xff\xeb\xff\xa9\xff\xde\xff\xc2\xff\xc3\xff\xbd\xff\xbc\xff\xd6\xff\xc1\xff\xc4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\xff\x00\x00\xe7\xff\x00\x00\xe0\xff\xfa\xff\xf7\xff\xaa\xff\xf9\xff\xd7\xff\x00\x00\xdd\xff\xe4\xff\x00\x00\xd2\xff\x00\x00\xd3\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\xff\x00\x00\xe8\xff\x00\x00\xef\xff\x00\x00\x00\x00\xc7\xff\x00\x00\x00\x00\xce\xff\x00\x00\xc8\xff\x00\x00\x00\x00\xf3\xff\xed\xff\xeb\xff\xec\xff\xe9\xff\xbe\xff\x00\x00\x00\x00\xb8\xff\xb7\xff\xb6\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xff\xd4\xff\x00\x00\x00\x00\xd1\xff\xfc\xff\xf6\xff\xbb\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\xff\xea\xff\xc5\xff\xc6\xff\x00\x00\xad\xff\xac\xff\xae\xff\xaf\xff\x00\x00\xd0\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\xff\x00\x00\x00\x00\xb2\xff\x00\x00\xb4\xff\xb1\xff\xb0\xff\xb3\xff"# +happyDefActions = HappyA# "\x00\x00\x00\x00\x00\x00\x00\x00\xf5\xff\x00\x00\x00\x00\xdc\xff\xf5\xff\x00\x00\x00\x00\xcd\xff\x00\x00\xcd\xff\xf4\xff\xfe\xff\x00\x00\xd9\xff\x00\x00\x00\x00\x00\x00\xac\xff\xfd\xff\xf9\xff\x00\x00\xd5\xff\x00\x00\x00\x00\xdc\xff\xcd\xff\x00\x00\xcf\xff\x00\x00\x00\x00\xf1\xff\x00\x00\x00\x00\xfb\xff\x00\x00\x00\x00\xcc\xff\xdb\xff\xe8\xff\xe8\xff\xdf\xff\x00\x00\xe8\xff\xcd\xff\x00\x00\xac\xff\x00\x00\xd8\xff\xf8\xff\x00\x00\xda\xff\x00\x00\x00\x00\x00\x00\xe5\xff\xe3\xff\xe8\xff\xe6\xff\x00\x00\xac\xff\x00\x00\x00\x00\xe2\xff\xe1\xff\xef\xff\x00\x00\xf0\xff\xf2\xff\x00\x00\x00\x00\xca\xff\xcb\xff\xc9\xff\x00\x00\xee\xff\xeb\xff\xaa\xff\xde\xff\xc2\xff\xc3\xff\xbd\xff\xbc\xff\xd6\xff\xc1\xff\xc4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xac\xff\x00\x00\xe7\xff\x00\x00\xe0\xff\xfa\xff\xf7\xff\xab\xff\xf9\xff\xd7\xff\x00\x00\xdd\xff\xe4\xff\x00\x00\xd2\xff\x00\x00\xd3\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\xff\x00\x00\xe8\xff\x00\x00\xef\xff\x00\x00\x00\x00\xc7\xff\x00\x00\x00\x00\xce\xff\x00\x00\xc8\xff\x00\x00\x00\x00\xf3\xff\xed\xff\xeb\xff\xec\xff\xe9\xff\xbe\xff\x00\x00\x00\x00\xb8\xff\xb7\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xff\xd4\xff\x00\x00\x00\x00\xd1\xff\xfc\xff\xf6\xff\xbb\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\xff\xea\xff\xc5\xff\xc6\xff\x00\x00\xae\xff\xad\xff\xaf\xff\xb0\xff\x00\x00\xd0\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\xff\x00\x00\x00\x00\xb3\xff\x00\x00\xb5\xff\xb2\xff\xb1\xff\xb4\xff"# happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x02\x00\x0f\x00\x04\x00\x0a\x00\x0b\x00\x03\x00\x04\x00\x02\x00\x13\x00\x04\x00\x15\x00\x04\x00\x03\x00\x04\x00\x02\x00\x0f\x00\x04\x00\x1f\x00\x10\x00\x11\x00\x05\x00\x02\x00\x0f\x00\x04\x00\x23\x00\x10\x00\x11\x00\x1d\x00\x1e\x00\x1f\x00\x25\x00\x1f\x00\x22\x00\x23\x00\x1d\x00\x1e\x00\x1f\x00\x23\x00\x1f\x00\x22\x00\x23\x00\x1d\x00\x1e\x00\x1f\x00\x23\x00\x0d\x00\x22\x00\x23\x00\x1d\x00\x1e\x00\x1f\x00\x14\x00\x15\x00\x22\x00\x23\x00\x02\x00\x0f\x00\x04\x00\x0a\x00\x0b\x00\x03\x00\x04\x00\x02\x00\x1f\x00\x04\x00\x15\x00\x23\x00\x03\x00\x04\x00\x02\x00\x0f\x00\x04\x00\x1f\x00\x10\x00\x11\x00\x18\x00\x02\x00\x0c\x00\x04\x00\x23\x00\x10\x00\x11\x00\x1d\x00\x1e\x00\x1f\x00\x25\x00\x1f\x00\x22\x00\x23\x00\x1d\x00\x1e\x00\x1f\x00\x23\x00\x02\x00\x22\x00\x23\x00\x1d\x00\x1e\x00\x1f\x00\x23\x00\x02\x00\x22\x00\x23\x00\x1d\x00\x1e\x00\x1f\x00\x14\x00\x15\x00\x22\x00\x23\x00\x02\x00\x10\x00\x04\x00\x02\x00\x23\x00\x04\x00\x03\x00\x02\x00\x17\x00\x04\x00\x02\x00\x23\x00\x04\x00\x20\x00\x21\x00\x22\x00\x0d\x00\x0e\x00\x0f\x00\x0f\x00\x20\x00\x21\x00\x22\x00\x05\x00\x06\x00\x05\x00\x06\x00\x1d\x00\x1e\x00\x1f\x00\x1d\x00\x1b\x00\x22\x00\x23\x00\x1d\x00\x22\x00\x23\x00\x1d\x00\x23\x00\x22\x00\x23\x00\x0c\x00\x22\x00\x23\x00\x03\x00\x04\x00\x03\x00\x04\x00\x03\x00\x04\x00\x03\x00\x04\x00\x03\x00\x04\x00\x24\x00\x1b\x00\x24\x00\x10\x00\x11\x00\x10\x00\x11\x00\x10\x00\x11\x00\x10\x00\x11\x00\x10\x00\x11\x00\x0f\x00\x1b\x00\x1c\x00\x1b\x00\x1c\x00\x1b\x00\x1c\x00\x03\x00\x04\x00\x23\x00\x19\x00\x23\x00\x1b\x00\x23\x00\x03\x00\x23\x00\x03\x00\x23\x00\x03\x00\x04\x00\x10\x00\x11\x00\x03\x00\x04\x00\x19\x00\x0e\x00\x0f\x00\x0e\x00\x0f\x00\x03\x00\x03\x00\x10\x00\x11\x00\x03\x00\x23\x00\x10\x00\x11\x00\x03\x00\x09\x00\x23\x00\x0e\x00\x0f\x00\x0f\x00\x03\x00\x0e\x00\x0f\x00\x23\x00\x03\x00\x23\x00\x0f\x00\x23\x00\x03\x00\x03\x00\x23\x00\x23\x00\x0f\x00\x03\x00\x12\x00\x13\x00\x0f\x00\x15\x00\x23\x00\x23\x00\x0f\x00\x0f\x00\x23\x00\x05\x00\x06\x00\x0f\x00\x23\x00\x0f\x00\x05\x00\x0e\x00\x0f\x00\x23\x00\x23\x00\x06\x00\x05\x00\x08\x00\x23\x00\x0a\x00\x0b\x00\x0c\x00\x23\x00\x23\x00\x0f\x00\x1f\x00\x04\x00\x23\x00\x1f\x00\x19\x00\x05\x00\x12\x00\x13\x00\x0f\x00\x15\x00\x1a\x00\x24\x00\x0f\x00\x0d\x00\x23\x00\x1f\x00\x13\x00\x21\x00\x22\x00\x23\x00\x24\x00\x18\x00\x0f\x00\x23\x00\x1f\x00\x0f\x00\x1d\x00\x0f\x00\x1f\x00\x0f\x00\x06\x00\x1f\x00\x08\x00\x0f\x00\x0a\x00\x0b\x00\x0c\x00\x1b\x00\x1f\x00\x0f\x00\x03\x00\x1f\x00\x0f\x00\x1f\x00\x03\x00\x1f\x00\x13\x00\x19\x00\x1a\x00\x1f\x00\x1a\x00\x18\x00\x05\x00\x19\x00\x1a\x00\x1f\x00\x1d\x00\x23\x00\x19\x00\x1a\x00\x19\x00\x1a\x00\x01\x00\x23\x00\x21\x00\x22\x00\x23\x00\x24\x00\x23\x00\x00\x00\x23\x00\x16\x00\x17\x00\x18\x00\x16\x00\x17\x00\x18\x00\x16\x00\x17\x00\x18\x00\x07\x00\x08\x00\x07\x00\x08\x00\x1f\x00\x20\x00\x02\x00\x03\x00\x19\x00\x20\x00\x19\x00\x15\x00\x19\x00\x11\x00\x1e\x00\x12\x00\x0f\x00\x09\x00\x10\x00\x10\x00\x16\x00\x10\x00\x10\x00\x10\x00\x1e\x00\x10\x00\x1b\x00\x10\x00\x07\x00\x25\x00\x10\x00\xff\xff\x20\x00\xff\xff\x16\x00\x19\x00\x17\x00\x16\x00\x16\x00\x16\x00\x10\x00\x0f\x00\xff\xff\x15\x00\x19\x00\xff\xff\x12\x00\x10\x00\x1c\x00\x1f\x00\x10\x00\xff\xff\xff\xff\x15\x00\x1b\x00\x12\x00\x01\x00\x15\x00\x23\x00\x1e\x00\x23\x00\x1c\x00\x20\x00\x14\x00\x19\x00\x1e\x00\x11\x00\x16\x00\x1e\x00\x1c\x00\x14\x00\x14\x00\x20\x00\x1f\x00\x11\x00\x16\x00\x20\x00\x1e\x00\x20\x00\x15\x00\x15\x00\xff\xff\xff\xff\x1f\x00\xff\xff\x1f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# +happyCheck = HappyA# "\xff\xff\x02\x00\x0f\x00\x04\x00\x0a\x00\x0b\x00\x03\x00\x04\x00\x02\x00\x13\x00\x04\x00\x15\x00\x04\x00\x03\x00\x04\x00\x02\x00\x0f\x00\x04\x00\x1f\x00\x10\x00\x11\x00\x05\x00\x02\x00\x0f\x00\x04\x00\x23\x00\x10\x00\x11\x00\x1d\x00\x1e\x00\x1f\x00\x25\x00\x1f\x00\x22\x00\x23\x00\x1d\x00\x1e\x00\x1f\x00\x23\x00\x1f\x00\x22\x00\x23\x00\x1d\x00\x1e\x00\x1f\x00\x23\x00\x0d\x00\x22\x00\x23\x00\x1d\x00\x1e\x00\x1f\x00\x0e\x00\x0f\x00\x22\x00\x23\x00\x02\x00\x0f\x00\x04\x00\x0a\x00\x0b\x00\x03\x00\x04\x00\x02\x00\x1f\x00\x04\x00\x14\x00\x15\x00\x05\x00\x1f\x00\x02\x00\x0f\x00\x04\x00\x1f\x00\x10\x00\x11\x00\x0d\x00\x02\x00\x0c\x00\x04\x00\x02\x00\x23\x00\x04\x00\x1d\x00\x1e\x00\x1f\x00\x25\x00\x1f\x00\x22\x00\x23\x00\x1d\x00\x1e\x00\x1f\x00\x23\x00\x1f\x00\x22\x00\x23\x00\x1d\x00\x1e\x00\x1f\x00\x18\x00\x02\x00\x22\x00\x23\x00\x1d\x00\x1e\x00\x1f\x00\x1d\x00\x03\x00\x22\x00\x23\x00\x0f\x00\x22\x00\x23\x00\x02\x00\x23\x00\x04\x00\x02\x00\x0f\x00\x04\x00\x0f\x00\x07\x00\x08\x00\x1b\x00\x1b\x00\x03\x00\x09\x00\x1f\x00\x0c\x00\x03\x00\x04\x00\x20\x00\x21\x00\x22\x00\x1f\x00\x0d\x00\x0e\x00\x0f\x00\x03\x00\x04\x00\x23\x00\x1d\x00\x10\x00\x11\x00\x1d\x00\x05\x00\x22\x00\x23\x00\x23\x00\x22\x00\x23\x00\x10\x00\x11\x00\x1b\x00\x1c\x00\x03\x00\x04\x00\x23\x00\x03\x00\x04\x00\x15\x00\x23\x00\x1b\x00\x1c\x00\x03\x00\x04\x00\x07\x00\x08\x00\x10\x00\x11\x00\x23\x00\x10\x00\x11\x00\x19\x00\x23\x00\x03\x00\x04\x00\x10\x00\x11\x00\x1b\x00\x1c\x00\x03\x00\x04\x00\x23\x00\x03\x00\x04\x00\x10\x00\x23\x00\x10\x00\x11\x00\x23\x00\x03\x00\x04\x00\x17\x00\x10\x00\x11\x00\x23\x00\x10\x00\x11\x00\x02\x00\x05\x00\x05\x00\x06\x00\x03\x00\x10\x00\x11\x00\x03\x00\x23\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x23\x00\x0e\x00\x0f\x00\x23\x00\x0e\x00\x0f\x00\x0e\x00\x0f\x00\x0e\x00\x0f\x00\x23\x00\x0f\x00\x03\x00\x05\x00\x03\x00\x01\x00\x20\x00\x21\x00\x22\x00\x24\x00\x03\x00\x03\x00\x23\x00\x03\x00\x0f\x00\x23\x00\x0f\x00\x23\x00\x00\x00\x23\x00\x19\x00\x23\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x05\x00\x06\x00\x05\x00\x06\x00\x12\x00\x13\x00\x0f\x00\x15\x00\x23\x00\x06\x00\x23\x00\x08\x00\x20\x00\x0a\x00\x1f\x00\x0c\x00\x23\x00\x23\x00\x0f\x00\x23\x00\x15\x00\x23\x00\x1f\x00\x0f\x00\x16\x00\x17\x00\x18\x00\x0f\x00\x1e\x00\x1a\x00\x04\x00\x24\x00\x0f\x00\x24\x00\x1f\x00\x1b\x00\x21\x00\x22\x00\x23\x00\x24\x00\x06\x00\x0f\x00\x08\x00\x1f\x00\x0a\x00\x13\x00\x0c\x00\x0f\x00\x1f\x00\x0f\x00\x18\x00\x12\x00\x13\x00\x19\x00\x15\x00\x1d\x00\x19\x00\x1f\x00\x14\x00\x15\x00\x1a\x00\x12\x00\x0f\x00\x1f\x00\x10\x00\x1f\x00\x13\x00\x0f\x00\x23\x00\x02\x00\x03\x00\x18\x00\x10\x00\x23\x00\x19\x00\x1a\x00\x1d\x00\x19\x00\x19\x00\x1b\x00\x19\x00\x1a\x00\x19\x00\x1a\x00\x23\x00\x19\x00\x1a\x00\x11\x00\x23\x00\x0f\x00\x23\x00\x09\x00\x23\x00\x1f\x00\x20\x00\x23\x00\x21\x00\x22\x00\x23\x00\x24\x00\x16\x00\x17\x00\x18\x00\x16\x00\x17\x00\x18\x00\x10\x00\x10\x00\x10\x00\x16\x00\x10\x00\x1b\x00\x10\x00\x19\x00\x07\x00\x1e\x00\x17\x00\x16\x00\x20\x00\x16\x00\x16\x00\x16\x00\x10\x00\xff\xff\x10\x00\x15\x00\x19\x00\x0f\x00\x12\x00\x10\x00\x1c\x00\x1f\x00\x1b\x00\x10\x00\xff\xff\x15\x00\x12\x00\x11\x00\x23\x00\x1e\x00\x15\x00\x14\x00\x01\x00\x20\x00\x1c\x00\x1e\x00\x16\x00\x19\x00\x14\x00\x14\x00\x11\x00\xff\xff\xff\xff\x1e\x00\x1c\x00\xff\xff\x16\x00\x20\x00\x1f\x00\x15\x00\x15\x00\x1e\x00\x20\x00\x1f\x00\xff\xff\xff\xff\xff\xff\x20\x00\x1f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x52\x00\x5f\x00\x53\x00\x8d\x00\x4e\x00\x2a\x00\x2b\x00\x52\x00\x7c\x00\x53\x00\x11\x00\x30\x00\x2a\x00\x2b\x00\x52\x00\x3f\x00\x53\x00\x61\x00\x2c\x00\xb2\x00\xa0\x00\x52\x00\x31\x00\x53\x00\x12\x00\x2c\x00\xab\x00\x54\x00\x55\x00\xca\x00\x4f\x00\x40\x00\x57\x00\x58\x00\x54\x00\x55\x00\xc5\x00\x2e\x00\x32\x00\x57\x00\x58\x00\x54\x00\x55\x00\xc8\x00\x2e\x00\x15\x00\x57\x00\x58\x00\x54\x00\x55\x00\xc9\x00\x69\x00\x33\x00\x57\x00\x58\x00\x52\x00\x21\x00\x53\x00\x4d\x00\x4e\x00\x2a\x00\x2b\x00\x52\x00\x16\x00\x53\x00\x19\x00\x12\x00\x2a\x00\x2b\x00\x52\x00\x3f\x00\x53\x00\x16\x00\x2c\x00\x93\x00\xb5\x00\x52\x00\xaa\x00\x53\x00\x12\x00\x2c\x00\x6b\x00\x54\x00\x55\x00\xa2\x00\x4f\x00\x40\x00\x57\x00\x58\x00\x54\x00\x55\x00\xa9\x00\x2e\x00\xb7\x00\x57\x00\x58\x00\x54\x00\x55\x00\x95\x00\x2e\x00\xb7\x00\x57\x00\x58\x00\x54\x00\x55\x00\x73\x00\x32\x00\x33\x00\x57\x00\x58\x00\x52\x00\x65\x00\x53\x00\x52\x00\x9d\x00\x53\x00\x3a\x00\x52\x00\x8c\x00\x53\x00\x52\x00\x12\x00\x53\x00\xc7\x00\xb9\x00\xba\x00\x8f\x00\x90\x00\x3c\x00\x72\x00\xb8\x00\xb9\x00\xba\x00\xa0\x00\x65\x00\x34\x00\xa1\x00\x54\x00\x55\x00\x56\x00\xad\x00\x73\x00\x57\x00\x58\x00\x7a\x00\x57\x00\x58\x00\x7d\x00\x3d\x00\x57\x00\x58\x00\x7f\x00\x57\x00\x58\x00\x2a\x00\x2b\x00\x2a\x00\x2b\x00\x2a\x00\x2b\x00\x2a\x00\x2b\x00\x2a\x00\x2b\x00\x66\x00\x48\x00\x66\x00\x2c\x00\x83\x00\x2c\x00\x88\x00\x2c\x00\x83\x00\x2c\x00\x51\x00\x2c\x00\x61\x00\x72\x00\x84\x00\xac\x00\x84\x00\x85\x00\x84\x00\x85\x00\x2a\x00\x2b\x00\x2e\x00\xc5\x00\x2e\x00\x73\x00\x2e\x00\x3a\x00\x2e\x00\x3a\x00\x2e\x00\x2a\x00\x2b\x00\x2c\x00\x38\x00\x2a\x00\x2b\x00\x8e\x00\x62\x00\x3c\x00\x3b\x00\x3c\x00\x3a\x00\x3a\x00\x2c\x00\x46\x00\x3a\x00\x1f\x00\x2c\x00\x2d\x00\x3a\x00\x23\x00\x2e\x00\x42\x00\x3c\x00\xa4\x00\x3a\x00\x43\x00\x3c\x00\x3d\x00\x3a\x00\x3d\x00\xa5\x00\x2e\x00\x3a\x00\x3a\x00\x26\x00\x2e\x00\xa6\x00\x3a\x00\x29\x00\x10\x00\xa7\x00\x11\x00\x3d\x00\x3d\x00\x91\x00\x94\x00\x3d\x00\x25\x00\x65\x00\x96\x00\x3d\x00\x21\x00\x25\x00\xbc\x00\xbd\x00\x12\x00\x3d\x00\x5a\x00\x34\x00\x5b\x00\x3d\x00\x5c\x00\x5d\x00\x5e\x00\x3d\x00\x3d\x00\x5f\x00\x16\x00\x30\x00\x3d\x00\xbe\x00\x9c\x00\x14\x00\x0f\x00\x10\x00\x5f\x00\x11\x00\x60\x00\x66\x00\x87\x00\x15\x00\x1f\x00\x61\x00\x4b\x00\x75\x00\x76\x00\x77\x00\x78\x00\x4c\x00\x3f\x00\x12\x00\x61\x00\x5f\x00\x4d\x00\x21\x00\x32\x00\x3f\x00\x5a\x00\x16\x00\x5b\x00\x21\x00\x5c\x00\x5d\x00\x5e\x00\x7f\x00\x40\x00\x5f\x00\x0b\x00\x61\x00\x4a\x00\x16\x00\x0d\x00\x40\x00\x4b\x00\x1d\x00\x39\x00\x16\x00\x60\x00\x4c\x00\x16\x00\x1d\x00\x28\x00\x61\x00\x4d\x00\x1f\x00\x1d\x00\x1e\x00\x1d\x00\x22\x00\x04\x00\x1f\x00\x75\x00\x76\x00\x77\x00\x78\x00\x1f\x00\x03\x00\x1f\x00\x6e\x00\xc3\x00\x70\x00\x6e\x00\x9f\x00\x70\x00\x6e\x00\x6f\x00\x70\x00\x0e\x00\x08\x00\x07\x00\x08\x00\x68\x00\x69\x00\x0a\x00\x0b\x00\xc7\x00\x18\x00\xc0\x00\xbf\x00\xc1\x00\xb7\x00\xc2\x00\xc3\x00\x72\x00\xb5\x00\xb4\x00\xaf\x00\xa4\x00\xb0\x00\xb1\x00\xb2\x00\x8d\x00\xa9\x00\x81\x00\x8a\x00\x93\x00\xff\xff\x9c\x00\x00\x00\x51\x00\x00\x00\x98\x00\x8b\x00\x8c\x00\x99\x00\x9a\x00\x9b\x00\x6d\x00\x7c\x00\x00\x00\x6e\x00\x9f\x00\x00\x00\x83\x00\x88\x00\x6b\x00\x16\x00\x65\x00\x00\x00\x00\x00\x22\x00\x81\x00\x37\x00\x03\x00\x38\x00\x79\x00\x82\x00\x7a\x00\x64\x00\x51\x00\x41\x00\x42\x00\x36\x00\x45\x00\x46\x00\x48\x00\x19\x00\x25\x00\x28\x00\x18\x00\x16\x00\x1b\x00\x1c\x00\x18\x00\x1d\x00\x18\x00\x22\x00\x07\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# +happyTable = HappyA# "\x00\x00\x52\x00\x5e\x00\x53\x00\x8b\x00\x4e\x00\x2a\x00\x2b\x00\x52\x00\x7a\x00\x53\x00\x11\x00\x30\x00\x2a\x00\x2b\x00\x52\x00\x3f\x00\x53\x00\x60\x00\x2c\x00\xaf\x00\x9d\x00\x52\x00\x31\x00\x53\x00\x12\x00\x2c\x00\xa8\x00\x54\x00\x55\x00\xc7\x00\x4f\x00\x40\x00\x57\x00\x58\x00\x54\x00\x55\x00\xc2\x00\x2e\x00\x32\x00\x57\x00\x58\x00\x54\x00\x55\x00\xc5\x00\x2e\x00\x15\x00\x57\x00\x58\x00\x54\x00\x55\x00\xc6\x00\xb9\x00\xba\x00\x57\x00\x58\x00\x52\x00\x21\x00\x53\x00\x4d\x00\x4e\x00\x2a\x00\x2b\x00\x52\x00\x16\x00\x53\x00\x68\x00\x33\x00\x14\x00\xbb\x00\x52\x00\x3f\x00\x53\x00\x16\x00\x2c\x00\x91\x00\x15\x00\x52\x00\xa7\x00\x53\x00\x52\x00\x12\x00\x53\x00\x54\x00\x55\x00\x9f\x00\x4f\x00\x40\x00\x57\x00\x58\x00\x54\x00\x55\x00\xa6\x00\x2e\x00\x16\x00\x57\x00\x58\x00\x54\x00\x55\x00\x72\x00\xb2\x00\xb4\x00\x57\x00\x58\x00\x54\x00\x55\x00\x56\x00\xaa\x00\x3a\x00\x57\x00\x58\x00\x5e\x00\x57\x00\x58\x00\x52\x00\x9a\x00\x53\x00\x52\x00\x21\x00\x53\x00\xa1\x00\x0e\x00\x08\x00\x7d\x00\x48\x00\x3a\x00\x23\x00\x60\x00\x7d\x00\x2a\x00\x2b\x00\xc4\x00\xb6\x00\xb7\x00\x16\x00\x8d\x00\x8e\x00\x3c\x00\x2a\x00\x2b\x00\x3d\x00\x78\x00\x2c\x00\x81\x00\x7b\x00\x25\x00\x57\x00\x58\x00\x26\x00\x57\x00\x58\x00\x2c\x00\x86\x00\x82\x00\xa9\x00\x2a\x00\x2b\x00\x3d\x00\x2a\x00\x2b\x00\x19\x00\x2e\x00\x82\x00\x83\x00\x2a\x00\x2b\x00\x07\x00\x08\x00\x2c\x00\x81\x00\x2e\x00\x2c\x00\x6a\x00\x8c\x00\x12\x00\x2a\x00\x2b\x00\x2c\x00\x51\x00\x82\x00\x83\x00\x2a\x00\x2b\x00\x1f\x00\x2a\x00\x2b\x00\x64\x00\x2e\x00\x2c\x00\x60\x00\x2e\x00\x2a\x00\x2b\x00\x8a\x00\x2c\x00\x38\x00\x2e\x00\x2c\x00\x46\x00\xb4\x00\x34\x00\x9d\x00\x64\x00\x3a\x00\x2c\x00\x2d\x00\x3a\x00\x2e\x00\x3a\x00\x0b\x00\x3a\x00\x0d\x00\x3a\x00\x2e\x00\x61\x00\x3c\x00\x2e\x00\x3b\x00\x3c\x00\x42\x00\x3c\x00\x43\x00\x3c\x00\x2e\x00\xa2\x00\x3a\x00\x16\x00\x3a\x00\x04\x00\xb5\x00\xb6\x00\xb7\x00\x65\x00\x3a\x00\x3a\x00\x3d\x00\x3a\x00\xa3\x00\x3d\x00\xa4\x00\x3d\x00\x03\x00\x3d\x00\xc4\x00\x3d\x00\x8f\x00\x92\x00\x5e\x00\x93\x00\x34\x00\x9e\x00\x25\x00\x64\x00\x29\x00\x10\x00\x3f\x00\x11\x00\x3d\x00\x5a\x00\x3d\x00\x5b\x00\x18\x00\x5c\x00\x60\x00\x5d\x00\x3d\x00\x3d\x00\x5e\x00\x3d\x00\xbc\x00\x12\x00\x40\x00\x71\x00\x6d\x00\xc0\x00\x6f\x00\x21\x00\xbf\x00\x5f\x00\x30\x00\x65\x00\x3f\x00\x65\x00\x60\x00\x72\x00\x74\x00\x75\x00\x76\x00\x77\x00\x5a\x00\x85\x00\x5b\x00\x16\x00\x5c\x00\x4b\x00\x5d\x00\x21\x00\x40\x00\x5e\x00\x4c\x00\x0f\x00\x10\x00\xbd\x00\x11\x00\x4d\x00\xbe\x00\x32\x00\x32\x00\x33\x00\x5f\x00\xc0\x00\x4a\x00\x16\x00\xb1\x00\x60\x00\x4b\x00\x71\x00\x12\x00\x0a\x00\x0b\x00\x4c\x00\xac\x00\x12\x00\x1d\x00\x39\x00\x4d\x00\xc2\x00\x99\x00\x72\x00\x1d\x00\x28\x00\x1d\x00\x1e\x00\x1f\x00\x1d\x00\x22\x00\xb4\x00\x1f\x00\x71\x00\x1f\x00\xb2\x00\x1f\x00\x67\x00\x68\x00\x1f\x00\x74\x00\x75\x00\x76\x00\x77\x00\x6d\x00\x9c\x00\x6f\x00\x6d\x00\x6e\x00\x6f\x00\xad\x00\xae\x00\xaf\x00\xa1\x00\xa6\x00\x7f\x00\x88\x00\x89\x00\x91\x00\x8b\x00\x8a\x00\x95\x00\x51\x00\x96\x00\x97\x00\x98\x00\x99\x00\x00\x00\x6c\x00\x6d\x00\x9c\x00\x7a\x00\x81\x00\x86\x00\x6a\x00\x16\x00\x7f\x00\x64\x00\x00\x00\x22\x00\x37\x00\x45\x00\x78\x00\x80\x00\x38\x00\x41\x00\x03\x00\x51\x00\x63\x00\x36\x00\x46\x00\x42\x00\x25\x00\x28\x00\x1b\x00\x00\x00\x00\x00\x48\x00\x19\x00\x00\x00\x1c\x00\x18\x00\x16\x00\x22\x00\x07\x00\x1d\x00\x18\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x18\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# -happyReduceArr = Happy_Data_Array.array (1, 86) [ +happyReduceArr = Happy_Data_Array.array (1, 85) [ (1 , happyReduce_1), (2 , happyReduce_2), (3 , happyReduce_3), @@ -389,8 +389,7 @@ (82 , happyReduce_82), (83 , happyReduce_83), (84 , happyReduce_84), - (85 , happyReduce_85), - (86 , happyReduce_86) + (85 , happyReduce_85) ] happy_n_terms = 38 :: Int @@ -1032,18 +1031,6 @@ happy_x_2 happy_x_1 = case happyOutTok happy_x_2 of { (TKstring happy_var_2) -> - case happyOut35 happy_x_3 of { happy_var_3 -> - happyIn35 - (case happy_var_2 of - --"SCC" -> IfaceNote (IfaceSCC "scc") happy_var_3 - "InlineMe" -> IfaceNote IfaceInlineMe happy_var_3 - )}} - -happyReduce_73 = happySpecReduce_3 31# happyReduction_73 -happyReduction_73 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_2 of { (TKstring happy_var_2) -> case happyOut19 happy_x_3 of { happy_var_3 -> happyIn35 (IfaceFCall (ForeignCall.CCall @@ -1052,15 +1039,15 @@ happy_var_3 )}} -happyReduce_74 = happySpecReduce_1 32# happyReduction_74 -happyReduction_74 happy_x_1 +happyReduce_73 = happySpecReduce_1 32# happyReduction_73 +happyReduction_73 happy_x_1 = case happyOut37 happy_x_1 of { happy_var_1 -> happyIn36 ([happy_var_1] )} -happyReduce_75 = happySpecReduce_3 32# happyReduction_75 -happyReduction_75 happy_x_3 +happyReduce_74 = happySpecReduce_3 32# happyReduction_74 +happyReduction_74 happy_x_3 happy_x_2 happy_x_1 = case happyOut37 happy_x_1 of { happy_var_1 -> @@ -1069,8 +1056,8 @@ (happy_var_1:happy_var_3 )}} -happyReduce_76 = happyReduce 4# 33# happyReduction_76 -happyReduction_76 (happy_x_4 `HappyStk` +happyReduce_75 = happyReduce 4# 33# happyReduction_75 +happyReduction_75 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` @@ -1082,8 +1069,8 @@ ((IfaceDataAlt happy_var_1, map ifaceBndrName happy_var_2, happy_var_4) ) `HappyStk` happyRest}}} -happyReduce_77 = happySpecReduce_3 33# happyReduction_77 -happyReduction_77 happy_x_3 +happyReduce_76 = happySpecReduce_3 33# happyReduction_76 +happyReduction_76 happy_x_3 happy_x_2 happy_x_1 = case happyOut6 happy_x_1 of { happy_var_1 -> @@ -1092,8 +1079,8 @@ ((IfaceDataAlt happy_var_1, [], happy_var_3) )}} -happyReduce_78 = happySpecReduce_3 33# happyReduction_78 -happyReduction_78 happy_x_3 +happyReduce_77 = happySpecReduce_3 33# happyReduction_77 +happyReduction_77 happy_x_3 happy_x_2 happy_x_1 = case happyOut38 happy_x_1 of { happy_var_1 -> @@ -1102,8 +1089,8 @@ ((IfaceLitAlt happy_var_1, [], happy_var_3) )}} -happyReduce_79 = happySpecReduce_3 33# happyReduction_79 -happyReduction_79 happy_x_3 +happyReduce_78 = happySpecReduce_3 33# happyReduction_78 +happyReduction_78 happy_x_3 happy_x_2 happy_x_1 = case happyOut35 happy_x_3 of { happy_var_3 -> @@ -1111,8 +1098,8 @@ ((IfaceDefault, [], happy_var_3) )} -happyReduce_80 = happyReduce 5# 34# happyReduction_80 -happyReduction_80 (happy_x_5 `HappyStk` +happyReduce_79 = happyReduce 5# 34# happyReduction_79 +happyReduction_79 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` @@ -1124,8 +1111,8 @@ (convIntLit happy_var_2 happy_var_4 ) `HappyStk` happyRest}} -happyReduce_81 = happyReduce 5# 34# happyReduction_81 -happyReduction_81 (happy_x_5 `HappyStk` +happyReduce_80 = happyReduce 5# 34# happyReduction_80 +happyReduction_80 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` @@ -1137,8 +1124,8 @@ (convRatLit happy_var_2 happy_var_4 ) `HappyStk` happyRest}} -happyReduce_82 = happyReduce 5# 34# happyReduction_82 -happyReduction_82 (happy_x_5 `HappyStk` +happyReduce_81 = happyReduce 5# 34# happyReduction_81 +happyReduction_81 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` @@ -1149,8 +1136,8 @@ (MachChar happy_var_2 ) `HappyStk` happyRest} -happyReduce_83 = happyReduce 5# 34# happyReduction_83 -happyReduction_83 (happy_x_5 `HappyStk` +happyReduce_82 = happyReduce 5# 34# happyReduction_82 +happyReduction_82 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` @@ -1161,22 +1148,22 @@ (MachStr (mkFastString happy_var_2) ) `HappyStk` happyRest} -happyReduce_84 = happySpecReduce_1 35# happyReduction_84 -happyReduction_84 happy_x_1 +happyReduce_83 = happySpecReduce_1 35# happyReduction_83 +happyReduction_83 happy_x_1 = case happyOutTok happy_x_1 of { (TKname happy_var_1) -> happyIn39 (mkFastString happy_var_1 )} -happyReduce_85 = happySpecReduce_1 36# happyReduction_85 -happyReduction_85 happy_x_1 +happyReduce_84 = happySpecReduce_1 36# happyReduction_84 +happyReduction_84 happy_x_1 = case happyOutTok happy_x_1 of { (TKname happy_var_1) -> happyIn40 (happy_var_1 )} -happyReduce_86 = happySpecReduce_1 37# happyReduction_86 -happyReduction_86 happy_x_1 +happyReduce_85 = happySpecReduce_1 37# happyReduction_85 +happyReduction_85 happy_x_1 = case happyOutTok happy_x_1 of { (TKcname happy_var_1) -> happyIn41 (mkOccName dataName happy_var_1 diff -ruN ghc-6.12.1/compiler/parser/ParserCore.y.source ghc-6.13.20091231/compiler/parser/ParserCore.y.source --- ghc-6.12.1/compiler/parser/ParserCore.y.source 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/parser/ParserCore.y.source 2009-12-31 10:14:17.000000000 -0800 @@ -269,11 +269,12 @@ | '%case' '(' ty ')' aexp '%of' id_bndr '{' alts1 '}' { IfaceCase $5 (fst $7) $3 $9 } | '%cast' aexp aty { IfaceCast $2 $3 } - | '%note' STRING exp - { case $2 of - --"SCC" -> IfaceNote (IfaceSCC "scc") $3 - "InlineMe" -> IfaceNote IfaceInlineMe $3 - } +-- No InlineMe any more +-- | '%note' STRING exp +-- { case $2 of +-- --"SCC" -> IfaceNote (IfaceSCC "scc") $3 +-- "InlineMe" -> IfaceNote IfaceInlineMe $3 +-- } | '%external' STRING aty { IfaceFCall (ForeignCall.CCall (CCallSpec (StaticTarget (mkFastString $2)) CCallConv (PlaySafe False))) diff -ruN ghc-6.12.1/compiler/parser/Parser.hs ghc-6.13.20091231/compiler/parser/Parser.hs --- ghc-6.12.1/compiler/parser/Parser.hs 2009-12-10 12:13:28.000000000 -0800 +++ ghc-6.13.20091231/compiler/parser/Parser.hs 2009-12-31 12:35:22.000000000 -0800 @@ -40,7 +40,7 @@ import Type ( Kind, mkArrowKind, liftedTypeKind, unliftedTypeKind ) import Class ( FunDep ) import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..), - Activation(..), RuleMatchInfo(..), defaultInlineSpec ) + Activation(..), RuleMatchInfo(..), defaultInlinePragma ) import DynFlags import OrdList import HaddockUtils @@ -4762,7 +4762,7 @@ case happyOut200 happy_x_3 of { happy_var_3 -> case happyOutTok happy_x_4 of { happy_var_4 -> happyIn124 - (sL (comb2 happy_var_1 happy_var_4) $ unitOL (sL (comb2 happy_var_1 happy_var_4) $ SigD (InlineSig happy_var_3 (mkInlineSpec happy_var_2 FunLike (getINLINE happy_var_1)))) + (sL (comb2 happy_var_1 happy_var_4) $ unitOL (sL (comb2 happy_var_1 happy_var_4) $ SigD (InlineSig happy_var_3 (mkInlinePragma happy_var_2 FunLike (getINLINE happy_var_1)))) ) `HappyStk` happyRest}}}} happyReduce_309 = happyReduce 4# 116# happyReduction_309 @@ -4776,7 +4776,7 @@ case happyOut200 happy_x_3 of { happy_var_3 -> case happyOutTok happy_x_4 of { happy_var_4 -> happyIn124 - (sL (comb2 happy_var_1 happy_var_4) $ unitOL (sL (comb2 happy_var_1 happy_var_4) $ SigD (InlineSig happy_var_3 (mkInlineSpec happy_var_2 ConLike (getINLINE_CONLIKE happy_var_1)))) + (sL (comb2 happy_var_1 happy_var_4) $ unitOL (sL (comb2 happy_var_1 happy_var_4) $ SigD (InlineSig happy_var_3 (mkInlinePragma happy_var_2 ConLike (getINLINE_CONLIKE happy_var_1)))) ) `HappyStk` happyRest}}}} happyReduce_310 = happyReduce 5# 116# happyReduction_310 @@ -4791,7 +4791,7 @@ case happyOut84 happy_x_4 of { happy_var_4 -> case happyOutTok happy_x_5 of { happy_var_5 -> happyIn124 - (sL (comb2 happy_var_1 happy_var_5) $ toOL [ sL (comb2 happy_var_1 happy_var_5) $ SigD (SpecSig happy_var_2 t defaultInlineSpec) + (sL (comb2 happy_var_1 happy_var_5) $ toOL [ sL (comb2 happy_var_1 happy_var_5) $ SigD (SpecSig happy_var_2 t defaultInlinePragma) | t <- happy_var_4] ) `HappyStk` happyRest}}}} @@ -4809,7 +4809,7 @@ case happyOut84 happy_x_5 of { happy_var_5 -> case happyOutTok happy_x_6 of { happy_var_6 -> happyIn124 - (sL (comb2 happy_var_1 happy_var_6) $ toOL [ sL (comb2 happy_var_1 happy_var_6) $ SigD (SpecSig happy_var_3 t (mkInlineSpec happy_var_2 FunLike (getSPEC_INLINE happy_var_1))) + (sL (comb2 happy_var_1 happy_var_6) $ toOL [ sL (comb2 happy_var_1 happy_var_6) $ SigD (SpecSig happy_var_3 t (mkInlinePragma happy_var_2 FunLike (getSPEC_INLINE happy_var_1))) | t <- happy_var_5] ) `HappyStk` happyRest}}}}} @@ -7473,7 +7473,7 @@ fileSrcSpan :: P SrcSpan fileSrcSpan = do l <- getSrcLoc; - let loc = mkSrcLoc (srcLocFile l) 1 0; + let loc = mkSrcLoc (srcLocFile l) 1 1; return (mkSrcSpan loc loc) {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} diff -ruN ghc-6.12.1/compiler/parser/Parser.y.pp.source ghc-6.13.20091231/compiler/parser/Parser.y.pp.source --- ghc-6.12.1/compiler/parser/Parser.y.pp.source 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/parser/Parser.y.pp.source 2009-12-31 10:14:18.000000000 -0800 @@ -48,7 +48,7 @@ import Type ( Kind, mkArrowKind, liftedTypeKind, unliftedTypeKind ) import Class ( FunDep ) import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..), - Activation(..), RuleMatchInfo(..), defaultInlineSpec ) + Activation(..), RuleMatchInfo(..), defaultInlinePragma ) import DynFlags import OrdList import HaddockUtils @@ -559,8 +559,8 @@ | stand_alone_deriving { unitOL (LL (DerivD (unLoc $1))) } | 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) } | 'foreign' fdecl { unitOL (LL (unLoc $2)) } - | '{-# DEPRECATED' deprecations '#-}' { $2 } - | '{-# WARNING' warnings '#-}' { $2 } + | '{-# DEPRECATED' deprecations '#-}' { $2 } + | '{-# WARNING' warnings '#-}' { $2 } | '{-# RULES' rules '#-}' { $2 } | annotation { unitOL $1 } | decl { unLoc $1 } @@ -981,7 +981,7 @@ type :: { LHsType RdrName } : btype { $1 } - | btype qtyconop type { LL $ HsOpTy $1 $2 $3 } + | btype qtyconop type { LL $ HsOpTy $1 $2 $3 } | btype tyvarop type { LL $ HsOpTy $1 $2 $3 } | btype '->' ctype { LL $ HsFunTy $1 $3 } | btype '~' btype { LL $ HsPredTy (HsEqualP $1 $3) } @@ -1228,17 +1228,17 @@ | infix prec ops { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1)))) | n <- unLoc $3 ] } | '{-# INLINE' activation qvar '#-}' - { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 FunLike (getINLINE $1)))) } + { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma $2 FunLike (getINLINE $1)))) } | '{-# INLINE_CONLIKE' activation qvar '#-}' - { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 ConLike (getINLINE_CONLIKE $1)))) } + { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma $2 ConLike (getINLINE_CONLIKE $1)))) } | '{-# SPECIALISE' qvar '::' sigtypes1 '#-}' - { LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlineSpec) + { LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlinePragma) | t <- $4] } | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}' - { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlineSpec $2 FunLike (getSPEC_INLINE $1))) + { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlinePragma $2 FunLike (getSPEC_INLINE $1))) | t <- $5] } | '{-# SPECIALISE' 'instance' inst_type '#-}' - { LL $ unitOL (LL $ SigD (SpecInstSig $3)) } + { LL $ unitOL (LL $ SigD (SpecInstSig $3)) } ----------------------------------------------------------------------------- -- Expressions @@ -2012,6 +2012,6 @@ fileSrcSpan :: P SrcSpan fileSrcSpan = do l <- getSrcLoc; - let loc = mkSrcLoc (srcLocFile l) 1 0; + let loc = mkSrcLoc (srcLocFile l) 1 1; return (mkSrcSpan loc loc) } diff -ruN ghc-6.12.1/compiler/parser/RdrHsSyn.lhs ghc-6.13.20091231/compiler/parser/RdrHsSyn.lhs --- ghc-6.12.1/compiler/parser/RdrHsSyn.lhs 2009-12-10 10:11:33.000000000 -0800 +++ ghc-6.13.20091231/compiler/parser/RdrHsSyn.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -12,7 +12,7 @@ mkHsIntegral, mkHsFractional, mkHsIsString, mkHsDo, mkHsSplice, mkTopSpliceDecl, mkClassDecl, mkTyData, mkTyFamily, mkTySynonym, - splitCon, mkInlineSpec, + splitCon, mkInlinePragma, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp cvBindGroup, @@ -54,9 +54,8 @@ import TypeRep ( Kind ) import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace ) -import BasicTypes ( maxPrecedence, Activation, RuleMatchInfo, - InlinePragma(..), InlineSpec(..), - alwaysInlineSpec, neverInlineSpec ) +import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo, + InlinePragma(..) ) import Lexer import TysWiredIn ( unitTyCon ) import ForeignCall @@ -960,13 +959,20 @@ mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) } -mkInlineSpec :: Maybe Activation -> RuleMatchInfo -> Bool -> InlineSpec --- The Maybe is becuase the user can omit the activation spec (and usually does) -mkInlineSpec Nothing match_info True = alwaysInlineSpec match_info - -- INLINE -mkInlineSpec Nothing match_info False = neverInlineSpec match_info - -- NOINLINE -mkInlineSpec (Just act) match_info inl = Inline (InlinePragma act match_info) inl +mkInlinePragma :: Maybe Activation -> RuleMatchInfo -> Bool -> InlinePragma +-- The Maybe is because the user can omit the activation spec (and usually does) +mkInlinePragma mb_act match_info inl + = InlinePragma { inl_inline = inl + , inl_act = act + , inl_rule = match_info } + where + act = case mb_act of + Just act -> act + Nothing | inl -> AlwaysActive + | otherwise -> NeverActive + -- If no specific phase is given then: + -- NOINLINE => NeverActive + -- INLINE => Active ----------------------------------------------------------------------------- -- utilities for foreign declarations @@ -979,9 +985,9 @@ -> P (HsDecl RdrName) mkImport cconv safety (L loc entity, v, ty) | cconv == PrimCallConv = do - let funcTarget = CFunction (StaticTarget entity) - importSpec = CImport PrimCallConv safety nilFS funcTarget - return (ForD (ForeignImport v ty importSpec)) + let funcTarget = CFunction (StaticTarget entity) + importSpec = CImport PrimCallConv safety nilFS funcTarget + return (ForD (ForeignImport v ty importSpec)) | otherwise = do case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of Nothing -> parseError loc "Malformed entity string" @@ -996,13 +1002,17 @@ listToMaybe $ map fst $ filter (null.snd) $ readP_to_S parse str where - parse = choice [ + parse = do + skipSpaces + r <- choice [ string "dynamic" >> return (mk nilFS (CFunction DynamicTarget)), string "wrapper" >> return (mk nilFS CWrapper), optional (string "static" >> skipSpaces) >> (mk nilFS <$> cimp nm) +++ (do h <- munch1 hdr_char; skipSpaces; mk (mkFastString h) <$> cimp nm) - ] + ] + skipSpaces + return r mk = CImport cconv safety diff -ruN ghc-6.12.1/compiler/prelude/PrelNames.lhs ghc-6.13.20091231/compiler/prelude/PrelNames.lhs --- ghc-6.12.1/compiler/prelude/PrelNames.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/prelude/PrelNames.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -234,7 +234,9 @@ pRELUDE :: Module pRELUDE = mkBaseModule_ pRELUDE_NAME -gHC_PRIM, gHC_TYPES, gHC_BOOL, gHC_UNIT, gHC_ORDERING, gHC_GENERICS, gHC_CLASSES, gHC_BASE, gHC_ENUM, +gHC_PRIM, gHC_TYPES, gHC_BOOL, gHC_UNIT, gHC_ORDERING, gHC_GENERICS, + gHC_MAGIC, + gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER, gHC_INTEGER_TYPE, gHC_LIST, gHC_PARR, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, gHC_PACK, gHC_CONC, gHC_IO, gHC_IO_Exception, @@ -242,12 +244,15 @@ gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, tYPEABLE, gENERICS, dOTNET, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS, cONTROL_EXCEPTION_BASE :: Module + gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values gHC_TYPES = mkPrimModule (fsLit "GHC.Types") gHC_UNIT = mkPrimModule (fsLit "GHC.Unit") gHC_BOOL = mkPrimModule (fsLit "GHC.Bool") gHC_ORDERING = mkPrimModule (fsLit "GHC.Ordering") gHC_GENERICS = mkPrimModule (fsLit "GHC.Generics") +gHC_MAGIC = mkPrimModule (fsLit "GHC.Magic") + gHC_CLASSES = mkBaseModule (fsLit "GHC.Classes") gHC_BASE = mkBaseModule (fsLit "GHC.Base") gHC_ENUM = mkBaseModule (fsLit "GHC.Enum") @@ -255,7 +260,7 @@ gHC_READ = mkBaseModule (fsLit "GHC.Read") gHC_NUM = mkBaseModule (fsLit "GHC.Num") gHC_INTEGER = mkIntegerModule (fsLit "GHC.Integer") -gHC_INTEGER_TYPE = mkIntegerModule (fsLit "GHC.Integer.Type") +gHC_INTEGER_TYPE= mkIntegerModule (fsLit "GHC.Integer.Type") gHC_LIST = mkBaseModule (fsLit "GHC.List") gHC_PARR = mkBaseModule (fsLit "GHC.PArr") gHC_TUPLE = mkPrimModule (fsLit "GHC.Tuple") @@ -283,7 +288,7 @@ gENERICS = mkBaseModule (fsLit "Data.Data") dOTNET = mkBaseModule (fsLit "GHC.Dotnet") rEAD_PREC = mkBaseModule (fsLit "Text.ParserCombinators.ReadPrec") -lEX = mkBaseModule (fsLit "Text.Read.Lex") +lEX = mkBaseModule (fsLit "Text.Read.Lex") gHC_INT = mkBaseModule (fsLit "GHC.Int") gHC_WORD = mkBaseModule (fsLit "GHC.Word") mONAD = mkBaseModule (fsLit "Control.Monad") @@ -562,7 +567,7 @@ -- The 'inline' function inlineIdName :: Name -inlineIdName = varQual gHC_BASE (fsLit "inline") inlineIdKey +inlineIdName = varQual gHC_MAGIC (fsLit "inline") inlineIdKey -- Base classes (Eq, Ord, Functor) eqClassName, eqName, ordClassName, geName, functorClassName :: Name @@ -923,7 +928,8 @@ listTyConKey, foreignObjPrimTyConKey, weakPrimTyConKey, mutableArrayPrimTyConKey, mutableByteArrayPrimTyConKey, orderingTyConKey, mVarPrimTyConKey, ratioTyConKey, rationalTyConKey, - realWorldTyConKey, stablePtrPrimTyConKey, stablePtrTyConKey :: Unique + realWorldTyConKey, stablePtrPrimTyConKey, stablePtrTyConKey, + anyTyConKey :: Unique addrPrimTyConKey = mkPreludeTyConUnique 1 arrayPrimTyConKey = mkPreludeTyConUnique 3 boolTyConKey = mkPreludeTyConUnique 4 @@ -956,10 +962,7 @@ realWorldTyConKey = mkPreludeTyConUnique 34 stablePtrPrimTyConKey = mkPreludeTyConUnique 35 stablePtrTyConKey = mkPreludeTyConUnique 36 - -anyPrimTyConKey, anyPrimTyCon1Key :: Unique -anyPrimTyConKey = mkPreludeTyConUnique 37 -anyPrimTyCon1Key = mkPreludeTyConUnique 38 +anyTyConKey = mkPreludeTyConUnique 37 statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey, mutVarPrimTyConKey, ioTyConKey, @@ -1026,7 +1029,8 @@ -- Coercion constructors symCoercionTyConKey, transCoercionTyConKey, leftCoercionTyConKey, - rightCoercionTyConKey, instCoercionTyConKey, unsafeCoercionTyConKey + rightCoercionTyConKey, instCoercionTyConKey, unsafeCoercionTyConKey, + csel1CoercionTyConKey, csel2CoercionTyConKey, cselRCoercionTyConKey :: Unique symCoercionTyConKey = mkPreludeTyConUnique 93 transCoercionTyConKey = mkPreludeTyConUnique 94 @@ -1034,10 +1038,13 @@ rightCoercionTyConKey = mkPreludeTyConUnique 96 instCoercionTyConKey = mkPreludeTyConUnique 97 unsafeCoercionTyConKey = mkPreludeTyConUnique 98 +csel1CoercionTyConKey = mkPreludeTyConUnique 99 +csel2CoercionTyConKey = mkPreludeTyConUnique 100 +cselRCoercionTyConKey = mkPreludeTyConUnique 101 unknownTyConKey, unknown1TyConKey, unknown2TyConKey, unknown3TyConKey, opaqueTyConKey :: Unique -unknownTyConKey = mkPreludeTyConUnique 99 +unknownTyConKey = mkPreludeTyConUnique 129 unknown1TyConKey = mkPreludeTyConUnique 130 unknown2TyConKey = mkPreludeTyConUnique 131 unknown3TyConKey = mkPreludeTyConUnique 132 @@ -1298,6 +1305,13 @@ , doubleTyConKey , floatTyConKey ] + +kindKeys :: [Unique] +kindKeys = [ liftedTypeKindTyConKey + , openTypeKindTyConKey + , unliftedTypeKindTyConKey + , ubxTupleKindTyConKey + , argTypeKindTyConKey ] \end{code} diff -ruN ghc-6.12.1/compiler/prelude/PrelRules.lhs ghc-6.13.20091231/compiler/prelude/PrelRules.lhs --- ghc-6.12.1/compiler/prelude/PrelRules.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/prelude/PrelRules.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -21,7 +21,7 @@ import CoreSyn import MkCore ( mkWildCase ) -import Id ( idUnfolding ) +import Id ( realIdUnfolding ) import Literal ( Literal(..), mkMachInt, mkMachWord , literalType , word2IntLit, int2WordLit @@ -35,7 +35,8 @@ import TysWiredIn ( boolTy, trueDataConId, falseDataConId ) import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon ) import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG ) -import CoreUtils ( cheapEqExpr, exprIsConApp_maybe ) +import CoreUtils ( cheapEqExpr ) +import CoreUnfold ( exprIsConApp_maybe ) import Type ( tyConAppTyCon, coreEqType ) import OccName ( occNameFS ) import PrelNames ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey, @@ -338,9 +339,9 @@ ru_fn = op_name, ru_nargs = 2, ru_try = rule_fn }] where - rule_fn [Lit lit, expr] = do_lit_eq lit expr - rule_fn [expr, Lit lit] = do_lit_eq lit expr - rule_fn _ = Nothing + rule_fn _ [Lit lit, expr] = do_lit_eq lit expr + rule_fn _ [expr, Lit lit] = do_lit_eq lit expr + rule_fn _ _ = Nothing do_lit_eq lit expr = Just (mkWildCase expr (literalType lit) boolTy @@ -373,7 +374,9 @@ %************************************************************************ \begin{code} -mkBasicRule :: Name -> Int -> ([CoreExpr] -> Maybe CoreExpr) -> [CoreRule] +mkBasicRule :: Name -> Int + -> (IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr) + -> [CoreRule] -- Gives the Rule the same name as the primop itself mkBasicRule op_name n_args rule_fn = [BuiltinRule { ru_name = occNameFS (nameOccName op_name), @@ -385,16 +388,16 @@ oneLit op_name test = mkBasicRule op_name 1 rule_fn where - rule_fn [Lit l1] = test (convFloating l1) - rule_fn _ = Nothing + rule_fn _ [Lit l1] = test (convFloating l1) + rule_fn _ _ = Nothing twoLits :: Name -> (Literal -> Literal -> Maybe CoreExpr) -> [CoreRule] twoLits op_name test = mkBasicRule op_name 2 rule_fn where - rule_fn [Lit l1, Lit l2] = test (convFloating l1) (convFloating l2) - rule_fn _ = Nothing + rule_fn _ [Lit l1, Lit l2] = test (convFloating l1) (convFloating l2) + rule_fn _ _ = Nothing -- When excess precision is not requested, cut down the precision of the -- Rational value to that of Float/Double. We confuse host architecture @@ -427,8 +430,8 @@ %************************************************************************ \begin{code} -tagToEnumRule :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) -tagToEnumRule [Type ty, Lit (MachInt i)] +tagToEnumRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) +tagToEnumRule _ [Type ty, Lit (MachInt i)] = ASSERT( isEnumerationTyCon tycon ) case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of @@ -441,7 +444,7 @@ tag = fromInteger i tycon = tyConAppTyCon ty -tagToEnumRule _ = Nothing +tagToEnumRule _ _ = Nothing \end{code} For dataToTag#, we can reduce if either @@ -450,18 +453,18 @@ (b) the argument is a variable whose unfolding is a known constructor \begin{code} -dataToTagRule :: [Expr CoreBndr] -> Maybe (Arg CoreBndr) -dataToTagRule [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] +dataToTagRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Arg CoreBndr) +dataToTagRule _ [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] | tag_to_enum `hasKey` tagToEnumKey , ty1 `coreEqType` ty2 = Just tag -- dataToTag (tagToEnum x) ==> x -dataToTagRule [_, val_arg] - | Just (dc,_) <- exprIsConApp_maybe val_arg +dataToTagRule id_unf [_, val_arg] + | Just (dc,_,_) <- exprIsConApp_maybe id_unf val_arg = ASSERT( not (isNewTyCon (dataConTyCon dc)) ) Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG))) -dataToTagRule _ = Nothing +dataToTagRule _ _ = Nothing \end{code} %************************************************************************ @@ -514,15 +517,15 @@ -- The rule is this: -- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) = unpackFoldrCString# "foobaz" c n -match_append_lit :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_append_lit [Type ty1, - Lit (MachStr s1), - c1, - Var unpk `App` Type ty2 - `App` Lit (MachStr s2) - `App` c2 - `App` n - ] +match_append_lit :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) +match_append_lit _ [Type ty1, + Lit (MachStr s1), + c1, + Var unpk `App` Type ty2 + `App` Lit (MachStr s2) + `App` c2 + `App` n + ] | unpk `hasKey` unpackCStringFoldrIdKey && c1 `cheapEqExpr` c2 = ASSERT( ty1 `coreEqType` ty2 ) @@ -531,26 +534,26 @@ `App` c1 `App` n) -match_append_lit _ = Nothing +match_append_lit _ _ = Nothing --------------------------------------------------- -- The rule is this: -- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2 -match_eq_string :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_eq_string [Var unpk1 `App` Lit (MachStr s1), - Var unpk2 `App` Lit (MachStr s2)] +match_eq_string :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) +match_eq_string _ [Var unpk1 `App` Lit (MachStr s1), + Var unpk2 `App` Lit (MachStr s2)] | unpk1 `hasKey` unpackCStringIdKey, unpk2 `hasKey` unpackCStringIdKey = Just (if s1 == s2 then trueVal else falseVal) -match_eq_string _ = Nothing +match_eq_string _ _ = Nothing --------------------------------------------------- -- The rule is this: -- inline f_ty (f a b c) = a b c --- (if f has an unfolding) +-- (if f has an unfolding, EVEN if it's a loop breaker) -- -- It's important to allow the argument to 'inline' to have args itself -- (a) because its more forgiving to allow the programmer to write @@ -560,11 +563,12 @@ -- programmer can't avoid -- -- Also, don't forget about 'inline's type argument! -match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_inline (Type _ : e : _) +match_inline :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) +match_inline _ (Type _ : e : _) | (Var f, args1) <- collectArgs e, - Just unf <- maybeUnfoldingTemplate (idUnfolding f) + Just unf <- maybeUnfoldingTemplate (realIdUnfolding f) + -- Ignore the IdUnfoldingFun here! = Just (mkApps unf args1) -match_inline _ = Nothing +match_inline _ _ = Nothing \end{code} diff -ruN ghc-6.12.1/compiler/prelude/PrimOp.lhs ghc-6.13.20091231/compiler/prelude/PrimOp.lhs --- ghc-6.12.1/compiler/prelude/PrimOp.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/prelude/PrimOp.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -31,7 +31,7 @@ import TysPrim import TysWiredIn -import NewDemand +import Demand import Var ( TyVar ) import OccName ( OccName, pprOccName, mkVarOccFS ) import TyCon ( TyCon, isPrimTyCon, tyConPrimRep, PrimRep(..) ) diff -ruN ghc-6.12.1/compiler/prelude/TysPrim.lhs ghc-6.13.20091231/compiler/prelude/TysPrim.lhs --- ghc-6.12.1/compiler/prelude/TysPrim.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/prelude/TysPrim.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -1,9 +1,13 @@ % % (c) The AQUA Project, Glasgow University, 1994-1998 % + + \section[TysPrim]{Wired-in knowledge about primitive types} \begin{code} +-- | This module defines TyCons that can't be expressed in Haskell. +-- They are all, therefore, wired-in TyCons. C.f module TysWiredIn module TysPrim( alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, alphaTy, betaTy, gammaTy, deltaTy, @@ -41,20 +45,21 @@ int64PrimTyCon, int64PrimTy, word64PrimTyCon, word64PrimTy, - anyPrimTyCon, anyPrimTy, anyPrimTyCon1, mkAnyPrimTyCon + -- * Any + anyTyCon, anyType, anyTyConOfKind, anyTypeOfKind ) where #include "HsVersions.h" import Var ( TyVar, mkTyVar ) import Name ( Name, BuiltInSyntax(..), mkInternalName, mkWiredInName ) +import OccName ( mkTcOcc ) import OccName ( mkTyVarOccFS, mkTcOccFS ) -import TyCon ( TyCon, mkPrimTyCon, mkLiftedPrimTyCon ) +import TyCon ( TyCon, mkPrimTyCon, mkLiftedPrimTyCon, mkAnyTyCon ) import Type import SrcLoc -import Unique ( mkAlphaTyVarUnique, pprUnique ) +import Unique ( mkAlphaTyVarUnique ) import PrelNames -import StaticFlags import FastString import Outputable @@ -94,7 +99,7 @@ , wordPrimTyCon , word32PrimTyCon , word64PrimTyCon - , anyPrimTyCon, anyPrimTyCon1 + , anyTyCon ] mkPrimTc :: FastString -> Unique -> TyCon -> Name @@ -104,7 +109,7 @@ (ATyCon tycon) -- Relevant TyCon UserSyntax -- None are built-in syntax -charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, anyPrimTyConName, anyPrimTyCon1Name :: Name +charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName :: Name charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon int32PrimTyConName = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon @@ -129,8 +134,6 @@ bcoPrimTyConName = mkPrimTc (fsLit "BCO#") bcoPrimTyConKey bcoPrimTyCon weakPrimTyConName = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon threadIdPrimTyConName = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon -anyPrimTyConName = mkPrimTc (fsLit "Any") anyPrimTyConKey anyPrimTyCon -anyPrimTyCon1Name = mkPrimTc (fsLit "Any1") anyPrimTyCon1Key anyPrimTyCon1 \end{code} %************************************************************************ @@ -182,6 +185,115 @@ %************************************************************************ %* * + Any +%* * +%************************************************************************ + +Note [Any types] +~~~~~~~~~~~~~~~~ +The type constructor Any::* has these properties + + * It is defined in module GHC.Prim, and exported so that it is + available to users. For this reason it's treated like any other + primitive type: + - has a fixed unique, anyTyConKey, + - lives in the global name cache + - built with TyCon.PrimTyCon + + * It is lifted, and hence represented by a pointer + + * It is inhabited by at least one value, namely bottom + + * You can unsafely coerce any lifted type to Ayny, and back. + + * It does not claim to be a *data* type, and that's important for + the code generator, because the code gen may *enter* a data value + but never enters a function value. + + * It is used to instantiate otherwise un-constrained type variables of kind * + For example length Any [] + See Note [Strangely-kinded void TyCons] + +In addition, we have a potentially-infinite family of types, one for +each kind /other than/ *, needed to instantiate otherwise +un-constrained type variables of kinds other than *. This is a bit +like tuples; there is a potentially-infinite family. They have slightly +different characteristics to Any::*: + + * They are built with TyCon.AnyTyCon + * They have non-user-writable names like "Any(*->*)" + * They are not exported by GHC.Prim + * They are uninhabited (of course; not kind *) + * They have a unique derived from their OccName (see Note [Uniques of Any]) + * Their Names do not live in the global name cache + +Note [Uniques of Any] +~~~~~~~~~~~~~~~~~~~~~ +Although Any(*->*), say, doesn't have a binding site, it still needs +to have a Unique. Unlike tuples (which are also an infinite family) +there is no convenient way to index them, so we use the Unique from +their OccName instead. That should be unique! (But in principle we +must take care: it does not include the module/package.) + +Note [Strangely-kinded void TyCons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See Trac #959 for more examples + +When the type checker finds a type variable with no binding, which +means it can be instantiated with an arbitrary type, it usually +instantiates it to Void. Eg. + + length [] +===> + length Any (Nil Any) + +But in really obscure programs, the type variable might have a kind +other than *, so we need to invent a suitably-kinded type. + +This commit uses + Any for kind * + Any(*->*) for kind *->* + etc + +\begin{code} +anyTyConName :: Name +anyTyConName = mkPrimTc (fsLit "Any") anyTyConKey anyTyCon + +anyTyCon :: TyCon +anyTyCon = mkLiftedPrimTyCon anyTyConName liftedTypeKind 0 PtrRep + +anyType :: Type +anyType = mkTyConApp anyTyCon [] + +anyTypeOfKind :: Kind -> Type +anyTypeOfKind kind + | isLiftedTypeKind kind = anyType + | otherwise = mkTyConApp (mk_any_tycon kind) [] + +anyTyConOfKind :: Kind -> TyCon +anyTyConOfKind kind + | isLiftedTypeKind kind = anyTyCon + | otherwise = mk_any_tycon kind + +mk_any_tycon :: Kind -> TyCon +mk_any_tycon kind -- Kind other than * + = tycon + where + -- Derive the name from the kind, thus: + -- Any(*->*), Any(*->*->*) + -- These are names that can't be written by the user, + -- and are not allocated in the global name cache + str = "Any" ++ showSDoc (pprParendKind kind) + + occ = mkTcOcc str + uniq = getUnique occ -- See Note [Uniques of Any] + name = mkWiredInName gHC_PRIM occ uniq (ATyCon tycon) UserSyntax + tycon = mkAnyTyCon name kind +\end{code} + + +%************************************************************************ +%* * \subsection[TysPrim-basic]{Basic primitive types (@Char#@, @Int#@, etc.)} %* * %************************************************************************ @@ -294,54 +406,6 @@ %************************************************************************ %* * - Any -%* * -%************************************************************************ - -The type constructor Any is type to which you can unsafely coerce any -lifted type, and back. - - * It is lifted, and hence represented by a pointer - - * It does not claim to be a *data* type, and that's important for - the code generator, because the code gen may *enter* a data value - but never enters a function value. - -It's also used to instantiate un-constrained type variables after type -checking. For example - length Any [] -Annoyingly, we sometimes need Anys of other kinds, such as (*->*) etc. -This is a bit like tuples. We define a couple of useful ones here, -and make others up on the fly. If any of these others end up being exported -into interface files, we'll get a crash; at least until we add interface-file -syntax to support them. - -\begin{code} -anyPrimTy :: Type -anyPrimTy = mkTyConApp anyPrimTyCon [] - -anyPrimTyCon :: TyCon -- Kind * -anyPrimTyCon = mkLiftedPrimTyCon anyPrimTyConName liftedTypeKind 0 PtrRep - -anyPrimTyCon1 :: TyCon -- Kind *->* -anyPrimTyCon1 = mkLiftedPrimTyCon anyPrimTyCon1Name kind 0 PtrRep - where - kind = mkArrowKind liftedTypeKind liftedTypeKind - -mkAnyPrimTyCon :: Unique -> Kind -> TyCon --- Grotesque hack alert: the client gives the unique; so equality won't work -mkAnyPrimTyCon unique kind - = WARN( opt_PprStyle_Debug, ptext (sLit "Urk! Inventing strangely-kinded Any TyCon:") <+> ppr unique <+> ppr kind ) - -- See Note [Strangely-kinded void TyCons] in TcHsSyn - tycon - where - name = mkPrimTc (mkFastString ("Any" ++ showSDoc (pprUnique unique))) unique tycon - tycon = mkLiftedPrimTyCon name kind 0 PtrRep -\end{code} - - -%************************************************************************ -%* * \subsection[TysPrim-arrays]{The primitive array types} %* * %************************************************************************ diff -ruN ghc-6.12.1/compiler/prelude/TysWiredIn.lhs ghc-6.13.20091231/compiler/prelude/TysWiredIn.lhs --- ghc-6.12.1/compiler/prelude/TysWiredIn.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/prelude/TysWiredIn.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -3,12 +3,9 @@ % \section[TysWiredIn]{Wired-in knowledge about {\em non-primitive} types} -This module tracks the ``state interface'' document, ``GHC prelude: -types and operations.'' - \begin{code} -- | This module is about types that can be defined in Haskell, but which --- must be wired into the compiler nonetheless. +-- must be wired into the compiler nonetheless. C.f module TysPrim module TysWiredIn ( -- * All wired in things wiredInTyCons, @@ -41,7 +38,7 @@ mkListTy, -- * Tuples - mkTupleTy, + mkTupleTy, mkBoxedTupleTy, tupleTyCon, tupleCon, unitTyCon, unitDataCon, unitDataConId, pairTyCon, unboxedSingletonTyCon, unboxedSingletonDataCon, @@ -329,6 +326,7 @@ unboxedPairDataCon = tupleCon Unboxed 2 \end{code} + %************************************************************************ %* * \subsection[TysWiredIn-boxed-prim]{The ``boxed primitive'' types (@Char@, @Int@, etc)} @@ -536,11 +534,17 @@ \end{itemize} \begin{code} -mkTupleTy :: Boxity -> Int -> [Type] -> Type -mkTupleTy boxity arity tys = mkTyConApp (tupleTyCon boxity arity) tys +mkTupleTy :: Boxity -> [Type] -> Type +-- Special case for *boxed* 1-tuples, which are represented by the type itself +mkTupleTy boxity [ty] | Boxed <- boxity = ty +mkTupleTy boxity tys = mkTyConApp (tupleTyCon boxity (length tys)) tys + +-- | Build the type of a small tuple that holds the specified type of thing +mkBoxedTupleTy :: [Type] -> Type +mkBoxedTupleTy tys = mkTupleTy Boxed tys unitTy :: Type -unitTy = mkTupleTy Boxed 0 [] +unitTy = mkTupleTy Boxed [] \end{code} %************************************************************************ diff -ruN ghc-6.12.1/compiler/rename/RnEnv.lhs ghc-6.13.20091231/compiler/rename/RnEnv.lhs --- ghc-6.12.1/compiler/rename/RnEnv.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/rename/RnEnv.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -284,12 +284,12 @@ | otherwise -- Find all the things the rdr-name maps to = do { -- and pick the one with the right parent name ; env <- getGlobalRdrEnv - ; let gres = (lookupGlobalRdrEnv env (rdrNameOcc rdr_name)) + ; let gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name) ; case pick parent gres of -- NB: lookupGlobalRdrEnv, not lookupGRE_RdrName! -- The latter does pickGREs, but we want to allow 'x' -- even if only 'M.x' is in scope - [gre] -> do { addUsedRdrName gre rdr_name + [gre] -> do { addUsedRdrNames (used_rdr_names gre) ; return (gre_name gre) } [] -> do { addErr (unknownSubordinateErr doc rdr_name) ; traceRn (text "RnEnv.lookup_sub_bndr" <+> (ppr rdr_name $$ ppr gres)) @@ -306,6 +306,15 @@ right_parent p (GRE { gre_par = ParentIs p' }) = p==p' right_parent _ _ = False + -- Note [Usage for sub-bndrs] + used_rdr_names gre + | isQual rdr_name = [rdr_name] + | otherwise = case gre_prov gre of + LocalDef -> [rdr_name] + Imported is -> map mk_qual_rdr is + mk_qual_rdr imp_spec = mkRdrQual (is_as (is_decl imp_spec)) rdr_occ + rdr_occ = rdrNameOcc rdr_name + newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name) newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr) @@ -320,12 +329,25 @@ (gre:_) -> return $ gre_name gre -- if there is more than one, an error will be raised elsewhere [] -> lookupOccRn rdr_name +\end{code} +Note [Usage for sub-bndrs] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +If you have this + import qualified M( C( f ) ) + intance M.C T where + f x = x +then is the qualified import M.f used? Obviously yes. +But the RdrName used in the instance decl is unqualified. In effect, +we fill in the qualification by looking for f's whose class is M.C +But when adding to the UsedRdrNames we must make that qualification +explicit, otherwise we get "Redundant import of M.C". -------------------------------------------------- -- Occurrences -------------------------------------------------- +\begin{code} getLookupOccRn :: RnM (Name -> Maybe Name) getLookupOccRn = getLocalRdrEnv `thenM` \ local_env -> diff -ruN ghc-6.12.1/compiler/rename/RnNames.lhs ghc-6.13.20091231/compiler/rename/RnNames.lhs --- ghc-6.12.1/compiler/rename/RnNames.lhs 2009-12-10 10:11:33.000000000 -0800 +++ ghc-6.13.20091231/compiler/rename/RnNames.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -722,7 +722,7 @@ mkChildEnv :: [GlobalRdrElt] -> NameEnv [Name] mkChildEnv gres = foldr add emptyNameEnv gres where - add (GRE { gre_name = n, gre_par = ParentIs p }) env = extendNameEnv_C (++) env p [n] + add (GRE { gre_name = n, gre_par = ParentIs p }) env = extendNameEnv_Acc (:) singleton env p n add _ env = env findChildren :: NameEnv [Name] -> Name -> [Name] diff -ruN ghc-6.12.1/compiler/simplCore/CoreMonad.lhs ghc-6.13.20091231/compiler/simplCore/CoreMonad.lhs --- ghc-6.12.1/compiler/simplCore/CoreMonad.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/simplCore/CoreMonad.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -7,11 +7,22 @@ {-# LANGUAGE UndecidableInstances #-} module CoreMonad ( + -- * Configuration of the core-to-core passes + CoreToDo(..), + SimplifierMode(..), + SimplifierSwitch(..), + FloatOutSwitches(..), + getCoreToDo, dumpSimplPhase, + + -- * Counting + SimplCount, doSimplTick, doFreeSimplTick, + pprSimplCount, plusSimplCount, zeroSimplCount, isZeroSimplCount, Tick(..), + -- * The monad CoreM, runCoreM, -- ** Reading from the monad - getHscEnv, getAnnEnv, getRuleBase, getModule, + getHscEnv, getRuleBase, getModule, getDynFlags, getOrigNameCache, -- ** Writing to the monad @@ -22,8 +33,11 @@ liftIO1, liftIO2, liftIO3, liftIO4, -- ** Dealing with annotations - findAnnotations, addAnnotation, + getAnnotations, getFirstAnnotations, + -- ** Debug output + endPass, endPassIf, endIteration, + -- ** Screen output putMsg, putMsgS, errorMsg, errorMsgS, fatalErrorMsg, fatalErrorMsgS, @@ -39,14 +53,19 @@ #ifdef GHCI import Name( Name ) #endif +import CoreSyn +import PprCore +import CoreUtils +import CoreLint ( lintCoreBindings ) import PrelNames ( iNTERACTIVE ) import HscTypes -import Module ( Module ) -import DynFlags ( DynFlags, DynFlag ) -import SimplMonad ( SimplCount, plusSimplCount, zeroSimplCount ) +import Module ( PackageId, Module ) +import DynFlags +import StaticFlags import Rules ( RuleBase ) +import BasicTypes ( CompilerPhase ) import Annotations -import Serialized +import Id ( Id ) import IOEnv hiding ( liftIO, failM, failWithM ) import qualified IOEnv ( liftIO ) @@ -54,10 +73,15 @@ import TcRnMonad ( TcM, initTc ) import Outputable +import FastString import qualified ErrUtils as Err import Maybes import UniqSupply +import LazyUniqFM ( UniqFM, mapUFM, filterUFM ) +import FiniteMap +import Util ( split ) +import Data.List ( intersperse ) import Data.Dynamic import Data.IORef import Data.Word @@ -71,12 +95,585 @@ #endif \end{code} -\subsection{Monad and carried data structure definitions} +%************************************************************************ +%* * + Debug output +%* * +%************************************************************************ + +These functions are not CoreM monad stuff, but they probably ought to +be, and it makes a conveneint place. place for them. They print out +stuff before and after core passes, and do Core Lint when necessary. + +\begin{code} +endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO () +endPass = dumpAndLint Err.dumpIfSet_core + +endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO () +endPassIf cond = dumpAndLint (Err.dumpIf_core cond) + +-- Same as endPass but doesn't dump Core even with -dverbose-core2core +endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO () +endIteration = dumpAndLint Err.dumpIfSet_dyn + +dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ()) + -> DynFlags -> String -> DynFlag + -> [CoreBind] -> [CoreRule] -> IO () +dumpAndLint dump dflags pass_name dump_flag binds rules + = do { -- Report result size if required + -- This has the side effect of forcing the intermediate to be evaluated + ; Err.debugTraceMsg dflags 2 $ + (text " Result size =" <+> int (coreBindsSize binds)) + + -- Report verbosely, if required + ; dump dflags dump_flag pass_name + (pprCoreBindings binds $$ ppUnless (null rules) pp_rules) + + -- Type check + ; lintCoreBindings dflags pass_name binds } + where + pp_rules = vcat [ blankLine + , ptext (sLit "------ Local rules for imported ids --------") + , pprRules rules ] +\end{code} + + +%************************************************************************ +%* * + The CoreToDo type and related types + Abstraction of core-to-core passes to run. +%* * +%************************************************************************ + +\begin{code} +data CoreToDo -- These are diff core-to-core passes, + -- which may be invoked in any order, + -- as many times as you like. + + = CoreDoSimplify -- The core-to-core simplifier. + SimplifierMode + [SimplifierSwitch] + -- Each run of the simplifier can take a different + -- set of simplifier-specific flags. + | CoreDoFloatInwards + | CoreDoFloatOutwards FloatOutSwitches + | CoreLiberateCase + | CoreDoPrintCore + | CoreDoStaticArgs + | CoreDoStrictness + | CoreDoWorkerWrapper + | CoreDoSpecialising + | CoreDoSpecConstr + | CoreDoOldStrictness + | CoreDoGlomBinds + | CoreCSE + | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules + -- matching this string + | CoreDoVectorisation PackageId + | CoreDoNothing -- Useful when building up + | CoreDoPasses [CoreToDo] -- lists of these things + + +data SimplifierMode -- See comments in SimplMonad + = SimplGently + { sm_rules :: Bool -- Whether RULES are enabled + , sm_inline :: Bool } -- Whether inlining is enabled + + | SimplPhase + { sm_num :: Int -- Phase number; counts downward so 0 is last phase + , sm_names :: [String] } -- Name(s) of the phase + +instance Outputable SimplifierMode where + ppr (SimplPhase { sm_num = n, sm_names = ss }) + = int n <+> brackets (text (concat $ intersperse "," ss)) + ppr (SimplGently { sm_rules = r, sm_inline = i }) + = ptext (sLit "gentle") <> + brackets (pp_flag r (sLit "rules") <> comma <> + pp_flag i (sLit "inline")) + where + pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s + +data SimplifierSwitch + = MaxSimplifierIterations Int + | NoCaseOfCase + +data FloatOutSwitches = FloatOutSwitches { + floatOutLambdas :: Bool, -- ^ True <=> float lambdas to top level + floatOutConstants :: Bool -- ^ True <=> float constants to top level, + -- even if they do not escape a lambda + } + +instance Outputable FloatOutSwitches where + ppr = pprFloatOutSwitches + +pprFloatOutSwitches :: FloatOutSwitches -> SDoc +pprFloatOutSwitches sw = pp_not (floatOutLambdas sw) <+> text "lambdas" <> comma + <+> pp_not (floatOutConstants sw) <+> text "constants" + where + pp_not True = empty + pp_not False = text "not" + +-- | Switches that specify the minimum amount of floating out +-- gentleFloatOutSwitches :: FloatOutSwitches +-- gentleFloatOutSwitches = FloatOutSwitches False False + +-- | Switches that do not specify floating out of lambdas, just of constants +constantsOnlyFloatOutSwitches :: FloatOutSwitches +constantsOnlyFloatOutSwitches = FloatOutSwitches False True +\end{code} + + +%************************************************************************ +%* * + Generating the main optimisation pipeline +%* * +%************************************************************************ + +\begin{code} +getCoreToDo :: DynFlags -> [CoreToDo] +getCoreToDo dflags + = core_todo + where + opt_level = optLevel dflags + phases = simplPhases dflags + max_iter = maxSimplIterations dflags + strictness = dopt Opt_Strictness dflags + full_laziness = dopt Opt_FullLaziness dflags + do_specialise = dopt Opt_Specialise dflags + do_float_in = dopt Opt_FloatIn dflags + cse = dopt Opt_CSE dflags + spec_constr = dopt Opt_SpecConstr dflags + liberate_case = dopt Opt_LiberateCase dflags + rule_check = ruleCheck dflags + static_args = dopt Opt_StaticArgumentTransformation dflags + + maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase) + + maybe_strictness_before phase + = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness + + simpl_phase phase names iter + = CoreDoPasses + [ maybe_strictness_before phase, + CoreDoSimplify (SimplPhase phase names) [ + MaxSimplifierIterations iter + ], + maybe_rule_check phase + ] + + vectorisation + = runWhen (dopt Opt_Vectorise dflags) + $ CoreDoPasses [ simpl_gently, CoreDoVectorisation (dphPackage dflags) ] + + + -- By default, we have 2 phases before phase 0. + + -- Want to run with inline phase 2 after the specialiser to give + -- maximum chance for fusion to work before we inline build/augment + -- in phase 1. This made a difference in 'ansi' where an + -- overloaded function wasn't inlined till too late. + + -- Need phase 1 so that build/augment get + -- inlined. I found that spectral/hartel/genfft lost some useful + -- strictness in the function sumcode' if augment is not inlined + -- before strictness analysis runs + simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter + | phase <- [phases, phases-1 .. 1] ] + + + -- initial simplify: mk specialiser happy: minimum effort please + simpl_gently = CoreDoSimplify + (SimplGently { sm_rules = True, sm_inline = False }) + [ + -- Simplify "gently" + -- Don't inline anything till full laziness has bitten + -- In particular, inlining wrappers inhibits floating + -- e.g. ...(case f x of ...)... + -- ==> ...(case (case x of I# x# -> fw x#) of ...)... + -- ==> ...(case x of I# x# -> case fw x# of ...)... + -- and now the redex (f x) isn't floatable any more + -- Similarly, don't apply any rules until after full + -- laziness. Notably, list fusion can prevent floating. + + NoCaseOfCase, -- Don't do case-of-case transformations. + -- This makes full laziness work better + MaxSimplifierIterations max_iter + ] + + core_todo = + if opt_level == 0 then + [vectorisation, + simpl_phase 0 ["final"] max_iter] + else {- opt_level >= 1 -} [ + + -- We want to do the static argument transform before full laziness as it + -- may expose extra opportunities to float things outwards. However, to fix + -- up the output of the transformation we need at do at least one simplify + -- after this before anything else + runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]), + + -- We run vectorisation here for now, but we might also try to run + -- it later + vectorisation, + + -- initial simplify: mk specialiser happy: minimum effort please + simpl_gently, + + -- Specialisation is best done before full laziness + -- so that overloaded functions have all their dictionary lambdas manifest + runWhen do_specialise CoreDoSpecialising, + + runWhen full_laziness (CoreDoFloatOutwards constantsOnlyFloatOutSwitches), + -- Was: gentleFloatOutSwitches + -- I have no idea why, but not floating constants to top level is + -- very bad in some cases. + -- Notably: p_ident in spectral/rewrite + -- Changing from "gentle" to "constantsOnly" improved + -- rewrite's allocation by 19%, and made 0.0% difference + -- to any other nofib benchmark + + runWhen do_float_in CoreDoFloatInwards, + + simpl_phases, + + -- Phase 0: allow all Ids to be inlined now + -- This gets foldr inlined before strictness analysis + + -- At least 3 iterations because otherwise we land up with + -- huge dead expressions because of an infelicity in the + -- simpifier. + -- let k = BIG in foldr k z xs + -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs + -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs + -- Don't stop now! + simpl_phase 0 ["main"] (max max_iter 3), + + runWhen strictness (CoreDoPasses [ + CoreDoStrictness, + CoreDoWorkerWrapper, + CoreDoGlomBinds, + simpl_phase 0 ["post-worker-wrapper"] max_iter + ]), + + runWhen full_laziness + (CoreDoFloatOutwards constantsOnlyFloatOutSwitches), + -- nofib/spectral/hartel/wang doubles in speed if you + -- do full laziness late in the day. It only happens + -- after fusion and other stuff, so the early pass doesn't + -- catch it. For the record, the redex is + -- f_el22 (f_el21 r_midblock) + + + runWhen cse CoreCSE, + -- We want CSE to follow the final full-laziness pass, because it may + -- succeed in commoning up things floated out by full laziness. + -- CSE used to rely on the no-shadowing invariant, but it doesn't any more + + runWhen do_float_in CoreDoFloatInwards, + + maybe_rule_check 0, + + -- Case-liberation for -O2. This should be after + -- strictness analysis and the simplification which follows it. + runWhen liberate_case (CoreDoPasses [ + CoreLiberateCase, + simpl_phase 0 ["post-liberate-case"] max_iter + ]), -- Run the simplifier after LiberateCase to vastly + -- reduce the possiblility of shadowing + -- Reason: see Note [Shadowing] in SpecConstr.lhs + + runWhen spec_constr CoreDoSpecConstr, + + maybe_rule_check 0, + + -- Final clean-up simplification: + simpl_phase 0 ["final"] max_iter + ] + +-- The core-to-core pass ordering is derived from the DynFlags: +runWhen :: Bool -> CoreToDo -> CoreToDo +runWhen True do_this = do_this +runWhen False _ = CoreDoNothing + +runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo +runMaybe (Just x) f = f x +runMaybe Nothing _ = CoreDoNothing + +dumpSimplPhase :: DynFlags -> SimplifierMode -> Bool +dumpSimplPhase dflags mode + | Just spec_string <- shouldDumpSimplPhase dflags + = match_spec spec_string + | otherwise + = dopt Opt_D_verbose_core2core dflags + + where + match_spec :: String -> Bool + match_spec spec_string + = or $ map (and . map match . split ':') + $ split ',' spec_string + + match :: String -> Bool + match "" = True + match s = case reads s of + [(n,"")] -> phase_num n + _ -> phase_name s + + phase_num :: Int -> Bool + phase_num n = case mode of + SimplPhase k _ -> n == k + _ -> False + + phase_name :: String -> Bool + phase_name s = case mode of + SimplGently {} -> s == "gentle" + SimplPhase { sm_names = ss } -> s `elem` ss +\end{code} + + +%************************************************************************ +%* * + Counting and logging +%* * +%************************************************************************ + +\begin{code} +verboseSimplStats :: Bool +verboseSimplStats = opt_PprStyle_Debug -- For now, anyway + +zeroSimplCount :: DynFlags -> SimplCount +isZeroSimplCount :: SimplCount -> Bool +pprSimplCount :: SimplCount -> SDoc +doSimplTick, doFreeSimplTick :: Tick -> SimplCount -> SimplCount +plusSimplCount :: SimplCount -> SimplCount -> SimplCount +\end{code} + +\begin{code} +data SimplCount + = VerySimplZero -- These two are used when + | VerySimplNonZero -- we are only interested in + -- termination info + + | SimplCount { + ticks :: !Int, -- Total ticks + details :: !TickCounts, -- How many of each type + + n_log :: !Int, -- N + log1 :: [Tick], -- Last N events; <= opt_HistorySize, + -- most recent first + log2 :: [Tick] -- Last opt_HistorySize events before that + -- Having log1, log2 lets us accumulate the + -- recent history reasonably efficiently + } + +type TickCounts = FiniteMap Tick Int + +zeroSimplCount dflags + -- This is where we decide whether to do + -- the VerySimpl version or the full-stats version + | dopt Opt_D_dump_simpl_stats dflags + = SimplCount {ticks = 0, details = emptyFM, + n_log = 0, log1 = [], log2 = []} + | otherwise + = VerySimplZero + +isZeroSimplCount VerySimplZero = True +isZeroSimplCount (SimplCount { ticks = 0 }) = True +isZeroSimplCount _ = False + +doFreeSimplTick tick sc@SimplCount { details = dts } + = sc { details = dts `addTick` tick } +doFreeSimplTick _ sc = sc + +doSimplTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 } + | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 } + | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 } + where + sc1 = sc { ticks = tks+1, details = dts `addTick` tick } + +doSimplTick _ _ = VerySimplNonZero -- The very simple case + + +-- Don't use plusFM_C because that's lazy, and we want to +-- be pretty strict here! +addTick :: TickCounts -> Tick -> TickCounts +addTick fm tick = case lookupFM fm tick of + Nothing -> addToFM fm tick 1 + Just n -> n1 `seq` addToFM fm tick n1 + where + n1 = n+1 + + +plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 }) + sc2@(SimplCount { ticks = tks2, details = dts2 }) + = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 } + where + -- A hackish way of getting recent log info + log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2 + | null (log2 sc2) = sc2 { log2 = log1 sc1 } + | otherwise = sc2 + +plusSimplCount VerySimplZero VerySimplZero = VerySimplZero +plusSimplCount _ _ = VerySimplNonZero + +pprSimplCount VerySimplZero = ptext (sLit "Total ticks: ZERO!") +pprSimplCount VerySimplNonZero = ptext (sLit "Total ticks: NON-ZERO!") +pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 }) + = vcat [ptext (sLit "Total ticks: ") <+> int tks, + blankLine, + pprTickCounts (fmToList dts), + if verboseSimplStats then + vcat [blankLine, + ptext (sLit "Log (most recent first)"), + nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))] + else empty + ] + +pprTickCounts :: [(Tick,Int)] -> SDoc +pprTickCounts [] = empty +pprTickCounts ((tick1,n1):ticks) + = vcat [int tot_n <+> text (tickString tick1), + pprTCDetails real_these, + pprTickCounts others + ] + where + tick1_tag = tickToTag tick1 + (these, others) = span same_tick ticks + real_these = (tick1,n1):these + same_tick (tick2,_) = tickToTag tick2 == tick1_tag + tot_n = sum [n | (_,n) <- real_these] + +pprTCDetails :: [(Tick, Int)] -> SDoc +pprTCDetails ticks + = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks]) +\end{code} + \begin{code} -data CoreState = CoreState { - cs_uniq_supply :: UniqSupply, - cs_ann_env :: AnnEnv +data Tick + = PreInlineUnconditionally Id + | PostInlineUnconditionally Id + + | UnfoldingDone Id + | RuleFired FastString -- Rule name + + | LetFloatFromLet + | EtaExpansion Id -- LHS binder + | EtaReduction Id -- Binder on outer lambda + | BetaReduction Id -- Lambda binder + + + | CaseOfCase Id -- Bndr on *inner* case + | KnownBranch Id -- Case binder + | CaseMerge Id -- Binder on outer case + | AltMerge Id -- Case binder + | CaseElim Id -- Case binder + | CaseIdentity Id -- Case binder + | FillInCaseDefault Id -- Case binder + + | BottomFound + | SimplifierDone -- Ticked at each iteration of the simplifier + +instance Outputable Tick where + ppr tick = text (tickString tick) <+> pprTickCts tick + +instance Eq Tick where + a == b = case a `cmpTick` b of + EQ -> True + _ -> False + +instance Ord Tick where + compare = cmpTick + +tickToTag :: Tick -> Int +tickToTag (PreInlineUnconditionally _) = 0 +tickToTag (PostInlineUnconditionally _) = 1 +tickToTag (UnfoldingDone _) = 2 +tickToTag (RuleFired _) = 3 +tickToTag LetFloatFromLet = 4 +tickToTag (EtaExpansion _) = 5 +tickToTag (EtaReduction _) = 6 +tickToTag (BetaReduction _) = 7 +tickToTag (CaseOfCase _) = 8 +tickToTag (KnownBranch _) = 9 +tickToTag (CaseMerge _) = 10 +tickToTag (CaseElim _) = 11 +tickToTag (CaseIdentity _) = 12 +tickToTag (FillInCaseDefault _) = 13 +tickToTag BottomFound = 14 +tickToTag SimplifierDone = 16 +tickToTag (AltMerge _) = 17 + +tickString :: Tick -> String +tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally" +tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally" +tickString (UnfoldingDone _) = "UnfoldingDone" +tickString (RuleFired _) = "RuleFired" +tickString LetFloatFromLet = "LetFloatFromLet" +tickString (EtaExpansion _) = "EtaExpansion" +tickString (EtaReduction _) = "EtaReduction" +tickString (BetaReduction _) = "BetaReduction" +tickString (CaseOfCase _) = "CaseOfCase" +tickString (KnownBranch _) = "KnownBranch" +tickString (CaseMerge _) = "CaseMerge" +tickString (AltMerge _) = "AltMerge" +tickString (CaseElim _) = "CaseElim" +tickString (CaseIdentity _) = "CaseIdentity" +tickString (FillInCaseDefault _) = "FillInCaseDefault" +tickString BottomFound = "BottomFound" +tickString SimplifierDone = "SimplifierDone" + +pprTickCts :: Tick -> SDoc +pprTickCts (PreInlineUnconditionally v) = ppr v +pprTickCts (PostInlineUnconditionally v)= ppr v +pprTickCts (UnfoldingDone v) = ppr v +pprTickCts (RuleFired v) = ppr v +pprTickCts LetFloatFromLet = empty +pprTickCts (EtaExpansion v) = ppr v +pprTickCts (EtaReduction v) = ppr v +pprTickCts (BetaReduction v) = ppr v +pprTickCts (CaseOfCase v) = ppr v +pprTickCts (KnownBranch v) = ppr v +pprTickCts (CaseMerge v) = ppr v +pprTickCts (AltMerge v) = ppr v +pprTickCts (CaseElim v) = ppr v +pprTickCts (CaseIdentity v) = ppr v +pprTickCts (FillInCaseDefault v) = ppr v +pprTickCts _ = empty + +cmpTick :: Tick -> Tick -> Ordering +cmpTick a b = case (tickToTag a `compare` tickToTag b) of + GT -> GT + EQ -> cmpEqTick a b + LT -> LT + +cmpEqTick :: Tick -> Tick -> Ordering +cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b +cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b +cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b +cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b +cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b +cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b +cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b +cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b +cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b +cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b +cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b +cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b +cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b +cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b +cmpEqTick _ _ = EQ +\end{code} + + +%************************************************************************ +%* * + Monad and carried data structure definitions +%* * +%************************************************************************ + +\begin{code} +newtype CoreState = CoreState { + cs_uniq_supply :: UniqSupply } data CoreReader = CoreReader { @@ -135,13 +732,12 @@ return us1 runCoreM :: HscEnv - -> AnnEnv -> RuleBase -> UniqSupply -> Module -> CoreM a -> IO (a, SimplCount) -runCoreM hsc_env ann_env rule_base us mod m = +runCoreM hsc_env rule_base us mod m = liftM extract $ runIOEnv reader $ unCoreM m state where reader = CoreReader { @@ -150,8 +746,7 @@ cr_module = mod } state = CoreState { - cs_uniq_supply = us, - cs_ann_env = ann_env + cs_uniq_supply = us } extract :: (a, CoreState, CoreWriter) -> (a, SimplCount) @@ -159,7 +754,12 @@ \end{code} -\subsection{Core combinators, not exported} + +%************************************************************************ +%* * + Core combinators, not exported +%* * +%************************************************************************ \begin{code} @@ -199,16 +799,18 @@ \end{code} -\subsection{Reader, writer and state accessors} + +%************************************************************************ +%* * + Reader, writer and state accessors +%* * +%************************************************************************ \begin{code} getHscEnv :: CoreM HscEnv getHscEnv = read cr_hsc_env -getAnnEnv :: CoreM AnnEnv -getAnnEnv = getS cs_ann_env - getRuleBase :: CoreM RuleBase getRuleBase = read cr_rule_base @@ -232,34 +834,59 @@ \end{code} -\subsection{Dealing with annotations} -\begin{code} +%************************************************************************ +%* * + Dealing with annotations +%* * +%************************************************************************ --- | Find all the annotations we currently know about for the given target. Note that no --- annotations will be returned if we haven't loaded information about the particular target --- you are inquiring about: by default, only those modules that have been imported by the --- program being compiled will have been loaded in this way. +\begin{code} +-- | Get all annotations of a given type. This happens lazily, that is +-- no deserialization will take place until the [a] is actually demanded and +-- the [a] can also be empty (the UniqFM is not filtered). -- --- To load the information from additional modules, you can use the functions 'DynamicLoading.forceLoadModuleInterfaces' --- and 'DynamicLoading.forceLoadNameModuleInterface', but be aware that doing this indiscriminantly --- will impose a performance penalty. +-- This should be done once at the start of a Core-to-Core pass that uses +-- annotations. -- --- If no deserialization function is supplied, only transient annotations will be returned. -findAnnotations :: Typeable a => ([Word8] -> a) -> CoreAnnTarget -> CoreM [a] -findAnnotations deserialize target = do - ann_env <- getAnnEnv - return (findAnns deserialize ann_env target) - -addAnnotation :: Typeable a => (a -> [Word8]) -> CoreAnnTarget -> a -> CoreM () -addAnnotation serialize target what = addAnnotationToEnv $ Annotation { ann_target = target, ann_value = toSerialized serialize what } - -addAnnotationToEnv :: Annotation -> CoreM () -addAnnotationToEnv annotation = modifyS (\state -> state { cs_ann_env = extendAnnEnvList (cs_ann_env state) [annotation] }) - +-- See Note [Annotations] +getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a]) +getAnnotations deserialize guts = do + hsc_env <- getHscEnv + ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts) + return (deserializeAnns deserialize ann_env) + +-- | Get at most one annotation of a given type per Unique. +getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a) +getFirstAnnotations deserialize guts + = liftM (mapUFM head . filterUFM (not . null)) + $ getAnnotations deserialize guts + \end{code} -\subsection{Direct screen output} +Note [Annotations] +~~~~~~~~~~~~~~~~~~ +A Core-to-Core pass that wants to make use of annotations calls +getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with +annotations of a specific type. This produces all annotations from interface +files read so far. However, annotations from interface files read during the +pass will not be visible until getAnnotations is called again. This is similar +to how rules work and probably isn't too bad. + +The current implementation could be optimised a bit: when looking up +annotations for a thing from the HomePackageTable, we could search directly in +the module where the thing is defined rather than building one UniqFM which +contains all annotations we know of. This would work because annotations can +only be given to things defined in the same module. However, since we would +only want to deserialise every annotation once, we would have to build a cache +for every module in the HTP. In the end, it's probably not worth it as long as +we aren't using annotations heavily. + +%************************************************************************ +%* * + Direct screen output +%* * +%************************************************************************ \begin{code} @@ -303,7 +930,6 @@ -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM () dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str) - \end{code} \begin{code} @@ -313,18 +939,25 @@ \end{code} -\subsection{Finding TyThings} -\begin{code} +%************************************************************************ +%* * + Finding TyThings +%* * +%************************************************************************ +\begin{code} instance MonadThings CoreM where lookupThing name = do hsc_env <- getHscEnv liftIO $ initTcForLookup hsc_env (tcLookupGlobal name) - \end{code} -\subsection{Template Haskell interoperability} +%************************************************************************ +%* * + Template Haskell interoperability +%* * +%************************************************************************ \begin{code} #ifdef GHCI diff -ruN ghc-6.12.1/compiler/simplCore/CSE.lhs ghc-6.13.20091231/compiler/simplCore/CSE.lhs --- ghc-6.12.1/compiler/simplCore/CSE.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/simplCore/CSE.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -11,7 +11,7 @@ #include "HsVersions.h" import Id ( Id, idType, idInlineActivation, zapIdOccInfo ) -import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr, exprIsCheap ) +import CoreUtils ( hashExpr, eqExpr, exprIsBig, mkAltExpr, exprIsCheap ) import DataCon ( isUnboxedTupleCon ) import Type ( tyConAppArgs ) import CoreSyn @@ -114,7 +114,7 @@ We are careful to do no CSE inside functions that the user has marked as INLINE or NOINLINE. In terms of Core, that means - a) we do not do CSE inside (Note InlineMe e) + a) we do not do CSE inside an InlineRule b) we do not do CSE on the RHS of a binding b=e unless b's InlinePragma is AlwaysActive @@ -218,7 +218,6 @@ cseExpr _ (Lit lit) = Lit lit cseExpr env (Var v) = Var (lookupSubst env v) cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a) -cseExpr _ (Note InlineMe e) = Note InlineMe e -- See Note [CSE for INLINE and NOINLINE] cseExpr env (Note n e) = Note n (cseExpr env e) cseExpr env (Cast e co) = Cast (cseExpr env e) co cseExpr env (Lam b e) = let (env', b') = addBinder env b @@ -302,15 +301,19 @@ emptyCSEnv = CS emptyUFM emptyInScopeSet emptyVarEnv lookupCSEnv :: CSEnv -> CoreExpr -> Maybe CoreExpr -lookupCSEnv (CS cs _ _) expr +lookupCSEnv (CS cs in_scope _) expr = case lookupUFM cs (hashExpr expr) of Nothing -> Nothing - Just pairs -> lookup_list pairs expr - -lookup_list :: [(CoreExpr,CoreExpr)] -> CoreExpr -> Maybe CoreExpr -lookup_list [] _ = Nothing -lookup_list ((e,e'):es) expr | cheapEqExpr e expr = Just e' - | otherwise = lookup_list es expr + Just pairs -> lookup_list pairs + where + -- In this lookup we use full expression equality + -- Reason: when expressions differ we generally find out quickly + -- but I found that cheapEqExpr was saying (\x.x) /= (\y.y), + -- and this kind of thing happened in real programs + lookup_list :: [(CoreExpr,CoreExpr)] -> Maybe CoreExpr + lookup_list [] = Nothing + lookup_list ((e,e'):es) | eqExpr in_scope e expr = Just e' + | otherwise = lookup_list es addCSEnvItem :: CSEnv -> CoreExpr -> CoreExpr -> CSEnv addCSEnvItem env expr expr' | exprIsBig expr = env diff -ruN ghc-6.12.1/compiler/simplCore/FloatIn.lhs ghc-6.13.20091231/compiler/simplCore/FloatIn.lhs --- ghc-6.12.1/compiler/simplCore/FloatIn.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/simplCore/FloatIn.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -18,7 +18,7 @@ import CoreSyn import CoreUtils ( exprIsHNF, exprIsDupable ) -import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf, idRuleVars ) +import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf, idRuleAndUnfoldingVars ) import Id ( isOneShotBndr, idType ) import Var import Type ( isUnLiftedType ) @@ -213,10 +213,6 @@ = -- Wimp out for now mkCoLets' to_drop (Note note (fiExpr [] expr)) -fiExpr to_drop (_, AnnNote InlineMe expr) - = -- Ditto... don't float anything into an INLINE expression - mkCoLets' to_drop (Note InlineMe (fiExpr [] expr)) - fiExpr to_drop (_, AnnNote note@(CoreNote _) expr) = Note note (fiExpr to_drop expr) \end{code} @@ -263,10 +259,12 @@ Note [extra_fvs (s): free variables of rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider let x{rule mentioning y} = rhs in body +Consider + let x{rule mentioning y} = rhs in body Here y is not free in rhs or body; but we still want to dump bindings that bind y outside the let. So we augment extra_fvs with the -idRuleVars of x. +idRuleAndUnfoldingVars of x. No need for type variables, hence not using +idFreeVars. \begin{code} @@ -275,7 +273,7 @@ where body_fvs = freeVarsOf body - rule_fvs = idRuleVars id -- See Note [extra_fvs (2): free variables of rules] + rule_fvs = idRuleAndUnfoldingVars id -- See Note [extra_fvs (2): free variables of rules] extra_fvs | noFloatIntoRhs ann_rhs || isUnLiftedType (idType id) = rule_fvs `unionVarSet` rhs_fvs | otherwise = rule_fvs @@ -304,7 +302,7 @@ body_fvs = freeVarsOf body -- See Note [extra_fvs (1,2)] - rule_fvs = foldr (unionVarSet . idRuleVars) emptyVarSet ids + rule_fvs = foldr (unionVarSet . idRuleAndUnfoldingVars) emptyVarSet ids extra_fvs = rule_fvs `unionVarSet` unionVarSets [ fvs | (fvs, rhs) <- rhss , noFloatIntoRhs rhs ] @@ -359,8 +357,7 @@ fi_alt to_drop (con, args, rhs) = (con, args, fiExpr to_drop rhs) noFloatIntoRhs :: AnnExpr' Var (UniqFM Var) -> Bool -noFloatIntoRhs (AnnNote InlineMe _) = True -noFloatIntoRhs (AnnLam b _) = not (is_one_shot b) +noFloatIntoRhs (AnnLam b _) = not (is_one_shot b) -- IMPORTANT: don't say 'True' for a RHS with a one-shot lambda at the top. -- This makes a big difference for things like -- f x# = let x = I# x# diff -ruN ghc-6.12.1/compiler/simplCore/FloatOut.lhs ghc-6.13.20091231/compiler/simplCore/FloatOut.lhs --- ghc-6.12.1/compiler/simplCore/FloatOut.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/simplCore/FloatOut.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -10,16 +10,21 @@ import CoreSyn import CoreUtils +import CoreArity ( etaExpand ) +import CoreMonad ( FloatOutSwitches(..) ) -import DynFlags ( DynFlags, DynFlag(..), FloatOutSwitches(..) ) +import DynFlags ( DynFlags, DynFlag(..) ) import ErrUtils ( dumpIfSet_dyn ) import CostCentre ( dupifyCC, CostCentre ) -import Id ( Id, idType ) +import Id ( Id, idType, idArity, isBottomingId ) import Type ( isUnLiftedType ) import SetLevels ( Level(..), LevelledExpr, LevelledBind, - setLevels, ltMajLvl, ltLvl, isTopLvl ) + setLevels, isTopLvl, tOP_LEVEL ) import UniqSupply ( UniqSupply ) -import Data.List +import Bag +import Util +import Maybes +import UniqFM import Outputable import FastString \end{code} @@ -96,10 +101,6 @@ @ Well, maybe. We don't do this at the moment. -\begin{code} -type FloatBind = (Level, CoreBind) -- INVARIANT: a FloatBind is always lifted -type FloatBinds = [FloatBind] -\end{code} %************************************************************************ %* * @@ -135,7 +136,7 @@ floatTopBind :: LevelledBind -> (FloatStats, [CoreBind]) floatTopBind bind = case (floatBind bind) of { (fs, floats) -> - (fs, floatsToBinds floats) + (fs, bagToList (flattenFloats floats)) } \end{code} @@ -145,17 +146,22 @@ %* * %************************************************************************ - \begin{code} floatBind :: LevelledBind -> (FloatStats, FloatBinds) -floatBind (NonRec (TB name level) rhs) +floatBind (NonRec (TB var level) rhs) = case (floatRhs level rhs) of { (fs, rhs_floats, rhs') -> - (fs, rhs_floats ++ [(level, NonRec name rhs')]) } + + -- A tiresome hack: + -- see Note [Bottoming floats: eta expansion] in SetLevels + let rhs'' | isBottomingId var = etaExpand (idArity var) rhs' + | otherwise = rhs' + + in (fs, rhs_floats `plusFloats` unitFloat level (NonRec var rhs'')) } floatBind bind@(Rec pairs) = case (unzip3 (map do_pair pairs)) of { (fss, rhss_floats, new_pairs) -> - let rhs_floats = concat rhss_floats in + let rhs_floats = foldr1 plusFloats rhss_floats in if not (isTopLvl bind_dest_lvl) then -- Find which bindings float out at least one lambda beyond this one @@ -165,7 +171,9 @@ -- they may not be mutually recursive but the occurrence analyser will -- find that out. case (partitionByMajorLevel bind_dest_lvl rhs_floats) of { (floats', heres) -> - (sum_stats fss, floats' ++ [(bind_dest_lvl, Rec (floatsToBindPairs heres ++ new_pairs))]) } + (sum_stats fss, + floats' `plusFloats` unitFloat bind_dest_lvl + (Rec (floatsToBindPairs heres new_pairs))) } else -- In a recursive binding, *destined for* the top level -- (only), the rhs floats may contain references to the @@ -180,7 +188,8 @@ -- This can only happen for bindings destined for the top level, -- because only then will partitionByMajorLevel allow through a binding -- that only differs in its minor level - (sum_stats fss, [(bind_dest_lvl, Rec (new_pairs ++ floatsToBindPairs rhs_floats))]) + (sum_stats fss, unitFloat tOP_LEVEL + (Rec (floatsToBindPairs (flattenFloats rhs_floats) new_pairs))) } where bind_dest_lvl = getBindLevel bind @@ -244,14 +253,14 @@ -- We use exprIsCheap because that is also what's used by the simplifier -- to decide whether to float a let out of a let -floatExpr _ (Var v) = (zeroStats, [], Var v) -floatExpr _ (Type ty) = (zeroStats, [], Type ty) -floatExpr _ (Lit lit) = (zeroStats, [], Lit lit) +floatExpr _ (Var v) = (zeroStats, emptyFloats, Var v) +floatExpr _ (Type ty) = (zeroStats, emptyFloats, Type ty) +floatExpr _ (Lit lit) = (zeroStats, emptyFloats, Lit lit) floatExpr lvl (App e a) = case (floatExpr lvl e) of { (fse, floats_e, e') -> case (floatRhs lvl a) of { (fsa, floats_a, a') -> - (fse `add_stats` fsa, floats_e ++ floats_a, App e' a') }} + (fse `add_stats` fsa, floats_e `plusFloats` floats_a, App e' a') }} floatExpr _ lam@(Lam _ _) = let @@ -282,27 +291,9 @@ -- Annotate bindings floated outwards past an scc expression -- with the cc. We mark that cc as "duplicated", though. - annotated_defns = annotate (dupifyCC cc) floating_defns + annotated_defns = wrapCostCentre (dupifyCC cc) floating_defns in (fs, annotated_defns, Note note expr') } - where - annotate :: CostCentre -> FloatBinds -> FloatBinds - - annotate dupd_cc defn_groups - = [ (level, ann_bind floater) | (level, floater) <- defn_groups ] - where - ann_bind (NonRec binder rhs) - = NonRec binder (mkSCC dupd_cc rhs) - - ann_bind (Rec pairs) - = Rec [(binder, mkSCC dupd_cc rhs) | (binder, rhs) <- pairs] - -floatExpr _ (Note InlineMe expr) -- Other than SCCs - = (zeroStats, [], Note InlineMe (unTag expr)) - -- Do no floating at all inside INLINE. - -- The SetLevels pass did not clone the bindings, so it's - -- unsafe to do any floating, even if we dump the results - -- inside the Note (which is what we used to do). floatExpr lvl (Note note expr) -- Other than SCCs = case (floatExpr lvl expr) of { (fs, floating_defns, expr') -> @@ -313,23 +304,23 @@ (fs, floating_defns, Cast expr' co) } floatExpr lvl (Let (NonRec (TB bndr bndr_lvl) rhs) body) - | isUnLiftedType (idType bndr) -- Treat unlifted lets just like a case - -- I.e. floatExpr for rhs, floatCaseAlt for body + | isUnLiftedType (idType bndr) -- Treat unlifted lets just like a case + -- I.e. floatExpr for rhs, floatCaseAlt for body = case floatExpr lvl rhs of { (_, rhs_floats, rhs') -> case floatCaseAlt bndr_lvl body of { (fs, body_floats, body') -> - (fs, rhs_floats ++ body_floats, Let (NonRec bndr rhs') body') }} + (fs, rhs_floats `plusFloats` body_floats, Let (NonRec bndr rhs') body') }} floatExpr lvl (Let bind body) = case (floatBind bind) of { (fsb, bind_floats) -> case (floatExpr lvl body) of { (fse, body_floats, body') -> (add_stats fsb fse, - bind_floats ++ body_floats, + bind_floats `plusFloats` body_floats, body') }} floatExpr lvl (Case scrut (TB case_bndr case_lvl) ty alts) = case floatExpr lvl scrut of { (fse, fde, scrut') -> case floatList float_alt alts of { (fsa, fda, alts') -> - (add_stats fse fsa, fda ++ fde, Case scrut' case_bndr ty alts') + (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts') }} where -- Use floatCaseAlt for the alternatives, so that we @@ -340,26 +331,15 @@ floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b]) -floatList _ [] = (zeroStats, [], []) +floatList _ [] = (zeroStats, emptyFloats, []) floatList f (a:as) = case f a of { (fs_a, binds_a, b) -> case floatList f as of { (fs_as, binds_as, bs) -> - (fs_a `add_stats` fs_as, binds_a ++ binds_as, b:bs) }} - -unTagBndr :: TaggedBndr tag -> CoreBndr -unTagBndr (TB b _) = b + (fs_a `add_stats` fs_as, binds_a `plusFloats` binds_as, b:bs) }} -unTag :: TaggedExpr tag -> CoreExpr -unTag (Var v) = Var v -unTag (Lit l) = Lit l -unTag (Type ty) = Type ty -unTag (Note n e) = Note n (unTag e) -unTag (App e1 e2) = App (unTag e1) (unTag e2) -unTag (Lam b e) = Lam (unTagBndr b) (unTag e) -unTag (Cast e co) = Cast (unTag e) co -unTag (Let (Rec prs) e) = Let (Rec [(unTagBndr b,unTag r) | (b, r) <- prs]) (unTag e) -unTag (Let (NonRec b r) e) = Let (NonRec (unTagBndr b) (unTag r)) (unTag e) -unTag (Case e b ty alts) = Case (unTag e) (unTagBndr b) ty - [(c, map unTagBndr bs, unTag r) | (c,bs,r) <- alts] +getBindLevel :: Bind (TaggedBndr Level) -> Level +getBindLevel (NonRec (TB _ lvl) _) = lvl +getBindLevel (Rec (((TB _ lvl), _) : _)) = lvl +getBindLevel (Rec []) = panic "getBindLevel Rec []" \end{code} %************************************************************************ @@ -390,13 +370,9 @@ add_stats (FlS a1 b1 c1) (FlS a2 b2 c2) = FlS (a1 + a2) (b1 + b2) (c1 + c2) -add_to_stats :: FloatStats -> [(Level, Bind CoreBndr)] -> FloatStats -add_to_stats (FlS a b c) floats - = FlS (a + length top_floats) (b + length other_floats) (c + 1) - where - (top_floats, other_floats) = partition to_very_top floats - - to_very_top (my_lvl, _) = isTopLvl my_lvl +add_to_stats :: FloatStats -> FloatBinds -> FloatStats +add_to_stats (FlS a b c) (FB tops others) + = FlS (a + lengthBag tops) (b + lengthBag (flattenMajor others)) (c + 1) \end{code} @@ -406,57 +382,115 @@ %* * %************************************************************************ -\begin{code} -getBindLevel :: Bind (TaggedBndr Level) -> Level -getBindLevel (NonRec (TB _ lvl) _) = lvl -getBindLevel (Rec (((TB _ lvl), _) : _)) = lvl -getBindLevel (Rec []) = panic "getBindLevel Rec []" -\end{code} +Note [Representation of FloatBinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The FloatBinds types is somewhat important. We can get very large numbers +of floating bindings, often all destined for the top level. A typical example +is x = [4,2,5,2,5, .... ] +Then we get lots of small expressions like (fromInteger 4), which all get +lifted to top level. + +The trouble is that + (a) we partition these floating bindings *at every binding site* + (b) SetLevels introduces a new bindings site for every float +So we had better not look at each binding at each binding site! + +That is why MajorEnv is represented as a finite map. + +We keep the bindings destined for the *top* level separate, because +we float them out even if they don't escape a *value* lambda; see +partitionByMajorLevel. + \begin{code} -partitionByMajorLevel, partitionByLevel - :: Level -- Partitioning level +type FloatBind = CoreBind -- INVARIANT: a FloatBind is always lifted - -> FloatBinds -- Defns to be divided into 2 piles... +data FloatBinds = FB !(Bag FloatBind) -- Destined for top level + !MajorEnv -- Levels other than top + -- See Note [Representation of FloatBinds] + +type MajorEnv = UniqFM MinorEnv -- Keyed by major level +type MinorEnv = UniqFM (Bag FloatBind) -- Keyed by minor level + +flattenFloats :: FloatBinds -> Bag FloatBind +flattenFloats (FB tops others) = tops `unionBags` flattenMajor others + +flattenMajor :: MajorEnv -> Bag FloatBind +flattenMajor = foldUFM (unionBags . flattenMinor) emptyBag + +flattenMinor :: MinorEnv -> Bag FloatBind +flattenMinor = foldUFM unionBags emptyBag + +emptyFloats :: FloatBinds +emptyFloats = FB emptyBag emptyUFM + +unitFloat :: Level -> FloatBind -> FloatBinds +unitFloat lvl@(Level major minor) b + | isTopLvl lvl = FB (unitBag b) emptyUFM + | otherwise = FB emptyBag (unitUFM major (unitUFM minor (unitBag b))) + +plusFloats :: FloatBinds -> FloatBinds -> FloatBinds +plusFloats (FB t1 b1) (FB t2 b2) = FB (t1 `unionBags` t2) (b1 `plusMajor` b2) - -> (FloatBinds, -- Defns with level strictly < partition level, - FloatBinds) -- The rest +plusMajor :: MajorEnv -> MajorEnv -> MajorEnv +plusMajor = plusUFM_C plusMinor +plusMinor :: MinorEnv -> MinorEnv -> MinorEnv +plusMinor = plusUFM_C unionBags -partitionByMajorLevel ctxt_lvl defns - = partition float_further defns +floatsToBindPairs :: Bag FloatBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] +floatsToBindPairs floats binds = foldrBag add binds floats where - -- Float it if we escape a value lambda, or if we get to the top level - float_further (my_lvl, _) = my_lvl `ltMajLvl` ctxt_lvl || isTopLvl my_lvl - -- The isTopLvl part says that if we can get to the top level, say "yes" anyway - -- This means that - -- x = f e - -- transforms to - -- lvl = e - -- x = f lvl - -- which is as it should be + add (Rec pairs) binds = pairs ++ binds + add (NonRec binder rhs) binds = (binder,rhs) : binds -partitionByLevel ctxt_lvl defns - = partition float_further defns +install :: Bag FloatBind -> CoreExpr -> CoreExpr +install defn_groups expr + = foldrBag install_group expr defn_groups where - float_further (my_lvl, _) = my_lvl `ltLvl` ctxt_lvl -\end{code} + install_group defns body = Let defns body -\begin{code} -floatsToBinds :: FloatBinds -> [CoreBind] -floatsToBinds floats = map snd floats +partitionByMajorLevel, partitionByLevel + :: Level -- Partitioning level + -> FloatBinds -- Defns to be divided into 2 piles... + -> (FloatBinds, -- Defns with level strictly < partition level, + Bag FloatBind) -- The rest -floatsToBindPairs :: FloatBinds -> [(Id,CoreExpr)] +-- ---- partitionByMajorLevel ---- +-- Float it if we escape a value lambda, *or* if we get to the top level +-- If we can get to the top level, say "yes" anyway. This means that +-- x = f e +-- transforms to +-- lvl = e +-- x = f lvl +-- which is as it should be -floatsToBindPairs floats = concat (map mk_pairs floats) +partitionByMajorLevel (Level major _) (FB tops defns) + = (FB tops outer, heres `unionBags` flattenMajor inner) where - mk_pairs (_, Rec pairs) = pairs - mk_pairs (_, NonRec binder rhs) = [(binder,rhs)] - -install :: FloatBinds -> CoreExpr -> CoreExpr + (outer, mb_heres, inner) = splitUFM defns major + heres = case mb_heres of + Nothing -> emptyBag + Just h -> flattenMinor h + +partitionByLevel (Level major minor) (FB tops defns) + = (FB tops (outer_maj `plusMajor` unitUFM major outer_min), + here_min `unionBags` flattenMinor inner_min + `unionBags` flattenMajor inner_maj) -install defn_groups expr - = foldr install_group expr defn_groups where - install_group (_, defns) body = Let defns body + (outer_maj, mb_here_maj, inner_maj) = splitUFM defns major + (outer_min, mb_here_min, inner_min) = case mb_here_maj of + Nothing -> (emptyUFM, Nothing, emptyUFM) + Just min_defns -> splitUFM min_defns minor + here_min = mb_here_min `orElse` emptyBag + +wrapCostCentre :: CostCentre -> FloatBinds -> FloatBinds +wrapCostCentre cc (FB tops defns) + = FB (wrap_defns tops) (mapUFM (mapUFM wrap_defns) defns) + where + wrap_defns = mapBag wrap_one + wrap_one (NonRec binder rhs) = NonRec binder (mkSCC cc rhs) + wrap_one (Rec pairs) = Rec (mapSnd (mkSCC cc) pairs) \end{code} + diff -ruN ghc-6.12.1/compiler/simplCore/OccurAnal.lhs ghc-6.13.20091231/compiler/simplCore/OccurAnal.lhs --- ghc-6.12.1/compiler/simplCore/OccurAnal.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/simplCore/OccurAnal.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -19,11 +19,11 @@ import CoreSyn import CoreFVs -import CoreUtils ( exprIsTrivial, isDefaultAlt ) -import Coercion ( mkSymCoercion ) +import Type ( tyVarsOfType ) +import CoreUtils ( exprIsTrivial, isDefaultAlt, mkCoerceI, isExpandableApp ) +import Coercion ( CoercionI(..), mkSymCoI ) import Id import Name ( localiseName ) -import IdInfo import BasicTypes import VarSet @@ -34,7 +34,8 @@ import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey ) import Unique ( Unique ) import UniqFM ( keysUFM, intersectUFM_C, foldUFM_Directly ) -import Util ( mapAndUnzip ) +import Util ( mapAndUnzip, filterOut ) +import Bag import Outputable import Data.List @@ -50,18 +51,21 @@ Here's the externally-callable interface: \begin{code} -occurAnalysePgm :: [CoreBind] -> [CoreBind] -occurAnalysePgm binds +occurAnalysePgm :: [CoreBind] -> [CoreRule] -> [CoreBind] +occurAnalysePgm binds rules = snd (go initOccEnv binds) where + initial_details = addIdOccs emptyDetails (rulesFreeVars rules) + -- The RULES keep things alive! + go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind]) go _ [] - = (emptyDetails, []) + = (initial_details, []) go env (bind:binds) = (final_usage, bind' ++ binds') where (bs_usage, binds') = go env binds - (final_usage, bind') = occAnalBind env bind bs_usage + (final_usage, bind') = occAnalBind env env bind bs_usage occurAnalyseExpr :: CoreExpr -> CoreExpr -- Do occurrence analysis, and discard occurence info returned @@ -79,13 +83,14 @@ ~~~~~~~~ \begin{code} -occAnalBind :: OccEnv +occAnalBind :: OccEnv -- The incoming OccEnv + -> OccEnv -- Same, but trimmed by (binderOf bind) -> CoreBind -> UsageDetails -- Usage details of scope -> (UsageDetails, -- Of the whole let(rec) [CoreBind]) -occAnalBind env (NonRec binder rhs) body_usage +occAnalBind env _ (NonRec binder rhs) body_usage | isTyVar binder -- A type let; we don't gather usage info = (body_usage, [NonRec binder rhs]) @@ -175,7 +180,7 @@ "loop"? In particular, a RULE is like an equation for 'f' that is *always* inlined if it is applicable. We do *not* disable rules for loop-breakers. It's up to whoever makes the rules to - make sure that the rules themselves alwasys terminate. See Note + make sure that the rules themselves always terminate. See Note [Rules for recursive functions] in Simplify.lhs Hence, if @@ -221,13 +226,15 @@ So we must *not* postInlineUnconditionally 'g', even though its RHS turns out to be trivial. (I'm assuming that 'g' is - not choosen as a loop breaker.) + not choosen as a loop breaker.) Why not? Because then we + drop the binding for 'g', which leaves it out of scope in the + RULE! We "solve" this by making g a "weak" or "rules-only" loop breaker, with OccInfo = IAmLoopBreaker True. A normal "strong" loop breaker has IAmLoopBreaker False. So - Inline postInlineUnconditinoally + Inline postInlineUnconditionally IAmLoopBreaker False no no IAmLoopBreaker True yes no other yes yes @@ -247,6 +254,14 @@ rule's LHS too, so we'd better ensure the dependency is respected + * Note [Inline rules] + ~~~~~~~~~~~~~~~~~~~ + None of the above stuff about RULES applies to Inline Rules, + stored in a CoreUnfolding. The unfolding, if any, is simplified + at the same time as the regular RHS of the function, so it should + be treated *exactly* like an extra RHS. + + Example [eftInt] ~~~~~~~~~~~~~~~ Example (from GHC.Enum): @@ -282,7 +297,7 @@ \begin{code} -occAnalBind env (Rec pairs) body_usage +occAnalBind _ env (Rec pairs) body_usage = foldr occAnalRec (body_usage, []) sccs -- For a recursive group, we -- * occ-analyse all the RHSs @@ -299,9 +314,10 @@ rec_edges = {-# SCC "occAnalBind.assoc" #-} map make_node pairs make_node (bndr, rhs) - = (ND bndr rhs' rhs_usage rhs_fvs, idUnique bndr, out_edges) + = (ND bndr rhs' all_rhs_usage rhs_fvs, idUnique bndr, out_edges) where (rhs_usage, rhs') = occAnalRhs env bndr rhs + all_rhs_usage = addRuleUsage rhs_usage bndr -- Note [Rules are extra RHSs] rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage out_edges = keysUFM (rhs_fvs `unionVarSet` idRuleVars bndr) -- (a -> b) means a mentions b @@ -324,7 +340,7 @@ = (body_usage, binds) | otherwise -- It's mentioned in the body - = (body_usage' +++ addRuleUsage rhs_usage bndr, -- Note [Rules are extra RHSs] + = (body_usage' +++ rhs_usage, NonRec tagged_bndr rhs : binds) where (body_usage', tagged_bndr) = tagBinder body_usage bndr @@ -346,8 +362,7 @@ ---------------------------- -- Tag the binders with their occurrence info total_usage = foldl add_usage body_usage nodes - add_usage body_usage (ND bndr _ rhs_usage _, _, _) - = body_usage +++ addRuleUsage rhs_usage bndr + add_usage usage_so_far (ND _ _ rhs_usage _, _, _) = usage_so_far +++ rhs_usage (final_usage, tagged_nodes) = mapAccumL tag_node total_usage nodes tag_node :: UsageDetails -> Node Details -> (UsageDetails, Node Details) @@ -371,7 +386,7 @@ | otherwise = foldr (reOrderRec 0) [] $ stronglyConnCompFromEdgedVerticesR loop_breaker_edges - -- See Note [Choosing loop breakers] for looop_breaker_edges + -- See Note [Choosing loop breakers] for loop_breaker_edges loop_breaker_edges = map mk_node tagged_nodes mk_node (details@(ND _ _ _ rhs_fvs), k, _) = (details, k, new_ks) where @@ -401,11 +416,6 @@ where new_fvs = extendFvs env emptyVarSet fvs -idRuleRhsVars :: Id -> VarSet --- Just the variables free on the *rhs* of a rule --- See Note [Choosing loop breakers] -idRuleRhsVars id = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet (idCoreRules id) - extendFvs :: IdEnv IdSet -> IdSet -> IdSet -> IdSet -- (extendFVs env fvs s) returns (fvs `union` env(s)) extendFvs env fvs id_set @@ -456,9 +466,14 @@ -- which is gotten from the Id. data Details = ND Id -- Binder CoreExpr -- RHS - UsageDetails -- Full usage from RHS (*not* including rules) - IdSet -- Other binders from this Rec group mentioned on RHS - -- (derivable from UsageDetails but cached here) + + UsageDetails -- Full usage from RHS, + -- including *both* RULES *and* InlineRule unfolding + + IdSet -- Other binders *from this Rec group* mentioned in + -- * the RHS + -- * any InlineRule unfolding + -- but *excluding* any RULES reOrderRec :: Int -> SCC (Node Details) -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] @@ -514,53 +529,43 @@ score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker score (ND bndr rhs _ _, _, _) - | workerExists (idWorkerInfo bndr) = 10 - -- Note [Worker inline loop] + | isDFunId bndr = 9 -- Never choose a DFun as a loop breaker + -- Note [DFuns should not be loop breakers] - | exprIsTrivial rhs = 5 -- Practically certain to be inlined + | Just (inl_source, _) <- isInlineRule_maybe (idUnfolding bndr) + = case inl_source of + InlineWrapper {} -> 10 -- Note [INLINE pragmas] + _other -> 3 -- Data structures are more important than this + -- so that dictionary/method recursion unravels + -- Note that this case hits all InlineRule things, so we + -- never look at 'rhs for InlineRule stuff. That's right, because + -- 'rhs' is irrelevant for inlining things with an InlineRule + + | is_con_app rhs = 5 -- Data types help with cases: Note [Constructor applications] + + | exprIsTrivial rhs = 10 -- Practically certain to be inlined -- Used to have also: && not (isExportedId bndr) -- But I found this sometimes cost an extra iteration when we have -- rec { d = (a,b); a = ...df...; b = ...df...; df = d } -- where df is the exported dictionary. Then df makes a really -- bad choice for loop breaker - | is_con_app rhs = 3 -- Data types help with cases - -- Note [Constructor applictions] - + -- If an Id is marked "never inline" then it makes a great loop breaker -- The only reason for not checking that here is that it is rare -- and I've never seen a situation where it makes a difference, -- so it probably isn't worth the time to test on every binder -- | isNeverActive (idInlinePragma bndr) = -10 - | inlineCandidate bndr rhs = 2 -- Likely to be inlined - -- Note [Inline candidates] + | isOneOcc (idOccInfo bndr) = 2 -- Likely to be inlined - | not (neverUnfold (idUnfolding bndr)) = 1 - -- the Id has some kind of unfolding + | canUnfold (realIdUnfolding bndr) = 1 + -- The Id has some kind of unfolding + -- Ignore loop-breaker-ness here because that is what we are setting! | otherwise = 0 - inlineCandidate :: Id -> CoreExpr -> Bool - inlineCandidate _ (Note InlineMe _) = True - inlineCandidate id _ = isOneOcc (idOccInfo id) - - -- Note [conapp] - -- - -- It's really really important to inline dictionaries. Real - -- example (the Enum Ordering instance from GHC.Base): - -- - -- rec f = \ x -> case d of (p,q,r) -> p x - -- g = \ x -> case d of (p,q,r) -> q x - -- d = (v, f, g) - -- - -- Here, f and g occur just once; but we can't inline them into d. - -- On the other hand we *could* simplify those case expressions if - -- we didn't stupidly choose d as the loop breaker. - -- But we won't because constructor args are marked "Many". - -- Inlining dictionaries is really essential to unravelling - -- the loops in static numeric dictionaries, see GHC.Float. - + -- Checking for a constructor application -- Cheap and cheerful; the simplifer moves casts out of the way -- The lambda case is important to spot x = /\a. C (f a) -- which comes up when C is a dictionary constructor and @@ -569,7 +574,7 @@ -- -- However we *also* treat (\x. C p q) as a con-app-like thing, -- Note [Closure conversion] - is_con_app (Var v) = isDataConWorkId v + is_con_app (Var v) = isConLikeId v is_con_app (App f _) = is_con_app f is_con_app (Lam _ e) = is_con_app e is_con_app (Note _ e) = is_con_app e @@ -617,13 +622,14 @@ Note [INLINE pragmas] ~~~~~~~~~~~~~~~~~~~~~ -Never choose a function with an INLINE pramga as the loop breaker! +Avoid choosing a function with an INLINE pramga as the loop breaker! If such a function is mutually-recursive with a non-INLINE thing, then the latter should be the loop-breaker. -A particular case is wrappers generated by the demand analyser. -If you make then into a loop breaker you may get an infinite -inlining loop. For example: +Usually this is just a question of optimisation. But a particularly +bad case is wrappers generated by the demand analyser: if you make +then into a loop breaker you may get an infinite inlining loop. For +example: rec { $wfoo x = ....foo x.... @@ -634,8 +640,36 @@ infinite inlining in the importing scope. So be a bit careful if you change this. A good example is Tree.repTree in nofib/spectral/minimax. If the repTree wrapper is chosen as the loop -breaker then compiling Game.hs goes into an infinite loop (this -happened when we gave is_con_app a lower score than inline candidates). +breaker then compiling Game.hs goes into an infinite loop. This +happened when we gave is_con_app a lower score than inline candidates: + + Tree.repTree + = __inline_me (/\a. \w w1 w2 -> + case Tree.$wrepTree @ a w w1 w2 of + { (# ww1, ww2 #) -> Branch @ a ww1 ww2 }) + Tree.$wrepTree + = /\a w w1 w2 -> + (# w2_smP, map a (Tree a) (Tree.repTree a w1 w) (w w2) #) + +Here we do *not* want to choose 'repTree' as the loop breaker. + +Note [DFuns should not be loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's particularly bad to make a DFun into a loop breaker. See +Note [How instance declarations are translated] in TcInstDcls + +We give DFuns a higher score than ordinary CONLIKE things because +if there's a choice we want the DFun to be the non-looop breker. Eg + +rec { sc = /\ a \$dC. $fBWrap (T a) ($fCT @ a $dC) + + $fCT :: forall a_afE. (Roman.C a_afE) => Roman.C (Roman.T a_afE) + {-# DFUN #-} + $fCT = /\a \$dC. MkD (T a) ((sc @ a $dC) |> blah) ($ctoF @ a $dC) + } + +Here 'sc' (the superclass) looks CONLIKE, but we'll never get to it +if we can't unravel the DFun first. Note [Constructor applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -693,10 +727,13 @@ -- For non-recs the binder is alrady tagged -- with occurrence info -> (UsageDetails, CoreExpr) + -- Returned usage details includes any INLINE rhs occAnalRhs env id rhs - = occAnal ctxt rhs + = (addIdOccs rhs_usage (idUnfoldingVars id), rhs') + -- Include occurrences for the "extra RHS" from a CoreUnfolding where + (rhs_usage, rhs') = occAnal ctxt rhs ctxt | certainly_inline id = env | otherwise = rhsCtxt env -- Note that we generally use an rhsCtxt. This tells the occ anal n @@ -724,12 +761,15 @@ \begin{code} addRuleUsage :: UsageDetails -> Id -> UsageDetails -- Add the usage from RULES in Id to the usage -addRuleUsage usage id - = foldVarSet add usage (idRuleVars id) +addRuleUsage usage id = addIdOccs usage (idRuleVars id) -- idRuleVars here: see Note [Rule dependency info] + +addIdOccs :: UsageDetails -> VarSet -> UsageDetails +addIdOccs usage id_set = foldVarSet add usage id_set where - add v u = addOneOcc u v NoOccInfo - -- Give a non-committal binder info (i.e manyOcc) because + add v u | isId v = addOneOcc u v NoOccInfo + | otherwise = u + -- Give a non-committal binder info (i.e NoOccInfo) because -- a) Many copies of the specialised thing can appear -- b) We don't want to substitute a BIG expression inside a RULE -- even if that's the only occurrence of the thing @@ -774,11 +814,6 @@ \end{code} \begin{code} -occAnal env (Note InlineMe body) - = case occAnal env body of { (usage, body') -> - (mapVarEnv markMany usage, Note InlineMe body') - } - occAnal env (Note note@(SCC _) body) = case occAnal env body of { (usage, body') -> (mapVarEnv markInsideSCC usage, Note note body') @@ -823,7 +858,9 @@ occAnal env expr@(Lam _ _) = case occAnal env_body body of { (body_usage, body') -> let - (final_usage, tagged_binders) = tagBinders body_usage binders + (final_usage, tagged_binders) = tagLamBinders body_usage binders' + -- Use binders' to put one-shot info on the lambdas + -- URGH! Sept 99: we don't seem to be able to use binders' here, because -- we get linear-typed things in the resulting program that we can't handle yet. -- (e.g. PrelShow) TODO @@ -836,7 +873,8 @@ (really_final_usage, mkLams tagged_binders body') } where - env_body = vanillaCtxt env -- Body is (no longer) an RhsContext + env_body = vanillaCtxt (trimOccEnv env binders) + -- Body is (no longer) an RhsContext (binders, body) = collectBinders expr binders' = oneShotGroup env binders linear = all is_one_shot binders' @@ -847,8 +885,7 @@ case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts') -> let alts_usage = foldr1 combineAltsUsageDetails alts_usage_s - alts_usage' = addCaseBndrUsage alts_usage - (alts_usage1, tagged_bndr) = tagBinder alts_usage' bndr + (alts_usage1, tagged_bndr) = tag_case_bndr alts_usage bndr total_usage = scrut_usage +++ alts_usage1 in total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }} @@ -862,20 +899,13 @@ -- case x of w { (p,q) -> f w } -- into -- case x of w { (p,q) -> f (p,q) } - addCaseBndrUsage usage = case lookupVarEnv usage bndr of - Nothing -> usage - Just _ -> extendVarEnv usage bndr NoOccInfo - - alt_env = mkAltEnv env bndr_swap - -- Consider x = case v of { True -> (p,q); ... } - -- Then it's fine to inline p and q - - bndr_swap = case scrut of - Var v -> Just (v, Var bndr) - Cast (Var v) co -> Just (v, Cast (Var bndr) (mkSymCoercion co)) - _other -> Nothing + tag_case_bndr usage bndr + = case lookupVarEnv usage bndr of + Nothing -> (usage, setIdOccInfo bndr IAmDead) + Just _ -> (usage `delVarEnv` bndr, setIdOccInfo bndr NoOccInfo) - occ_anal_alt = occAnalAlt alt_env bndr bndr_swap + alt_env = mkAltEnv env scrut bndr + occ_anal_alt = occAnalAlt alt_env bndr occ_anal_scrut (Var v) (alt1 : other_alts) | not (null other_alts) || not (isDefaultAlt alt1) @@ -886,9 +916,11 @@ = occAnal (vanillaCtxt env) scrut -- No need for rhsCtxt occAnal env (Let bind body) - = case occAnal env body of { (body_usage, body') -> - case occAnalBind env bind body_usage of { (final_usage, new_binds) -> + = case occAnal env_body body of { (body_usage, body') -> + case occAnalBind env env_body bind body_usage of { (final_usage, new_binds) -> (final_usage, mkLets new_binds body') }} + where + env_body = trimOccEnv env (bindersOf bind) occAnalArgs :: OccEnv -> [CoreExpr] -> (UsageDetails, [CoreExpr]) occAnalArgs env args @@ -908,13 +940,16 @@ occAnalApp env (Var fun, args) = case args_stuff of { (args_uds, args') -> let - final_args_uds = markRhsUds env is_pap args_uds + final_args_uds = markRhsUds env is_exp args_uds in (fun_uds +++ final_args_uds, mkApps (Var fun) args') } where fun_uniq = idUnique fun fun_uds = mkOneOcc env fun (valArgCount args > 0) - is_pap = isConLikeId fun || valArgCount args < idArity fun + is_exp = isExpandableApp fun (valArgCount args) + -- See Note [CONLIKE pragma] in BasicTypes + -- The definition of is_exp should match that in + -- Simplify.prepareRhs -- Hack for build, fold, runST args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args @@ -985,6 +1020,188 @@ \end{code} +Note [Binders in case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + case x of y { (a,b) -> f y } +We treat 'a', 'b' as dead, because they don't physically occur in the +case alternative. (Indeed, a variable is dead iff it doesn't occur in +its scope in the output of OccAnal.) It really helps to know when +binders are unused. See esp the call to isDeadBinder in +Simplify.mkDupableAlt + +In this example, though, the Simplifier will bring 'a' and 'b' back to +life, beause it binds 'y' to (a,b) (imagine got inlined and +scrutinised y). + +\begin{code} +occAnalAlt :: OccEnv + -> CoreBndr + -> CoreAlt + -> (UsageDetails, Alt IdWithOccInfo) +occAnalAlt env case_bndr (con, bndrs, rhs) + = let + env' = trimOccEnv env bndrs + in + case occAnal env' rhs of { (rhs_usage1, rhs1) -> + let + proxies = getProxies env' case_bndr + (rhs_usage2, rhs2) = foldrBag wrapProxy (rhs_usage1, rhs1) proxies + (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage2 bndrs + bndrs' = tagged_bndrs -- See Note [Binders in case alternatives] + in + (alt_usg, (con, bndrs', rhs2)) } + +wrapProxy :: ProxyBind -> (UsageDetails, CoreExpr) -> (UsageDetails, CoreExpr) +wrapProxy (bndr, rhs_var, co) (body_usg, body) + | not (bndr `usedIn` body_usg) + = (body_usg, body) + | otherwise + = (body_usg' +++ rhs_usg, Let (NonRec tagged_bndr rhs) body) + where + (body_usg', tagged_bndr) = tagBinder body_usg bndr + rhs_usg = unitVarEnv rhs_var NoOccInfo -- We don't need exact info + rhs = mkCoerceI co (Var rhs_var) +\end{code} + + +%************************************************************************ +%* * + OccEnv +%* * +%************************************************************************ + +\begin{code} +data OccEnv + = OccEnv { occ_encl :: !OccEncl -- Enclosing context information + , occ_ctxt :: !CtxtTy -- Tells about linearity + , occ_proxy :: ProxyEnv } + + +----------------------------- +-- OccEncl is used to control whether to inline into constructor arguments +-- For example: +-- x = (p,q) -- Don't inline p or q +-- y = /\a -> (p a, q a) -- Still don't inline p or q +-- z = f (p,q) -- Do inline p,q; it may make a rule fire +-- So OccEncl tells enought about the context to know what to do when +-- we encounter a contructor application or PAP. + +data OccEncl + = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda + -- Don't inline into constructor args here + | OccVanilla -- Argument of function, body of lambda, scruintee of case etc. + -- Do inline into constructor args here + +type CtxtTy = [Bool] + -- [] No info + -- + -- True:ctxt Analysing a function-valued expression that will be + -- applied just once + -- + -- False:ctxt Analysing a function-valued expression that may + -- be applied many times; but when it is, + -- the CtxtTy inside applies + +initOccEnv :: OccEnv +initOccEnv = OccEnv { occ_encl = OccVanilla + , occ_ctxt = [] + , occ_proxy = PE emptyVarEnv emptyVarSet } + +vanillaCtxt :: OccEnv -> OccEnv +vanillaCtxt env = OccEnv { occ_encl = OccVanilla + , occ_ctxt = [] + , occ_proxy = occ_proxy env } + +rhsCtxt :: OccEnv -> OccEnv +rhsCtxt env = OccEnv { occ_encl = OccRhs, occ_ctxt = [] + , occ_proxy = occ_proxy env } + +setCtxtTy :: OccEnv -> CtxtTy -> OccEnv +setCtxtTy env ctxt = env { occ_ctxt = ctxt } + +isRhsEnv :: OccEnv -> Bool +isRhsEnv (OccEnv { occ_encl = OccRhs }) = True +isRhsEnv (OccEnv { occ_encl = OccVanilla }) = False + +oneShotGroup :: OccEnv -> [CoreBndr] -> [CoreBndr] + -- The result binders have one-shot-ness set that they might not have had originally. + -- This happens in (build (\cn -> e)). Here the occurrence analyser + -- linearity context knows that c,n are one-shot, and it records that fact in + -- the binder. This is useful to guide subsequent float-in/float-out tranformations + +oneShotGroup (OccEnv { occ_ctxt = ctxt }) bndrs + = go ctxt bndrs [] + where + go _ [] rev_bndrs = reverse rev_bndrs + + go (lin_ctxt:ctxt) (bndr:bndrs) rev_bndrs + | isId bndr = go ctxt bndrs (bndr':rev_bndrs) + where + bndr' | lin_ctxt = setOneShotLambda bndr + | otherwise = bndr + + go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs) + +addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv +addAppCtxt env@(OccEnv { occ_ctxt = ctxt }) args + = env { occ_ctxt = replicate (valArgCount args) True ++ ctxt } +\end{code} + +%************************************************************************ +%* * + ProxyEnv +%* * +%************************************************************************ + +\begin{code} +data ProxyEnv + = PE (IdEnv (Id, [(Id,CoercionI)])) VarSet + -- Main env, and its free variables (of both range and domain) +\end{code} + +Note [ProxyEnv] +~~~~~~~~~~~~~~~ +The ProxyEnv keeps track of the connection between case binders and +scrutinee. Specifically, if + sc |-> (sc, [...(cb, co)...]) +is a binding in the ProxyEnv, then + cb = sc |> coi +Typically we add such a binding when encountering the case expression + case (sc |> coi) of cb { ... } + +Things to note: + * The domain of the ProxyEnv is the variable (or casted variable) + scrutinees of enclosing cases. This is additionally used + to ensure we gather occurrence info even for GlobalId scrutinees; + see Note [Binder swap for GlobalId scrutinee] + + * The ProxyEnv is just an optimisation; you can throw away any + element without losing correctness. And we do so when pushing + it inside a binding (see trimProxyEnv). + + * Once scrutinee might map to many case binders: Eg + case sc of cb1 { DEFAULT -> ....case sc of cb2 { ... } .. } + +INVARIANTS + * If sc1 |-> (sc2, [...(cb, co)...]), then sc1==sc2 + It's a UniqFM and we sometimes need the domain Id + + * Any particular case binder 'cb' occurs only once in entire range + + * No loops + +The Main Reason for having a ProxyEnv is so that when we encounter + case e of cb { pi -> ri } +we can find all the in-scope variables derivable from 'cb', +and effectively add let-bindings for them thus: + case e of cb { pi -> let { x = ..cb..; y = ...cb.. } + in ri } +The function getProxies finds these bindings; then we +add just the necessary ones, using wrapProxy. + +More info under Note [Binder swap] + Note [Binder swap] ~~~~~~~~~~~~~~~~~~ We do these two transformations right here: @@ -1040,22 +1257,50 @@ I think this is just too bad. CSE will recover some of it. +Note [Case of cast] +~~~~~~~~~~~~~~~~~~~ +Consider case (x `cast` co) of b { I# -> + ... (case (x `cast` co) of {...}) ... +We'd like to eliminate the inner case. That is the motivation for +equation (2) in Note [Binder swap]. When we get to the inner case, we +inline x, cancel the casts, and away we go. + Note [Binder swap on GlobalId scrutinees] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When the scrutinee is a GlobalId we must take care in two ways i) In order to *know* whether 'x' occurs free in the RHS, we need its occurrence info. BUT, we don't gather occurrence info for - GlobalIds. That's what the (small) occ_scrut_ids set in OccEnv is + GlobalIds. That's one use for the (small) occ_proxy env in OccEnv is for: it says "gather occurrence info for these. ii) We must call localiseId on 'x' first, in case it's a GlobalId, or has an External Name. See, for example, SimplEnv Note [Global Ids in the substitution]. +Note [getProxies is subtle] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The code for getProxies isn't all that obvious. Consider + + case v |> cov of x { DEFAULT -> + case x |> cox1 of y { DEFAULT -> + case x |> cox2 of z { DEFAULT -> r + +These will give us a ProxyEnv looking like: + x |-> (x, [(y, cox1), (z, cox2)]) + v |-> (v, [(x, cov)]) + +From this we want to extract the bindings + x = z |> sym cox2 + v = x |> sym cov + y = x |> cox1 + +Notice that later bindings may mention earlier ones, and that +we need to go "both ways". + Historical note [no-case-of-case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We *used* to suppress the binder-swap in case expressoins when +We *used* to suppress the binder-swap in case expressions when -fno-case-of-case is on. Old remarks: "This happens in the first simplifier pass, and enhances full laziness. Here's the bad case: @@ -1114,160 +1359,118 @@ binder-swap unconditionally and still get occurrence analysis information right. -Note [Case of cast] -~~~~~~~~~~~~~~~~~~~ -Consider case (x `cast` co) of b { I# -> - ... (case (x `cast` co) of {...}) ... -We'd like to eliminate the inner case. That is the motivation for -equation (2) in Note [Binder swap]. When we get to the inner case, we -inline x, cancel the casts, and away we go. - -Note [Binders in case alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - case x of y { (a,b) -> f y } -We treat 'a', 'b' as dead, because they don't physically occur in the -case alternative. (Indeed, a variable is dead iff it doesn't occur in -its scope in the output of OccAnal.) This invariant is It really -helpe to know when binders are unused. See esp the call to -isDeadBinder in Simplify.mkDupableAlt - -In this example, though, the Simplifier will bring 'a' and 'b' back to -life, beause it binds 'y' to (a,b) (imagine got inlined and -scrutinised y). - \begin{code} -occAnalAlt :: OccEnv - -> CoreBndr - -> Maybe (Id, CoreExpr) -- Note [Binder swap] - -> CoreAlt - -> (UsageDetails, Alt IdWithOccInfo) -occAnalAlt env case_bndr mb_scrut_var (con, bndrs, rhs) - = case occAnal env rhs of { (rhs_usage, rhs') -> - let - (alt_usg, tagged_bndrs) = tagBinders rhs_usage bndrs - bndrs' = tagged_bndrs -- See Note [Binders in case alternatives] - in - case mb_scrut_var of - Just (scrut_var, scrut_rhs) -- See Note [Binder swap] - | scrut_var `localUsedIn` alt_usg -- (a) Fast path, usually false - , not (any shadowing bndrs) -- (b) - -> (addOneOcc usg_wo_scrut case_bndr NoOccInfo, - -- See Note [Case binder usage] for the NoOccInfo - (con, bndrs', Let (NonRec scrut_var2 scrut_rhs) rhs')) - where - scrut_var1 = mkLocalId (localiseName (idName scrut_var)) (idType scrut_var) - -- Localise the scrut_var before shadowing it; we're making a - -- new binding for it, and it might have an External Name, or - -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees] - -- Also we don't want any INLILNE or NOINLINE pragmas! - - (usg_wo_scrut, scrut_var2) = tagBinder alt_usg scrut_var1 - shadowing bndr = bndr `elemVarSet` rhs_fvs - rhs_fvs = exprFreeVars scrut_rhs - - _other -> (alt_usg, (con, bndrs', rhs')) } -\end{code} - - -%************************************************************************ -%* * -\subsection[OccurAnal-types]{OccEnv} -%* * -%************************************************************************ - -\begin{code} -data OccEnv - = OccEnv { occ_encl :: !OccEncl -- Enclosing context information - , occ_ctxt :: !CtxtTy -- Tells about linearity - , occ_scrut_ids :: !GblScrutIds } - -type GblScrutIds = IdSet -- GlobalIds that are scrutinised, and for which - -- we want to gather occurence info; see - -- Note [Binder swap for GlobalId scrutinee] - -- No need to prune this if there's a shadowing binding - -- because it's OK for it to be too big - --- OccEncl is used to control whether to inline into constructor arguments --- For example: --- x = (p,q) -- Don't inline p or q --- y = /\a -> (p a, q a) -- Still don't inline p or q --- z = f (p,q) -- Do inline p,q; it may make a rule fire --- So OccEncl tells enought about the context to know what to do when --- we encounter a contructor application or PAP. - -data OccEncl - = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda - -- Don't inline into constructor args here - | OccVanilla -- Argument of function, body of lambda, scruintee of case etc. - -- Do inline into constructor args here - -type CtxtTy = [Bool] - -- [] No info - -- - -- True:ctxt Analysing a function-valued expression that will be - -- applied just once - -- - -- False:ctxt Analysing a function-valued expression that may - -- be applied many times; but when it is, - -- the CtxtTy inside applies - -initOccEnv :: OccEnv -initOccEnv = OccEnv { occ_encl = OccRhs - , occ_ctxt = [] - , occ_scrut_ids = emptyVarSet } - -vanillaCtxt :: OccEnv -> OccEnv -vanillaCtxt env = OccEnv { occ_encl = OccVanilla, occ_ctxt = [] - , occ_scrut_ids = occ_scrut_ids env } - -rhsCtxt :: OccEnv -> OccEnv -rhsCtxt env = OccEnv { occ_encl = OccRhs, occ_ctxt = [] - , occ_scrut_ids = occ_scrut_ids env } +extendProxyEnv :: ProxyEnv -> Id -> CoercionI -> Id -> ProxyEnv +-- (extendPE x co y) typically arises from +-- case (x |> co) of y { ... } +-- It extends the proxy env with the binding +-- y = x |> co +extendProxyEnv pe scrut co case_bndr + | scrut == case_bndr = PE env1 fvs1 -- If case_bndr shadows scrut, + | otherwise = PE env2 fvs2 -- don't extend + where + PE env1 fvs1 = trimProxyEnv pe [case_bndr] + env2 = extendVarEnv_Acc add single env1 scrut1 (case_bndr,co) + single cb_co = (scrut1, [cb_co]) + add cb_co (x, cb_cos) = (x, cb_co:cb_cos) + fvs2 = fvs1 `unionVarSet` freeVarsCoI co + `extendVarSet` case_bndr + `extendVarSet` scrut1 + + scrut1 = mkLocalId (localiseName (idName scrut)) (idType scrut) + -- Localise the scrut_var before shadowing it; we're making a + -- new binding for it, and it might have an External Name, or + -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees] + -- Also we don't want any INLILNE or NOINLINE pragmas! + +----------- +type ProxyBind = (Id, Id, CoercionI) + +getProxies :: OccEnv -> Id -> Bag ProxyBind +-- Return a bunch of bindings [...(xi,ei)...] +-- such that let { ...; xi=ei; ... } binds the xi using y alone +-- See Note [getProxies is subtle] +getProxies (OccEnv { occ_proxy = PE pe _ }) case_bndr + = -- pprTrace "wrapProxies" (ppr case_bndr) $ + go_fwd case_bndr + where + fwd_pe :: IdEnv (Id, CoercionI) + fwd_pe = foldVarEnv add1 emptyVarEnv pe + where + add1 (x,ycos) env = foldr (add2 x) env ycos + add2 x (y,co) env = extendVarEnv env y (x,co) + + go_fwd :: Id -> Bag ProxyBind + -- Return bindings derivable from case_bndr + go_fwd case_bndr = -- pprTrace "go_fwd" (vcat [ppr case_bndr, text "fwd_pe =" <+> ppr fwd_pe, + -- text "pe =" <+> ppr pe]) $ + go_fwd' case_bndr + + go_fwd' case_bndr + | Just (scrut, co) <- lookupVarEnv fwd_pe case_bndr + = unitBag (scrut, case_bndr, mkSymCoI co) + `unionBags` go_fwd scrut + `unionBags` go_bwd scrut [pr | pr@(cb,_) <- lookup_bwd scrut + , cb /= case_bndr] + | otherwise + = emptyBag + + lookup_bwd :: Id -> [(Id, CoercionI)] + -- Return case_bndrs that are connected to scrut + lookup_bwd scrut = case lookupVarEnv pe scrut of + Nothing -> [] + Just (_, cb_cos) -> cb_cos + + go_bwd :: Id -> [(Id, CoercionI)] -> Bag ProxyBind + go_bwd scrut cb_cos = foldr (unionBags . go_bwd1 scrut) emptyBag cb_cos + + go_bwd1 :: Id -> (Id, CoercionI) -> Bag ProxyBind + go_bwd1 scrut (case_bndr, co) + = -- pprTrace "go_bwd1" (ppr case_bndr) $ + unitBag (case_bndr, scrut, co) + `unionBags` go_bwd case_bndr (lookup_bwd case_bndr) -mkAltEnv :: OccEnv -> Maybe (Id, CoreExpr) -> OccEnv +----------- +mkAltEnv :: OccEnv -> CoreExpr -> Id -> OccEnv -- Does two things: a) makes the occ_ctxt = OccVanilla --- b) extends the scrut_ids if necessary -mkAltEnv env (Just (scrut_id, _)) - | not (isLocalId scrut_id) - = OccEnv { occ_encl = OccVanilla - , occ_scrut_ids = extendVarSet (occ_scrut_ids env) scrut_id - , occ_ctxt = occ_ctxt env } -mkAltEnv env _ - | isRhsEnv env = env { occ_encl = OccVanilla } - | otherwise = env - -setCtxtTy :: OccEnv -> CtxtTy -> OccEnv -setCtxtTy env ctxt = env { occ_ctxt = ctxt } - -isRhsEnv :: OccEnv -> Bool -isRhsEnv (OccEnv { occ_encl = OccRhs }) = True -isRhsEnv (OccEnv { occ_encl = OccVanilla }) = False - -oneShotGroup :: OccEnv -> [CoreBndr] -> [CoreBndr] - -- The result binders have one-shot-ness set that they might not have had originally. - -- This happens in (build (\cn -> e)). Here the occurrence analyser - -- linearity context knows that c,n are one-shot, and it records that fact in - -- the binder. This is useful to guide subsequent float-in/float-out tranformations - -oneShotGroup (OccEnv { occ_ctxt = ctxt }) bndrs - = go ctxt bndrs [] +-- b) extends the ProxyEnv if possible +mkAltEnv env scrut cb + = env { occ_encl = OccVanilla, occ_proxy = pe' } where - go _ [] rev_bndrs = reverse rev_bndrs - - go (lin_ctxt:ctxt) (bndr:bndrs) rev_bndrs - | isId bndr = go ctxt bndrs (bndr':rev_bndrs) - where - bndr' | lin_ctxt = setOneShotLambda bndr - | otherwise = bndr - - go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs) - -addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv -addAppCtxt env@(OccEnv { occ_ctxt = ctxt }) args - = env { occ_ctxt = replicate (valArgCount args) True ++ ctxt } + pe = occ_proxy env + pe' = case scrut of + Var v -> extendProxyEnv pe v IdCo cb + Cast (Var v) co -> extendProxyEnv pe v (ACo co) cb + _other -> trimProxyEnv pe [cb] + +----------- +trimOccEnv :: OccEnv -> [CoreBndr] -> OccEnv +trimOccEnv env bndrs = env { occ_proxy = trimProxyEnv (occ_proxy env) bndrs } + +----------- +trimProxyEnv :: ProxyEnv -> [CoreBndr] -> ProxyEnv +-- We are about to push this ProxyEnv inside a binding for 'bndrs' +-- So dump any ProxyEnv bindings which mention any of the bndrs +trimProxyEnv (PE pe fvs) bndrs + | not (bndr_set `intersectsVarSet` fvs) + = PE pe fvs + | otherwise + = PE pe' (fvs `minusVarSet` bndr_set) + where + pe' = mapVarEnv trim pe + bndr_set = mkVarSet bndrs + trim (scrut, cb_cos) | scrut `elemVarSet` bndr_set = (scrut, []) + | otherwise = (scrut, filterOut discard cb_cos) + discard (cb,co) = bndr_set `intersectsVarSet` + extendVarSet (freeVarsCoI co) cb + +----------- +freeVarsCoI :: CoercionI -> VarSet +freeVarsCoI IdCo = emptyVarSet +freeVarsCoI (ACo co) = tyVarsOfType co \end{code} + %************************************************************************ %* * \subsection[OccurAnal-types]{OccEnv} @@ -1302,17 +1505,21 @@ type IdWithOccInfo = Id -tagBinders :: UsageDetails -- Of scope - -> [Id] -- Binders - -> (UsageDetails, -- Details with binders removed - [IdWithOccInfo]) -- Tagged binders - -tagBinders usage binders - = let - usage' = usage `delVarEnvList` binders - uss = map (setBinderOcc usage) binders - in - usage' `seq` (usage', uss) +tagLamBinders :: UsageDetails -- Of scope + -> [Id] -- Binders + -> (UsageDetails, -- Details with binders removed + [IdWithOccInfo]) -- Tagged binders +-- Used for lambda and case binders +-- It copes with the fact that lambda bindings can have InlineRule +-- unfoldings, used for join points +tagLamBinders usage binders = usage' `seq` (usage', bndrs') + where + (usage', bndrs') = mapAccumR tag_lam usage binders + tag_lam usage bndr = (usage2, setBinderOcc usage bndr) + where + usage1 = usage `delVarEnv` bndr + usage2 | isId bndr = addIdOccs usage1 (idUnfoldingVars bndr) + | otherwise = usage1 tagBinder :: UsageDetails -- Of scope -> Id -- Binders @@ -1352,8 +1559,9 @@ mkOneOcc :: OccEnv -> Id -> InterestingCxt -> UsageDetails mkOneOcc env id int_cxt | isLocalId id = unitVarEnv id (OneOcc False True int_cxt) - | id `elemVarSet` occ_scrut_ids env = unitVarEnv id NoOccInfo - | otherwise = emptyDetails + | PE env _ <- occ_proxy env + , id `elemVarEnv` env = unitVarEnv id NoOccInfo + | otherwise = emptyDetails markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo diff -ruN ghc-6.12.1/compiler/simplCore/SetLevels.lhs ghc-6.13.20091231/compiler/simplCore/SetLevels.lhs --- ghc-6.12.1/compiler/simplCore/SetLevels.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/simplCore/SetLevels.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -48,30 +48,32 @@ Level(..), tOP_LEVEL, LevelledBind, LevelledExpr, - incMinorLvl, ltMajLvl, ltLvl, isTopLvl, isInlineCtxt + incMinorLvl, ltMajLvl, ltLvl, isTopLvl ) where #include "HsVersions.h" import CoreSyn - -import DynFlags ( FloatOutSwitches(..) ) -import CoreUtils ( exprType, exprIsTrivial, mkPiTypes ) +import CoreMonad ( FloatOutSwitches(..) ) +import CoreUtils ( exprType, mkPiTypes ) +import CoreArity ( exprBotStrictness_maybe ) import CoreFVs -- all of it -import CoreSubst ( Subst, emptySubst, extendInScope, extendIdSubst, - cloneIdBndr, cloneRecIdBndrs ) -import Id ( idType, mkSysLocal, isOneShotLambda, +import CoreSubst ( Subst, emptySubst, extendInScope, extendInScopeList, + extendIdSubst, cloneIdBndr, cloneRecIdBndrs ) +import Id ( idType, mkLocalIdWithInfo, mkSysLocal, isOneShotLambda, zapDemandIdInfo, transferPolyIdInfo, - idSpecialisation, idWorkerInfo, setIdInfo + idSpecialisation, idUnfolding, setIdInfo, + setIdStrictness, setIdArity ) import IdInfo import Var import VarSet import VarEnv -import Name ( getOccName ) +import Demand ( StrictSig, increaseStrictSigArity ) +import Name ( getOccName, mkSystemVarName ) import OccName ( occNameString ) import Type ( isUnLiftedType, Type ) -import BasicTypes ( TopLevelFlag(..) ) +import BasicTypes ( TopLevelFlag(..), Arity ) import UniqSupply import Util ( sortLe, isSingleton, count ) import Outputable @@ -85,9 +87,7 @@ %************************************************************************ \begin{code} -data Level = InlineCtxt -- A level that's used only for - -- the context parameter ctxt_lvl - | Level Int -- Level number of enclosing lambdas +data Level = Level Int -- Level number of enclosing lambdas Int -- Number of big-lambda and/or case expressions between -- here and the nearest enclosing lambda \end{code} @@ -150,55 +150,37 @@ type LevelledExpr = TaggedExpr Level type LevelledBind = TaggedBind Level -tOP_LEVEL, iNLINE_CTXT :: Level +tOP_LEVEL :: Level tOP_LEVEL = Level 0 0 -iNLINE_CTXT = InlineCtxt incMajorLvl :: Level -> Level --- For InlineCtxt we ignore any inc's; we don't want --- to do any floating at all; see notes above -incMajorLvl InlineCtxt = InlineCtxt incMajorLvl (Level major _) = Level (major + 1) 0 incMinorLvl :: Level -> Level -incMinorLvl InlineCtxt = InlineCtxt incMinorLvl (Level major minor) = Level major (minor+1) maxLvl :: Level -> Level -> Level -maxLvl InlineCtxt l2 = l2 -maxLvl l1 InlineCtxt = l1 maxLvl l1@(Level maj1 min1) l2@(Level maj2 min2) | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1 | otherwise = l2 ltLvl :: Level -> Level -> Bool -ltLvl _ InlineCtxt = False -ltLvl InlineCtxt (Level _ _) = True ltLvl (Level maj1 min1) (Level maj2 min2) = (maj1 < maj2) || (maj1 == maj2 && min1 < min2) ltMajLvl :: Level -> Level -> Bool -- Tells if one level belongs to a difft *lambda* level to another -ltMajLvl _ InlineCtxt = False -ltMajLvl InlineCtxt (Level maj2 _) = 0 < maj2 ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2 isTopLvl :: Level -> Bool isTopLvl (Level 0 0) = True isTopLvl _ = False -isInlineCtxt :: Level -> Bool -isInlineCtxt InlineCtxt = True -isInlineCtxt _ = False - instance Outputable Level where - ppr InlineCtxt = text "" ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ] instance Eq Level where - InlineCtxt == InlineCtxt = True (Level maj1 min1) == (Level maj2 min2) = maj1 == maj2 && min1 == min2 - _ == _ = False \end{code} @@ -215,21 +197,17 @@ -> [LevelledBind] setLevels float_lams binds us - = initLvl us (do_them binds) + = initLvl us (do_them init_env binds) where - -- "do_them"'s main business is to thread the monad along - -- It gives each top binding the same empty envt, because - -- things unbound in the envt have level number zero implicitly - do_them :: [CoreBind] -> LvlM [LevelledBind] - - do_them [] = return [] - do_them (b:bs) = do - (lvld_bind, _) <- lvlTopBind init_env b - lvld_binds <- do_them bs - return (lvld_bind : lvld_binds) - init_env = initialEnv float_lams + do_them :: LevelEnv -> [CoreBind] -> LvlM [LevelledBind] + do_them _ [] = return [] + do_them env (b:bs) + = do { (lvld_bind, env') <- lvlTopBind env b + ; lvld_binds <- do_them env' bs + ; return (lvld_bind : lvld_binds) } + lvlTopBind :: LevelEnv -> Bind Id -> LvlM (LevelledBind, LevelEnv) lvlTopBind env (NonRec binder rhs) = lvlBind TopLevel tOP_LEVEL env (AnnNonRec binder (freeVars rhs)) @@ -273,20 +251,9 @@ lvlExpr _ _ (_, AnnLit lit) = return (Lit lit) lvlExpr ctxt_lvl env (_, AnnApp fun arg) = do - fun' <- lvl_fun fun + fun' <- lvlExpr ctxt_lvl env fun -- We don't do MFE on partial applications arg' <- lvlMFE False ctxt_lvl env arg return (App fun' arg') - where --- gaw 2004 - lvl_fun (_, AnnCase _ _ _ _) = lvlMFE True ctxt_lvl env fun - lvl_fun _ = lvlExpr ctxt_lvl env fun - -- We don't do MFE on partial applications generally, - -- but we do if the function is big and hairy, like a case - -lvlExpr _ env (_, AnnNote InlineMe expr) = do --- Don't float anything out of an InlineMe; hence the iNLINE_CTXT - expr' <- lvlExpr iNLINE_CTXT env expr - return (Note InlineMe expr') lvlExpr ctxt_lvl env (_, AnnNote note expr) = do expr' <- lvlExpr ctxt_lvl env expr @@ -359,13 +326,40 @@ the expression, so that it can itself be floated. Note [Unlifted MFEs] -~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~ We don't float unlifted MFEs, which potentially loses big opportunites. For example: \x -> f (h y) where h :: Int -> Int# is expensive. We'd like to float the (h y) outside the \x, but we don't because it's unboxed. Possible solution: box it. +Note [Bottoming floats] +~~~~~~~~~~~~~~~~~~~~~~~ +If we see + f = \x. g (error "urk") +we'd like to float the call to error, to get + lvl = error "urk" + f = \x. g lvl +Furthermore, we want to float a bottoming expression even if it has free +variables: + f = \x. g (let v = h x in error ("urk" ++ v)) +Then we'd like to abstact over 'x' can float the whole arg of g: + lvl = \x. let v = h x in error ("urk" ++ v) + f = \x. g (lvl x) +See Maessen's paper 1999 "Bottom extraction: factoring error handling out +of functional programs" (unpublished I think). + +When we do this, we set the strictness and arity of the new bottoming +Id, so that it's properly exposed as such in the interface file, even if +this is all happening after strictness analysis. + +Note [Bottoming floats: eta expansion] c.f Note [Bottoming floats] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Tiresomely, though, the simplifier has an invariant that the manifest +arity of the RHS should be the same as the arity; but we can't call +etaExpand during SetLevels because it works over a decorated form of +CoreExpr. So we do the eta expansion later, in FloatOut. + Note [Case MFEs] ~~~~~~~~~~~~~~~~ We don't float a case expression as an MFE from a strict context. Why not? @@ -384,13 +378,17 @@ lvlMFE _ _ _ (_, AnnType ty) = return (Type ty) --- No point in floating out an expression wrapped in a coercion; +-- No point in floating out an expression wrapped in a coercion or note -- If we do we'll transform lvl = e |> co -- to lvl' = e; lvl = lvl' |> co -- and then inline lvl. Better just to float out the payload. +lvlMFE strict_ctxt ctxt_lvl env (_, AnnNote n e) + = do { e' <- lvlMFE strict_ctxt ctxt_lvl env e + ; return (Note n e') } + lvlMFE strict_ctxt ctxt_lvl env (_, AnnCast e co) - = do { expr' <- lvlMFE strict_ctxt ctxt_lvl env e - ; return (Cast expr' co) } + = do { e' <- lvlMFE strict_ctxt ctxt_lvl env e + ; return (Cast e' co) } -- Note [Case MFEs] lvlMFE True ctxt_lvl env e@(_, AnnCase {}) @@ -398,21 +396,21 @@ lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _) | isUnLiftedType ty -- Can't let-bind it; see Note [Unlifted MFEs] - || isInlineCtxt ctxt_lvl -- Don't float out of an __inline__ context - || exprIsTrivial expr -- Never float if it's trivial + || notWorthFloating ann_expr abs_vars || not good_destination = -- Don't float it out lvlExpr ctxt_lvl env ann_expr | otherwise -- Float it out! = do expr' <- lvlFloatRhs abs_vars dest_lvl env ann_expr - var <- newLvlVar "lvl" abs_vars ty + var <- newLvlVar abs_vars ty mb_bot return (Let (NonRec (TB var dest_lvl) expr') (mkVarApps (Var var) abs_vars)) where expr = deAnnotate ann_expr ty = exprType expr - dest_lvl = destLevel env fvs (isFunction ann_expr) + mb_bot = exprBotStrictness_maybe expr + dest_lvl = destLevel env fvs (isFunction ann_expr) mb_bot abs_vars = abstractVars dest_lvl env fvs -- A decision to float entails let-binding this thing, and we only do @@ -439,6 +437,42 @@ -- concat = /\ a -> lvl a -- lvl = /\ a -> foldr ..a.. (++) [] -- which is pretty stupid. Hence the strict_ctxt test + +annotateBotStr :: Id -> Maybe (Arity, StrictSig) -> Id +annotateBotStr id Nothing = id +annotateBotStr id (Just (arity,sig)) = id `setIdArity` arity + `setIdStrictness` sig + +notWorthFloating :: CoreExprWithFVs -> [Var] -> Bool +-- Returns True if the expression would be replaced by +-- something bigger than it is now. For example: +-- abs_vars = tvars only: return True if e is trivial, +-- but False for anything bigger +-- abs_vars = [x] (an Id): return True for trivial, or an application (f x) +-- but False for (f x x) +-- +-- One big goal is that floating should be idempotent. Eg if +-- we replace e with (lvl79 x y) and then run FloatOut again, don't want +-- to replace (lvl79 x y) with (lvl83 x y)! + +notWorthFloating e abs_vars + = go e (count isId abs_vars) + where + go (_, AnnVar {}) n = n == 0 + go (_, AnnLit {}) n = n == 0 + go (_, AnnCast e _) n = go e n + go (_, AnnApp e arg) n + | (_, AnnType {}) <- arg = go e n + | n==0 = False + | is_triv arg = go e (n-1) + | otherwise = False + go _ _ = False + + is_triv (_, AnnLit {}) = True -- Treat all literals as trivial + is_triv (_, AnnVar {}) = True -- (ie not worth floating) + is_triv (_, AnnCast e _) = is_triv e + is_triv (_, AnnApp e (_, AnnType {})) = is_triv e + is_triv _ = False \end{code} Note [Escaping a value lambda] @@ -503,7 +537,6 @@ lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_)) | isTyVar bndr -- Don't do anything for TyVar binders -- (simplifier gets rid of them pronto) - || isInlineCtxt ctxt_lvl -- Don't do anything inside InlineMe = do rhs' <- lvlExpr ctxt_lvl env rhs return (NonRec (TB bndr ctxt_lvl) rhs', env) @@ -516,22 +549,20 @@ | otherwise = do -- Yes, type abstraction; create a new binder, extend substitution, etc rhs' <- lvlFloatRhs abs_vars dest_lvl env rhs - (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr] + (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr_w_str] return (NonRec (TB bndr' dest_lvl) rhs', env') where - bind_fvs = rhs_fvs `unionVarSet` idFreeVars bndr - abs_vars = abstractVars dest_lvl env bind_fvs - dest_lvl = destLevel env bind_fvs (isFunction rhs) + bind_fvs = rhs_fvs `unionVarSet` idFreeVars bndr + abs_vars = abstractVars dest_lvl env bind_fvs + dest_lvl = destLevel env bind_fvs (isFunction rhs) mb_bot + mb_bot = exprBotStrictness_maybe (deAnnotate rhs) + bndr_w_str = annotateBotStr bndr mb_bot \end{code} \begin{code} lvlBind top_lvl ctxt_lvl env (AnnRec pairs) - | isInlineCtxt ctxt_lvl -- Don't do anything inside InlineMe - = do rhss' <- mapM (lvlExpr ctxt_lvl env) rhss - return (Rec ([TB b ctxt_lvl | b <- bndrs] `zip` rhss'), env) - | null abs_vars = do (new_env, new_bndrs) <- cloneRecVars top_lvl env bndrs ctxt_lvl dest_lvl new_rhss <- mapM (lvlExpr ctxt_lvl new_env) rhss @@ -580,7 +611,7 @@ `minusVarSet` mkVarSet bndrs - dest_lvl = destLevel env bind_fvs (all isFunction rhss) + dest_lvl = destLevel env bind_fvs (all isFunction rhss) Nothing abs_vars = abstractVars dest_lvl env bind_fvs ---------------------------------------------------- @@ -637,12 +668,14 @@ \begin{code} -- Destintion level is the max Id level of the expression -- (We'll abstract the type variables, if any.) -destLevel :: LevelEnv -> VarSet -> Bool -> Level -destLevel env fvs is_function +destLevel :: LevelEnv -> VarSet -> Bool -> Maybe (Arity, StrictSig) -> Level +destLevel env fvs is_function mb_bot + | Just {} <- mb_bot = tOP_LEVEL -- Send bottoming bindings to the top + -- regardless; see Note [Bottoming floats] | floatLams env - && is_function = tOP_LEVEL -- Send functions to top level; see + && is_function = tOP_LEVEL -- Send functions to top level; see -- the comments with isFunction - | otherwise = maxIdLevel env fvs + | otherwise = maxIdLevel env fvs isFunction :: CoreExprWithFVs -> Bool -- The idea here is that we want to float *functions* to @@ -733,6 +766,12 @@ -- incorrectly, because the SubstEnv was still lying around. Ouch! -- KSW 2000-07. +extendInScopeEnv :: LevelEnv -> Var -> LevelEnv +extendInScopeEnv (fl, le, subst, ids) v = (fl, le, extendInScope subst v, ids) + +extendInScopeEnvList :: LevelEnv -> [Var] -> LevelEnv +extendInScopeEnvList (fl, le, subst, ids) vs = (fl, le, extendInScopeList subst vs, ids) + -- extendCaseBndrLvlEnv adds the mapping case-bndr->scrut-var if it can -- (see point 4 of the module overview comment) extendCaseBndrLvlEnv :: LevelEnv -> Expr (TaggedBndr Level) -> Var -> Level @@ -820,7 +859,7 @@ -- We are going to lambda-abstract, so nuke any IdInfo, -- and add the tyvars of the Id (if necessary) - zap v | isId v = WARN( workerExists (idWorkerInfo v) || + zap v | isId v = WARN( isInlineRule (idUnfolding v) || not (isEmptySpecInfo (idSpecialisation v)), text "absVarsOf: discarding info on" <+> ppr v ) setIdInfo v vanillaIdInfo @@ -869,19 +908,29 @@ str = "poly_" ++ occNameString (getOccName bndr) poly_ty = mkPiTypes abs_vars (idType bndr) -newLvlVar :: String - -> [CoreBndr] -> Type -- Abstract wrt these bndrs +newLvlVar :: [CoreBndr] -> Type -- Abstract wrt these bndrs + -> Maybe (Arity, StrictSig) -- Note [Bottoming floats] -> LvlM Id -newLvlVar str vars body_ty = do - uniq <- getUniqueM - return (mkSysLocal (mkFastString str) uniq (mkPiTypes vars body_ty)) +newLvlVar vars body_ty mb_bot + = do { uniq <- getUniqueM + ; return (mkLocalIdWithInfo (mk_name uniq) (mkPiTypes vars body_ty) info) } + where + mk_name uniq = mkSystemVarName uniq (mkFastString "lvl") + arity = count isId vars + info = case mb_bot of + Nothing -> vanillaIdInfo + Just (bot_arity, sig) -> vanillaIdInfo + `setArityInfo` (arity + bot_arity) + `setStrictnessInfo` Just (increaseStrictSigArity arity sig) -- The deeply tiresome thing is that we have to apply the substitution -- to the rules inside each Id. Grr. But it matters. cloneVar :: TopLevelFlag -> LevelEnv -> Id -> Level -> Level -> LvlM (LevelEnv, Id) cloneVar TopLevel env v _ _ - = return (env, v) -- Don't clone top level things + = return (extendInScopeEnv env v, v) -- Don't clone top level things + -- But do extend the in-scope env, to satisfy the in-scope invariant + cloneVar NotTopLevel env@(_,_,subst,_) v ctxt_lvl dest_lvl = ASSERT( isId v ) do us <- getUniqueSupplyM @@ -893,7 +942,7 @@ cloneRecVars :: TopLevelFlag -> LevelEnv -> [Id] -> Level -> Level -> LvlM (LevelEnv, [Id]) cloneRecVars TopLevel env vs _ _ - = return (env, vs) -- Don't clone top level things + = return (extendInScopeEnvList env vs, vs) -- Don't clone top level things cloneRecVars NotTopLevel env@(_,_,subst,_) vs ctxt_lvl dest_lvl = ASSERT( all isId vs ) do us <- getUniqueSupplyM diff -ruN ghc-6.12.1/compiler/simplCore/SimplCore.lhs ghc-6.13.20091231/compiler/simplCore/SimplCore.lhs --- ghc-6.12.1/compiler/simplCore/SimplCore.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/simplCore/SimplCore.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -15,10 +15,9 @@ #include "HsVersions.h" -import DynFlags ( CoreToDo(..), SimplifierSwitch(..), - SimplifierMode(..), DynFlags, DynFlag(..), dopt, - getCoreToDo, shouldDumpSimplPhase ) +import DynFlags ( DynFlags, DynFlag(..), dopt ) import CoreSyn +import CoreSubst import HscTypes import CSE ( cseProgram ) import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase, @@ -30,11 +29,12 @@ import IdInfo import CoreUtils ( coreBindsSize ) import Simplify ( simplTopBinds, simplExpr ) -import SimplEnv ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet ) +import SimplUtils ( simplEnvForGHCi, simplEnvForRules ) +import SimplEnv import SimplMonad import CoreMonad -import qualified ErrUtils as Err ( dumpIfSet_dyn, dumpIfSet, showPass ) -import CoreLint ( showPass, endPass, endPassIf, endIteration ) +import qualified ErrUtils as Err +import CoreLint import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) import FamInstEnv @@ -52,10 +52,6 @@ import SpecConstr ( specConstrProgram) import DmdAnal ( dmdAnalPgm ) import WorkWrap ( wwTopBinds ) -#ifdef OLD_STRICTNESS -import StrictAnal ( saBinds ) -import CprAnalyse ( cprAnalyse ) -#endif import Vectorise ( vectorise ) import FastString import Util @@ -85,11 +81,9 @@ us <- mkSplitUniqSupply 's' let (cp_us, ru_us) = splitUniqSupply us - -- COMPUTE THE ANNOTATIONS TO USE - ann_env <- prepareAnnotations hsc_env (Just guts) - -- COMPUTE THE RULE BASE TO USE - (imp_rule_base, guts1) <- prepareRules hsc_env guts ru_us + -- See Note [Overall plumbing for rules] in Rules.lhs + (hpt_rule_base, guts1) <- prepareRules hsc_env guts ru_us -- Get the module out of the current HscEnv so we can retrieve it from the monad. -- This is very convienent for the users of the monad (e.g. plugins do not have to @@ -97,7 +91,7 @@ -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which -- would mean our cached value would go out of date. let mod = mg_module guts - (guts2, stats) <- runCoreM hsc_env ann_env imp_rule_base cp_us mod $ do + (guts2, stats) <- runCoreM hsc_env hpt_rule_base cp_us mod $ do -- FIND BUILT-IN PASSES let builtin_core_todos = getCoreToDo dflags @@ -118,6 +112,8 @@ -> IO CoreExpr -- simplifyExpr is called by the driver to simplify an -- expression typed in at the interactive prompt +-- +-- Also used by Template Haskell simplifyExpr dflags expr = do { ; Err.showPass dflags "Simplify" @@ -125,7 +121,7 @@ ; us <- mkSplitUniqSupply 's' ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $ - simplExprGently gentleSimplEnv expr + simplExprGently simplEnvForGHCi expr ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression" (pprCoreExpr expr') @@ -133,9 +129,6 @@ ; return expr' } -gentleSimplEnv :: SimplEnv -gentleSimplEnv = mkSimplEnv SimplGently (isAmongSimpl []) - doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts doCorePasses passes guts = foldM (flip doCorePass) guts passes @@ -178,7 +171,7 @@ doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-} describePassR "SpecConstr" Opt_D_dump_spec $ - doPassDU specConstrProgram + specConstrProgram doCorePass (CoreDoVectorisation be) = {-# SCC "Vectorise" #-} describePass "Vectorisation" Opt_D_dump_vect $ @@ -188,24 +181,8 @@ doCorePass CoreDoPrintCore = dontDescribePass $ observe printCore doCorePass (CoreDoRuleCheck phase pat) = dontDescribePass $ ruleCheck phase pat -#ifdef OLD_STRICTNESS -doCorePass CoreDoOldStrictness = {-# SCC "OldStrictness" #-} doOldStrictness -#endif - doCorePass CoreDoNothing = return doCorePass (CoreDoPasses passes) = doCorePasses passes - -#ifdef OLD_STRICTNESS -doOldStrictness :: ModGuts -> CoreM ModGuts -doOldStrictness guts - = do dfs <- getDynFlags - guts' <- describePass "Strictness analysis" Opt_D_dump_stranal $ - doPassM (saBinds dfs) guts - guts'' <- describePass "Constructed Product analysis" Opt_D_dump_cpranal $ - doPass cprAnalyse guts' - return guts'' -#endif - \end{code} %************************************************************************ @@ -223,10 +200,10 @@ describePass name dflag pass guts = do dflags <- getDynFlags - liftIO $ showPass dflags name + liftIO $ Err.showPass dflags name guts' <- pass guts - liftIO $ endPass dflags name dflag (mg_binds guts') - + liftIO $ endPass dflags name dflag (mg_binds guts') (mg_rules guts') + return guts' describePassD :: SDoc -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts @@ -243,11 +220,10 @@ ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts ruleCheck current_phase pat guts = do - let is_active = isActive current_phase rb <- getRuleBase dflags <- getDynFlags liftIO $ Err.showPass dflags "RuleCheck" - liftIO $ printDump (ruleCheckProgram is_active pat rb (mg_binds guts)) + liftIO $ printDump (ruleCheckProgram current_phase pat rb (mg_binds guts)) return guts @@ -319,64 +295,74 @@ ModGuts) -- Modified fields are -- (a) Bindings have rules attached, + -- and INLINE rules simplified -- (b) Rules are now just orphan rules prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt }) guts@(ModGuts { mg_binds = binds, mg_deps = deps , mg_rules = local_rules, mg_rdr_env = rdr_env }) us - = do { let -- Simplify the local rules; boringly, we need to make an in-scope set + = do { us <- mkSplitUniqSupply 'w' + + ; let -- Simplify the local rules; boringly, we need to make an in-scope set -- from the local binders, to avoid warnings from Simplify.simplVar local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds)) - env = setInScopeSet gentleSimplEnv local_ids - (better_rules,_) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $ - (mapM (simplRule env) local_rules) - home_pkg_rules = hptRules hsc_env (dep_mods deps) - - -- Find the rules for locally-defined Ids; then we can attach them - -- to the binders in the top-level bindings - -- - -- Reason - -- - It makes the rules easier to look up - -- - It means that transformation rules and specialisations for - -- locally defined Ids are handled uniformly - -- - It keeps alive things that are referred to only from a rule - -- (the occurrence analyser knows about rules attached to Ids) - -- - It makes sure that, when we apply a rule, the free vars - -- of the RHS are more likely to be in scope - -- - The imported rules are carried in the in-scope set - -- which is extended on each iteration by the new wave of - -- local binders; any rules which aren't on the binding will - -- thereby get dropped - (rules_for_locals, rules_for_imps) = partition isLocalRule better_rules - local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals - binds_w_rules = updateBinders local_rule_base binds + env = setInScopeSet simplEnvForRules local_ids + (simpl_rules, _) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $ + mapM (simplRule env) local_rules + + ; let (rules_for_locals, rules_for_imps) = partition isLocalRule simpl_rules + + home_pkg_rules = hptRules hsc_env (dep_mods deps) + hpt_rule_base = mkRuleBase home_pkg_rules + binds_w_rules = updateBinders rules_for_locals binds - hpt_rule_base = mkRuleBase home_pkg_rules - imp_rule_base = extendRuleBaseList hpt_rule_base rules_for_imps ; Err.dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules" (withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $ - vcat [text "Local rules", pprRules better_rules, - text "", - text "Imported rules", pprRuleBase imp_rule_base]) + vcat [text "Local rules for local Ids", pprRules simpl_rules, + blankLine, + text "Local rules for imported Ids", pprRuleBase hpt_rule_base]) - ; return (imp_rule_base, guts { mg_binds = binds_w_rules, + ; return (hpt_rule_base, guts { mg_binds = binds_w_rules, mg_rules = rules_for_imps }) } -updateBinders :: RuleBase -> [CoreBind] -> [CoreBind] -updateBinders local_rules binds - = map update_bndrs binds +-- Note [Attach rules to local ids] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Find the rules for locally-defined Ids; then we can attach them +-- to the binders in the top-level bindings +-- +-- Reason +-- - It makes the rules easier to look up +-- - It means that transformation rules and specialisations for +-- locally defined Ids are handled uniformly +-- - It keeps alive things that are referred to only from a rule +-- (the occurrence analyser knows about rules attached to Ids) +-- - It makes sure that, when we apply a rule, the free vars +-- of the RHS are more likely to be in scope +-- - The imported rules are carried in the in-scope set +-- which is extended on each iteration by the new wave of +-- local binders; any rules which aren't on the binding will +-- thereby get dropped + +updateBinders :: [CoreRule] -> [CoreBind] -> [CoreBind] +updateBinders rules_for_locals binds + = map update_bind binds where - update_bndrs (NonRec b r) = NonRec (update_bndr b) r - update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs] + local_rules = extendRuleBaseList emptyRuleBase rules_for_locals + + update_bind (NonRec b r) = NonRec (add_rules b) r + update_bind (Rec prs) = Rec (mapFst add_rules prs) - update_bndr bndr = case lookupNameEnv local_rules (idName bndr) of - Nothing -> bndr - Just rules -> bndr `addIdSpecialisations` rules - -- The binder might have some existing rules, - -- arising from specialisation pragmas + -- See Note [Attach rules to local ids] + -- NB: the binder might have some existing rules, + -- arising from specialisation pragmas + add_rules bndr + | Just rules <- lookupNameEnv local_rules (idName bndr) + = bndr `addIdSpecialisations` rules + | otherwise + = bndr \end{code} Note [Simplifying the left-hand side of a RULE] @@ -393,25 +379,19 @@ otherwise we don't match when given an argument like augment (\a. h a a) (build h) +The simplifier does indeed do eta reduction (it's in +Simplify.completeLam) but only if -O is on. + \begin{code} +simplRule :: SimplEnv -> CoreRule -> SimplM CoreRule simplRule env rule@(BuiltinRule {}) = return rule simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs }) = do (env, bndrs') <- simplBinders env bndrs args' <- mapM (simplExprGently env) args rhs' <- simplExprGently env rhs - return (rule { ru_bndrs = bndrs', ru_args = args', ru_rhs = rhs' }) - --- It's important that simplExprGently does eta reduction. --- For example, in a rule like: --- augment g (build h) --- we do not want to get --- augment (\a. g a) (build h) --- otherwise we don't match when given an argument like --- (\a. h a a) --- --- The simplifier does indeed do eta reduction (it's in --- Simplify.completeLam) but only if -O is on. + return (rule { ru_bndrs = bndrs', ru_args = args' + , ru_rhs = occurAnalyseExpr rhs' }) \end{code} \begin{code} @@ -494,45 +474,49 @@ do { hsc_env <- getHscEnv ; us <- getUniqueSupplyM ; rb <- getRuleBase - ; let fam_inst_env = mg_fam_inst_env guts - dump_phase = shouldDumpSimplPhase (hsc_dflags hsc_env) mode - simplify_pgm = simplifyPgmIO dump_phase mode switches - hsc_env us rb fam_inst_env - - ; doPassM (liftIOWithCount . simplify_pgm) guts } + ; liftIOWithCount $ + simplifyPgmIO mode switches hsc_env us rb guts } where doc = ptext (sLit "Simplifier Phase") <+> text (showPpr mode) -simplifyPgmIO :: Bool - -> SimplifierMode - -> [SimplifierSwitch] - -> HscEnv - -> UniqSupply - -> RuleBase - -> FamInstEnv - -> [CoreBind] - -> IO (SimplCount, [CoreBind]) -- New bindings - -simplifyPgmIO dump_phase mode switches hsc_env us imp_rule_base fam_inst_env binds +simplifyPgmIO :: SimplifierMode + -> [SimplifierSwitch] + -> HscEnv + -> UniqSupply + -> RuleBase + -> ModGuts + -> IO (SimplCount, ModGuts) -- New bindings + +simplifyPgmIO mode switches hsc_env us hpt_rule_base + guts@(ModGuts { mg_binds = binds, mg_rules = rules + , mg_fam_inst_env = fam_inst_env }) = do { - (termination_msg, it_count, counts_out, binds') - <- do_iteration us 1 (zeroSimplCount dflags) binds ; + (termination_msg, it_count, counts_out, guts') + <- do_iteration us 1 (zeroSimplCount dflags) binds rules ; Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags) "Simplifier statistics for following pass" (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations", - text "", + blankLine, pprSimplCount counts_out]); - return (counts_out, binds') + return (counts_out, guts') } where - dflags = hsc_dflags hsc_env + dflags = hsc_dflags hsc_env + dump_phase = dumpSimplPhase dflags mode sw_chkr = isAmongSimpl switches max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2 - do_iteration us iteration_no counts binds + do_iteration :: UniqSupply + -> Int -- Counts iterations + -> SimplCount -- Logs optimisations performed + -> [CoreBind] -- Bindings in + -> [CoreRule] -- and orphan rules + -> IO (String, Int, SimplCount, ModGuts) + + do_iteration us iteration_no counts binds rules -- iteration_no is the number of the iteration we are -- about to begin, with '1' for the first | iteration_no > max_iterations -- Stop if we've run out of iterations @@ -542,25 +526,28 @@ " iterations; bailing out. Size = " ++ show (coreBindsSize binds) ++ "\n" )) -- Subtract 1 from iteration_no to get the -- number of iterations we actually completed - return ("Simplifier bailed out", iteration_no - 1, counts, binds) + return ("Simplifier bailed out", iteration_no - 1, counts, + guts { mg_binds = binds, mg_rules = rules }) -- Try and force thunks off the binds; significantly reduces -- space usage, especially with -O. JRS, 000620. | let sz = coreBindsSize binds in sz == sz = do { -- Occurrence analysis - let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds } ; + let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds rules } ; Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" (pprCoreBindings tagged_binds); -- Get any new rules, and extend the rule base + -- See Note [Overall plumbing for rules] in Rules.lhs -- We need to do this regularly, because simplification can -- poke on IdInfo thunks, which in turn brings in new rules -- behind the scenes. Otherwise there's a danger we'll simply -- miss the rules for Ids hidden inside imported inlinings eps <- hscEPS hsc_env ; - let { rule_base' = unionRuleBase imp_rule_base (eps_rule_base eps) - ; simpl_env = mkSimplEnv mode sw_chkr + let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps) + ; rule_base2 = extendRuleBaseList rule_base1 rules + ; simpl_env = mkSimplEnv sw_chkr mode ; simpl_binds = {-# SCC "SimplTopBinds" #-} simplTopBinds simpl_env tagged_binds ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ; @@ -576,19 +563,18 @@ -- case t of {(_,counts') -> if counts'=0 then ... } -- So the conditional didn't force counts', because the -- selection got duplicated. Sigh! - case initSmpl dflags rule_base' fam_envs us1 simpl_binds of { - (binds', counts') -> do { + case initSmpl dflags rule_base2 fam_envs us1 simpl_binds of { + (env1, counts1) -> do { - let { all_counts = counts `plusSimplCount` counts' - ; herald = "Simplifier mode " ++ showPpr mode ++ - ", iteration " ++ show iteration_no ++ - " out of " ++ show max_iterations + let { all_counts = counts `plusSimplCount` counts1 + ; binds1 = getFloats env1 + ; rules1 = substRulesForImportedIds (mkCoreSubst env1) rules } ; -- Stop if nothing happened; don't dump output - if isZeroSimplCount counts' then - return ("Simplifier reached fixed point", iteration_no, - all_counts, binds') + if isZeroSimplCount counts1 then + return ("Simplifier reached fixed point", iteration_no, all_counts, + guts { mg_binds = binds1, mg_rules = rules1 }) else do { -- Short out indirections -- We do this *after* at least one run of the simplifier @@ -598,18 +584,30 @@ -- -- ToDo: alas, this means that indirection-shorting does not happen at all -- if the simplifier does nothing (not common, I know, but unsavoury) - let { binds'' = {-# SCC "ZapInd" #-} shortOutIndirections binds' } ; + let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; -- Dump the result of this iteration - Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald - (pprSimplCount counts') ; - endIteration dflags herald Opt_D_dump_simpl_iterations binds'' ; + end_iteration dflags mode iteration_no max_iterations counts1 binds2 rules1 ; -- Loop - do_iteration us2 (iteration_no + 1) all_counts binds'' + do_iteration us2 (iteration_no + 1) all_counts binds2 rules1 } } } } where (us1, us2) = splitUniqSupply us + +------------------- +end_iteration :: DynFlags -> SimplifierMode -> Int -> Int + -> SimplCount -> [CoreBind] -> [CoreRule] -> IO () +-- Same as endIteration but with simplifier counts +end_iteration dflags mode iteration_no max_iterations counts binds rules + = do { Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations pass_name + (pprSimplCount counts) ; + + ; endIteration dflags pass_name Opt_D_dump_simpl_iterations binds rules } + where + pass_name = "Simplifier mode " ++ showPpr mode ++ + ", iteration " ++ show iteration_no ++ + " out of " ++ show max_iterations \end{code} @@ -646,11 +644,11 @@ RULES: we want to *add* any RULES for x_local to x_exported. -Note [Messing up the exported Id's IdInfo] +Note [Messing up the exported Id's RULES] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must be careful about discarding the IdInfo on the old Id - -The example that went bad on me at one stage was this one: +We must be careful about discarding (obviously) or even merging the +RULES on the exported Id. The example that went bad on me at one stage +was this one: iterate :: (a -> a) -> a -> [a] [Exported] @@ -821,8 +819,8 @@ = modifyIdInfo transfer exported_id where local_info = idInfo local_id - transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info - `setWorkerInfo` workerInfo local_info + transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info + `setUnfoldingInfo` unfoldingInfo local_info `setInlinePragInfo` inlinePragInfo local_info `setSpecInfo` addSpecInfo (specInfo exp_info) new_info new_info = setSpecInfoHead (idName exported_id) diff -ruN ghc-6.12.1/compiler/simplCore/SimplEnv.lhs ghc-6.13.20091231/compiler/simplCore/SimplEnv.lhs --- ghc-6.12.1/compiler/simplCore/SimplEnv.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/simplCore/SimplEnv.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -10,7 +10,7 @@ InCoercion, OutCoercion, -- The simplifier mode - setMode, getMode, + setMode, getMode, updMode, -- Switch checker SwitchChecker, SwitchResult(..), getSwitchChecker, getSimplIntSwitch, @@ -19,17 +19,17 @@ setEnclosingCC, getEnclosingCC, -- Environments - SimplEnv(..), pprSimplEnv, -- Temp not abstract + SimplEnv(..), StaticEnv, pprSimplEnv, -- Temp not abstract mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, zapSubstEnv, setSubstEnv, getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds, - getSimplRules, + getSimplRules, inGentleMode, SimplSR(..), mkContEx, substId, lookupRecBndr, simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs, simplBinder, simplBinders, addBndrRules, - substExpr, substWorker, substTy, + substExpr, substTy, getTvSubst, mkCoreSubst, -- Floats Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats, @@ -40,6 +40,7 @@ #include "HsVersions.h" import SimplMonad +import CoreMonad ( SimplifierMode(..) ) import IdInfo import CoreSyn import CoreUtils @@ -49,12 +50,11 @@ import VarSet import OrdList import Id -import qualified CoreSubst ( Subst, mkSubst, substExpr, substSpec, substWorker ) +import qualified CoreSubst ( Subst, mkSubst, substExpr, substSpec, substUnfolding ) import qualified Type ( substTy, substTyVarBndr ) import Type hiding ( substTy, substTyVarBndr ) import Coercion import BasicTypes -import DynFlags import MonadUtils import Outputable import FastString @@ -99,23 +99,32 @@ \begin{code} data SimplEnv = SimplEnv { + ----------- Static part of the environment ----------- + -- Static in the sense of lexically scoped, + -- wrt the original expression + seMode :: SimplifierMode, seChkr :: SwitchChecker, seCC :: CostCentreStack, -- The enclosing CCS (when profiling) + -- The current substitution + seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType + seIdSubst :: SimplIdSubst, -- InId |--> OutExpr + + ----------- Dynamic part of the environment ----------- + -- Dynamic in the sense of describing the setup where + -- the expression finally ends up + -- The current set of in-scope variables -- They are all OutVars, and all bound in this module seInScope :: InScopeSet, -- OutVars only -- Includes all variables bound by seFloats - seFloats :: Floats, + seFloats :: Floats -- See Note [Simplifier floats] - - -- The current substitution - seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType - seIdSubst :: SimplIdSubst -- InId |--> OutExpr - } +type StaticEnv = SimplEnv -- Just the static part is relevant + pprSimplEnv :: SimplEnv -> SDoc -- Used for debugging; selective pprSimplEnv env @@ -206,8 +215,8 @@ \begin{code} -mkSimplEnv :: SimplifierMode -> SwitchChecker -> SimplEnv -mkSimplEnv mode switches +mkSimplEnv :: SwitchChecker -> SimplifierMode -> SimplEnv +mkSimplEnv switches mode = SimplEnv { seChkr = switches, seCC = subsumedCCS, seMode = mode, seInScope = emptyInScopeSet, seFloats = emptyFloats, @@ -225,6 +234,14 @@ setMode :: SimplifierMode -> SimplEnv -> SimplEnv setMode mode env = env { seMode = mode } +updMode :: (SimplifierMode -> SimplifierMode) -> SimplEnv -> SimplEnv +updMode upd env = env { seMode = upd (seMode env) } + +inGentleMode :: SimplEnv -> Bool +inGentleMode env = case seMode env of + SimplGently {} -> True + _other -> False + --------------------- getEnclosingCC :: SimplEnv -> CostCentreStack getEnclosingCC env = seCC env @@ -660,29 +677,6 @@ old_rules = idSpecialisation in_id new_rules = CoreSubst.substSpec subst out_id old_rules final_id = out_id `setIdSpecialisation` new_rules - ------------------- -substIdType :: SimplEnv -> Id -> Id -substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id - | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id - | otherwise = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty) - -- The tyVarsOfType is cheaper than it looks - -- because we cache the free tyvars of the type - -- in a Note in the id's type itself - where - old_ty = idType id - ------------------- -substUnfolding :: SimplEnv -> Unfolding -> Unfolding -substUnfolding _ NoUnfolding = NoUnfolding -substUnfolding _ (OtherCon cons) = OtherCon cons -substUnfolding env (CompulsoryUnfolding rhs) = CompulsoryUnfolding (substExpr env rhs) -substUnfolding env (CoreUnfolding rhs t u v w g) = CoreUnfolding (substExpr env rhs) t u v w g - ------------------- -substWorker :: SimplEnv -> WorkerInfo -> WorkerInfo -substWorker _ NoWorker = NoWorker -substWorker env wkr_info = CoreSubst.substWorker (mkCoreSubst env) wkr_info \end{code} @@ -693,13 +687,16 @@ %************************************************************************ \begin{code} +getTvSubst :: SimplEnv -> TvSubst +getTvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) + = mkTvSubst in_scope tv_env + substTy :: SimplEnv -> Type -> Type -substTy (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) ty - = Type.substTy (TvSubst in_scope tv_env) ty +substTy env ty = Type.substTy (getTvSubst env) ty substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar) -substTyVarBndr env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) tv - = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of +substTyVarBndr env tv + = case Type.substTyVarBndr (getTvSubst env) tv of (TvSubst in_scope' tv_env', tv') -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv') @@ -718,9 +715,24 @@ fiddle (DoneId v) = Var v fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e +------------------ +substIdType :: SimplEnv -> Id -> Id +substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id + | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id + | otherwise = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty) + -- The tyVarsOfType is cheaper than it looks + -- because we cache the free tyvars of the type + -- in a Note in the id's type itself + where + old_ty = idType id + +------------------ substExpr :: SimplEnv -> CoreExpr -> CoreExpr substExpr env expr = CoreSubst.substExpr (mkCoreSubst env) expr -- Do *not* short-cut in the case of an empty substitution -- See CoreSubst: Note [Extending the Subst] + +substUnfolding :: SimplEnv -> Unfolding -> Unfolding +substUnfolding env unf = CoreSubst.substUnfolding (mkCoreSubst env) unf \end{code} diff -ruN ghc-6.12.1/compiler/simplCore/Simplify.lhs ghc-6.13.20091231/compiler/simplCore/Simplify.lhs --- ghc-6.12.1/compiler/simplCore/Simplify.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/simplCore/Simplify.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -18,22 +18,26 @@ import MkId ( mkImpossibleExpr, seqId ) import Var import IdInfo +import Name ( mkSystemVarName, isExternalName ) import Coercion import FamInstEnv ( topNormaliseType ) -import DataCon ( dataConRepStrictness, dataConUnivTyVars ) +import DataCon ( DataCon, dataConWorkId, dataConRepStrictness ) +import CoreMonad ( SimplifierSwitch(..), Tick(..) ) import CoreSyn -import NewDemand ( isStrictDmd, splitStrictSig ) +import Demand ( isStrictDmd, splitStrictSig ) import PprCore ( pprParendExpr, pprCoreExpr ) -import CoreUnfold ( mkUnfolding, callSiteInline, CallCtxt(..) ) +import CoreUnfold ( mkUnfolding, mkCoreUnfolding, mkInlineRule, + exprIsConApp_maybe, callSiteInline, CallCtxt(..) ) import CoreUtils +import qualified CoreSubst import CoreArity ( exprArity ) import Rules ( lookupRule, getRules ) import BasicTypes ( isMarkedStrict, Arity ) import CostCentre ( currentCCS, pushCCisNop ) import TysPrim ( realWorldStatePrimTy ) import PrelInfo ( realWorldPrimId ) -import BasicTypes ( TopLevelFlag(..), isTopLevel, - RecFlag(..), isNonRuleLoopBreaker ) +import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..) ) +import MonadUtils ( foldlM, mapAccumLM ) import Maybes ( orElse ) import Data.List ( mapAccumL ) import Outputable @@ -201,7 +205,7 @@ %************************************************************************ \begin{code} -simplTopBinds :: SimplEnv -> [InBind] -> SimplM [OutBind] +simplTopBinds :: SimplEnv -> [InBind] -> SimplM SimplEnv simplTopBinds env0 binds0 = do { -- Put all the top-level binders into scope at the start @@ -210,11 +214,10 @@ -- It's rather as if the top-level binders were imported. ; env1 <- simplRecBndrs env0 (bindersOfBinds binds0) ; dflags <- getDOptsSmpl - ; let dump_flag = dopt Opt_D_dump_inlinings dflags || - dopt Opt_D_dump_rule_firings dflags + ; let dump_flag = dopt Opt_D_verbose_core2core dflags ; env2 <- simpl_binds dump_flag env1 binds0 ; freeTick SimplifierDone - ; return (getFloats env2) } + ; return env2 } where -- We need to track the zapped top-level binders, because -- they should have their fragile IdInfo zapped (notably occurrence info) @@ -332,10 +335,9 @@ -- See Note [Floating and type abstraction] in SimplUtils -- Simplify the RHS - ; (body_env1, body1) <- simplExprF body_env body mkBoringStop - + ; (body_env1, body1) <- simplExprF body_env body mkRhsStop -- ANF-ise a constructor or PAP rhs - ; (body_env2, body2) <- prepareRhs body_env1 body1 + ; (body_env2, body2) <- prepareRhs body_env1 bndr1 body1 ; (env', rhs') <- if not (doFloatFromRhs top_lvl is_rec False body2 body_env2) @@ -351,7 +353,7 @@ do { tick LetFloatFromLet ; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2 ; rhs' <- mkLam env tvs' body3 - ; let env' = foldl (addPolyBind top_lvl) env poly_binds + ; env' <- foldlM (addPolyBind top_lvl) env poly_binds ; return (env', rhs') } ; completeBind env' top_lvl bndr bndr1 rhs' } @@ -381,7 +383,7 @@ -> SimplM SimplEnv completeNonRecX env is_strict old_bndr new_bndr new_rhs - = do { (env1, rhs1) <- prepareRhs (zapFloats env) new_rhs + = do { (env1, rhs1) <- prepareRhs (zapFloats env) new_bndr new_rhs ; (env2, rhs2) <- if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1 then do { tick LetFloatFromLet @@ -432,36 +434,42 @@ That's what the 'go' loop in prepareRhs does \begin{code} -prepareRhs :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr) +prepareRhs :: SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr) -- Adds new floats to the env iff that allows us to return a good RHS -prepareRhs env (Cast rhs co) -- Note [Float coercions] +prepareRhs env id (Cast rhs co) -- Note [Float coercions] | (ty1, _ty2) <- coercionKind co -- Do *not* do this if rhs has an unlifted type , not (isUnLiftedType ty1) -- see Note [Float coercions (unlifted)] - = do { (env', rhs') <- makeTrivial env rhs + = do { (env', rhs') <- makeTrivialWithInfo env sanitised_info rhs ; return (env', Cast rhs' co) } + where + sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info + `setDemandInfo` demandInfo info + info = idInfo id -prepareRhs env0 rhs0 - = do { (_is_val, env1, rhs1) <- go 0 env0 rhs0 +prepareRhs env0 _ rhs0 + = do { (_is_exp, env1, rhs1) <- go 0 env0 rhs0 ; return (env1, rhs1) } where go n_val_args env (Cast rhs co) - = do { (is_val, env', rhs') <- go n_val_args env rhs - ; return (is_val, env', Cast rhs' co) } + = do { (is_exp, env', rhs') <- go n_val_args env rhs + ; return (is_exp, env', Cast rhs' co) } go n_val_args env (App fun (Type ty)) - = do { (is_val, env', rhs') <- go n_val_args env fun - ; return (is_val, env', App rhs' (Type ty)) } + = do { (is_exp, env', rhs') <- go n_val_args env fun + ; return (is_exp, env', App rhs' (Type ty)) } go n_val_args env (App fun arg) - = do { (is_val, env', fun') <- go (n_val_args+1) env fun - ; case is_val of + = do { (is_exp, env', fun') <- go (n_val_args+1) env fun + ; case is_exp of True -> do { (env'', arg') <- makeTrivial env' arg ; return (True, env'', App fun' arg') } False -> return (False, env, App fun arg) } go n_val_args env (Var fun) - = return (is_val, env, Var fun) + = return (is_exp, env, Var fun) where - is_val = n_val_args > 0 -- There is at least one arg - -- ...and the fun a constructor or PAP - && (isConLikeId fun || n_val_args < idArity fun) + is_exp = isExpandableApp fun n_val_args -- The fun a constructor or PAP + -- See Note [CONLIKE pragma] in BasicTypes + -- The definition of is_exp should match that in + -- OccurAnal.occAnalApp + go _ env other = return (False, env, other) \end{code} @@ -489,6 +497,17 @@ go n = case x of { T m -> go (n-m) } -- This case should optimise +Note [Preserve strictness when floating coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the Note [Float coercions] transformation, keep the strictness info. +Eg + f = e `cast` co -- f has strictness SSL +When we transform to + f' = e -- f' also has strictness SSL + f = f' `cast` co -- f still has strictness SSL + +Its not wrong to drop it on the floor, but better to keep it. + Note [Float coercions (unlifted)] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ BUT don't do [Float coercions] if 'e' has an unlifted type. @@ -509,16 +528,19 @@ \begin{code} makeTrivial :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr) -- Binds the expression to a variable, if it's not trivial, returning the variable -makeTrivial env expr +makeTrivial env expr = makeTrivialWithInfo env vanillaIdInfo expr + +makeTrivialWithInfo :: SimplEnv -> IdInfo -> OutExpr -> SimplM (SimplEnv, OutExpr) +-- Propagate strictness and demand info to the new binder +-- Note [Preserve strictness when floating coercions] +makeTrivialWithInfo env info expr | exprIsTrivial expr = return (env, expr) | otherwise -- See Note [Take care] below - = do { var <- newId (fsLit "a") (exprType expr) + = do { uniq <- getUniqueM + ; let name = mkSystemVarName uniq (fsLit "a") + var = mkLocalIdWithInfo name (exprType expr) info ; env' <- completeNonRecX env False var var expr --- pprTrace "makeTrivial" (vcat [ppr var <+> ppr (exprArity (substExpr env' (Var var))) --- , ppr expr --- , ppr (substExpr env' (Var var)) --- , ppr (idArity (fromJust (lookupInScope (seInScope env') var))) ]) $ ; return (env', substExpr env' (Var var)) } -- The substitution is needed becase we're constructing a new binding -- a = rhs @@ -566,29 +588,24 @@ -- * or by adding to the floats in the envt completeBind env top_lvl old_bndr new_bndr new_rhs - | postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs unfolding - -- Inline and discard the binding - = do { tick (PostInlineUnconditionally old_bndr) - ; -- pprTrace "postInlineUnconditionally" (ppr old_bndr <+> ppr new_bndr <+> ppr new_rhs) $ - return (extendIdSubst env old_bndr (DoneEx new_rhs)) } - -- Use the substitution to make quite, quite sure that the - -- substitution will happen, since we are going to discard the binding + = do { let old_info = idInfo old_bndr + old_unf = unfoldingInfo old_info + occ_info = occInfo old_info + + ; new_unfolding <- simplUnfolding env top_lvl old_bndr occ_info new_rhs old_unf + + ; if postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs new_unfolding + -- Inline and discard the binding + then do { tick (PostInlineUnconditionally old_bndr) + ; -- pprTrace "postInlineUnconditionally" (ppr old_bndr <+> equals <+> ppr new_rhs) $ + return (extendIdSubst env old_bndr (DoneEx new_rhs)) } + -- Use the substitution to make quite, quite sure that the + -- substitution will happen, since we are going to discard the binding - | otherwise - = return (addNonRecWithUnf env new_bndr new_rhs unfolding wkr) - where - unfolding | omit_unfolding = NoUnfolding - | otherwise = mkUnfolding (isTopLevel top_lvl) new_rhs - old_info = idInfo old_bndr - occ_info = occInfo old_info - wkr = substWorker env (workerInfo old_info) - omit_unfolding = isNonRuleLoopBreaker occ_info - -- or not (activeInline env old_bndr) - -- Do *not* trim the unfolding in SimplGently, else - -- the specialiser can't see it! + else return (addNonRecWithUnf env new_bndr new_rhs new_unfolding) } ------------------ -addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplEnv +------------------------------ +addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplM SimplEnv -- Add a new binding to the environment, complete with its unfolding -- but *do not* do postInlineUnconditionally, because we have already -- processed some of the scope of the binding @@ -601,71 +618,81 @@ -- opportunity to inline 'y' too. addPolyBind top_lvl env (NonRec poly_id rhs) - = addNonRecWithUnf env poly_id rhs unfolding NoWorker - where - unfolding | not (activeInline env poly_id) = NoUnfolding - | otherwise = mkUnfolding (isTopLevel top_lvl) rhs - -- addNonRecWithInfo adds the new binding in the - -- proper way (ie complete with unfolding etc), - -- and extends the in-scope set + = do { unfolding <- simplUnfolding env top_lvl poly_id NoOccInfo rhs noUnfolding + -- Assumes that poly_id did not have an INLINE prag + -- which is perhaps wrong. ToDo: think about this + ; return (addNonRecWithUnf env poly_id rhs unfolding) } -addPolyBind _ env bind@(Rec _) = extendFloats env bind +addPolyBind _ env bind@(Rec _) = return (extendFloats env bind) -- Hack: letrecs are more awkward, so we extend "by steam" -- without adding unfoldings etc. At worst this leads to -- more simplifier iterations ------------------ +------------------------------ addNonRecWithUnf :: SimplEnv - -> OutId -> OutExpr -- New binder and RHS - -> Unfolding -> WorkerInfo -- and unfolding - -> SimplEnv --- Add suitable IdInfo to the Id, add the binding to the floats, and extend the in-scope set -addNonRecWithUnf env new_bndr rhs unfolding wkr - = ASSERT( isId new_bndr ) + -> OutId -> OutExpr -- New binder and RHS + -> Unfolding -- New unfolding + -> SimplEnv +addNonRecWithUnf env new_bndr new_rhs new_unfolding + = let new_arity = exprArity new_rhs + old_arity = idArity new_bndr + info1 = idInfo new_bndr `setArityInfo` new_arity + + -- Unfolding info: Note [Setting the new unfolding] + info2 = info1 `setUnfoldingInfo` new_unfolding + + -- Demand info: Note [Setting the demand info] + info3 | isEvaldUnfolding new_unfolding = zapDemandInfo info2 `orElse` info2 + | otherwise = info2 + + final_id = new_bndr `setIdInfo` info3 + dmd_arity = length $ fst $ splitStrictSig $ idStrictness new_bndr + in + ASSERT( isId new_bndr ) WARN( new_arity < old_arity || new_arity < dmd_arity, (ptext (sLit "Arity decrease:") <+> ppr final_id <+> ppr old_arity - <+> ppr new_arity <+> ppr dmd_arity) $$ ppr rhs ) + <+> ppr new_arity <+> ppr dmd_arity) ) -- Note [Arity decrease] - final_id `seq` -- This seq forces the Id, and hence its IdInfo, - -- and hence any inner substitutions - addNonRec env final_id rhs - -- The addNonRec adds it to the in-scope set too - where - dmd_arity = length $ fst $ splitStrictSig $ idNewStrictness new_bndr - old_arity = idArity new_bndr - -- Arity info - new_arity = exprArity rhs - new_bndr_info = idInfo new_bndr `setArityInfo` new_arity - - -- Unfolding info - -- Add the unfolding *only* for non-loop-breakers - -- Making loop breakers not have an unfolding at all - -- means that we can avoid tests in exprIsConApp, for example. - -- This is important: if exprIsConApp says 'yes' for a recursive - -- thing, then we can get into an infinite loop - - -- Demand info - -- If the unfolding is a value, the demand info may - -- go pear-shaped, so we nuke it. Example: - -- let x = (a,b) in - -- case x of (p,q) -> h p q x - -- Here x is certainly demanded. But after we've nuked - -- the case, we'll get just - -- let x = (a,b) in h a b x - -- and now x is not demanded (I'm assuming h is lazy) - -- This really happens. Similarly - -- let f = \x -> e in ...f..f... - -- After inlining f at some of its call sites the original binding may - -- (for example) be no longer strictly demanded. - -- The solution here is a bit ad hoc... - info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding - `setWorkerInfo` wkr + final_id `seq` -- This seq forces the Id, and hence its IdInfo, + -- and hence any inner substitutions + -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $ + addNonRec env final_id new_rhs + -- The addNonRec adds it to the in-scope set too + +------------------------------ +simplUnfolding :: SimplEnv-> TopLevelFlag + -> Id + -> OccInfo -> OutExpr + -> Unfolding -> SimplM Unfolding +-- Note [Setting the new unfolding] +simplUnfolding env _ _ _ _ (DFunUnfolding con ops) + = return (DFunUnfolding con ops') + where + ops' = map (CoreSubst.substExpr (mkCoreSubst env)) ops - final_info | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf - | otherwise = info_w_unf - - final_id = new_bndr `setIdInfo` final_info +simplUnfolding env top_lvl id _ _ + (CoreUnfolding { uf_tmpl = expr, uf_arity = arity + , uf_src = src, uf_guidance = guide }) + | isInlineRuleSource src + = -- pprTrace "su" (vcat [ppr id, ppr act, ppr (getMode env), ppr (getMode rule_env)]) $ + do { expr' <- simplExpr rule_env expr + ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst env) src + ; return (mkCoreUnfolding (isTopLevel top_lvl) src' expr' arity guide) } + -- See Note [Top-level flag on inline rules] in CoreUnfold + where + act = idInlineActivation id + rule_env = updMode (updModeForInlineRules act) env + -- See Note [Simplifying gently inside InlineRules] in SimplUtils + +simplUnfolding _ top_lvl id _occ_info new_rhs _ + = return (mkUnfolding (isTopLevel top_lvl) (isBottomingId id) new_rhs) + -- We make an unfolding *even for loop-breakers*. + -- Reason: (a) It might be useful to know that they are WHNF + -- (b) In TidyPgm we currently assume that, if we want to + -- expose the unfolding then indeed we *have* an unfolding + -- to expose. (We could instead use the RHS, but currently + -- we don't.) The simple thing is always to have one. \end{code} Note [Arity decrease] @@ -691,6 +718,38 @@ That's why Specialise goes to a little trouble to pin the right arity on specialised functions too. +Note [Setting the new unfolding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* If there's an INLINE pragma, we simplify the RHS gently. Maybe we + should do nothing at all, but simplifying gently might get rid of + more crap. + +* If not, we make an unfolding from the new RHS. But *only* for + non-loop-breakers. Making loop breakers not have an unfolding at all + means that we can avoid tests in exprIsConApp, for example. This is + important: if exprIsConApp says 'yes' for a recursive thing, then we + can get into an infinite loop + +If there's an InlineRule on a loop breaker, we hang on to the inlining. +It's pretty dodgy, but the user did say 'INLINE'. May need to revisit +this choice. + +Note [Setting the demand info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the unfolding is a value, the demand info may +go pear-shaped, so we nuke it. Example: + let x = (a,b) in + case x of (p,q) -> h p q x +Here x is certainly demanded. But after we've nuked +the case, we'll get just + let x = (a,b) in h a b x +and now x is not demanded (I'm assuming h is lazy) +This really happens. Similarly + let f = \x -> e in ...f..f... +After inlining f at some of its call sites the original binding may +(for example) be no longer strictly demanded. +The solution here is a bit ad hoc... + %************************************************************************ %* * @@ -787,7 +846,7 @@ simplExprF' env (Type ty) cont = ASSERT( contIsRhsOrArg cont ) - do { ty' <- simplType env ty + do { ty' <- simplCoercion env ty ; rebuild env (Type ty') cont } simplExprF' env (Case scrut bndr _ alts) cont @@ -819,9 +878,18 @@ -- Kept monadic just so we can do the seqType simplType env ty = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $ - seqType new_ty `seq` return new_ty + seqType new_ty `seq` return new_ty where new_ty = substTy env ty + +--------------------------------- +simplCoercion :: SimplEnv -> InType -> SimplM OutType +-- The InType isn't *necessarily* a coercion, but it might be +-- (in a type application, say) and optCoercion is a no-op on types +simplCoercion env co + = seqType new_co `seq` return new_co + where + new_co = optCoercion (getTvSubst env) co \end{code} @@ -841,7 +909,7 @@ Stop {} -> return (env, expr) CoerceIt co cont -> rebuild env (mkCoerce co expr) cont Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont - StrictArg fun _ info cont -> rebuildCall env (fun `App` expr) info cont + StrictArg info _ cont -> rebuildCall env (info `addArgTo` expr) cont StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr ; simplLam env' bs body cont } ApplyTo _ arg se cont -> do { arg' <- simplExpr (se `setInScope` env) arg @@ -859,7 +927,7 @@ simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont -> SimplM (SimplEnv, OutExpr) simplCast env body co0 cont0 - = do { co1 <- simplType env co0 + = do { co1 <- simplCoercion env co0 ; simplExprF env body (addCoerce co1 cont0) } where addCoerce co cont = add_coerce co (coercionKind co) cont @@ -883,14 +951,19 @@ add_coerce co (s1s2, _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont) -- (f |> g) ty ---> (f ty) |> (g @ ty) - -- This implements the PushT rule from the paper + -- This implements the PushT and PushC rules from the paper | Just (tyvar,_) <- splitForAllTy_maybe s1s2 - , not (isCoVar tyvar) - = ApplyTo dup (Type ty') (zapSubstEnv env) (addCoerce (mkInstCoercion co ty') cont) + = let + (new_arg_ty, new_cast) + | isCoVar tyvar = (new_arg_co, mkCselRCoercion co) -- PushC rule + | otherwise = (ty', mkInstCoercion co ty') -- PushT rule + in + ApplyTo dup (Type new_arg_ty) (zapSubstEnv arg_se) (addCoerce new_cast cont) where ty' = substTy (arg_se `setInScope` env) arg_ty - - -- ToDo: the PushC rule is not implemented at all + new_arg_co = mkCsel1Coercion co `mkTransCoercion` + ty' `mkTransCoercion` + mkSymCoercion (mkCsel2Coercion co) add_coerce co (s1s2, _t1t2) (ApplyTo dup arg arg_se cont) | not (isTypeArg arg) -- This implements the Push rule from the paper @@ -909,7 +982,7 @@ -- But it isn't a common case. -- -- Example of use: Trac #995 - = ApplyTo dup new_arg (zapSubstEnv env) (addCoerce co2 cont) + = ApplyTo dup new_arg (zapSubstEnv arg_se) (addCoerce co2 cont) where -- we split coercion t1->t2 ~ s1->s2 into t1 ~ s1 and -- t2 ~ s2 with left and right on the curried form: @@ -948,7 +1021,7 @@ ------------------ simplNonRecE :: SimplEnv - -> InId -- The binder + -> InBndr -- The binder -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda) -> ([InBndr], InExpr) -- Body of the let/lambda -- \xs.e @@ -1010,21 +1083,9 @@ = do { e' <- simplExpr (setEnclosingCC env currentCCS) e ; rebuild env (mkSCC cc e') cont } --- See notes with SimplMonad.inlineMode -simplNote env InlineMe e cont - | Just (inside, outside) <- splitInlineCont cont -- Boring boring continuation; see notes above - = do { -- Don't inline inside an INLINE expression - e' <- simplExprC (setMode inlineMode env) e inside - ; rebuild env (mkInlineMe e') outside } - - | otherwise -- Dissolve the InlineMe note if there's - -- an interesting context of any kind to combine with - -- (even a type application -- anything except Stop) - = simplExprF env e cont - -simplNote env (CoreNote s) e cont = do - e' <- simplExpr env e - rebuild env (Note (CoreNote s) e') cont +simplNote env (CoreNote s) e cont + = do { e' <- simplExpr env e + ; rebuild env (Note (CoreNote s) e') cont } \end{code} @@ -1040,7 +1101,7 @@ = case substId env var of DoneEx e -> simplExprF (zapSubstEnv env) e cont ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont - DoneId var1 -> completeCall (zapSubstEnv env) var1 cont + DoneId var1 -> completeCall env var1 cont -- Note [zapSubstEnv] -- The template is already simplified, so don't re-substitute. -- This is VITAL. Consider @@ -1056,66 +1117,52 @@ completeCall :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr) completeCall env var cont - = do { let (args,call_cont) = contArgs cont + = do { ------------- Try inlining ---------------- + dflags <- getDOptsSmpl + ; let (args,call_cont) = contArgs cont -- The args are OutExprs, obtained by *lazily* substituting -- in the args found in cont. These args are only examined -- to limited depth (unless a rule fires). But we must do -- the substitution; rule matching on un-simplified args would -- be bogus - ------------- First try rules ---------------- - -- Do this before trying inlining. Some functions have - -- rules *and* are strict; in this case, we don't want to - -- inline the wrapper of the non-specialised thing; better - -- to call the specialised thing instead. - -- - -- We used to use the black-listing mechanism to ensure that inlining of - -- the wrapper didn't occur for things that have specialisations till a - -- later phase, so but now we just try RULES first - -- - -- See also Note [Rules for recursive functions] - ; mb_rule <- tryRules env var args call_cont - ; case mb_rule of { - Just (n_args, rule_rhs) -> simplExprF env rule_rhs (dropArgs n_args cont) ; - -- The ruleArity says how many args the rule consumed - ; Nothing -> do -- No rules - - - ------------- Next try inlining ---------------- - { dflags <- getDOptsSmpl - ; let arg_infos = [interestingArg arg | arg <- args, isValArg arg] - n_val_args = length arg_infos - interesting_cont = interestingCallContext call_cont - active_inline = activeInline env var - maybe_inline = callSiteInline dflags active_inline var - (null args) arg_infos interesting_cont + arg_infos = [interestingArg arg | arg <- args, isValArg arg] + n_val_args = length arg_infos + interesting_cont = interestingCallContext call_cont + unfolding = activeUnfolding env var + maybe_inline = callSiteInline dflags var unfolding + (null args) arg_infos interesting_cont ; case maybe_inline of { Just unfolding -- There is an inlining! -> do { tick (UnfoldingDone var) - ; (if dopt Opt_D_dump_inlinings dflags then - pprTrace ("Inlining done: " ++ showSDoc (ppr var)) (vcat [ - text "Before:" <+> ppr var <+> sep (map pprParendExpr args), - text "Inlined fn: " <+> nest 2 (ppr unfolding), - text "Cont: " <+> ppr call_cont]) - else - id) - simplExprF env unfolding cont } + ; trace_inline dflags unfolding args call_cont $ + simplExprF (zapSubstEnv env) unfolding cont } - ; Nothing -> -- No inlining! + ; Nothing -> do -- No inlining! - ------------- No inlining! ---------------- - -- Next, look for rules or specialisations that match - -- - rebuildCall env (Var var) - (mkArgInfo var n_val_args call_cont) cont - }}}} + { rule_base <- getSimplRules + ; let info = mkArgInfo var (getRules rule_base var) n_val_args call_cont + ; rebuildCall env info cont + }}} + where + trace_inline dflags unfolding args call_cont stuff + | not (dopt Opt_D_dump_inlinings dflags) = stuff + | not (dopt Opt_D_verbose_core2core dflags) + = if isExternalName (idName var) then + pprTrace "Inlining done:" (ppr var) stuff + else stuff + | otherwise + = pprTrace ("Inlining done: " ++ showSDoc (ppr var)) + (vcat [text "Before:" <+> ppr var <+> sep (map pprParendExpr args), + text "Inlined fn: " <+> nest 2 (ppr unfolding), + text "Cont: " <+> ppr call_cont]) + stuff rebuildCall :: SimplEnv - -> OutExpr -- Function -> ArgInfo -> SimplCont -> SimplM (SimplEnv, OutExpr) -rebuildCall env fun (ArgInfo { ai_strs = [] }) cont +rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) cont -- When we run out of strictness args, it means -- that the call is definitely bottom; see SimplUtils.mkArgInfo -- Then we want to discard the entire strict continuation. E.g. @@ -1127,25 +1174,26 @@ -- the continuation, leaving just the bottoming expression. But the -- type might not be right, so we may have to add a coerce. | not (contIsTrivial cont) -- Only do this if there is a non-trivial - = return (env, mk_coerce fun) -- contination to discard, else we do it + = return (env, mk_coerce res) -- contination to discard, else we do it where -- again and again! - fun_ty = exprType fun - cont_ty = contResultType env fun_ty cont - co = mkUnsafeCoercion fun_ty cont_ty - mk_coerce expr | cont_ty `coreEqType` fun_ty = expr + res = mkApps (Var fun) (reverse rev_args) + res_ty = exprType res + cont_ty = contResultType env res_ty cont + co = mkUnsafeCoercion res_ty cont_ty + mk_coerce expr | cont_ty `coreEqType` res_ty = expr | otherwise = mkCoerce co expr -rebuildCall env fun info (ApplyTo _ (Type arg_ty) se cont) - = do { ty' <- simplType (se `setInScope` env) arg_ty - ; rebuildCall env (fun `App` Type ty') info cont } - -rebuildCall env fun - (ArgInfo { ai_rules = has_rules, ai_strs = str:strs, ai_discs = disc:discs }) - (ApplyTo _ arg arg_se cont) +rebuildCall env info (ApplyTo _ (Type arg_ty) se cont) + = do { ty' <- simplCoercion (se `setInScope` env) arg_ty + ; rebuildCall env (info `addArgTo` Type ty') cont } + +rebuildCall env info@(ArgInfo { ai_encl = encl_rules + , ai_strs = str:strs, ai_discs = disc:discs }) + (ApplyTo _ arg arg_se cont) | str -- Strict argument = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ simplExprF (arg_se `setFloats` env) arg - (StrictArg fun cci arg_info' cont) + (StrictArg info' cci cont) -- Note [Shadowing] | otherwise -- Lazy argument @@ -1155,15 +1203,39 @@ -- floating a demanded let. = do { arg' <- simplExprC (arg_se `setInScope` env) arg (mkLazyArgStop cci) - ; rebuildCall env (fun `App` arg') arg_info' cont } + ; rebuildCall env (addArgTo info' arg') cont } where - arg_info' = ArgInfo { ai_rules = has_rules, ai_strs = strs, ai_discs = discs } - cci | has_rules || disc > 0 = ArgCtxt has_rules disc -- Be keener here - | otherwise = BoringCtxt -- Nothing interesting - -rebuildCall env fun _ cont - = rebuild env fun cont -\end{code} + info' = info { ai_strs = strs, ai_discs = discs } + cci | encl_rules || disc > 0 = ArgCtxt encl_rules -- Be keener here + | otherwise = BoringCtxt -- Nothing interesting + +rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) cont + = do { -- We've accumulated a simplified call in + -- so try rewrite rules; see Note [RULEs apply to simplified arguments] + -- See also Note [Rules for recursive functions] + ; let args = reverse rev_args + env' = zapSubstEnv env + ; mb_rule <- tryRules env rules fun args cont + ; case mb_rule of { + Just (n_args, rule_rhs) -> simplExprF env' rule_rhs $ + pushArgs env' (drop n_args args) cont ; + -- n_args says how many args the rule consumed + ; Nothing -> rebuild env (mkApps (Var fun) args) cont -- No rules + } } +\end{code} + +Note [RULES apply to simplified arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's very desirable to try RULES once the arguments have been simplified, because +doing so ensures that rule cascades work in one pass. Consider + {-# RULES g (h x) = k x + f (k x) = x #-} + ...f (g (h x))... +Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If +we match f's rules against the un-simplified RHS, it won't match. This +makes a particularly big difference when superclass selectors are involved: + op ($p1 ($p2 (df d))) +We want all this to unravel in one sweeep. Note [Shadowing] ~~~~~~~~~~~~~~~~ @@ -1197,33 +1269,38 @@ %************************************************************************ \begin{code} -tryRules :: SimplEnv -> Id -> [OutExpr] -> SimplCont +tryRules :: SimplEnv -> [CoreRule] + -> Id -> [OutExpr] -> SimplCont -> SimplM (Maybe (Arity, CoreExpr)) -- The arity is the number of -- args consumed by the rule -tryRules env fn args call_cont - = do { dflags <- getDOptsSmpl - ; rule_base <- getSimplRules - ; let in_scope = getInScope env - rules = getRules rule_base fn - maybe_rule = case activeRule dflags env of - Nothing -> Nothing -- No rules apply - Just act_fn -> lookupRule act_fn in_scope - fn args rules - ; case (rules, maybe_rule) of { - ([], _) -> return Nothing ; - (_, Nothing) -> return Nothing ; - (_, Just (rule, rule_rhs)) -> do - - { tick (RuleFired (ru_name rule)) - ; (if dopt Opt_D_dump_rule_firings dflags then - pprTrace "Rule fired" (vcat [ - text "Rule:" <+> ftext (ru_name rule), - text "Before:" <+> ppr fn <+> sep (map pprParendExpr args), - text "After: " <+> pprCoreExpr rule_rhs, - text "Cont: " <+> ppr call_cont]) - else - id) $ - return (Just (ruleArity rule, rule_rhs)) }}} +tryRules env rules fn args call_cont + | null rules + = return Nothing + | otherwise + = do { dflags <- getDOptsSmpl + ; case activeRule dflags env of { + Nothing -> return Nothing ; -- No rules apply + Just act_fn -> + case lookupRule act_fn (activeUnfInRule env) (getInScope env) fn args rules of { + Nothing -> return Nothing ; -- No rule matches + Just (rule, rule_rhs) -> + + do { tick (RuleFired (ru_name rule)) + ; trace_dump dflags rule rule_rhs $ + return (Just (ruleArity rule, rule_rhs)) }}}} + where + trace_dump dflags rule rule_rhs stuff + | not (dopt Opt_D_dump_rule_firings dflags) = stuff + | not (dopt Opt_D_verbose_core2core dflags) + + = pprTrace "Rule fired:" (ftext (ru_name rule)) stuff + | otherwise + = pprTrace "Rule fired" + (vcat [text "Rule:" <+> ftext (ru_name rule), + text "Before:" <+> ppr fn <+> sep (map pprParendExpr args), + text "After: " <+> pprCoreExpr rule_rhs, + text "Cont: " <+> ppr call_cont]) + stuff \end{code} Note [Rules for recursive functions] @@ -1350,14 +1427,27 @@ -------------------------------------------------- rebuildCase env scrut case_bndr alts cont - | Just (con,args) <- exprIsConApp_maybe scrut - -- Works when the scrutinee is a variable with a known unfolding - -- as well as when it's an explicit constructor application - = knownCon env scrut (DataAlt con) args case_bndr alts cont - | Lit lit <- scrut -- No need for same treatment as constructors -- because literals are inlined more vigorously - = knownCon env scrut (LitAlt lit) [] case_bndr alts cont + = do { tick (KnownBranch case_bndr) + ; case findAlt (LitAlt lit) alts of + Nothing -> missingAlt env case_bndr alts cont + Just (_, bs, rhs) -> simple_rhs bs rhs } + + | Just (con, ty_args, other_args) <- exprIsConApp_maybe (activeUnfInRule env) scrut + -- Works when the scrutinee is a variable with a known unfolding + -- as well as when it's an explicit constructor application + = do { tick (KnownBranch case_bndr) + ; case findAlt (DataAlt con) alts of + Nothing -> missingAlt env case_bndr alts cont + Just (DEFAULT, bs, rhs) -> simple_rhs bs rhs + Just (_, bs, rhs) -> knownCon env scrut con ty_args other_args + case_bndr bs rhs cont + } + where + simple_rhs bs rhs = ASSERT( null bs ) + do { env' <- simplNonRecX env case_bndr scrut + ; simplExprF env' rhs cont } -------------------------------------------------- @@ -1398,20 +1488,25 @@ where -- The case binder is going to be evaluated later, -- and the scrutinee is a simple variable - var_demanded_later (Var v) = isStrictDmd (idNewDemandInfo case_bndr) + var_demanded_later (Var v) = isStrictDmd (idDemandInfo case_bndr) && not (isTickBoxOp v) -- ugly hack; covering this case is what -- exprOkForSpeculation was intended for. var_demanded_later _ = False +-------------------------------------------------- +-- 3. Try seq rules; see Note [User-defined RULES for seq] in MkId +-------------------------------------------------- + rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont | all isDeadBinder (case_bndr : bndrs) -- So this is just 'seq' - = -- For this case, see Note [Rules for seq] in MkId - do { let rhs' = substExpr env rhs + = do { let rhs' = substExpr env rhs out_args = [Type (substTy env (idType case_bndr)), Type (exprType rhs'), scrut, rhs'] -- Lazily evaluated, so we don't do most of this - ; mb_rule <- tryRules env seqId out_args cont + + ; rule_base <- getSimplRules + ; mb_rule <- tryRules env (getRules rule_base seqId) seqId out_args cont ; case mb_rule of Just (n_args, res) -> simplExprF (zapSubstEnv env) (mkApps res (drop n_args out_args)) @@ -1436,9 +1531,11 @@ -- Check for empty alternatives ; if null alts' then missingAlt env case_bndr alts cont else do - { case_expr <- mkCase scrut' case_bndr' alts' + { dflags <- getDOptsSmpl + ; case_expr <- mkCase dflags scrut' case_bndr' alts' - -- Notice that rebuild gets the in-scope set from env, not alt_env + -- Notice that rebuild gets the in-scope set from env', not alt_env + -- (which in any case is only build in simplAlts) -- The case binder *not* scope over the whole returned case-expression ; rebuild env' case_expr nodup_cont } } \end{code} @@ -1465,6 +1562,19 @@ after the outer case, and that makes (a,b) alive. At least we do unless the case binder is guaranteed dead. +In practice, the scrutinee is almost always a variable, so we pretty +much always zap the OccInfo of the binders. It doesn't matter much though. + + +Note [Case of cast] +~~~~~~~~~~~~~~~~~~~ +Consider case (v `cast` co) of x { I# y -> + ... (case (v `cast` co) of {...}) ... +We'd like to eliminate the inner case. We can get this neatly by +arranging that inside the outer case we add the unfolding + v |-> x `cast` (sym co) +to v. Then we should inline v at the inner case, cancel the casts, and away we go + Note [Improving seq] ~~~~~~~~~~~~~~~~~~~ Consider @@ -1479,10 +1589,31 @@ I# x# -> let x = x' `cast` sym co in rhs -so that 'rhs' can take advantage of the form of x'. Notice that Note -[Case of cast] may then apply to the result. +so that 'rhs' can take advantage of the form of x'. + +Notice that Note [Case of cast] may then apply to the result. -This showed up in Roman's experiments. Example: +Nota Bene: We only do the [Improving seq] transformation if the +case binder 'x' is actually used in the rhs; that is, if the case +is *not* a *pure* seq. + a) There is no point in adding the cast to a pure seq. + b) There is a good reason not to: doing so would interfere + with seq rules (Note [Built-in RULES for seq] in MkId). + In particular, this [Improving seq] thing *adds* a cast + while [Built-in RULES for seq] *removes* one, so they + just flip-flop. + +You might worry about + case v of x { __DEFAULT -> + ... case (v `cast` co) of y { I# -> ... }} +This is a pure seq (since x is unused), so [Improving seq] won't happen. +But it's ok: the simplifier will replace 'v' by 'x' in the rhs to get + case v of x { __DEFAULT -> + ... case (x `cast` co) of y { I# -> ... }} +Now the outer case is not a pure seq, so [Improving seq] will happen, +and then the inner case will disappear. + +The need for [Improving seq] showed up in Roman's experiments. Example: foo :: F Int -> Int -> Int foo t n = t `seq` bar n where @@ -1491,94 +1622,9 @@ Here we'd like to avoid repeated evaluating t inside the loop, by taking advantage of the `seq`. -At one point I did transformation in LiberateCase, but it's more robust here. -(Otherwise, there's a danger that we'll simply drop the 'seq' altogether, before -LiberateCase gets to see it.) - - - - -\begin{code} -improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv - -> OutExpr -> InId -> OutId -> [InAlt] - -> SimplM (SimplEnv, OutExpr, OutId) --- Note [Improving seq] -improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)] - | Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1) - = do { case_bndr2 <- newId (fsLit "nt") ty2 - ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co) - env2 = extendIdSubst env case_bndr rhs - ; return (env2, scrut `Cast` co, case_bndr2) } - -improveSeq _ env scrut _ case_bndr1 _ - = return (env, scrut, case_bndr1) - -{- - improve_case_bndr env scrut case_bndr - -- See Note [no-case-of-case] - -- | switchIsOn (getSwitchChecker env) NoCaseOfCase - -- = (env, case_bndr) - - | otherwise -- Failed try; see Note [Suppressing the case binder-swap] - -- not (isEvaldUnfolding (idUnfolding v)) - = case scrut of - Var v -> (modifyInScope env1 v case_bndr', case_bndr') - -- Note about using modifyInScope for v here - -- We could extend the substitution instead, but it would be - -- a hack because then the substitution wouldn't be idempotent - -- any more (v is an OutId). And this does just as well. - - Cast (Var v) co -> (addBinderUnfolding env1 v rhs, case_bndr') - where - rhs = Cast (Var case_bndr') (mkSymCoercion co) - - _ -> (env, case_bndr) - where - case_bndr' = zapIdOccInfo case_bndr - env1 = modifyInScope env case_bndr case_bndr' --} -\end{code} - - -simplAlts does two things: - -1. Eliminate alternatives that cannot match, including the - DEFAULT alternative. - -2. If the DEFAULT alternative can match only one possible constructor, - then make that constructor explicit. - e.g. - case e of x { DEFAULT -> rhs } - ===> - case e of x { (a,b) -> rhs } - where the type is a single constructor type. This gives better code - when rhs also scrutinises x or e. - -Here "cannot match" includes knowledge from GADTs - -It's a good idea do do this stuff before simplifying the alternatives, to -avoid simplifying alternatives we know can't happen, and to come up with -the list of constructors that are handled, to put into the IdInfo of the -case binder, for use when simplifying the alternatives. - -Eliminating the default alternative in (1) isn't so obvious, but it can -happen: - -data Colour = Red | Green | Blue - -f x = case x of - Red -> .. - Green -> .. - DEFAULT -> h x - -h y = case y of - Blue -> .. - DEFAULT -> [ case y of ... ] - -If we inline h into f, the default case of the inlined h can't happen. -If we don't notice this, we may end up filtering out *all* the cases -of the inner case y, which give us nowhere to go! - +At one point I did transformation in LiberateCase, but it's more +robust here. (Otherwise, there's a danger that we'll simply drop the +'seq' altogether, before LiberateCase gets to see it.) \begin{code} simplAlts :: SimplEnv @@ -1588,7 +1634,7 @@ -> SimplCont -> SimplM (OutExpr, OutId, [OutAlt]) -- Includes the continuation -- Like simplExpr, this just returns the simplified alternatives; --- it not return an environment +-- it does not return an environment simplAlts env scrut case_bndr alts cont' = -- pprTrace "simplAlts" (ppr alts $$ ppr (seIdSubst env)) $ @@ -1600,11 +1646,29 @@ ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env1 scrut case_bndr case_bndr1 alts - ; (imposs_deflt_cons, in_alts) <- prepareAlts alt_env' scrut' case_bndr' alts + ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts ; alts' <- mapM (simplAlt alt_env' imposs_deflt_cons case_bndr' cont') in_alts ; return (scrut', case_bndr', alts') } + +------------------------------------ +improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv + -> OutExpr -> InId -> OutId -> [InAlt] + -> SimplM (SimplEnv, OutExpr, OutId) +-- Note [Improving seq] +improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)] + | not (isDeadBinder case_bndr) -- Not a pure seq! See the Note! + , Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1) + = do { case_bndr2 <- newId (fsLit "nt") ty2 + ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co) + env2 = extendIdSubst env case_bndr rhs + ; return (env2, scrut `Cast` co, case_bndr2) } + +improveSeq _ env scrut _ case_bndr1 _ + = return (env, scrut, case_bndr1) + + ------------------------------------ simplAlt :: SimplEnv -> [AltCon] -- These constructors can't be present when @@ -1678,7 +1742,7 @@ addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv addBinderUnfolding env bndr rhs - = modifyInScope env (bndr `setIdUnfolding` mkUnfolding False rhs) + = modifyInScope env (bndr `setIdUnfolding` mkUnfolding False False rhs) addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv addBinderOtherCon env bndr cons @@ -1714,26 +1778,15 @@ All this should happen in one sweep. \begin{code} -knownCon :: SimplEnv -> OutExpr -> AltCon - -> [OutExpr] -- Args *including* the universal args - -> InId -> [InAlt] -> SimplCont - -> SimplM (SimplEnv, OutExpr) - -knownCon env scrut con args bndr alts cont - = do { tick (KnownBranch bndr) - ; case findAlt con alts of - Nothing -> missingAlt env bndr alts cont - Just alt -> knownAlt env scrut args bndr alt cont - } - -------------------- -knownAlt :: SimplEnv -> OutExpr -> [OutExpr] - -> InId -> InAlt -> SimplCont +knownCon :: SimplEnv + -> OutExpr -- The scrutinee + -> DataCon -> [OutType] -> [OutExpr] -- The scrutinee (in pieces) + -> InId -> [InBndr] -> InExpr -- The alternative + -> SimplCont -> SimplM (SimplEnv, OutExpr) -knownAlt env scrut the_args bndr (DataAlt dc, bs, rhs) cont - = do { let n_drop_tys = length (dataConUnivTyVars dc) - ; env' <- bind_args env bs (drop n_drop_tys the_args) +knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont + = do { env' <- bind_args env bs dc_args ; let -- It's useful to bind bndr to scrut, rather than to a fresh -- binding x = Con arg1 .. argn @@ -1742,12 +1795,12 @@ -- BUT, if scrut is a not a variable, we must be careful -- about duplicating the arg redexes; in that case, make -- a new con-app from the args - bndr_rhs = case scrut of - Var _ -> scrut - _ -> con_app - con_app = mkConApp dc (take n_drop_tys the_args ++ con_args) - con_args = [substExpr env' (varToCoreExpr b) | b <- bs] - -- args are aready OutExprs, but bs are InIds + bndr_rhs | exprIsTrivial scrut = scrut + | otherwise = con_app + con_app = Var (dataConWorkId dc) + `mkTyApps` dc_ty_args + `mkApps` [substExpr env' (varToCoreExpr b) | b <- bs] + -- dc_ty_args are aready OutTypes, but bs are InBndrs ; env'' <- simplNonRecX env' bndr bndr_rhs ; simplExprF env'' rhs cont } @@ -1773,15 +1826,9 @@ ; bind_args env'' bs' args } bind_args _ _ _ = - pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr the_args $$ + pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$ text "scrut:" <+> ppr scrut -knownAlt env scrut _ bndr (_, bs, rhs) cont - = ASSERT( null bs ) -- Works for LitAlt and DEFAULT - do { env' <- simplNonRecX env bndr scrut - ; simplExprF env' rhs cont } - - ------------------- missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExpr) -- This isn't strictly an error, although it is unusual. @@ -1834,18 +1881,11 @@ = return (env, mkBoringStop, cont) -- See Note [Duplicating StrictBind] -mkDupableCont env (StrictArg fun cci ai cont) +mkDupableCont env (StrictArg info cci cont) -- See Note [Duplicating StrictArg] = do { (env', dup, nodup) <- mkDupableCont env cont - ; (env'', fun') <- mk_dupable_call env' fun - ; return (env'', StrictArg fun' cci ai dup, nodup) } - where - mk_dupable_call env (Var v) = return (env, Var v) - mk_dupable_call env (App fun arg) = do { (env', fun') <- mk_dupable_call env fun - ; (env'', arg') <- makeTrivial env' arg - ; return (env'', fun' `App` arg') } - mk_dupable_call _ other = pprPanic "mk_dupable_call" (ppr other) - -- The invariant of StrictArg is that the first arg is always an App chain + ; (env'', args') <- mapAccumLM makeTrivial env' (ai_args info) + ; return (env'', StrictArg (info { ai_args = args' }) cci dup, nodup) } mkDupableCont env (ApplyTo _ arg se cont) = -- e.g. [...hole...] (...arg...) @@ -1914,12 +1954,31 @@ mkDupableAlt :: SimplEnv -> OutId -> (AltCon, [CoreBndr], CoreExpr) -> SimplM (SimplEnv, (AltCon, [CoreBndr], CoreExpr)) -mkDupableAlt env case_bndr' (con, bndrs', rhs') +mkDupableAlt env case_bndr (con, bndrs', rhs') | exprIsDupable rhs' -- Note [Small alternative rhs] = return (env, (con, bndrs', rhs')) | otherwise - = do { let rhs_ty' = exprType rhs' - used_bndrs' = filter abstract_over (case_bndr' : bndrs') + = do { let rhs_ty' = exprType rhs' + scrut_ty = idType case_bndr + case_bndr_w_unf + = case con of + DEFAULT -> case_bndr + DataAlt dc -> setIdUnfolding case_bndr unf + where + -- See Note [Case binders and join points] + unf = mkInlineRule needSaturated rhs 0 + rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty) + ++ varsToCoreExprs bndrs') + + LitAlt {} -> WARN( True, ptext (sLit "mkDupableAlt") + <+> ppr case_bndr <+> ppr con ) + case_bndr + -- The case binder is alive but trivial, so why has + -- it not been substituted away? + + used_bndrs' | isDeadBinder case_bndr = filter abstract_over bndrs' + | otherwise = bndrs' ++ [case_bndr_w_unf] + abstract_over bndr | isTyVar bndr = True -- Abstract over all type variables just in case | otherwise = not (isDeadBinder bndr) @@ -1944,10 +2003,42 @@ join_rhs = mkLams really_final_bndrs rhs' join_call = mkApps (Var join_bndr) final_args - ; return (addPolyBind NotTopLevel env (NonRec join_bndr join_rhs), (con, bndrs', join_call)) } + ; env' <- addPolyBind NotTopLevel env (NonRec join_bndr join_rhs) + ; return (env', (con, bndrs', join_call)) } -- See Note [Duplicated env] \end{code} +Note [Case binders and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + case (case .. ) of c { + I# c# -> ....c.... + +If we make a join point with c but not c# we get + $j = \c -> ....c.... + +But if later inlining scrutines the c, thus + + $j = \c -> ... case c of { I# y -> ... } ... + +we won't see that 'c' has already been scrutinised. This actually +happens in the 'tabulate' function in wave4main, and makes a significant +difference to allocation. + +An alternative plan is this: + + $j = \c# -> let c = I# c# in ...c.... + +but that is bad if 'c' is *not* later scrutinised. + +So instead we do both: we pass 'c' and 'c#' , and record in c's inlining +that it's really I# c#, thus + + $j = \c# -> \c[=I# c#] -> ...c.... + +Absence analysis may later discard 'c'. + + Note [Duplicated env] ~~~~~~~~~~~~~~~~~~~~~ Some of the alternatives are simplified, but have not been turned into a join point diff -ruN ghc-6.12.1/compiler/simplCore/SimplMonad.lhs ghc-6.13.20091231/compiler/simplCore/SimplMonad.lhs --- ghc-6.12.1/compiler/simplCore/SimplMonad.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/simplCore/SimplMonad.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -14,14 +14,13 @@ MonadUnique(..), newId, -- Counting - SimplCount, Tick(..), - tick, freeTick, + SimplCount, tick, freeTick, getSimplCount, zeroSimplCount, pprSimplCount, plusSimplCount, isZeroSimplCount, -- Switch checker SwitchChecker, SwitchResult(..), getSimplIntSwitch, - isAmongSimpl, intSwitchSet, switchIsOn + isAmongSimpl, intSwitchSet, switchIsOn, allOffSwitchChecker ) where import Id ( Id, mkSysLocal ) @@ -29,10 +28,9 @@ import FamInstEnv ( FamInstEnv ) import Rules ( RuleBase ) import UniqSupply -import DynFlags ( SimplifierSwitch(..), DynFlags, DynFlag(..), dopt ) -import StaticFlags ( opt_PprStyle_Debug, opt_HistorySize ) +import DynFlags ( DynFlags ) import Maybes ( expectJust ) -import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, plusFM_C, fmToList ) +import CoreMonad import FastString import Outputable import FastTypes @@ -154,256 +152,17 @@ tick :: Tick -> SimplM () tick t - = SM (\_st_env us sc -> let sc' = doTick t sc + = SM (\_st_env us sc -> let sc' = doSimplTick t sc in sc' `seq` ((), us, sc')) freeTick :: Tick -> SimplM () -- Record a tick, but don't add to the total tick count, which is -- used to decide when nothing further has happened freeTick t - = SM (\_st_env us sc -> let sc' = doFreeTick t sc + = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc in sc' `seq` ((), us, sc')) \end{code} -\begin{code} -verboseSimplStats :: Bool -verboseSimplStats = opt_PprStyle_Debug -- For now, anyway - -zeroSimplCount :: DynFlags -> SimplCount -isZeroSimplCount :: SimplCount -> Bool -pprSimplCount :: SimplCount -> SDoc -doTick, doFreeTick :: Tick -> SimplCount -> SimplCount -plusSimplCount :: SimplCount -> SimplCount -> SimplCount -\end{code} - -\begin{code} -data SimplCount = VerySimplZero -- These two are used when - | VerySimplNonZero -- we are only interested in - -- termination info - - | SimplCount { - ticks :: !Int, -- Total ticks - details :: !TickCounts, -- How many of each type - n_log :: !Int, -- N - log1 :: [Tick], -- Last N events; <= opt_HistorySize - log2 :: [Tick] -- Last opt_HistorySize events before that - } - -type TickCounts = FiniteMap Tick Int - -zeroSimplCount dflags - -- This is where we decide whether to do - -- the VerySimpl version or the full-stats version - | dopt Opt_D_dump_simpl_stats dflags - = SimplCount {ticks = 0, details = emptyFM, - n_log = 0, log1 = [], log2 = []} - | otherwise - = VerySimplZero - -isZeroSimplCount VerySimplZero = True -isZeroSimplCount (SimplCount { ticks = 0 }) = True -isZeroSimplCount _ = False - -doFreeTick tick sc@SimplCount { details = dts } - = sc { details = dts `addTick` tick } -doFreeTick _ sc = sc - -doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 } - | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 } - | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 } - where - sc1 = sc { ticks = tks+1, details = dts `addTick` tick } - -doTick _ _ = VerySimplNonZero -- The very simple case - - --- Don't use plusFM_C because that's lazy, and we want to --- be pretty strict here! -addTick :: TickCounts -> Tick -> TickCounts -addTick fm tick = case lookupFM fm tick of - Nothing -> addToFM fm tick 1 - Just n -> n1 `seq` addToFM fm tick n1 - where - n1 = n+1 - - -plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 }) - sc2@(SimplCount { ticks = tks2, details = dts2 }) - = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 } - where - -- A hackish way of getting recent log info - log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2 - | null (log2 sc2) = sc2 { log2 = log1 sc1 } - | otherwise = sc2 - -plusSimplCount VerySimplZero VerySimplZero = VerySimplZero -plusSimplCount _ _ = VerySimplNonZero - -pprSimplCount VerySimplZero = ptext (sLit "Total ticks: ZERO!") -pprSimplCount VerySimplNonZero = ptext (sLit "Total ticks: NON-ZERO!") -pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 }) - = vcat [ptext (sLit "Total ticks: ") <+> int tks, - text "", - pprTickCounts (fmToList dts), - if verboseSimplStats then - vcat [text "", - ptext (sLit "Log (most recent first)"), - nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))] - else empty - ] - -pprTickCounts :: [(Tick,Int)] -> SDoc -pprTickCounts [] = empty -pprTickCounts ((tick1,n1):ticks) - = vcat [int tot_n <+> text (tickString tick1), - pprTCDetails real_these, - pprTickCounts others - ] - where - tick1_tag = tickToTag tick1 - (these, others) = span same_tick ticks - real_these = (tick1,n1):these - same_tick (tick2,_) = tickToTag tick2 == tick1_tag - tot_n = sum [n | (_,n) <- real_these] - -pprTCDetails :: [(Tick, Int)] -> SDoc -pprTCDetails ticks@((tick,_):_) - | verboseSimplStats || isRuleFired tick - = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks]) - | otherwise - = empty -pprTCDetails [] = panic "pprTCDetails []" -\end{code} - -%************************************************************************ -%* * -\subsection{Ticks} -%* * -%************************************************************************ - -\begin{code} -data Tick - = PreInlineUnconditionally Id - | PostInlineUnconditionally Id - - | UnfoldingDone Id - | RuleFired FastString -- Rule name - - | LetFloatFromLet - | EtaExpansion Id -- LHS binder - | EtaReduction Id -- Binder on outer lambda - | BetaReduction Id -- Lambda binder - - - | CaseOfCase Id -- Bndr on *inner* case - | KnownBranch Id -- Case binder - | CaseMerge Id -- Binder on outer case - | AltMerge Id -- Case binder - | CaseElim Id -- Case binder - | CaseIdentity Id -- Case binder - | FillInCaseDefault Id -- Case binder - - | BottomFound - | SimplifierDone -- Ticked at each iteration of the simplifier - -isRuleFired :: Tick -> Bool -isRuleFired (RuleFired _) = True -isRuleFired _ = False - -instance Outputable Tick where - ppr tick = text (tickString tick) <+> pprTickCts tick - -instance Eq Tick where - a == b = case a `cmpTick` b of - EQ -> True - _ -> False - -instance Ord Tick where - compare = cmpTick - -tickToTag :: Tick -> Int -tickToTag (PreInlineUnconditionally _) = 0 -tickToTag (PostInlineUnconditionally _) = 1 -tickToTag (UnfoldingDone _) = 2 -tickToTag (RuleFired _) = 3 -tickToTag LetFloatFromLet = 4 -tickToTag (EtaExpansion _) = 5 -tickToTag (EtaReduction _) = 6 -tickToTag (BetaReduction _) = 7 -tickToTag (CaseOfCase _) = 8 -tickToTag (KnownBranch _) = 9 -tickToTag (CaseMerge _) = 10 -tickToTag (CaseElim _) = 11 -tickToTag (CaseIdentity _) = 12 -tickToTag (FillInCaseDefault _) = 13 -tickToTag BottomFound = 14 -tickToTag SimplifierDone = 16 -tickToTag (AltMerge _) = 17 - -tickString :: Tick -> String -tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally" -tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally" -tickString (UnfoldingDone _) = "UnfoldingDone" -tickString (RuleFired _) = "RuleFired" -tickString LetFloatFromLet = "LetFloatFromLet" -tickString (EtaExpansion _) = "EtaExpansion" -tickString (EtaReduction _) = "EtaReduction" -tickString (BetaReduction _) = "BetaReduction" -tickString (CaseOfCase _) = "CaseOfCase" -tickString (KnownBranch _) = "KnownBranch" -tickString (CaseMerge _) = "CaseMerge" -tickString (AltMerge _) = "AltMerge" -tickString (CaseElim _) = "CaseElim" -tickString (CaseIdentity _) = "CaseIdentity" -tickString (FillInCaseDefault _) = "FillInCaseDefault" -tickString BottomFound = "BottomFound" -tickString SimplifierDone = "SimplifierDone" - -pprTickCts :: Tick -> SDoc -pprTickCts (PreInlineUnconditionally v) = ppr v -pprTickCts (PostInlineUnconditionally v)= ppr v -pprTickCts (UnfoldingDone v) = ppr v -pprTickCts (RuleFired v) = ppr v -pprTickCts LetFloatFromLet = empty -pprTickCts (EtaExpansion v) = ppr v -pprTickCts (EtaReduction v) = ppr v -pprTickCts (BetaReduction v) = ppr v -pprTickCts (CaseOfCase v) = ppr v -pprTickCts (KnownBranch v) = ppr v -pprTickCts (CaseMerge v) = ppr v -pprTickCts (AltMerge v) = ppr v -pprTickCts (CaseElim v) = ppr v -pprTickCts (CaseIdentity v) = ppr v -pprTickCts (FillInCaseDefault v) = ppr v -pprTickCts _ = empty - -cmpTick :: Tick -> Tick -> Ordering -cmpTick a b = case (tickToTag a `compare` tickToTag b) of - GT -> GT - EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b - | otherwise -> EQ - LT -> LT - -- Always distinguish RuleFired, so that the stats - -- can report them even in non-verbose mode - -cmpEqTick :: Tick -> Tick -> Ordering -cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b -cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b -cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b -cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b -cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b -cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b -cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b -cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b -cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b -cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b -cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b -cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b -cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b -cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b -cmpEqTick _ _ = EQ -\end{code} - %************************************************************************ %* * @@ -419,6 +178,9 @@ | SwString FastString -- nothing or a String | SwInt Int -- nothing or an Int +allOffSwitchChecker :: SwitchChecker +allOffSwitchChecker _ = SwBool False + isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult isAmongSimpl on_switches -- Switches mentioned later occur *earlier* -- in the list; defaults right at the end. diff -ruN ghc-6.12.1/compiler/simplCore/SimplUtils.lhs ghc-6.13.20091231/compiler/simplCore/SimplUtils.lhs --- ghc-6.12.1/compiler/simplCore/SimplUtils.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/simplCore/SimplUtils.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -6,18 +6,19 @@ \begin{code} module SimplUtils ( -- Rebuilding - mkLam, mkCase, prepareAlts, bindCaseBndr, + mkLam, mkCase, prepareAlts, -- Inlining, preInlineUnconditionally, postInlineUnconditionally, - activeInline, activeRule, inlineMode, + activeUnfolding, activeUnfInRule, activeRule, + simplEnvForGHCi, simplEnvForRules, updModeForInlineRules, -- The continuation type SimplCont(..), DupFlag(..), ArgInfo(..), contIsDupable, contResultType, contIsTrivial, contArgs, dropArgs, - countValArgs, countArgs, splitInlineCont, - mkBoringStop, mkLazyArgStop, contIsRhsOrArg, - interestingCallContext, interestingArgContext, + pushArgs, countValArgs, countArgs, addArgTo, + mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg, + interestingCallContext, interestingArg, mkArgInfo, @@ -27,6 +28,7 @@ #include "HsVersions.h" import SimplEnv +import CoreMonad ( SimplifierMode(..), Tick(..) ) import DynFlags import StaticFlags import CoreSyn @@ -39,7 +41,7 @@ import Name import Id import Var ( isCoVar ) -import NewDemand +import Demand import SimplMonad import Type hiding( substTy ) import Coercion ( coercionKind ) @@ -98,44 +100,53 @@ | ApplyTo -- C arg DupFlag - InExpr SimplEnv -- The argument and its static env + InExpr StaticEnv -- The argument and its static env SimplCont | Select -- case C of alts DupFlag - InId [InAlt] SimplEnv -- The case binder, alts, and subst-env + InId [InAlt] StaticEnv -- The case binder, alts, and subst-env SimplCont -- The two strict forms have no DupFlag, because we never duplicate them | StrictBind -- (\x* \xs. e) C InId [InBndr] -- let x* = [] in e - InExpr SimplEnv -- is a special case + InExpr StaticEnv -- is a special case SimplCont - | StrictArg -- e C - OutExpr -- e; *always* of form (Var v `App1` e1 .. `App` en) - CallCtxt -- Whether *this* argument position is interesting - ArgInfo -- Whether the function at the head of e has rules, etc - SimplCont -- plus strictness flags for *further* args + | StrictArg -- f e1 ..en C + ArgInfo -- Specifies f, e1..en, Whether f has rules, etc + -- plus strictness flags for *further* args + CallCtxt -- Whether *this* argument position is interesting + SimplCont data ArgInfo = ArgInfo { - ai_rules :: Bool, -- Function has rules (recursively) - -- => be keener to inline in all args - ai_strs :: [Bool], -- Strictness of arguments + ai_fun :: Id, -- The function + ai_args :: [OutExpr], -- ...applied to these args (which are in *reverse* order) + ai_rules :: [CoreRule], -- Rules for this function + + ai_encl :: Bool, -- Flag saying whether this function + -- or an enclosing one has rules (recursively) + -- True => be keener to inline in all args + + ai_strs :: [Bool], -- Strictness of remaining arguments -- Usually infinite, but if it is finite it guarantees -- that the function diverges after being given -- that number of args - ai_discs :: [Int] -- Discounts for arguments; non-zero => be keener to inline + ai_discs :: [Int] -- Discounts for remaining arguments; non-zero => be keener to inline -- Always infinite } +addArgTo :: ArgInfo -> OutExpr -> ArgInfo +addArgTo ai arg = ai { ai_args = arg : ai_args ai } + instance Outputable SimplCont where ppr (Stop interesting) = ptext (sLit "Stop") <> brackets (ppr interesting) ppr (ApplyTo dup arg _ cont) = ((ptext (sLit "ApplyTo") <+> ppr dup <+> pprParendExpr arg) {- $$ nest 2 (pprSimplEnv se) -}) $$ ppr cont ppr (StrictBind b _ _ _ cont) = (ptext (sLit "StrictBind") <+> ppr b) $$ ppr cont - ppr (StrictArg f _ _ cont) = (ptext (sLit "StrictArg") <+> ppr f) $$ ppr cont + ppr (StrictArg ai _ cont) = (ptext (sLit "StrictArg") <+> ppr (ai_fun ai)) $$ ppr cont ppr (Select dup bndr alts _ cont) = (ptext (sLit "Select") <+> ppr dup <+> ppr bndr) $$ (nest 4 (ppr alts)) $$ ppr cont ppr (CoerceIt co cont) = (ptext (sLit "CoerceIt") <+> ppr co) $$ ppr cont @@ -152,6 +163,9 @@ mkBoringStop :: SimplCont mkBoringStop = Stop BoringCtxt +mkRhsStop :: SimplCont -- See Note [RHS of lets] in CoreUnfold +mkRhsStop = Stop (ArgCtxt False) + mkLazyArgStop :: CallCtxt -> SimplCont mkLazyArgStop cci = Stop cci @@ -187,13 +201,17 @@ go (Stop {}) ty = ty go (CoerceIt co cont) _ = go cont (snd (coercionKind co)) go (StrictBind _ bs body se cont) _ = go cont (subst_ty se (exprType (mkLams bs body))) - go (StrictArg fn _ _ cont) _ = go cont (funResultTy (exprType fn)) + go (StrictArg ai _ cont) _ = go cont (funResultTy (argInfoResultTy ai)) go (Select _ _ alts se cont) _ = go cont (subst_ty se (coreAltsType alts)) go (ApplyTo _ arg se cont) ty = go cont (apply_to_arg ty arg se) apply_to_arg ty (Type ty_arg) se = applyTy ty (subst_ty se ty_arg) apply_to_arg ty _ _ = funResultTy ty +argInfoResultTy :: ArgInfo -> OutType +argInfoResultTy (ArgInfo { ai_fun = fun, ai_args = args }) + = foldr (\arg fn_ty -> applyTypeToArg fn_ty arg) (idType fun) args + ------------------- countValArgs :: SimplCont -> Int countValArgs (ApplyTo _ (Type _) _ cont) = countValArgs cont @@ -211,38 +229,14 @@ go args (ApplyTo _ arg se cont) = go (substExpr se arg : args) cont go args cont = (reverse args, cont) +pushArgs :: SimplEnv -> [CoreExpr] -> SimplCont -> SimplCont +pushArgs _env [] cont = cont +pushArgs env (arg:args) cont = ApplyTo NoDup arg env (pushArgs env args cont) + dropArgs :: Int -> SimplCont -> SimplCont dropArgs 0 cont = cont dropArgs n (ApplyTo _ _ _ cont) = dropArgs (n-1) cont dropArgs n other = pprPanic "dropArgs" (ppr n <+> ppr other) - --------------------- -splitInlineCont :: SimplCont -> Maybe (SimplCont, SimplCont) --- Returns Nothing if the continuation should dissolve an InlineMe Note --- Return Just (c1,c2) otherwise, --- where c1 is the continuation to put inside the InlineMe --- and c2 outside - --- Example: (__inline_me__ (/\a. e)) ty --- Here we want to do the beta-redex without dissolving the InlineMe --- See test simpl017 (and Trac #1627) for a good example of why this is important - -splitInlineCont (ApplyTo dup (Type ty) se c) - | Just (c1, c2) <- splitInlineCont c = Just (ApplyTo dup (Type ty) se c1, c2) -splitInlineCont cont@(Stop {}) = Just (mkBoringStop, cont) -splitInlineCont cont@(StrictBind {}) = Just (mkBoringStop, cont) -splitInlineCont _ = Nothing - -- NB: we dissolve an InlineMe in any strict context, - -- not just function aplication. - -- E.g. foldr k z (__inline_me (case x of p -> build ...)) - -- Here we want to get rid of the __inline_me__ so we - -- can float the case, and see foldr/build - -- - -- However *not* in a strict RHS, else we get - -- let f = __inline_me__ (\x. e) in ...f... - -- Now if f is guaranteed to be called, hence a strict binding - -- we don't thereby want to dissolve the __inline_me__; for - -- example, 'f' might be a wrapper, so we'd inline the worker \end{code} @@ -288,8 +282,9 @@ where interesting (Select _ bndr _ _ _) | isDeadBinder bndr = CaseCtxt - | otherwise = ArgCtxt False 2 -- If the binder is used, this + | otherwise = ArgCtxt False -- If the binder is used, this -- is like a strict let + -- See Note [RHS of lets] in CoreUnfold interesting (ApplyTo _ arg _ cont) | isTypeArg arg = interesting cont @@ -298,10 +293,10 @@ -- motivation to inline. See Note [Cast then apply] -- in CoreUnfold - interesting (StrictArg _ cci _ _) = cci - interesting (StrictBind {}) = BoringCtxt - interesting (Stop cci) = cci - interesting (CoerceIt _ cont) = interesting cont + interesting (StrictArg _ cci _) = cci + interesting (StrictBind {}) = BoringCtxt + interesting (Stop cci) = cci + interesting (CoerceIt _ cont) = interesting cont -- If this call is the arg of a strict function, the context -- is a bit interesting. If we inline here, we may get useful -- evaluation information to avoid repeated evals: e.g. @@ -320,24 +315,27 @@ ------------------- mkArgInfo :: Id + -> [CoreRule] -- Rules for function -> Int -- Number of value args -> SimplCont -- Context of the call -> ArgInfo -mkArgInfo fun n_val_args call_cont +mkArgInfo fun rules n_val_args call_cont | n_val_args < idArity fun -- Note [Unsaturated functions] - = ArgInfo { ai_rules = False + = ArgInfo { ai_fun = fun, ai_args = [], ai_rules = rules + , ai_encl = False , ai_strs = vanilla_stricts , ai_discs = vanilla_discounts } | otherwise - = ArgInfo { ai_rules = interestingArgContext fun call_cont + = ArgInfo { ai_fun = fun, ai_args = [], ai_rules = rules + , ai_encl = interestingArgContext rules call_cont , ai_strs = add_type_str (idType fun) arg_stricts , ai_discs = arg_discounts } where vanilla_discounts, arg_discounts :: [Int] vanilla_discounts = repeat 0 arg_discounts = case idUnfolding fun of - CoreUnfolding _ _ _ _ _ (UnfoldIfGoodArgs _ discounts _ _) + CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_args = discounts}} -> discounts ++ vanilla_discounts _ -> vanilla_discounts @@ -345,7 +343,7 @@ vanilla_stricts = repeat False arg_stricts - = case splitStrictSig (idNewStrictness fun) of + = case splitStrictSig (idStrictness fun) of (demands, result_info) | not (demands `lengthExceeds` n_val_args) -> -- Enough args, use the strictness given. @@ -391,7 +389,7 @@ on its first argument -- it must be saturated for these to kick in -} -interestingArgContext :: Id -> SimplCont -> Bool +interestingArgContext :: [CoreRule] -> SimplCont -> Bool -- If the argument has form (f x y), where x,y are boring, -- and f is marked INLINE, then we don't want to inline f. -- But if the context of the argument is @@ -402,25 +400,27 @@ -- where h has rules, then we do want to inline f; hence the -- call_cont argument to interestingArgContext -- --- The interesting_arg_ctxt flag makes this happen; if it's +-- The ai-rules flag makes this happen; if it's -- set, the inliner gets just enough keener to inline f -- regardless of how boring f's arguments are, if it's marked INLINE -- -- The alternative would be to *always* inline an INLINE function, -- regardless of how boring its context is; but that seems overkill -- For example, it'd mean that wrapper functions were always inlined -interestingArgContext fn call_cont - = idHasRules fn || go call_cont +interestingArgContext rules call_cont + = notNull rules || enclosing_fn_has_rules where - go (Select {}) = False - go (ApplyTo {}) = False - go (StrictArg _ cci _ _) = interesting cci - go (StrictBind {}) = False -- ?? - go (CoerceIt _ c) = go c - go (Stop cci) = interesting cci + enclosing_fn_has_rules = go call_cont - interesting (ArgCtxt rules _) = rules - interesting _ = False + go (Select {}) = False + go (ApplyTo {}) = False + go (StrictArg _ cci _) = interesting cci + go (StrictBind {}) = False -- ?? + go (CoerceIt _ c) = go c + go (Stop cci) = interesting cci + + interesting (ArgCtxt rules) = rules + interesting _ = False \end{code} @@ -432,17 +432,41 @@ %************************************************************************ Inlining is controlled partly by the SimplifierMode switch. This has two -settings: - +settings + SimplGently (a) Simplifying before specialiser/full laziness - (b) Simplifiying inside INLINE pragma + (b) Simplifiying inside InlineRules (c) Simplifying the LHS of a rule (d) Simplifying a GHCi expression or Template Haskell splice SimplPhase n _ Used at all other times -The key thing about SimplGently is that it does no call-site inlining. +Note [Gentle mode] +~~~~~~~~~~~~~~~~~~ +Gentle mode has a separate boolean flag to control + a) inlining (sm_inline flag) + b) rules (sm_rules flag) +A key invariant about Gentle mode is that it is treated as the EARLIEST +phase. Something is inlined if the sm_inline flag is on AND the thing +is inlinable in the earliest phase. This is important. Example + + {-# INLINE [~1] g #-} + g = ... + + {-# INLINE f #-} + f x = g (g x) + +If we were to inline g into f's inlining, then an importing module would +never be able to do + f e --> g (g e) ---> RULE fires +because the InlineRule for f has had g inlined into it. + +On the other hand, it is bad not to do ANY inlining into an +InlineRule, because then recursive knots in instance declarations +don't get unravelled. + +However, *sometimes* SimplGently must do no call-site inlining at all. Before full laziness we must be careful not to inline wrappers, because doing so inhibits floating e.g. ...(case f x of ...)... @@ -456,41 +480,92 @@ anything, because the byte-code interpreter might get confused about unboxed tuples and suchlike. -INLINE pragmas -~~~~~~~~~~~~~~ -SimplGently is also used as the mode to simplify inside an InlineMe note. - -\begin{code} -inlineMode :: SimplifierMode -inlineMode = SimplGently -\end{code} - -It really is important to switch off inlinings inside such -expressions. Consider the following example +Note [RULEs enabled in SimplGently] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +RULES are enabled when doing "gentle" simplification. Two reasons: + + * We really want the class-op cancellation to happen: + op (df d1 d2) --> $cop3 d1 d2 + because this breaks the mutual recursion between 'op' and 'df' + + * I wanted the RULE + lift String ===> ... + to work in Template Haskell when simplifying + splices, so we get simpler code for literal strings + +Note [Simplifying inside InlineRules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must take care with simplification inside InlineRules (which come from +INLINE pragmas). +First, consider the following example let f = \pq -> BIG in let g = \y -> f y y {-# INLINE g #-} in ...g...g...g...g...g... +Now, if that's the ONLY occurrence of f, it might be inlined inside g, +and thence copied multiple times when g is inlined. HENCE we treat +any occurrence in an InlineRule as a multiple occurrence, not a single +one; see OccurAnal.addRuleUsage. + +Second, we do want *do* to some modest rules/inlining stuff in InlineRules, +partly to eliminate senseless crap, and partly to break the recursive knots +generated by instance declarations. To keep things simple, we always set +the phase to 'gentle' when processing InlineRules. OK, so suppose we have + {-# INLINE f #-} + f = +meaning "inline f in phases p where activation (p) holds". +Then what inlinings/rules can we apply to the copy of captured in +f's InlineRule? Our model is that literally is substituted for +f when it is inlined. So our conservative plan (implemented by +updModeForInlineRules) is this: + + ------------------------------------------------------------- + When simplifying the RHS of an InlineRule, + If the InlineRule becomes active in phase p, then + if the current phase is *earlier than* p, + make no inlinings or rules active when simplifying the RHS + otherwise + set the phase to p when simplifying the RHS + ------------------------------------------------------------- + +That ensures that + + a) Rules/inlinings that *cease* being active before p will + not apply to the InlineRule rhs, consistent with it being + inlined in its *original* form in phase p. + + b) Rules/inlinings that only become active *after* p will + not apply to the InlineRule rhs, again to be consistent with + inlining the *original* rhs in phase p. + +For example, + {-# INLINE f #-} + f x = ...g... + + {-# NOINLINE [1] g #-} + g y = ... + + {-# RULE h g = ... #-} +Here we must not inline g into f's RHS, even when we get to phase 0, +because when f is later inlined into some other module we want the +rule for h to fire. + +Similarly, consider + {-# INLINE f #-} + f x = ...g... + + g y = ... +and suppose that there are auto-generated specialisations and a strictness +wrapper for g. The specialisations get activation AlwaysActive, and the +strictness wrapper get activation (ActiveAfter 0). So the strictness +wrepper fails the test and won't be inlined into f's InlineRule. That +means f can inline, expose the specialised call to g, so the specialisation +rules can fire. -Now, if that's the ONLY occurrence of f, it will be inlined inside g, -and thence copied multiple times when g is inlined. - - -This function may be inlinined in other modules, so we -don't want to remove (by inlining) calls to functions that have -specialisations, or that may have transformation rules in an importing -scope. - -E.g. {-# INLINE f #-} - f x = ...g... - -and suppose that g is strict *and* has specialisations. If we inline -g's wrapper, we deny f the chance of getting the specialised version -of g when f is inlined at some call site (perhaps in some other -module). - +A note about wrappers +~~~~~~~~~~~~~~~~~~~~~ It's also important not to inline a worker back into a wrapper. A wrapper looks like wraper = inline_me (\x -> ...worker... ) @@ -498,19 +573,43 @@ the wrapper (initially, the worker's only call site!). But, if the wrapper is sure to be called, the strictness analyser will mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf -continuation. That's why the keep_inline predicate returns True for -ArgOf continuations. It shouldn't do any harm not to dissolve the -inline-me note under these circumstances. - -Note that the result is that we do very little simplification -inside an InlineMe. - - all xs = foldr (&&) True xs - any p = all . map p {-# INLINE any #-} - -Problem: any won't get deforested, and so if it's exported and the -importer doesn't use the inlining, (eg passes it as an arg) then we -won't get deforestation at all. We havn't solved this problem yet! +continuation. + +\begin{code} +simplEnvForGHCi :: SimplEnv +simplEnvForGHCi = mkSimplEnv allOffSwitchChecker $ + SimplGently { sm_rules = False, sm_inline = False } + -- Do not do any inlining, in case we expose some unboxed + -- tuple stuff that confuses the bytecode interpreter + +simplEnvForRules :: SimplEnv +simplEnvForRules = mkSimplEnv allOffSwitchChecker $ + SimplGently { sm_rules = True, sm_inline = False } + +updModeForInlineRules :: Activation -> SimplifierMode -> SimplifierMode +-- See Note [Simplifying inside InlineRules] +-- Treat Gentle as phase "infinity" +-- If current_phase `earlier than` inline_rule_start_phase +-- then no_op +-- else +-- if current_phase `same phase` inline_rule_start_phase +-- then current_phase (keep gentle flags) +-- else inline_rule_start_phase +updModeForInlineRules inline_rule_act current_mode + = case inline_rule_act of + NeverActive -> no_op + AlwaysActive -> mk_gentle current_mode + ActiveBefore {} -> mk_gentle current_mode + ActiveAfter n -> mk_phase n current_mode + where + no_op = SimplGently { sm_rules = False, sm_inline = False } + + mk_gentle (SimplGently {}) = current_mode + mk_gentle _ = SimplGently { sm_rules = True, sm_inline = True } + + mk_phase n (SimplPhase _ ss) = SimplPhase n ss + mk_phase n (SimplGently {}) = SimplPhase n ["gentle-rules"] +\end{code} preInlineUnconditionally @@ -577,11 +676,30 @@ Conclusion: inline top level things gaily until Phase 0 (the last phase), at which point don't. +Note [pre/postInlineUnconditionally in gentle mode] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Even in gentle mode we want to do preInlineUnconditionally. The +reason is that too little clean-up happens if you don't inline +use-once things. Also a bit of inlining is *good* for full laziness; +it can expose constant sub-expressions. Example in +spectral/mandel/Mandel.hs, where the mandelset function gets a useful +let-float if you inline windowToViewport + +However, as usual for Gentle mode, do not inline things that are +inactive in the intial stages. See Note [Gentle mode]. + +Note [Top-level botomming Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Don't inline top-level Ids that are bottoming, even if they are used just +once, because FloatOut has gone to some trouble to extract them out. +Inlining them won't make the program run faster! + \begin{code} preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool preInlineUnconditionally env top_lvl bndr rhs - | not active = False - | opt_SimplNoPreInlining = False + | not active = False + | isTopLevel top_lvl && isBottomingId bndr = False -- Note [Top-level bottoming Ids] + | opt_SimplNoPreInlining = False | otherwise = case idOccInfo bndr of IAmDead -> True -- Happens in ((\x.1) v) OneOcc in_lam True int_cxt -> try_once in_lam int_cxt @@ -589,15 +707,15 @@ where phase = getMode env active = case phase of - SimplGently -> isAlwaysActive act + SimplGently {} -> isEarlyActive act + -- See Note [pre/postInlineUnconditionally in gentle mode] SimplPhase n _ -> isActive n act act = idInlineActivation bndr - try_once in_lam int_cxt -- There's one textual occurrence | not in_lam = isNotTopLevel top_lvl || early_phase | otherwise = int_cxt && canInlineInLam rhs --- Be very careful before inlining inside a lambda, becuase (a) we must not +-- Be very careful before inlining inside a lambda, because (a) we must not -- invalidate occurrence information, and (b) we want to avoid pushing a -- single allocation (here) into multiple allocations (inside lambda). -- Inlining a *function* with a single *saturated* call would be ok, mind you. @@ -674,17 +792,19 @@ \begin{code} postInlineUnconditionally :: SimplEnv -> TopLevelFlag - -> InId -- The binder (an OutId would be fine too) + -> OutId -- The binder (an InId would be fine too) -> OccInfo -- From the InId -> OutExpr -> Unfolding -> Bool postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding - | not active = False - | isLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, don't inline + | not active = False + | isLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, don't inline -- because it might be referred to "earlier" - | isExportedId bndr = False - | exprIsTrivial rhs = True + | isExportedId bndr = False + | isStableUnfolding unfolding = False -- Note [InlineRule and postInlineUnconditionally] + | exprIsTrivial rhs = True + | isTopLevel top_lvl = False -- Note [Top level and postInlineUnconditionally] | otherwise = case occ_info of -- The point of examining occ_info here is that for *non-values* @@ -697,7 +817,8 @@ -- case v of -- True -> case x of ... -- False -> case x of ... - -- I'm not sure how important this is in practice + -- This is very important in practice; e.g. wheel-seive1 doubles + -- in allocation if you miss this out OneOcc in_lam _one_br int_cxt -- OneOcc => no code-duplication issue -> smallEnoughToInline unfolding -- Small enough to dup -- ToDo: consider discount on smallEnoughToInline if int_cxt is true @@ -710,8 +831,8 @@ -- PRINCIPLE: when we've already simplified an expression once, -- make sure that we only inline it if it's reasonably small. - && ((isNotTopLevel top_lvl && not in_lam) || - -- But outside a lambda, we want to be reasonably aggressive + && (not in_lam || + -- Outside a lambda, we want to be reasonably aggressive -- about inlining into multiple branches of case -- e.g. let x = -- in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... } @@ -745,32 +866,61 @@ where active = case getMode env of - SimplGently -> isAlwaysActive act + SimplGently {} -> isEarlyActive act + -- See Note [pre/postInlineUnconditionally in gentle mode] SimplPhase n _ -> isActive n act act = idInlineActivation bndr -activeInline :: SimplEnv -> OutId -> Bool -activeInline env id +activeUnfolding :: SimplEnv -> IdUnfoldingFun +activeUnfolding env = case getMode env of - SimplGently -> False - -- No inlining at all when doing gentle stuff, - -- except for local things that occur once (pre/postInlineUnconditionally) - -- The reason is that too little clean-up happens if you - -- don't inline use-once things. Also a bit of inlining is *good* for - -- full laziness; it can expose constant sub-expressions. - -- Example in spectral/mandel/Mandel.hs, where the mandelset - -- function gets a useful let-float if you inline windowToViewport - - -- NB: we used to have a second exception, for data con wrappers. - -- On the grounds that we use gentle mode for rule LHSs, and - -- they match better when data con wrappers are inlined. - -- But that only really applies to the trivial wrappers (like (:)), - -- and they are now constructed as Compulsory unfoldings (in MkId) - -- so they'll happen anyway. - - SimplPhase n _ -> isActive n act + SimplGently { sm_inline = False } -> active_unfolding_minimal + SimplGently { sm_inline = True } -> active_unfolding_gentle + SimplPhase n _ -> active_unfolding n + +activeUnfInRule :: SimplEnv -> IdUnfoldingFun +-- When matching in RULE, we want to "look through" an unfolding +-- if *rules* are on, even if *inlinings* are not. A notable example +-- is DFuns, which really we want to match in rules like (op dfun) +-- in gentle mode. +activeUnfInRule env + = case getMode env of + SimplGently { sm_rules = False } -> active_unfolding_minimal + SimplGently { sm_rules = True } -> active_unfolding_gentle + SimplPhase n _ -> active_unfolding n + +active_unfolding_minimal :: IdUnfoldingFun +-- Compuslory unfoldings only +-- Ignore SimplGently, because we want to inline regardless; +-- the Id has no top-level binding at all +-- +-- NB: we used to have a second exception, for data con wrappers. +-- On the grounds that we use gentle mode for rule LHSs, and +-- they match better when data con wrappers are inlined. +-- But that only really applies to the trivial wrappers (like (:)), +-- and they are now constructed as Compulsory unfoldings (in MkId) +-- so they'll happen anyway. +active_unfolding_minimal id + | isCompulsoryUnfolding unf = unf + | otherwise = NoUnfolding where - act = idInlineActivation id + unf = realIdUnfolding id -- Never a loop breaker + +active_unfolding_gentle :: IdUnfoldingFun +-- Anything that is early-active +-- See Note [Gentle mode] +active_unfolding_gentle id + | isEarlyActive (idInlineActivation id) = idUnfolding id + | otherwise = NoUnfolding + -- idUnfolding checks for loop-breakers + -- Things with an INLINE pragma may have + -- an unfolding *and* be a loop breaker + -- (maybe the knot is not yet untied) + +active_unfolding :: CompilerPhase -> IdUnfoldingFun +active_unfolding n id + | isActive n (idInlineActivation id) = idUnfolding id + | otherwise = NoUnfolding activeRule :: DynFlags -> SimplEnv -> Maybe (Activation -> Bool) -- Nothing => No rules at all @@ -779,15 +929,39 @@ = Nothing -- Rewriting is off | otherwise = case getMode env of - SimplGently -> Just isAlwaysActive - -- Used to be Nothing (no rules in gentle mode) - -- Main motivation for changing is that I wanted - -- lift String ===> ... - -- to work in Template Haskell when simplifying - -- splices, so we get simpler code for literal strings - SimplPhase n _ -> Just (isActive n) + SimplGently { sm_rules = rules_on } + | rules_on -> Just isEarlyActive -- Note [RULEs enabled in SimplGently] + | otherwise -> Nothing + SimplPhase n _ -> Just (isActive n) \end{code} +Note [Top level and postInlineUnconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't do postInlineUnconditionally for top-level things (exept ones that +are trivial): + * There is no point, because the main goal is to get rid of local + bindings used in multiple case branches. + * Doing so will inline top-level error expressions that have been + carefully floated out by FloatOut. More generally, it might + replace static allocation with dynamic. + +Note [InlineRule and postInlineUnconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do not do postInlineUnconditionally if the Id has an InlineRule, otherwise +we lose the unfolding. Example + + -- f has InlineRule with rhs (e |> co) + -- where 'e' is big + f = e |> co + +Then there's a danger we'll optimise to + + f' = e + f = f' |> co + +and now postInlineUnconditionally, losing the InlineRule on f. Now f' +won't inline because 'e' is too big. + %************************************************************************ %* * @@ -803,7 +977,7 @@ mkLam _b [] body = return body -mkLam _env bndrs body +mkLam env bndrs body = do { dflags <- getDOptsSmpl ; mkLam' dflags bndrs body } where @@ -824,7 +998,9 @@ ; return etad_lam } | dopt Opt_DoLambdaEtaExpansion dflags, - any isRuntimeVar bndrs + not (inGentleMode env), -- In gentle mode don't eta-expansion + any isRuntimeVar bndrs -- because it can clutter up the code + -- with casts etc that may not be removed = do { let body' = tryEtaExpansion dflags body ; return (mkLams bndrs body') } @@ -1220,83 +1396,61 @@ prepareAlts tries these things: -1. If several alternatives are identical, merge them into - a single DEFAULT alternative. I've occasionally seen this - making a big difference: - - case e of =====> case e of - C _ -> f x D v -> ....v.... - D v -> ....v.... DEFAULT -> f x - DEFAULT -> f x - - The point is that we merge common RHSs, at least for the DEFAULT case. - [One could do something more elaborate but I've never seen it needed.] - To avoid an expensive test, we just merge branches equal to the *first* - alternative; this picks up the common cases - a) all branches equal - b) some branches equal to the DEFAULT (which occurs first) - -2. Case merging: - case e of b { ==> case e of b { - p1 -> rhs1 p1 -> rhs1 - ... ... - pm -> rhsm pm -> rhsm - _ -> case b of b' { pn -> let b'=b in rhsn - pn -> rhsn ... - ... po -> let b'=b in rhso - po -> rhso _ -> let b'=b in rhsd - _ -> rhsd - } - - which merges two cases in one case when -- the default alternative of - the outer case scrutises the same variable as the outer case This - transformation is called Case Merging. It avoids that the same - variable is scrutinised multiple times. - - -The case where transformation (1) showed up was like this (lib/std/PrelCError.lhs): +1. Eliminate alternatives that cannot match, including the + DEFAULT alternative. - x | p `is` 1 -> e1 - | p `is` 2 -> e2 - ...etc... - -where @is@ was something like - - p `is` n = p /= (-1) && p == n - -This gave rise to a horrible sequence of cases - - case p of - (-1) -> $j p - 1 -> e1 - DEFAULT -> $j p - -and similarly in cascade for all the join points! - -Note [Dead binders] -~~~~~~~~~~~~~~~~~~~~ -We do this *here*, looking at un-simplified alternatives, because we -have to check that r doesn't mention the variables bound by the -pattern in each alternative, so the binder-info is rather useful. +2. If the DEFAULT alternative can match only one possible constructor, + then make that constructor explicit. + e.g. + case e of x { DEFAULT -> rhs } + ===> + case e of x { (a,b) -> rhs } + where the type is a single constructor type. This gives better code + when rhs also scrutinises x or e. + +3. Returns a list of the constructors that cannot holds in the + DEFAULT alternative (if there is one) + +Here "cannot match" includes knowledge from GADTs + +It's a good idea do do this stuff before simplifying the alternatives, to +avoid simplifying alternatives we know can't happen, and to come up with +the list of constructors that are handled, to put into the IdInfo of the +case binder, for use when simplifying the alternatives. + +Eliminating the default alternative in (1) isn't so obvious, but it can +happen: + +data Colour = Red | Green | Blue + +f x = case x of + Red -> .. + Green -> .. + DEFAULT -> h x + +h y = case y of + Blue -> .. + DEFAULT -> [ case y of ... ] + +If we inline h into f, the default case of the inlined h can't happen. +If we don't notice this, we may end up filtering out *all* the cases +of the inner case y, which give us nowhere to go! \begin{code} -prepareAlts :: SimplEnv -> OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt]) -prepareAlts env scrut case_bndr' alts - = do { dflags <- getDOptsSmpl - ; alts <- combineIdenticalAlts case_bndr' alts - - ; let (alts_wo_default, maybe_deflt) = findDefault alts +prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt]) +prepareAlts scrut case_bndr' alts + = do { let (alts_wo_default, maybe_deflt) = findDefault alts alt_cons = [con | (con,_,_) <- alts_wo_default] imposs_deflt_cons = nub (imposs_cons ++ alt_cons) -- "imposs_deflt_cons" are handled -- EITHER by the context, -- OR by a non-DEFAULT branch in this case expression. - ; default_alts <- prepareDefault dflags env case_bndr' mb_tc_app + ; default_alts <- prepareDefault case_bndr' mb_tc_app imposs_deflt_cons maybe_deflt ; let trimmed_alts = filterOut impossible_alt alts_wo_default - merged_alts = mergeAlts trimmed_alts default_alts + merged_alts = mergeAlts trimmed_alts default_alts -- We need the mergeAlts in case the new default_alt -- has turned into a constructor alternative. -- The merge keeps the inner DEFAULT at the front, if there is one @@ -1317,29 +1471,7 @@ impossible_alt _ = False --------------------------------------------------- --- 1. Merge identical branches --------------------------------------------------- -combineIdenticalAlts :: OutId -> [InAlt] -> SimplM [InAlt] - -combineIdenticalAlts case_bndr ((_con1,bndrs1,rhs1) : con_alts) - | all isDeadBinder bndrs1, -- Remember the default - length filtered_alts < length con_alts -- alternative comes first - -- Also Note [Dead binders] - = do { tick (AltMerge case_bndr) - ; return ((DEFAULT, [], rhs1) : filtered_alts) } - where - filtered_alts = filter keep con_alts - keep (_con,bndrs,rhs) = not (all isDeadBinder bndrs && rhs `cheapEqExpr` rhs1) - -combineIdenticalAlts _ alts = return alts - -------------------------------------------------------------------------- --- Prepare the default alternative -------------------------------------------------------------------------- -prepareDefault :: DynFlags - -> SimplEnv - -> OutId -- Case binder; need just for its type. Note that as an +prepareDefault :: OutId -- Case binder; need just for its type. Note that as an -- OutId, it has maximum information; this is important. -- Test simpl013 is an example -> Maybe (TyCon, [Type]) -- Type of scrutinee, decomposed @@ -1347,42 +1479,9 @@ -> Maybe InExpr -- Rhs -> SimplM [InAlt] -- Still unsimplified -- We use a list because it's what mergeAlts expects, - -- And becuase case-merging can cause many to show up - -------- Merge nested cases ---------- -prepareDefault dflags env outer_bndr _bndr_ty imposs_cons (Just deflt_rhs) - | dopt Opt_CaseMerge dflags - , Case (Var inner_scrut_var) inner_bndr _ inner_alts <- deflt_rhs - , DoneId inner_scrut_var' <- substId env inner_scrut_var - -- Remember, inner_scrut_var is an InId, but outer_bndr is an OutId - , inner_scrut_var' == outer_bndr - -- NB: the substId means that if the outer scrutinee was a - -- variable, and inner scrutinee is the same variable, - -- then inner_scrut_var' will be outer_bndr - -- via the magic of simplCaseBinder - = do { tick (CaseMerge outer_bndr) - - ; let munge_rhs rhs = bindCaseBndr inner_bndr (Var outer_bndr) rhs - ; return [(con, args, munge_rhs rhs) | (con, args, rhs) <- inner_alts, - not (con `elem` imposs_cons) ] - -- NB: filter out any imposs_cons. Example: - -- case x of - -- A -> e1 - -- DEFAULT -> case x of - -- A -> e2 - -- B -> e3 - -- When we merge, we must ensure that e1 takes - -- precedence over e2 as the value for A! - } - -- Warning: don't call prepareAlts recursively! - -- Firstly, there's no point, because inner alts have already had - -- mkCase applied to them, so they won't have a case in their default - -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr - -- in munge_rhs may put a case into the DEFAULT branch! - --------- Fill in known constructor ----------- -prepareDefault _ _ case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rhs) +prepareDefault case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rhs) | -- This branch handles the case where we are -- scrutinisng an algebraic data type isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples. @@ -1401,7 +1500,7 @@ -- which would be quite legitmate. But it's a really obscure corner, and -- not worth wasting code on. , let imposs_data_cons = [con | DataAlt con <- imposs_cons] -- We now know it's a data type - impossible con = con `elem` imposs_data_cons || dataConCannotMatch inst_tys con + impossible con = con `elem` imposs_data_cons || dataConCannotMatch inst_tys con = case filterOut impossible all_cons of [] -> return [] -- Eliminate the default alternative -- altogether if it can't match @@ -1416,27 +1515,48 @@ _ -> return [(DEFAULT, [], deflt_rhs)] | debugIsOn, isAlgTyCon tycon, not (isOpenTyCon tycon), null (tyConDataCons tycon) - -- This can legitimately happen for type families, so don't report that + -- Check for no data constructors + -- This can legitimately happen for type families, so don't report that = pprTrace "prepareDefault" (ppr case_bndr <+> ppr tycon) $ return [(DEFAULT, [], deflt_rhs)] --------- Catch-all cases ----------- -prepareDefault _dflags _env _case_bndr _bndr_ty _imposs_cons (Just deflt_rhs) +prepareDefault _case_bndr _bndr_ty _imposs_cons (Just deflt_rhs) = return [(DEFAULT, [], deflt_rhs)] -prepareDefault _dflags _env _case_bndr _bndr_ty _imposs_cons Nothing +prepareDefault _case_bndr _bndr_ty _imposs_cons Nothing = return [] -- No default branch \end{code} -================================================================================= +%************************************************************************ +%* * + mkCase +%* * +%************************************************************************ mkCase tries these things -1. Eliminate the case altogether if possible +1. Merge Nested Cases -2. Case-identity: + case e of b { ==> case e of b { + p1 -> rhs1 p1 -> rhs1 + ... ... + pm -> rhsm pm -> rhsm + _ -> case b of b' { pn -> let b'=b in rhsn + pn -> rhsn ... + ... po -> let b'=b in rhso + po -> rhso _ -> let b'=b in rhsd + _ -> rhsd + } + + which merges two cases in one case when -- the default alternative of + the outer case scrutises the same variable as the outer case. This + transformation is called Case Merging. It avoids that the same + variable is scrutinised multiple times. + +2. Eliminate Identity Case case e of ===> e True -> True; @@ -1444,19 +1564,99 @@ and similar friends. +3. Merge identical alternatives. + If several alternatives are identical, merge them into + a single DEFAULT alternative. I've occasionally seen this + making a big difference: + + case e of =====> case e of + C _ -> f x D v -> ....v.... + D v -> ....v.... DEFAULT -> f x + DEFAULT -> f x + + The point is that we merge common RHSs, at least for the DEFAULT case. + [One could do something more elaborate but I've never seen it needed.] + To avoid an expensive test, we just merge branches equal to the *first* + alternative; this picks up the common cases + a) all branches equal + b) some branches equal to the DEFAULT (which occurs first) + +The case where Merge Identical Alternatives transformation showed up +was like this (base/Foreign/C/Err/Error.lhs): + + x | p `is` 1 -> e1 + | p `is` 2 -> e2 + ...etc... + +where @is@ was something like + + p `is` n = p /= (-1) && p == n + +This gave rise to a horrible sequence of cases + + case p of + (-1) -> $j p + 1 -> e1 + DEFAULT -> $j p + +and similarly in cascade for all the join points! + \begin{code} -mkCase :: OutExpr -> OutId -> [OutAlt] -- Increasing order - -> SimplM OutExpr +mkCase, mkCase1, mkCase2 + :: DynFlags + -> OutExpr -> OutId + -> [OutAlt] -- Alternatives in standard (increasing) order + -> SimplM OutExpr -------------------------------------------------- --- 2. Identity case +-- 1. Merge Nested Cases -------------------------------------------------- -mkCase scrut case_bndr alts -- Identity case +mkCase dflags scrut outer_bndr ((DEFAULT, _, deflt_rhs) : outer_alts) + | dopt Opt_CaseMerge dflags + , Case (Var inner_scrut_var) inner_bndr _ inner_alts <- deflt_rhs + , inner_scrut_var == outer_bndr + = do { tick (CaseMerge outer_bndr) + + ; let wrap_alt (con, args, rhs) = ASSERT( outer_bndr `notElem` args ) + (con, args, wrap_rhs rhs) + -- Simplifier's no-shadowing invariant should ensure + -- that outer_bndr is not shadowed by the inner patterns + wrap_rhs rhs = Let (NonRec inner_bndr (Var outer_bndr)) rhs + -- The let is OK even for unboxed binders, + + wrapped_alts | isDeadBinder inner_bndr = inner_alts + | otherwise = map wrap_alt inner_alts + + merged_alts = mergeAlts outer_alts wrapped_alts + -- NB: mergeAlts gives priority to the left + -- case x of + -- A -> e1 + -- DEFAULT -> case x of + -- A -> e2 + -- B -> e3 + -- When we merge, we must ensure that e1 takes + -- precedence over e2 as the value for A! + + ; mkCase1 dflags scrut outer_bndr merged_alts + } + -- Warning: don't call mkCase recursively! + -- Firstly, there's no point, because inner alts have already had + -- mkCase applied to them, so they won't have a case in their default + -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr + -- in munge_rhs may put a case into the DEFAULT branch! + +mkCase dflags scrut bndr alts = mkCase1 dflags scrut bndr alts + +-------------------------------------------------- +-- 2. Eliminate Identity Case +-------------------------------------------------- + +mkCase1 _dflags scrut case_bndr alts -- Identity case | all identity_alt alts - = do tick (CaseIdentity case_bndr) - return (re_cast scrut) + = do { tick (CaseIdentity case_bndr) + ; return (re_cast scrut) } where identity_alt (con, args, rhs) = check_eq con args (de_cast rhs) @@ -1484,22 +1684,93 @@ (_,_,Cast _ co) -> Cast scrut co _ -> scrut +-------------------------------------------------- +-- 3. Merge Identical Alternatives +-------------------------------------------------- +mkCase1 dflags scrut case_bndr ((_con1,bndrs1,rhs1) : con_alts) + | all isDeadBinder bndrs1 -- Remember the default + , length filtered_alts < length con_alts -- alternative comes first + -- Also Note [Dead binders] + = do { tick (AltMerge case_bndr) + ; mkCase2 dflags scrut case_bndr alts' } + where + alts' = (DEFAULT, [], rhs1) : filtered_alts + filtered_alts = filter keep con_alts + keep (_con,bndrs,rhs) = not (all isDeadBinder bndrs && rhs `cheapEqExpr` rhs1) +mkCase1 dflags scrut bndr alts = mkCase2 dflags scrut bndr alts -------------------------------------------------- -- Catch-all -------------------------------------------------- -mkCase scrut bndr alts = return (Case scrut bndr (coreAltsType alts) alts) +mkCase2 _dflags scrut bndr alts + = return (Case scrut bndr (coreAltsType alts) alts) \end{code} +Note [Dead binders] +~~~~~~~~~~~~~~~~~~~~ +Note that dead-ness is maintained by the simplifier, so that it is +accurate after simplification as well as before. -When adding auxiliary bindings for the case binder, it's worth checking if -its dead, because it often is, and occasionally these mkCase transformations -cascade rather nicely. -\begin{code} -bindCaseBndr :: Id -> CoreExpr -> CoreExpr -> CoreExpr -bindCaseBndr bndr rhs body - | isDeadBinder bndr = body - | otherwise = bindNonRec bndr rhs body -\end{code} +Note [Cascading case merge] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Case merging should cascade in one sweep, because it +happens bottom-up + + case e of a { + DEFAULT -> case a of b + DEFAULT -> case b of c { + DEFAULT -> e + A -> ea + B -> eb + C -> ec +==> + case e of a { + DEFAULT -> case a of b + DEFAULT -> let c = b in e + A -> let c = b in ea + B -> eb + C -> ec +==> + case e of a { + DEFAULT -> let b = a in let c = b in e + A -> let b = a in let c = b in ea + B -> let b = a in eb + C -> ec + + +However here's a tricky case that we still don't catch, and I don't +see how to catch it in one pass: + + case x of c1 { I# a1 -> + case a1 of c2 -> + 0 -> ... + DEFAULT -> case x of c3 { I# a2 -> + case a2 of ... + +After occurrence analysis (and its binder-swap) we get this + + case x of c1 { I# a1 -> + let x = c1 in -- Binder-swap addition + case a1 of c2 -> + 0 -> ... + DEFAULT -> case x of c3 { I# a2 -> + case a2 of ... + +When we simplify the inner case x, we'll see that +x=c1=I# a1. So we'll bind a2 to a1, and get + + case x of c1 { I# a1 -> + case a1 of c2 -> + 0 -> ... + DEFAULT -> case a1 of ... + +This is corect, but we can't do a case merge in this sweep +because c2 /= a1. Reason: the binding c1=I# a1 went inwards +without getting changed to c1=I# c2. + +I don't think this is worth fixing, even if I knew how. It'll +all come out in the next pass anyway. + + \ No newline at end of file diff -ruN ghc-6.12.1/compiler/specialise/Rules.lhs ghc-6.13.20091231/compiler/specialise/Rules.lhs --- ghc-6.12.1/compiler/specialise/Rules.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/specialise/Rules.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -22,9 +22,9 @@ addIdSpecialisations, -- * Misc. CoreRule helpers - rulesOfBinds, getRules, pprRulesForUser, + rulesOfBinds, getRules, pprRulesForUser, - lookupRule, mkLocalRule, roughTopNames + lookupRule, mkRule, mkLocalRule, roughTopNames ) where #include "HsVersions.h" @@ -32,9 +32,9 @@ import CoreSyn -- All of it import OccurAnal ( occurAnalyseExpr ) import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars, rulesFreeVars ) -import CoreUtils ( exprType ) +import CoreUtils ( exprType, eqExprX ) import PprCore ( pprRules ) -import Type ( Type, TvSubstEnv, tcEqTypeX ) +import Type ( Type, TvSubstEnv ) import TcType ( tcSplitTyConApp_maybe ) import CoreTidy ( tidyRules ) import Id @@ -45,7 +45,7 @@ import Name ( Name, NamedThing(..) ) import NameEnv import Unify ( ruleMatchTyX, MatchEnv(..) ) -import BasicTypes ( Activation ) +import BasicTypes ( Activation, CompilerPhase, isActive ) import StaticFlags ( opt_PprStyle_Debug ) import Outputable import FastString @@ -57,6 +57,71 @@ \end{code} +Note [Overall plumbing for rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +* The ModGuts initially contains mg_rules :: [CoreRule] of rules + declared in this module. During the core-to-core pipeline, + locally-declared rules for locally-declared Ids are attached to the + IdInfo for that Id, so the mg_rules field of ModGuts now only + contains locally-declared rules for *imported* Ids. TidyPgm restores + the original setup, so that the ModGuts again has *all* the + locally-declared rules. See Note [Attach rules to local ids] in + SimplCore + +* The HomePackageTable contains a ModDetails for each home package + module. Each contains md_rules :: [CoreRule] of rules declared in + that module. The HomePackageTable grows as ghc --make does its + up-sweep. In batch mode (ghc -c), the HPT is empty; all imported modules + are treated by the "external" route, discussed next, regardless of + which package they come from. + +* The ExternalPackageState has a single eps_rule_base :: RuleBase for + Ids in other packages. This RuleBase simply grow monotonically, as + ghc --make compiles one module after another. + + During simplification, interface files may get demand-loaded, + as the simplifier explores the unfoldings for Ids it has in + its hand. (Via an unsafePerformIO; the EPS is really a cache.) + That in turn may make the EPS rule-base grow. In contrast, the + HPT never grows in this way. + +* The result of all this is that during Core-to-Core optimisation + there are four sources of rules: + + (a) Rules in the IdInfo of the Id they are a rule for. These are + easy: fast to look up, and if you apply a substitution then + it'll be applied to the IdInfo as a matter of course. + + (b) Rules declared in this module for imported Ids, kept in the + ModGuts. If you do a substitution, you'd better apply the + substitution to these. There are seldom many of these. + + (c) Rules declared in the HomePackageTable. These never change. + + (d) Rules in the ExternalPackageTable. These can grow in response + to lazy demand-loading of interfaces. + +* At the moment (c) is carried in a reader-monad way by the CoreMonad. + The HomePackageTable doesn't have a single RuleBase because technically + we should only be able to "see" rules "below" this module; so we + generate a RuleBase for (c) by combing rules from all the modules + "below" us. That's whye we can't just select the home-package RuleBase + from HscEnv. + + [NB: we are inconsistent here. We should do the same for external + pacakges, but we don't. Same for type-class instances.] + +* So in the outer simplifier loop, we combine (b-d) into a single + RuleBase, reading + (b) from the ModGuts, + (c) from the CoreMonad, and + (d) from its mutable variable + [Of coures this means that we won't see new EPS rules that come in + during a single simplifier iteration, but that probably does not + matter.] + + %************************************************************************ %* * \subsection[specialisation-IdInfo]{Specialisation info about an @Id@} @@ -96,11 +161,18 @@ -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule -- ^ Used to make 'CoreRule' for an 'Id' defined in the module being -- compiled. See also 'CoreSyn.CoreRule' -mkLocalRule name act fn bndrs args rhs +mkLocalRule = mkRule True + +mkRule :: Bool -> RuleName -> Activation + -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule +-- ^ Used to make 'CoreRule' for an 'Id' defined in the module being +-- compiled. See also 'CoreSyn.CoreRule' +mkRule is_local name act fn bndrs args rhs = Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs, ru_args = args, - ru_rhs = rhs, ru_rough = roughTopNames args, - ru_local = True } + ru_rhs = occurAnalyseExpr rhs, + ru_rough = roughTopNames args, + ru_local = is_local } -------------- roughTopNames :: [CoreExpr] -> [Maybe Name] @@ -192,18 +264,32 @@ rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds getRules :: RuleBase -> Id -> [CoreRule] - -- The rules for an Id come from two places: - -- (a) the ones it is born with (idCoreRules fn) - -- (b) rules added in subsequent modules (extra_rules) - -- PrimOps, for example, are born with a bunch of rules under (a) +-- See Note [Where rules are found] getRules rule_base fn - | isLocalId fn = idCoreRules fn - | otherwise = WARN( not (isPrimOpId fn) && notNull (idCoreRules fn), - ppr fn <+> ppr (idCoreRules fn) ) - idCoreRules fn ++ (lookupNameEnv rule_base (idName fn) `orElse` []) - -- Only PrimOpIds have rules inside themselves, and perhaps more besides + = idCoreRules fn ++ imp_rules + where + imp_rules = lookupNameEnv rule_base (idName fn) `orElse` [] \end{code} +Note [Where rules are found] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The rules for an Id come from two places: + (a) the ones it is born with, stored inside the Id iself (idCoreRules fn), + (b) rules added in other modules, stored in the global RuleBase (imp_rules) + +It's tempting to think that + - LocalIds have only (a) + - non-LocalIds have only (b) + +but that isn't quite right: + + - PrimOps and ClassOps are born with a bunch of rules inside the Id, + even when they are imported + + - The rules in PrelRules.builtinRules should be active even + in the module defining the Id (when it's a LocalId), but + the rules are kept in the global RuleBase + %************************************************************************ %* * @@ -267,13 +353,15 @@ -- supplied rules to this instance of an application in a given -- context, returning the rule applied and the resulting expression if -- successful. -lookupRule :: (Activation -> Bool) -> InScopeSet +lookupRule :: (Activation -> Bool) -- When rule is active + -> IdUnfoldingFun -- When Id can be unfolded + -> InScopeSet -> Id -> [CoreExpr] -> [CoreRule] -> Maybe (CoreRule, CoreExpr) -- See Note [Extra args in rule matching] -- See comments on matchRule -lookupRule is_active in_scope fn args rules +lookupRule is_active id_unf in_scope fn args rules = -- pprTrace "matchRules" (ppr fn <+> ppr rules) $ case go [] rules of [] -> Nothing @@ -283,7 +371,7 @@ go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)] go ms [] = ms - go ms (r:rs) = case (matchRule is_active in_scope args rough_args r) of + go ms (r:rs) = case (matchRule is_active id_unf in_scope args rough_args r) of Just e -> go ((r,e):ms) rs Nothing -> -- pprTrace "match failed" (ppr r $$ ppr args $$ -- ppr [(arg_id, unfoldingTemplate unf) | Var arg_id <- args, let unf = idUnfolding arg_id, isCheapUnfolding unf] ) @@ -318,8 +406,9 @@ isMoreSpecific _ (BuiltinRule {}) = False isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 }) (Rule { ru_bndrs = bndrs2, ru_args = args2 }) - = isJust (matchN in_scope bndrs2 args2 args1) + = isJust (matchN id_unfolding_fun in_scope bndrs2 args2 args1) where + id_unfolding_fun _ = NoUnfolding -- Don't expand in templates in_scope = mkInScopeSet (mkVarSet bndrs1) -- Actually we should probably include the free vars -- of rule1's args, but I can't be bothered @@ -327,7 +416,8 @@ noBlackList :: Activation -> Bool noBlackList _ = False -- Nothing is black listed -matchRule :: (Activation -> Bool) -> InScopeSet +matchRule :: (Activation -> Bool) -> IdUnfoldingFun + -> InScopeSet -> [CoreExpr] -> [Maybe Name] -> CoreRule -> Maybe CoreExpr @@ -353,20 +443,21 @@ -- Any 'surplus' arguments in the input are simply put on the end -- of the output. -matchRule _is_active _in_scope args _rough_args +matchRule _is_active id_unf _in_scope args _rough_args (BuiltinRule { ru_try = match_fn }) - = case match_fn args of +-- Built-in rules can't be switched off, it seems + = case match_fn id_unf args of Just expr -> Just expr Nothing -> Nothing -matchRule is_active in_scope args rough_args +matchRule is_active id_unf in_scope args rough_args (Rule { ru_act = act, ru_rough = tpl_tops, ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs }) | not (is_active act) = Nothing | ruleCantMatch tpl_tops rough_args = Nothing | otherwise - = case matchN in_scope tpl_vars tpl_args args of + = case matchN id_unf in_scope tpl_vars tpl_args args of Nothing -> Nothing Just (binds, tpl_vals) -> Just (mkLets binds $ rule_fn `mkApps` tpl_vals) @@ -379,14 +470,15 @@ -- For a given match template and context, find bindings to wrap around -- the entire result and what should be substituted for each template variable. -- Fail if there are two few actual arguments from the target to match the template -matchN :: InScopeSet -- ^ In-scope variables +matchN :: IdUnfoldingFun + -> InScopeSet -- ^ In-scope variables -> [Var] -- ^ Match template type variables -> [CoreExpr] -- ^ Match template -> [CoreExpr] -- ^ Target; can have more elements than the template -> Maybe ([CoreBind], [CoreExpr]) -matchN in_scope tmpl_vars tmpl_es target_es +matchN id_unf in_scope tmpl_vars tmpl_es target_es = do { (tv_subst, id_subst, binds) <- go init_menv emptySubstEnv tmpl_es target_es ; return (fromOL binds, @@ -399,7 +491,7 @@ go _ subst [] _ = Just subst go _ _ _ [] = Nothing -- Fail if too few actual args - go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e + go menv subst (t:ts) (e:es) = do { subst1 <- match id_unf menv subst t e ; go menv subst1 ts es } lookup_tmpl :: TvSubstEnv -> IdSubstEnv -> Var -> CoreExpr @@ -462,7 +554,8 @@ -- SLPJ July 99 -match :: MatchEnv +match :: IdUnfoldingFun + -> MatchEnv -> SubstEnv -> CoreExpr -- Template -> CoreExpr -- Target @@ -484,31 +577,31 @@ -- succeed in matching what looks like the template variable 'a' against 3. -- The Var case follows closely what happens in Unify.match -match menv subst (Var v1) e2 - | Just subst <- match_var menv subst v1 e2 +match idu menv subst (Var v1) e2 + | Just subst <- match_var idu menv subst v1 e2 = Just subst -match menv subst (Note _ e1) e2 = match menv subst e1 e2 -match menv subst e1 (Note _ e2) = match menv subst e1 e2 +match idu menv subst (Note _ e1) e2 = match idu menv subst e1 e2 +match idu menv subst e1 (Note _ e2) = match idu menv subst e1 e2 -- Ignore notes in both template and thing to be matched -- See Note [Notes in RULE matching] -match menv subst e1 (Var v2) -- Note [Expanding variables] - | not (locallyBoundR rn_env v2) -- Note [Do not expand locally-bound variables] - , Just e2' <- expandId v2' - = match (menv { me_env = nukeRnEnvR rn_env }) subst e1 e2' +match id_unfolding_fun menv subst e1 (Var v2) -- Note [Expanding variables] + | not (inRnEnvR rn_env v2) -- Note [Do not expand locally-bound variables] + , Just e2' <- expandUnfolding_maybe (id_unfolding_fun v2') + = match id_unfolding_fun (menv { me_env = nukeRnEnvR rn_env }) subst e1 e2' where v2' = lookupRnInScope rn_env v2 rn_env = me_env menv -- Notice that we look up v2 in the in-scope set -- See Note [Lookup in-scope] -- No need to apply any renaming first (hence no rnOccR) - -- becuase of the not-locallyBoundR + -- because of the not-inRnEnvR -match menv (tv_subst, id_subst, binds) e1 (Let bind e2) +match idu menv (tv_subst, id_subst, binds) e1 (Let bind e2) | all freshly_bound bndrs -- See Note [Matching lets] - , not (any (locallyBoundR rn_env) bind_fvs) - = match (menv { me_env = rn_env' }) + , not (any (inRnEnvR rn_env) bind_fvs) + = match idu (menv { me_env = rn_env' }) (tv_subst, id_subst, binds `snocOL` bind') e1 e2' where @@ -520,16 +613,16 @@ e2' = e2 rn_env' = extendRnInScopeList rn_env bndrs -match _ subst (Lit lit1) (Lit lit2) +match _ _ subst (Lit lit1) (Lit lit2) | lit1 == lit2 = Just subst -match menv subst (App f1 a1) (App f2 a2) - = do { subst' <- match menv subst f1 f2 - ; match menv subst' a1 a2 } +match idu menv subst (App f1 a1) (App f2 a2) + = do { subst' <- match idu menv subst f1 f2 + ; match idu menv subst' a1 a2 } -match menv subst (Lam x1 e1) (Lam x2 e2) - = match menv' subst e1 e2 +match idu menv subst (Lam x1 e1) (Lam x2 e2) + = match idu menv' subst e1 e2 where menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 } @@ -538,45 +631,46 @@ -- It's important that this is *after* the let rule, -- so that (\x.M) ~ (let y = e in \y.N) -- does the let thing, and then gets the lam/lam rule above -match menv subst (Lam x1 e1) e2 - = match menv' subst e1 (App e2 (varToCoreExpr new_x)) +match idu menv subst (Lam x1 e1) e2 + = match idu menv' subst e1 (App e2 (varToCoreExpr new_x)) where (rn_env', new_x) = rnBndrL (me_env menv) x1 menv' = menv { me_env = rn_env' } -- Eta expansion the other way -- M ~ (\y.N) iff M y ~ N -match menv subst e1 (Lam x2 e2) - = match menv' subst (App e1 (varToCoreExpr new_x)) e2 +match idu menv subst e1 (Lam x2 e2) + = match idu menv' subst (App e1 (varToCoreExpr new_x)) e2 where (rn_env', new_x) = rnBndrR (me_env menv) x2 menv' = menv { me_env = rn_env' } -match menv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) +match idu menv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) = do { subst1 <- match_ty menv subst ty1 ty2 - ; subst2 <- match menv subst1 e1 e2 + ; subst2 <- match idu menv subst1 e1 e2 ; let menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 } - ; match_alts menv' subst2 alts1 alts2 -- Alts are both sorted + ; match_alts idu menv' subst2 alts1 alts2 -- Alts are both sorted } -match menv subst (Type ty1) (Type ty2) +match _ menv subst (Type ty1) (Type ty2) = match_ty menv subst ty1 ty2 -match menv subst (Cast e1 co1) (Cast e2 co2) +match idu menv subst (Cast e1 co1) (Cast e2 co2) = do { subst1 <- match_ty menv subst co1 co2 - ; match menv subst1 e1 e2 } + ; match idu menv subst1 e1 e2 } -- Everything else fails -match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $ +match _ _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $ Nothing ------------------------------------------ -match_var :: MatchEnv +match_var :: IdUnfoldingFun + -> MatchEnv -> SubstEnv -> Var -- Template -> CoreExpr -- Target -> Maybe SubstEnv -match_var menv subst@(tv_subst, id_subst, binds) v1 e2 +match_var idu menv subst@(tv_subst, id_subst, binds) v1 e2 | v1' `elemVarSet` me_tmpls menv = case lookupVarEnv id_subst v1' of Nothing | any (inRnEnvR rn_env) (varSetElems (exprFreeVars e2)) @@ -599,7 +693,7 @@ -- c.f. match_ty below ; return (tv_subst', extendVarEnv id_subst v1' e2, binds) } - Just e1' | eqExpr (nukeRnEnvL rn_env) e1' e2 + Just e1' | eqExprX idu (nukeRnEnvL rn_env) e1' e2 -> Just subst | otherwise @@ -620,22 +714,23 @@ ------------------------------------------ -match_alts :: MatchEnv - -> SubstEnv - -> [CoreAlt] -- Template - -> [CoreAlt] -- Target - -> Maybe SubstEnv -match_alts _ subst [] [] +match_alts :: IdUnfoldingFun + -> MatchEnv + -> SubstEnv + -> [CoreAlt] -- Template + -> [CoreAlt] -- Target + -> Maybe SubstEnv +match_alts _ _ subst [] [] = return subst -match_alts menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) +match_alts idu menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) | c1 == c2 - = do { subst1 <- match menv' subst r1 r2 - ; match_alts menv subst1 alts1 alts2 } + = do { subst1 <- match idu menv' subst r1 r2 + ; match_alts idu menv subst1 alts1 alts2 } where menv' :: MatchEnv menv' = menv { me_env = rnBndrs2 (me_env menv) vs1 vs2 } -match_alts _ _ _ _ +match_alts _ _ _ _ _ = Nothing \end{code} @@ -772,82 +867,6 @@ That is why the 'lookupRnInScope' call in the (Var v2) case of 'match' is so important. -\begin{code} -eqExpr :: RnEnv2 -> CoreExpr -> CoreExpr -> Bool --- ^ A kind of shallow equality used in rule matching, so does --- /not/ look through newtypes or predicate types - -eqExpr env (Var v1) (Var v2) - | rnOccL env v1 == rnOccR env v2 - = True - --- The next two rules expand non-local variables --- C.f. Note [Expanding variables] --- and Note [Do not expand locally-bound variables] -eqExpr env (Var v1) e2 - | not (locallyBoundL env v1) - , Just e1' <- expandId (lookupRnInScope env v1) - = eqExpr (nukeRnEnvL env) e1' e2 - -eqExpr env e1 (Var v2) - | not (locallyBoundR env v2) - , Just e2' <- expandId (lookupRnInScope env v2) - = eqExpr (nukeRnEnvR env) e1 e2' - -eqExpr _ (Lit lit1) (Lit lit2) = lit1 == lit2 -eqExpr env (App f1 a1) (App f2 a2) = eqExpr env f1 f2 && eqExpr env a1 a2 -eqExpr env (Lam v1 e1) (Lam v2 e2) = eqExpr (rnBndr2 env v1 v2) e1 e2 -eqExpr env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eqExpr env e1 e2 -eqExpr env (Cast e1 co1) (Cast e2 co2) = tcEqTypeX env co1 co2 && eqExpr env e1 e2 -eqExpr env (Type t1) (Type t2) = tcEqTypeX env t1 t2 - -eqExpr env (Let (NonRec v1 r1) e1) - (Let (NonRec v2 r2) e2) = eqExpr env r1 r2 - && eqExpr (rnBndr2 env v1 v2) e1 e2 -eqExpr env (Let (Rec ps1) e1) - (Let (Rec ps2) e2) = equalLength ps1 ps2 - && and (zipWith eq_rhs ps1 ps2) - && eqExpr env' e1 e2 - where - env' = foldl2 rn_bndr2 env ps2 ps2 - rn_bndr2 env (b1,_) (b2,_) = rnBndr2 env b1 b2 - eq_rhs (_,r1) (_,r2) = eqExpr env' r1 r2 -eqExpr env (Case e1 v1 t1 a1) - (Case e2 v2 t2 a2) = eqExpr env e1 e2 - && tcEqTypeX env t1 t2 - && equalLength a1 a2 - && and (zipWith (eq_alt env') a1 a2) - where - env' = rnBndr2 env v1 v2 - -eqExpr _ _ _ = False - -eq_alt :: RnEnv2 -> CoreAlt -> CoreAlt -> Bool -eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 && eqExpr (rnBndrs2 env vs1 vs2) r1 r2 - -eq_note :: RnEnv2 -> Note -> Note -> Bool -eq_note _ (SCC cc1) (SCC cc2) = cc1 == cc2 -eq_note _ (CoreNote s1) (CoreNote s2) = s1 == s2 -eq_note _ (InlineMe) (InlineMe) = True -eq_note _ _ _ = False -\end{code} - -Auxiliary functions - -\begin{code} -locallyBoundL, locallyBoundR :: RnEnv2 -> Var -> Bool -locallyBoundL rn_env v = inRnEnvL rn_env v -locallyBoundR rn_env v = inRnEnvR rn_env v - - -expandId :: Id -> Maybe CoreExpr -expandId id - | isExpandableUnfolding unfolding = Just (unfoldingTemplate unfolding) - | otherwise = Nothing - where - unfolding = idUnfolding id -\end{code} - %************************************************************************ %* * Rule-check the program @@ -860,12 +879,12 @@ \begin{code} -- | Report partial matches for rules beginning with the specified -- string for the purposes of error reporting -ruleCheckProgram :: (Activation -> Bool) -- ^ Rule activation test +ruleCheckProgram :: CompilerPhase -- ^ Rule activation test -> String -- ^ Rule pattern -> RuleBase -- ^ Database of rules -> [CoreBind] -- ^ Bindings to check in -> SDoc -- ^ Resulting check message -ruleCheckProgram is_active rule_pat rule_base binds +ruleCheckProgram phase rule_pat rule_base binds | isEmptyBag results = text "Rule check results: no rule application sites" | otherwise @@ -874,11 +893,17 @@ vcat [ p $$ line | p <- bagToList results ] ] where - results = unionManyBags (map (ruleCheckBind (RuleCheckEnv is_active rule_pat rule_base)) binds) + env = RuleCheckEnv { rc_is_active = isActive phase + , rc_id_unf = idUnfolding -- Not quite right + -- Should use activeUnfolding + , rc_pattern = rule_pat + , rc_rule_base = rule_base } + results = unionManyBags (map (ruleCheckBind env) binds) line = text (replicate 20 '-') data RuleCheckEnv = RuleCheckEnv { rc_is_active :: Activation -> Bool, + rc_id_unf :: IdUnfoldingFun, rc_pattern :: String, rc_rule_base :: RuleBase } @@ -913,13 +938,13 @@ ruleCheckFun env fn args | null name_match_rules = emptyBag - | otherwise = unitBag (ruleAppCheck_help (rc_is_active env) fn args name_match_rules) + | otherwise = unitBag (ruleAppCheck_help env fn args name_match_rules) where name_match_rules = filter match (getRules (rc_rule_base env) fn) match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule) -ruleAppCheck_help :: (Activation -> Bool) -> Id -> [CoreExpr] -> [CoreRule] -> SDoc -ruleAppCheck_help is_active fn args rules +ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc +ruleAppCheck_help env fn args rules = -- The rules match the pattern, so we want to print something vcat [text "Expression:" <+> ppr (mkApps (Var fn) args), vcat (map check_rule rules)] @@ -936,14 +961,14 @@ = ptext (sLit "Rule") <+> doubleQuotes (ftext name) rule_info rule - | Just _ <- matchRule noBlackList emptyInScopeSet args rough_args rule + | Just _ <- matchRule noBlackList (rc_id_unf env) emptyInScopeSet args rough_args rule = text "matches (which is very peculiar!)" rule_info (BuiltinRule {}) = text "does not match" rule_info (Rule { ru_act = act, ru_bndrs = rule_bndrs, ru_args = rule_args}) - | not (is_active act) = text "active only in later phase" + | not (rc_is_active env act) = text "active only in later phase" | n_args < n_rule_args = text "too few arguments" | n_mismatches == n_rule_args = text "no arguments match" | n_mismatches == 0 = text "all arguments match (considered individually), but rule as a whole does not" @@ -955,7 +980,7 @@ not (isJust (match_fn rule_arg arg))] lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars - match_fn rule_arg arg = match menv emptySubstEnv rule_arg arg + match_fn rule_arg arg = match (rc_id_unf env) menv emptySubstEnv rule_arg arg where in_scope = lhs_fvs `unionVarSet` exprFreeVars arg menv = ME { me_env = mkRnEnv2 (mkInScopeSet in_scope) diff -ruN ghc-6.12.1/compiler/specialise/SpecConstr.lhs ghc-6.13.20091231/compiler/specialise/SpecConstr.lhs --- ghc-6.12.1/compiler/specialise/SpecConstr.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/specialise/SpecConstr.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -11,7 +11,7 @@ -- for details module SpecConstr( - specConstrProgram + specConstrProgram, SpecConstrAnnotation(..) ) where #include "HsVersions.h" @@ -21,8 +21,12 @@ import CoreUtils import CoreUnfold ( couldBeSmallEnoughToInline ) import CoreFVs ( exprsFreeVars ) +import CoreMonad +import HscTypes ( ModGuts(..) ) import WwLib ( mkWorkerArgs ) -import DataCon ( dataConRepArity, dataConUnivTyVars ) +import DataCon ( dataConTyCon, dataConRepArity, dataConUnivTyVars ) +import TyCon ( TyCon ) +import Literal ( literalType ) import Coercion import Rules import Type hiding( substTy ) @@ -35,18 +39,24 @@ import DynFlags ( DynFlags(..) ) import StaticFlags ( opt_PprStyle_Debug ) import StaticFlags ( opt_SpecInlineJoinPoints ) -import BasicTypes ( Activation(..) ) import Maybes ( orElse, catMaybes, isJust, isNothing ) -import NewDemand +import Demand import DmdAnal ( both ) +import Serialized ( deserializeWithData ) import Util import UniqSupply import Outputable import FastString import UniqFM +import qualified LazyUniqFM as L import MonadUtils import Control.Monad ( zipWithM ) import Data.List +#if __GLASGOW_HASKELL__ > 609 +import Data.Data ( Data, Typeable ) +#else +import Data.Generics ( Data, Typeable ) +#endif \end{code} ----------------------------------------------------- @@ -455,7 +465,19 @@ a T (I# x) really, because T is strict and Int has one constructor. (We can't unbox the strict fields, becuase T is polymorphic!) +%************************************************************************ +%* * +\subsection{Annotations} +%* * +%************************************************************************ +Annotating a type with NoSpecConstr will make SpecConstr not specialise +for arguments of that type. + +\begin{code} +data SpecConstrAnnotation = NoSpecConstr | ForceSpecConstr + deriving( Data, Typeable, Eq ) +\end{code} %************************************************************************ %* * @@ -464,8 +486,14 @@ %************************************************************************ \begin{code} -specConstrProgram :: DynFlags -> UniqSupply -> [CoreBind] -> [CoreBind] -specConstrProgram dflags us binds = fst $ initUs us (go (initScEnv dflags) binds) +specConstrProgram :: ModGuts -> CoreM ModGuts +specConstrProgram guts + = do + dflags <- getDynFlags + us <- getUniqueSupplyM + annos <- getFirstAnnotations deserializeWithData guts + let binds' = fst $ initUs us (go (initScEnv dflags annos) (mg_binds guts)) + return (guts { mg_binds = binds' }) where go _ [] = return [] go env (bind:binds) = do (env', bind') <- scTopBind env bind @@ -491,9 +519,11 @@ -- Binds interesting non-top-level variables -- Domain is OutVars (*after* applying the substitution) - sc_vals :: ValueEnv + sc_vals :: ValueEnv, -- Domain is OutIds (*after* applying the substitution) -- Used even for top-level bindings (but not imported ones) + + sc_annotations :: L.UniqFM SpecConstrAnnotation } --------------------- @@ -517,13 +547,14 @@ ppr LambdaVal = ptext (sLit "") --------------------- -initScEnv :: DynFlags -> ScEnv -initScEnv dflags +initScEnv :: DynFlags -> L.UniqFM SpecConstrAnnotation -> ScEnv +initScEnv dflags anns = SCE { sc_size = specConstrThreshold dflags, sc_count = specConstrCount dflags, sc_subst = emptySubst, sc_how_bound = emptyVarEnv, - sc_vals = emptyVarEnv } + sc_vals = emptyVarEnv, + sc_annotations = anns } data HowBound = RecFun -- These are the recursive functions for which -- we seek interesting call patterns @@ -622,6 +653,39 @@ where vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++ varsToCoreExprs alt_bndrs + +ignoreTyCon :: ScEnv -> TyCon -> Bool +ignoreTyCon env tycon + = L.lookupUFM (sc_annotations env) tycon == Just NoSpecConstr + +ignoreType :: ScEnv -> Type -> Bool +ignoreType env ty + = case splitTyConApp_maybe ty of + Just (tycon, _) -> ignoreTyCon env tycon + _ -> False + +ignoreAltCon :: ScEnv -> AltCon -> Bool +ignoreAltCon env (DataAlt dc) = ignoreTyCon env (dataConTyCon dc) +ignoreAltCon env (LitAlt lit) = ignoreType env (literalType lit) +ignoreAltCon _ DEFAULT = True + +forceSpecBndr :: ScEnv -> Var -> Bool +forceSpecBndr env var = forceSpecFunTy env . varType $ var + +forceSpecFunTy :: ScEnv -> Type -> Bool +forceSpecFunTy env = any (forceSpecArgTy env) . fst . splitFunTys + +forceSpecArgTy :: ScEnv -> Type -> Bool +forceSpecArgTy env ty + | Just ty' <- coreView ty = forceSpecArgTy env ty' + +forceSpecArgTy env ty + | Just (tycon, tys) <- splitTyConApp_maybe ty + , tycon /= funTyCon + = L.lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr + || any (forceSpecArgTy env) tys + +forceSpecArgTy _ _ = False \end{code} @@ -852,12 +916,14 @@ = do { let (bndrs,rhss) = unzip prs (rhs_env1,bndrs') = extendRecBndrs env bndrs rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun + force_spec = any (forceSpecBndr env) bndrs' ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss) ; (body_usg, body') <- scExpr rhs_env2 body -- NB: start specLoop from body_usg - ; (spec_usg, specs) <- specLoop rhs_env2 (scu_calls body_usg) rhs_infos nullUsage + ; (spec_usg, specs) <- specLoop rhs_env2 force_spec + (scu_calls body_usg) rhs_infos nullUsage [SI [] 0 (Just usg) | usg <- rhs_usgs] ; let all_usg = spec_usg `combineUsage` body_usg @@ -911,6 +977,7 @@ scTopBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind) scTopBind env (Rec prs) | Just threshold <- sc_size env + , not force_spec , not (all (couldBeSmallEnoughToInline threshold) rhss) -- No specialisation = do { let (rhs_env,bndrs') = extendRecBndrs env bndrs @@ -923,13 +990,15 @@ ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss) ; let rhs_usg = combineUsages rhs_usgs - ; (_, specs) <- specLoop rhs_env2 (scu_calls rhs_usg) rhs_infos nullUsage + ; (_, specs) <- specLoop rhs_env2 force_spec + (scu_calls rhs_usg) rhs_infos nullUsage [SI [] 0 Nothing | _ <- bndrs] ; return (rhs_env1, -- For the body of the letrec, delete the RecFun business Rec (concat (zipWith specInfoBinds rhs_infos specs))) } where (bndrs,rhss) = unzip prs + force_spec = any (forceSpecBndr env) bndrs scTopBind env (NonRec bndr rhs) = do { (_, rhs') <- scExpr env rhs @@ -994,12 +1063,13 @@ specLoop :: ScEnv + -> Bool -- force specialisation? -> CallEnv -> [RhsInfo] -> ScUsage -> [SpecInfo] -- One per binder; acccumulating parameter -> UniqSM (ScUsage, [SpecInfo]) -- ...ditto... -specLoop env all_calls rhs_infos usg_so_far specs_so_far - = do { specs_w_usg <- zipWithM (specialise env all_calls) rhs_infos specs_so_far +specLoop env force_spec all_calls rhs_infos usg_so_far specs_so_far + = do { specs_w_usg <- zipWithM (specialise env force_spec all_calls) rhs_infos specs_so_far ; let (new_usg_s, all_specs) = unzip specs_w_usg new_usg = combineUsages new_usg_s new_calls = scu_calls new_usg @@ -1007,10 +1077,11 @@ ; if isEmptyVarEnv new_calls then return (all_usg, all_specs) else - specLoop env new_calls rhs_infos all_usg all_specs } + specLoop env force_spec new_calls rhs_infos all_usg all_specs } specialise :: ScEnv + -> Bool -- force specialisation? -> CallEnv -- Info on calls -> RhsInfo -> SpecInfo -- Original RHS plus patterns dealt with @@ -1020,7 +1091,7 @@ -- So when we make a specialised copy of the RHS, we're starting -- from an RHS whose nested functions have been optimised already. -specialise env bind_calls (fn, arg_bndrs, body, arg_occs) +specialise env force_spec bind_calls (fn, arg_bndrs, body, arg_occs) spec_info@(SI specs spec_count mb_unspec) | not (isBottomingId fn) -- Note [Do not specialise diverging functions] , notNull arg_bndrs -- Only specialise functions @@ -1035,7 +1106,7 @@ -- Rather a hacky way to do so, but it'll do for now ; let spec_count' = length pats + spec_count ; case sc_count env of - Just max | spec_count' > max + Just max | not force_spec && spec_count' > max -> WARN( True, msg ) return (nullUsage, spec_info) where msg = vcat [ sep [ ptext (sLit "SpecConstr: specialisation of") <+> quotes (ppr fn) @@ -1107,18 +1178,19 @@ -- Usual w/w hack to avoid generating -- a spec_rhs of unlifted type and no args - fn_name = idName fn - fn_loc = nameSrcSpan fn_name - spec_occ = mkSpecOcc (nameOccName fn_name) - rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number)) - spec_rhs = mkLams spec_lam_args spec_body - spec_str = calcSpecStrictness fn spec_lam_args pats - spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc - `setIdNewStrictness` spec_str -- See Note [Transfer strictness] - `setIdArity` count isId spec_lam_args - body_ty = exprType spec_body - rule_rhs = mkVarApps (Var spec_id) spec_call_args - rule = mkLocalRule rule_name specConstrActivation fn_name qvars pats rule_rhs + fn_name = idName fn + fn_loc = nameSrcSpan fn_name + spec_occ = mkSpecOcc (nameOccName fn_name) + rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number)) + spec_rhs = mkLams spec_lam_args spec_body + spec_str = calcSpecStrictness fn spec_lam_args pats + spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc + `setIdStrictness` spec_str -- See Note [Transfer strictness] + `setIdArity` count isId spec_lam_args + body_ty = exprType spec_body + rule_rhs = mkVarApps (Var spec_id) spec_call_args + inline_act = idInlineActivation fn + rule = mkLocalRule rule_name inline_act fn_name qvars pats rule_rhs ; return (spec_usg, OS call_pat rule spec_id spec_rhs) } calcSpecStrictness :: Id -- The original function @@ -1129,7 +1201,7 @@ = StrictSig (mkTopDmdType spec_dmds TopRes) where spec_dmds = [ lookupVarEnv dmd_env qv `orElse` lazyDmd | qv <- qvars, isId qv ] - StrictSig (DmdType _ dmds _) = idNewStrictness fn + StrictSig (DmdType _ dmds _) = idStrictness fn dmd_env = go emptyVarEnv dmds pats @@ -1143,18 +1215,23 @@ | (Var _, args) <- collectArgs e = go env ds args go_one env _ _ = env --- In which phase should the specialise-constructor rules be active? --- Originally I made them always-active, but Manuel found that --- this defeated some clever user-written rules. So Plan B --- is to make them active only in Phase 0; after all, currently, --- the specConstr transformation is only run after the simplifier --- has reached Phase 0. In general one would want it to be --- flag-controllable, but for now I'm leaving it baked in --- [SLPJ Oct 01] -specConstrActivation :: Activation -specConstrActivation = ActiveAfter 0 -- Baked in; see comments above \end{code} +Note [Transfer activation] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +In which phase should the specialise-constructor rules be active? +Originally I made them always-active, but Manuel found that this +defeated some clever user-written rules. Then I made them active only +in Phase 0; after all, currently, the specConstr transformation is +only run after the simplifier has reached Phase 0, but that meant +that specialisations didn't fire inside wrappers; see test +simplCore/should_compile/spec-inline. + +So now I just use the inline-activation of the parent Id, as the +activation for the specialiation RULE, just like the main specialiser; +see Note [Auto-specialisation and RULES] in Specialise. + + Note [Transfer strictness] ~~~~~~~~~~~~~~~~~~~~~~~~~~ We must transfer strictness information from the original function to @@ -1211,7 +1288,7 @@ = return Nothing | otherwise = do { let in_scope = substInScope (sc_subst env) - ; prs <- argsToPats in_scope con_env (args `zip` bndr_occs) + ; prs <- argsToPats env in_scope con_env (args `zip` bndr_occs) ; let (interesting_s, pats) = unzip prs pat_fvs = varSetElems (exprsFreeVars pats) qvars = filterOut (`elemInScopeSet` in_scope) pat_fvs @@ -1235,7 +1312,8 @@ -- placeholder variables. For example: -- C a (D (f x) (g y)) ==> C p1 (D p2 p3) -argToPat :: InScopeSet -- What's in scope at the fn defn site +argToPat :: ScEnv + -> InScopeSet -- What's in scope at the fn defn site -> ValueEnv -- ValueEnv at the call site -> CoreArg -- A call arg (or component thereof) -> ArgOcc @@ -1250,11 +1328,11 @@ -- lvl7 --> (True, lvl7) if lvl7 is bound -- somewhere further out -argToPat _in_scope _val_env arg@(Type {}) _arg_occ +argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ = return (False, arg) -argToPat in_scope val_env (Note _ arg) arg_occ - = argToPat in_scope val_env arg arg_occ +argToPat env in_scope val_env (Note _ arg) arg_occ + = argToPat env in_scope val_env arg arg_occ -- Note [Notes in call patterns] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Ignore Notes. In particular, we want to ignore any InlineMe notes @@ -1262,16 +1340,16 @@ -- ride roughshod over them all for now. --- See Note [Notes in RULE matching] in Rules -argToPat in_scope val_env (Let _ arg) arg_occ - = argToPat in_scope val_env arg arg_occ +argToPat env in_scope val_env (Let _ arg) arg_occ + = argToPat env in_scope val_env arg arg_occ -- Look through let expressions -- e.g. f (let v = rhs in \y -> ...v...) -- Here we can specialise for f (\y -> ...) -- because the rule-matcher will look through the let. -argToPat in_scope val_env (Cast arg co) arg_occ - = do { (interesting, arg') <- argToPat in_scope val_env arg arg_occ - ; let (ty1,ty2) = coercionKind co +argToPat env in_scope val_env (Cast arg co) arg_occ + | not (ignoreType env ty2) + = do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ ; if not interesting then wildCardPat ty2 else do @@ -1280,6 +1358,10 @@ ; let co_name = mkSysTvName uniq (fsLit "sg") co_var = mkCoVar co_name (mkCoKind ty1 ty2) ; return (interesting, Cast arg' (mkTyVarTy co_var)) } } + where + (ty1, ty2) = coercionKind co + + {- Disabling lambda specialisation for now It's fragile, and the spec_loop can be infinite @@ -1295,15 +1377,16 @@ -- Check for a constructor application -- NB: this *precedes* the Var case, so that we catch nullary constrs -argToPat in_scope val_env arg arg_occ +argToPat env in_scope val_env arg arg_occ | Just (ConVal dc args) <- isValue val_env arg + , not (ignoreAltCon env dc) , case arg_occ of ScrutOcc _ -> True -- Used only by case scrutinee BothOcc -> case arg of -- Used elsewhere App {} -> True -- see Note [Reboxing] _other -> False _other -> False -- No point; the arg is not decomposed - = do { args' <- argsToPats in_scope val_env (args `zip` conArgOccs arg_occ dc) + = do { args' <- argsToPats env in_scope val_env (args `zip` conArgOccs arg_occ dc) ; return (True, mk_con_app dc (map snd args')) } -- Check if the argument is a variable that @@ -1311,9 +1394,10 @@ -- It's worth specialising on this if -- (a) it's used in an interesting way in the body -- (b) we know what its value is -argToPat in_scope val_env (Var v) arg_occ +argToPat env in_scope val_env (Var v) arg_occ | case arg_occ of { UnkOcc -> False; _other -> True }, -- (a) - is_value -- (b) + is_value, -- (b) + not (ignoreType env (varType v)) = return (True, Var v) where is_value @@ -1342,7 +1426,7 @@ -- We don't want to specialise for that *particular* x,y -- The default case: make a wild-card -argToPat _in_scope _val_env arg _arg_occ +argToPat _env _in_scope _val_env arg _arg_occ = wildCardPat (exprType arg) wildCardPat :: Type -> UniqSM (Bool, CoreArg) @@ -1350,13 +1434,13 @@ ; let id = mkSysLocal (fsLit "sc") uniq ty ; return (False, Var id) } -argsToPats :: InScopeSet -> ValueEnv +argsToPats :: ScEnv -> InScopeSet -> ValueEnv -> [(CoreArg, ArgOcc)] -> UniqSM [(Bool, CoreArg)] -argsToPats in_scope val_env args +argsToPats env in_scope val_env args = mapM do_one args where - do_one (arg,occ) = argToPat in_scope val_env arg occ + do_one (arg,occ) = argToPat env in_scope val_env arg occ \end{code} diff -ruN ghc-6.12.1/compiler/specialise/Specialise.lhs ghc-6.13.20091231/compiler/specialise/Specialise.lhs --- ghc-6.12.1/compiler/specialise/Specialise.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/specialise/Specialise.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -17,7 +17,7 @@ import Id import TcType import CoreSubst -import CoreUnfold ( mkUnfolding ) +import CoreUnfold ( mkUnfolding, mkInlineRule ) import VarSet import VarEnv import CoreSyn @@ -29,6 +29,7 @@ import MkId ( voidArgId, realWorldPrimId ) import FiniteMap import Maybes ( catMaybes, isJust ) +import BasicTypes ( isNeverActive, inlinePragmaActivation ) import Bag import Util import Outputable @@ -773,6 +774,9 @@ | rhs_tyvars `lengthIs` n_tyvars -- Rhs of fn's defn has right number of big lambdas && rhs_ids `lengthAtLeast` n_dicts -- and enough dict args && notNull calls_for_me -- And there are some calls to specialise + && not (isNeverActive (idInlineActivation fn)) + -- Don't specialise NOINLINE things + -- See Note [Auto-specialisation and RULES] -- && not (certainlyWillInline (idUnfolding fn)) -- And it's not small -- See Note [Inline specialisation] for why we do not @@ -800,17 +804,24 @@ where fn_type = idType fn fn_arity = idArity fn + fn_unf = realIdUnfolding fn -- Ignore loop-breaker-ness here (tyvars, theta, _) = tcSplitSigmaTy fn_type n_tyvars = length tyvars n_dicts = length theta - inline_act = idInlineActivation fn + inl_act = inlinePragmaActivation (idInlinePragma fn) - (body_uds_without_me, calls_for_me) = callsForMe fn body_uds + -- Figure out whether the function has an INLINE pragma + -- See Note [Inline specialisations] + fn_has_inline_rule :: Maybe Bool -- Derive sat-flag from existing thing + fn_has_inline_rule = case isInlineRule_maybe fn_unf of + Just (_,sat) -> Just sat + Nothing -> Nothing + + spec_arity = unfoldingArity fn_unf - n_dicts -- Arity of the *specialised* inline rule + + (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs - -- It's important that we "see past" any INLINE pragma - -- else we'll fail to specialise an INLINE thing - (inline_rhs, rhs_inside) = dropInline rhs - (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs_inside + (body_uds_without_me, calls_for_me) = callsForMe fn body_uds rhs_dict_ids = take n_dicts rhs_ids body = mkLams (drop n_dicts rhs_ids) rhs_body @@ -818,7 +829,8 @@ already_covered :: [CoreExpr] -> Bool already_covered args -- Note [Specialisations already covered] - = isJust (lookupRule (const True) (substInScope subst) + = isJust (lookupRule (const True) realIdUnfolding + (substInScope subst) fn args (idCoreRules fn)) mk_ty_args :: [Maybe Type] -> [CoreExpr] @@ -878,10 +890,6 @@ spec_id_ty = mkPiTypes lam_args body_ty ; spec_f <- newSpecIdSM fn spec_id_ty - ; let spec_f_w_arity = setIdArity spec_f (max 0 (fn_arity - n_dicts)) - -- Adding arity information just propagates it a bit faster - -- See Note [Arity decrease] in Simplify - ; (spec_rhs, rhs_uds) <- specExpr rhs_subst2 (mkLams lam_args body) ; let -- The rule to put in the function's specialisation is: @@ -889,19 +897,29 @@ rule_name = mkFastString ("SPEC " ++ showSDoc (ppr fn <+> ppr spec_ty_args)) spec_env_rule = mkLocalRule rule_name - inline_act -- Note [Auto-specialisation and RULES] + inl_act -- Note [Auto-specialisation and RULES] (idName fn) (poly_tyvars ++ inst_dict_ids) inst_args - (mkVarApps (Var spec_f_w_arity) app_args) + (mkVarApps (Var spec_f) app_args) -- Add the { d1' = dx1; d2' = dx2 } usage stuff final_uds = foldr consDictBind rhs_uds dx_binds - spec_pr | inline_rhs = (spec_f_w_arity `setInlineActivation` inline_act, Note InlineMe spec_rhs) - | otherwise = (spec_f_w_arity, spec_rhs) - - ; return (Just (spec_pr, final_uds, spec_env_rule)) } } + -- Adding arity information just propagates it a bit faster + -- See Note [Arity decrease] in Simplify + -- Copy InlinePragma information from the parent Id. + -- So if f has INLINE[1] so does spec_f + spec_f_w_arity = spec_f `setIdArity` max 0 (fn_arity - n_dicts) + `setInlineActivation` inl_act + + -- Add an InlineRule if the parent has one + -- See Note [Inline specialisations] + final_spec_f | Just sat <- fn_has_inline_rule + = spec_f_w_arity `setIdUnfolding` mkInlineRule sat spec_rhs spec_arity + | otherwise + = spec_f_w_arity + ; return (Just ((final_spec_f, spec_rhs), final_uds, spec_env_rule)) } } where my_zipEqual xs ys zs | debugIsOn && not (equalLength xs ys && equalLength ys zs) @@ -927,7 +945,7 @@ -- No auxiliary binding necessary | otherwise = go subst_w_unf (NonRec dx_id dx : binds) pairs where - dx_id1 = dx_id `setIdUnfolding` mkUnfolding False dx + dx_id1 = dx_id `setIdUnfolding` mkUnfolding False False dx subst_w_unf = extendIdSubst subst d (Var dx_id1) -- Important! We're going to substitute dx_id1 for d -- and we want it to look "interesting", else we won't gather *any* @@ -1100,10 +1118,14 @@ RULE f g_spec = 0 But that's a bit complicated. For now we ask the programmer's help, -by *copying the INLINE activation pragma* to the auto-specialised rule. -So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule will also -not be active until phase 2. +by *copying the INLINE activation pragma* to the auto-specialised +rule. So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule +will also not be active until phase 2. And that's what programmers +should jolly well do anyway, even aside from specialisation, to ensure +that g doesn't inline too early. +This in turn means that the RULE would never fire for a NOINLINE +thing so not much point in generating a specialisation at all. Note [Specialisation shape] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1129,13 +1151,12 @@ where choose doesn't have any dict arguments. Thus far I have not tried to fix this (wait till there's a real example). - Note [Inline specialisations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We transfer to the specialised function any INLINE stuff from the -original. This means (a) the Activation in the IdInfo, and (b) any -InlineMe on the RHS. We do not, however, transfer the RuleMatchInfo -since we do not expect the specialisation to occur in rewrite rules. +original. This means + (a) the Activation for its inlining (from its InlinePragma) + (b) any InlineRule This is a change (Jun06). Previously the idea is that the point of inlining was precisely to specialise the function at its call site, @@ -1154,14 +1175,6 @@ boring to trigger inlining), and it's certainly better to call the specialised version. -A case in point is dictionary functions, which are current marked -INLINE, but which are worth specialising. - -\begin{code} -dropInline :: CoreExpr -> (Bool, CoreExpr) -dropInline (Note InlineMe rhs) = (True, rhs) -dropInline rhs = (False, rhs) -\end{code} %************************************************************************ %* * diff -ruN ghc-6.12.1/compiler/stgSyn/CoreToStg.lhs ghc-6.13.20091231/compiler/stgSyn/CoreToStg.lhs --- ghc-6.12.1/compiler/stgSyn/CoreToStg.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/stgSyn/CoreToStg.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -437,7 +437,7 @@ | isUnLiftedTyCon tc -> PrimAlt tc | isHiBootTyCon tc -> look_for_better_tycon | isAlgTyCon tc -> AlgAlt tc - | otherwise -> ASSERT( _is_poly_alt_tycon tc ) + | otherwise -> ASSERT2( _is_poly_alt_tycon tc, ppr tc ) PolyAlt Nothing -> PolyAlt diff -ruN ghc-6.12.1/compiler/stgSyn/StgLint.lhs ghc-6.13.20091231/compiler/stgSyn/StgLint.lhs --- ghc-6.12.1/compiler/stgSyn/StgLint.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/stgSyn/StgLint.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -316,7 +316,7 @@ if isEmptyBag errs then Nothing else - Just (vcat (punctuate (text "") (bagToList errs))) + Just (vcat (punctuate blankLine (bagToList errs))) } instance Monad LintM where diff -ruN ghc-6.12.1/compiler/stranal/DmdAnal.lhs ghc-6.13.20091231/compiler/stranal/DmdAnal.lhs --- ghc-6.12.1/compiler/stranal/DmdAnal.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/stranal/DmdAnal.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -22,7 +22,7 @@ import DynFlags ( DynFlags, DynFlag(..) ) import StaticFlags ( opt_MaxWorkerArgs ) -import NewDemand -- All of it +import Demand -- All of it import CoreSyn import PprCore import CoreUtils ( exprIsHNF, exprIsTrivial ) @@ -31,17 +31,11 @@ import TyCon ( isProductTyCon, isRecursiveTyCon ) import Id ( Id, idType, idInlineActivation, isDataConWorkId, isGlobalId, idArity, -#ifdef OLD_STRICTNESS - idDemandInfo, idStrictness, idCprInfo, idName, -#endif - idNewStrictness, idNewStrictness_maybe, - setIdNewStrictness, idNewDemandInfo, - idNewDemandInfo_maybe, - setIdNewDemandInfo + idStrictness, idStrictness_maybe, + setIdStrictness, idDemandInfo, + idDemandInfo_maybe, + setIdDemandInfo ) -#ifdef OLD_STRICTNESS -import IdInfo ( newStrictnessFromOld, newDemand ) -#endif import Var ( Var ) import VarEnv import TysWiredIn ( unboxedPairDataCon ) @@ -50,11 +44,11 @@ keysUFM, minusUFM, ufmToList, filterUFM ) import Type ( isUnLiftedType, coreEqType, splitTyConApp_maybe ) import Coercion ( coercionKind ) -import CoreLint ( showPass, endPass ) import Util ( mapAndUnzip, lengthIs ) import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive, RecFlag(..), isRec ) import Maybes ( orElse, expectJust ) +import ErrUtils ( showPass ) import Outputable import Data.List @@ -79,12 +73,6 @@ dmdAnalPgm dflags binds = do { let { binds_plus_dmds = do_prog binds } ; -#ifdef OLD_STRICTNESS - -- Only if OLD_STRICTNESS is on, because only then is the old - -- strictness analyser run - let { dmd_changes = get_changes binds_plus_dmds } ; - printDump (text "Changes in demands" $$ dmd_changes) ; -#endif return binds_plus_dmds } where @@ -229,9 +217,9 @@ (deferType lam_ty, Lam var' body') dmdAnal sigs dmd (Case scrut case_bndr ty [alt@(DataAlt dc,bndrs,rhs)]) - | let tycon = dataConTyCon dc, - isProductTyCon tycon, - not (isRecursiveTyCon tycon) + | let tycon = dataConTyCon dc + , isProductTyCon tycon + , not (isRecursiveTyCon tycon) = let sigs_alt = extendSigEnv NotTopLevel sigs case_bndr case_bndr_sig (alt_ty, alt') = dmdAnalAlt sigs_alt dmd alt @@ -257,7 +245,7 @@ -- x = (a, absent-error) -- and that'll crash. -- So at one stage I had: - -- dead_case_bndr = isAbsentDmd (idNewDemandInfo case_bndr') + -- dead_case_bndr = isAbsentDmd (idDemandInfo case_bndr') -- keepity | dead_case_bndr = Drop -- | otherwise = Keep -- @@ -268,9 +256,9 @@ -- The insight is, of course, that a demand on y is a demand on the -- scrutinee, so we need to `both` it with the scrut demand - alt_dmd = Eval (Prod [idNewDemandInfo b | b <- bndrs', isId b]) + alt_dmd = Eval (Prod [idDemandInfo b | b <- bndrs', isId b]) scrut_dmd = alt_dmd `both` - idNewDemandInfo case_bndr' + idDemandInfo case_bndr' (scrut_ty, scrut') = dmdAnal sigs scrut_dmd scrut in @@ -425,7 +413,7 @@ -- of the fixpoint algorithm. (Cunning plan.) -- Note that the cunning plan extends to the DmdEnv too, -- since it is part of the strictness signature -initialSig id = idNewStrictness_maybe id `orElse` botSig +initialSig id = idStrictness_maybe id `orElse` botSig dmdAnalRhs :: TopLevelFlag -> RecFlag -> SigEnv -> (Id, CoreExpr) @@ -443,7 +431,7 @@ -- The RHS can be eta-reduced to just a variable, -- in which case we should not complain. mkSigTy top_lvl rec_flag id rhs rhs_dmd_ty - id' = id `setIdNewStrictness` sig_ty + id' = id `setIdStrictness` sig_ty sigs' = extendSigEnv top_lvl sigs id sig_ty \end{code} @@ -464,7 +452,7 @@ = mk_sig_ty never_inline thunk_cpr_ok rhs dmd_ty where never_inline = isNeverActive (idInlineActivation id) - maybe_id_dmd = idNewDemandInfo_maybe id + maybe_id_dmd = idDemandInfo_maybe id -- Is Nothing the first time round thunk_cpr_ok @@ -734,7 +722,7 @@ -- No effect on the argument demands annotateBndr dmd_ty@(DmdType fv ds res) var | isTyVar var = (dmd_ty, var) - | otherwise = (DmdType fv' ds res, setIdNewDemandInfo var dmd) + | otherwise = (DmdType fv' ds res, setIdDemandInfo var dmd) where (fv', dmd) = removeFV fv var res @@ -749,7 +737,7 @@ -- For lambdas we add the demand to the argument demands -- Only called for Ids = ASSERT( isId id ) - (DmdType fv' (hacked_dmd:ds) res, setIdNewDemandInfo id hacked_dmd) + (DmdType fv' (hacked_dmd:ds) res, setIdDemandInfo id hacked_dmd) where (fv', dmd) = removeFV fv id res hacked_dmd = argDemand dmd @@ -815,7 +803,7 @@ -- CPR results (e.g. from \x -> x!). extendSigsWithLam sigs id - = case idNewDemandInfo_maybe id of + = case idDemandInfo_maybe id of Nothing -> extendVarEnv sigs id (cprSig, NotTopLevel) -- Optimistic in the Nothing case; -- See notes [CPR-AND-STRICTNESS] @@ -835,7 +823,7 @@ ------ DATA CONSTRUCTOR | isDataConWorkId var -- Data constructor = let - StrictSig dmd_ty = idNewStrictness var -- It must have a strictness sig + StrictSig dmd_ty = idStrictness var -- It must have a strictness sig DmdType _ _ con_res = dmd_ty arity = idArity var in @@ -866,7 +854,7 @@ ------ IMPORTED FUNCTION | isGlobalId var, -- Imported function - let StrictSig dmd_ty = idNewStrictness var + let StrictSig dmd_ty = idStrictness var = if dmdTypeDepth dmd_ty <= call_depth then -- Saturated, so unleash the demand dmd_ty else @@ -1097,22 +1085,11 @@ both Abs d2 = d2 +-- Note [Bottom demands] both Bot Bot = Bot both Bot Abs = Bot both Bot (Eval ds) = Eval (mapDmds (`both` Bot) ds) - -- Consider - -- f x = error x - -- From 'error' itself we get demand Bot on x - -- From the arg demand on x we get - -- x :-> evalDmd = Box (Eval (Poly Abs)) - -- So we get Bot `both` Box (Eval (Poly Abs)) - -- = Seq Keep (Poly Bot) - -- - -- Consider also - -- f x = if ... then error (fst x) else fst x - -- Then we get (Eval (Box Bot, Bot) `lub` Eval (SA)) - -- = Eval (SA) - -- which is what we want. +both Bot (Defer ds) = Eval (mapDmds (`both` Bot) ds) both Bot d = errDmd both Top Bot = errDmd @@ -1147,87 +1124,29 @@ boths ds1 ds2 = zipWithDmds both ds1 ds2 \end{code} +Note [Bottom demands] +~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = error x +From 'error' itself we get demand Bot on x +From the arg demand on x we get + x :-> evalDmd = Box (Eval (Poly Abs)) +So we get Bot `both` Box (Eval (Poly Abs)) + = Seq Keep (Poly Bot) + +Consider also + f x = if ... then error (fst x) else fst x +Then we get (Eval (Box Bot, Bot) `lub` Eval (SA)) + = Eval (SA) +which is what we want. + +Consider also + f x = error [fst x] +Then we get + x :-> Bot `both` Defer [SA] +and we want the Bot demand to cancel out the Defer +so that we get Eval [SA]. Otherwise we'd have the odd +situation that + f x = error (fst x) -- Strictness U(SA)b + g x = error ('y':fst x) -- Strictness Tb - -%************************************************************************ -%* * -\subsection{Miscellaneous -%* * -%************************************************************************ - - -\begin{code} -#ifdef OLD_STRICTNESS -get_changes binds = vcat (map get_changes_bind binds) - -get_changes_bind (Rec pairs) = vcat (map get_changes_pr pairs) -get_changes_bind (NonRec id rhs) = get_changes_pr (id,rhs) - -get_changes_pr (id,rhs) - = get_changes_var id $$ get_changes_expr rhs - -get_changes_var var - | isId var = get_changes_str var $$ get_changes_dmd var - | otherwise = empty - -get_changes_expr (Type t) = empty -get_changes_expr (Var v) = empty -get_changes_expr (Lit l) = empty -get_changes_expr (Note n e) = get_changes_expr e -get_changes_expr (App e1 e2) = get_changes_expr e1 $$ get_changes_expr e2 -get_changes_expr (Lam b e) = {- get_changes_var b $$ -} get_changes_expr e -get_changes_expr (Let b e) = get_changes_bind b $$ get_changes_expr e -get_changes_expr (Case e b a) = get_changes_expr e $$ {- get_changes_var b $$ -} vcat (map get_changes_alt a) - -get_changes_alt (con,bs,rhs) = {- vcat (map get_changes_var bs) $$ -} get_changes_expr rhs - -get_changes_str id - | new_better && old_better = empty - | new_better = message "BETTER" - | old_better = message "WORSE" - | otherwise = message "INCOMPARABLE" - where - message word = text word <+> text "strictness for" <+> ppr id <+> info - info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new) - new = squashSig (idNewStrictness id) -- Don't report spurious diffs that the old - -- strictness analyser can't track - old = newStrictnessFromOld (idName id) (idArity id) (idStrictness id) (idCprInfo id) - old_better = old `betterStrictness` new - new_better = new `betterStrictness` old - -get_changes_dmd id - | isUnLiftedType (idType id) = empty -- Not useful - | new_better && old_better = empty - | new_better = message "BETTER" - | old_better = message "WORSE" - | otherwise = message "INCOMPARABLE" - where - message word = text word <+> text "demand for" <+> ppr id <+> info - info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new) - new = squashDmd (argDemand (idNewDemandInfo id)) -- To avoid spurious improvements - -- A bit of a hack - old = newDemand (idDemandInfo id) - new_better = new `betterDemand` old - old_better = old `betterDemand` new - -betterStrictness :: StrictSig -> StrictSig -> Bool -betterStrictness (StrictSig t1) (StrictSig t2) = betterDmdType t1 t2 - -betterDmdType t1 t2 = (t1 `lubType` t2) == t2 - -betterDemand :: Demand -> Demand -> Bool --- If d1 `better` d2, and d2 `better` d2, then d1==d2 -betterDemand d1 d2 = (d1 `lub` d2) == d2 - -squashSig (StrictSig (DmdType fv ds res)) - = StrictSig (DmdType emptyDmdEnv (map squashDmd ds) res) - where - -- squash just gets rid of call demands - -- which the old analyser doesn't track -squashDmd (Call d) = evalDmd -squashDmd (Box d) = Box (squashDmd d) -squashDmd (Eval ds) = Eval (mapDmds squashDmd ds) -squashDmd (Defer ds) = Defer (mapDmds squashDmd ds) -squashDmd d = d -#endif -\end{code} diff -ruN ghc-6.12.1/compiler/stranal/SaAbsInt.lhs ghc-6.13.20091231/compiler/stranal/SaAbsInt.lhs --- ghc-6.12.1/compiler/stranal/SaAbsInt.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/stranal/SaAbsInt.lhs 1969-12-31 16:00:00.000000000 -0800 @@ -1,932 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 -% -\section[SaAbsInt]{Abstract interpreter for strictness analysis} - -\begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - -#ifndef OLD_STRICTNESS --- If OLD_STRICTNESS is off, omit all exports -module SaAbsInt () where - -#else -module SaAbsInt ( - findStrictness, - findDemand, findDemandAlts, - absEval, - widen, - fixpoint, - isBot - ) where - -#include "HsVersions.h" - -import StaticFlags ( opt_AllStrict, opt_NumbersStrict ) -import CoreSyn -import CoreUnfold ( maybeUnfoldingTemplate ) -import Id ( Id, idType, idUnfolding, isDataConWorkId_maybe, - idStrictness, - ) -import DataCon ( dataConTyCon, splitProductType_maybe, dataConRepArgTys ) -import IdInfo ( StrictnessInfo(..) ) -import Demand ( Demand(..), wwPrim, wwStrict, wwUnpack, wwLazy, - mkStrictnessInfo, isLazy - ) -import SaLib -import TyCon ( isProductTyCon, isRecursiveTyCon ) -import Type ( splitTyConApp_maybe, - isUnLiftedType, Type ) -import TyCon ( tyConUnique ) -import PrelInfo ( numericTyKeys ) -import Util ( isIn, nOfThem, zipWithEqual, equalLength ) -import Outputable -\end{code} - -%************************************************************************ -%* * -\subsection[AbsVal-ops]{Operations on @AbsVals@} -%* * -%************************************************************************ - -Least upper bound, greatest lower bound. - -\begin{code} -lub, glb :: AbsVal -> AbsVal -> AbsVal - -lub AbsBot val2 = val2 -lub val1 AbsBot = val1 - -lub (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual "lub" lub xs ys) - -lub _ _ = AbsTop -- Crude, but conservative - -- The crudity only shows up if there - -- are functions involved - --- Slightly funny glb; for absence analysis only; --- AbsBot is the safe answer. --- --- Using anyBot rather than just testing for AbsBot is important. --- Consider: --- --- f = \a b -> ... --- --- g = \x y z -> case x of --- [] -> f x --- (p:ps) -> f p --- --- Now, the abstract value of the branches of the case will be an --- AbsFun, but when testing for z's absence we want to spot that it's --- an AbsFun which can't possibly return AbsBot. So when glb'ing we --- mustn't be too keen to bale out and return AbsBot; the anyBot test --- spots that (f x) can't possibly return AbsBot. - --- We have also tripped over the following interesting case: --- case x of --- [] -> \y -> 1 --- (p:ps) -> f --- --- Now, suppose f is bound to AbsTop. Does this expression mention z? --- Obviously not. But the case will take the glb of AbsTop (for f) and --- an AbsFun (for \y->1). We should not bale out and give AbsBot, because --- that would say that it *does* mention z (or anything else for that matter). --- Nor can we always return AbsTop, because the AbsFun might be something --- like (\y->z), which obviously does mention z. The point is that we're --- glbing two functions, and AbsTop is not actually the top of the function --- lattice. It is more like (\xyz -> x|y|z); that is, AbsTop returns --- poison iff any of its arguments do. - --- Deal with functions specially, because AbsTop isn't the --- top of their domain. - -glb v1 v2 - | is_fun v1 || is_fun v2 - = if not (anyBot v1) && not (anyBot v2) - then - AbsTop - else - AbsBot - where - 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 - -glb (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual "glb" glb xs ys) - -glb AbsTop v2 = v2 -glb v1 AbsTop = v1 - -glb _ _ = AbsBot -- Be pessimistic -\end{code} - -@isBot@ returns True if its argument is (a representation of) bottom. The -``representation'' part is because we need to detect the bottom {\em function} -too. To detect the bottom function, bind its args to top, and see if it -returns bottom. - -Used only in strictness analysis: -\begin{code} -isBot :: AbsVal -> Bool - -isBot AbsBot = True -isBot other = False -- Functions aren't bottom any more -\end{code} - -Used only in absence analysis: - -\begin{code} -anyBot :: AbsVal -> Bool - -anyBot AbsBot = True -- poisoned! -anyBot AbsTop = False -anyBot (AbsProd vals) = any anyBot vals -anyBot (AbsFun bndr_ty abs_fn) = anyBot (abs_fn AbsTop) -anyBot (AbsApproxFun _ val) = anyBot val -\end{code} - -@widen@ takes an @AbsVal@, $val$, and returns and @AbsVal@ which is -approximated by $val$. Furthermore, the result has no @AbsFun@s in -it, so it can be compared for equality by @sameVal@. - -\begin{code} -widen :: AnalysisKind -> AbsVal -> AbsVal - --- Widening is complicated by the fact that funtions are lifted -widen StrAnal the_fn@(AbsFun bndr_ty _) - = case widened_body of - AbsApproxFun ds val -> AbsApproxFun (d : ds) val - where - d = findRecDemand str_fn abs_fn bndr_ty - str_fn val = isBot (foldl (absApply StrAnal) the_fn - (val : [AbsTop | d <- ds])) - - other -> AbsApproxFun [d] widened_body - where - d = findRecDemand str_fn abs_fn bndr_ty - str_fn val = isBot (absApply StrAnal the_fn val) - where - widened_body = widen StrAnal (absApply StrAnal the_fn AbsTop) - abs_fn val = False -- Always says poison; so it looks as if - -- nothing is absent; safe - -{- 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 - -- - -- f x y = let g y = case x of ... - -- in (g ..) + (g ..) - -- - -- Here, when we are considering strictness of f in x, we'll - -- evaluate the body of f with x bound to bottom. The current - -- strategy is to bind g to its *widened* value; without the isBot - -- (...) test above, we'd bind g to an AbsApproxFun, and deliver - -- Top, not Bot as the value of f's rhs. The test spots the - -- unconditional bottom-ness of g when x is bottom. (Another - -- 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 the_fn@(AbsFun bndr_ty _) - | anyBot widened_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 - = case widened_body of - AbsApproxFun ds val -> AbsApproxFun (d : ds) val - where - d = findRecDemand str_fn abs_fn bndr_ty - abs_fn val = not (anyBot (foldl (absApply AbsAnal) the_fn - (val : [AbsTop | d <- ds]))) - - other -> AbsApproxFun [d] widened_body - where - d = findRecDemand str_fn abs_fn bndr_ty - abs_fn val = not (anyBot (absApply AbsAnal the_fn val)) - where - widened_body = widen AbsAnal (absApply AbsAnal the_fn AbsTop) - str_fn val = True -- Always says non-termination; - -- that'll make findRecDemand peer into the - -- structure of the value. - -widen AbsAnal (AbsProd vals) = AbsProd (map (widen AbsAnal) vals) - - -- It's desirable to do a good job of widening for product - -- values. Consider - -- - -- let p = (x,y) - -- in ...(case p of (x,y) -> x)... - -- - -- Now, is y absent in this expression? Currently the - -- analyser widens p before looking at p's scope, to avoid - -- lots of recomputation in the case where p is a function. - -- So if widening doesn't have a case for products, we'll - -- widen p to AbsBot (since when searching for absence in y we - -- bind y to poison ie AbsBot), and now we are lost. - -widen AbsAnal other_val = other_val - --- WAS: if anyBot val then AbsBot else AbsTop --- Nowadays widen is doing a better job on functions for absence analysis. -\end{code} - -@crudeAbsWiden@ is used just for absence analysis, and always -returns AbsTop or AbsBot, so it widens to a two-point domain - -\begin{code} -crudeAbsWiden :: AbsVal -> AbsVal -crudeAbsWiden val = if anyBot val then AbsBot else AbsTop -\end{code} - -@sameVal@ compares two abstract values for equality. It can't deal with -@AbsFun@, but that should have been removed earlier in the day by @widen@. - -\begin{code} -sameVal :: AbsVal -> AbsVal -> Bool -- Can't handle AbsFun! - -#ifdef DEBUG -sameVal (AbsFun _ _) _ = panic "sameVal: AbsFun: arg1" -sameVal _ (AbsFun _ _) = panic "sameVal: AbsFun: arg2" -#endif - -sameVal AbsBot AbsBot = True -sameVal AbsBot other = False -- widen has reduced AbsFun bots to AbsBot - -sameVal AbsTop AbsTop = True -sameVal AbsTop other = False -- Right? - -sameVal (AbsProd vals1) (AbsProd vals2) = and (zipWithEqual "sameVal" sameVal vals1 vals2) -sameVal (AbsProd _) AbsTop = False -sameVal (AbsProd _) AbsBot = False - -sameVal (AbsApproxFun str1 v1) (AbsApproxFun str2 v2) = str1 == str2 && sameVal v1 v2 -sameVal (AbsApproxFun _ _) AbsTop = False -sameVal (AbsApproxFun _ _) AbsBot = False - -sameVal val1 val2 = panic "sameVal: type mismatch or AbsFun encountered" -\end{code} - - -@evalStrictness@ compares a @Demand@ with an abstract value, returning -@True@ iff the abstract value is {\em less defined} than the demand. -(@True@ is the exciting answer; @False@ is always safe.) - -\begin{code} -evalStrictness :: Demand - -> AbsVal - -> Bool -- True iff the value is sure - -- to be less defined than the Demand - -evalStrictness (WwLazy _) _ = False -evalStrictness WwStrict val = isBot val -evalStrictness WwEnum val = isBot val - -evalStrictness (WwUnpack _ demand_info) val - = case val of - AbsTop -> False - AbsBot -> True - AbsProd vals - | not (equalLength vals demand_info) -> pprTrace "TELL SIMON: evalStrictness" (ppr demand_info $$ ppr val) - False - | otherwise -> or (zipWithEqual "evalStrictness" evalStrictness demand_info vals) - - _ -> pprTrace "evalStrictness?" empty False - -evalStrictness WwPrim val - = case val of - AbsTop -> False - AbsBot -> True -- Can happen: consider f (g x), where g is a - -- recursive function returning an Int# that diverges - - other -> pprPanic "evalStrictness: WwPrim:" (ppr other) -\end{code} - -For absence analysis, we're interested in whether "poison" in the -argument (ie a bottom therein) can propagate to the result of the -function call; that is, whether the specified demand can {\em -possibly} hit poison. - -\begin{code} -evalAbsence (WwLazy True) _ = False -- Can't possibly hit poison - -- with Absent demand - -evalAbsence (WwUnpack _ demand_info) val - = case val of - AbsTop -> False -- No poison in here - AbsBot -> True -- Pure poison - AbsProd vals - | not (equalLength vals demand_info) -> pprTrace "TELL SIMON: evalAbsence" (ppr demand_info $$ ppr val) - True - | otherwise -> or (zipWithEqual "evalAbsence" evalAbsence demand_info vals) - _ -> pprTrace "TELL SIMON: evalAbsence" - (ppr demand_info $$ ppr val) - True - -evalAbsence other val = anyBot val - -- The demand is conservative; even "Lazy" *might* evaluate the - -- argument arbitrarily so we have to look everywhere for poison -\end{code} - -%************************************************************************ -%* * -\subsection[absEval]{Evaluate an expression in the abstract domain} -%* * -%************************************************************************ - -\begin{code} --- The isBottomingId stuf is now dealt with via the Id's strictness info --- absId anal var env | isBottomingId var --- = case anal of --- StrAnal -> AbsBot -- See discussion below --- AbsAnal -> AbsTop -- Just want to see if there's any poison in - -- error's arg - -absId anal var env - = case (lookupAbsValEnv env var, - isDataConWorkId_maybe var, - idStrictness var, - maybeUnfoldingTemplate (idUnfolding var)) of - - (Just abs_val, _, _, _) -> - abs_val -- Bound in the environment - - (_, Just data_con, _, _) | isProductTyCon tycon && - not (isRecursiveTyCon tycon) - -> -- A product. We get infinite loops if we don't - -- check for recursive products! - -- The strictness info on the constructor - -- isn't expressive enough to contain its abstract value - productAbsVal (dataConRepArgTys data_con) [] - where - tycon = dataConTyCon data_con - - (_, _, NoStrictnessInfo, Just unfolding) -> - -- We have an unfolding for the expr - -- Assume the unfolding has no free variables since it - -- came from inside the Id - absEval anal unfolding env - -- Notice here that we only look in the unfolding if we don't - -- have strictness info (an unusual situation). - -- We could have chosen to look in the unfolding if it exists, - -- and only try the strictness info if it doesn't, and that would - -- give more accurate results, at the cost of re-abstract-interpreting - -- the unfolding every time. - -- We found only one place where the look-at-unfolding-first - -- method gave better results, which is in the definition of - -- showInt in the Prelude. In its defintion, fromIntegral is - -- not inlined (it's big) but ab-interp-ing its unfolding gave - -- a better result than looking at its strictness only. - -- showInt :: Integral a => a -> [Char] -> [Char] - -- ! {-# GHC_PRAGMA _A_ 1 _U_ 122 _S_ - -- "U(U(U(U(SA)AAAAAAAAL)AA)AAAAASAAASA)" {...} _N_ _N_ #-} - -- --- 42,44 ---- - -- showInt :: Integral a => a -> [Char] -> [Char] - -- ! {-# GHC_PRAGMA _A_ 1 _U_ 122 _S_ - -- "U(U(U(U(SL)LLLLLLLLL)LL)LLLLLSLLLLL)" _N_ _N_ #-} - - - (_, _, strictness_info, _) -> - -- Includes NoUnfolding - -- Try the strictness info - absValFromStrictness anal strictness_info - -productAbsVal [] rev_abs_args = AbsProd (reverse rev_abs_args) -productAbsVal (arg_ty : arg_tys) rev_abs_args = AbsFun arg_ty (\ abs_arg -> productAbsVal arg_tys (abs_arg : rev_abs_args)) -\end{code} - -\begin{code} -absEval :: AnalysisKind -> CoreExpr -> AbsValEnv -> AbsVal - -absEval anal (Type ty) env = AbsTop -absEval anal (Var var) env = absId anal var env -\end{code} - -Discussion about error (following/quoting Lennart): Any expression -'error e' is regarded as bottom (with HBC, with the -ffail-strict -flag, on with -O). - -Regarding it as bottom gives much better strictness properties for -some functions. E.g. - - f [x] y = x+y - f (x:xs) y = f xs (x+y) -i.e. - f [] _ = error "no match" - f [x] y = x+y - f (x:xs) y = f xs (x+y) - -is strict in y, which you really want. But, it may lead to -transformations that turn a call to \tr{error} into non-termination. -(The odds of this happening aren't good.) - -Things are a little different for absence analysis, because we want -to make sure that any poison (?????) - -\begin{code} -absEval anal (Lit _) env = AbsTop - -- Literals terminate (strictness) and are not poison (absence) -\end{code} - -\begin{code} -absEval anal (Lam bndr body) env - | isTyVar bndr = absEval anal body env -- Type lambda - | otherwise = AbsFun (idType bndr) abs_fn -- Value lambda - where - abs_fn arg = absEval anal body (addOneToAbsValEnv env bndr arg) - -absEval anal (App expr (Type ty)) env - = absEval anal expr env -- Type appplication -absEval anal (App f val_arg) env - = absApply anal (absEval anal f env) -- Value applicationn - (absEval anal val_arg env) -\end{code} - -\begin{code} -absEval anal expr@(Case scrut case_bndr alts) env - = let - scrut_val = absEval anal scrut env - alts_env = addOneToAbsValEnv env case_bndr scrut_val - in - case (scrut_val, alts) of - (AbsBot, _) -> AbsBot - - (AbsProd arg_vals, [(con, bndrs, rhs)]) - | con /= DEFAULT -> - -- The scrutinee is a product value, so it must be of a single-constr - -- type; so the constructor in this alternative must be the right one - -- so we can go ahead and bind the constructor args to the components - -- of the product value. - ASSERT(equalLength arg_vals val_bndrs) - absEval anal rhs rhs_env - where - val_bndrs = filter isId bndrs - rhs_env = growAbsValEnvList alts_env (val_bndrs `zip` arg_vals) - - other -> absEvalAlts anal alts alts_env -\end{code} - -For @Lets@ we widen the value we get. This is nothing to -do with fixpointing. The reason is so that we don't get an explosion -in the amount of computation. For example, consider: -\begin{verbatim} - let - g a = case a of - q1 -> ... - q2 -> ... - f x = case x of - p1 -> ...g r... - p2 -> ...g s... - in - f e -\end{verbatim} -If we bind @f@ and @g@ to their exact abstract value, then we'll -``execute'' one call to @f@ and {\em two} calls to @g@. This can blow -up exponentially. Widening cuts it off by making a fixed -approximation to @f@ and @g@, so that the bodies of @f@ and @g@ are -not evaluated again at all when they are called. - -Of course, this can lose useful joint strictness, which is sad. An -alternative approach would be to try with a certain amount of ``fuel'' -and be prepared to bale out. - -\begin{code} -absEval anal (Let (NonRec binder e1) e2) env - = let - new_env = addOneToAbsValEnv env binder (widen anal (absEval anal e1 env)) - in - -- The binder of a NonRec should *not* be of unboxed type, - -- hence no need to strictly evaluate the Rhs. - absEval anal e2 new_env - -absEval anal (Let (Rec pairs) body) env - = let - (binders,rhss) = unzip pairs - rhs_vals = cheapFixpoint anal binders rhss env -- Returns widened values - new_env = growAbsValEnvList env (binders `zip` rhs_vals) - in - absEval anal body new_env - -absEval anal (Note (Coerce _ _) expr) env = AbsTop - -- Don't look inside coerces, becuase they - -- are usually recursive newtypes - -- (Could improve, for the error case, but we're about - -- to kill this analyser anyway.) -absEval anal (Note note expr) env = absEval anal expr env -\end{code} - -\begin{code} -absEvalAlts :: AnalysisKind -> [CoreAlt] -> AbsValEnv -> AbsVal -absEvalAlts anal alts env - = combine anal (map go alts) - where - combine StrAnal = foldr1 lub -- Diverge only if all diverge - combine AbsAnal = foldr1 glb -- Find any poison - - go (con, bndrs, rhs) - = absEval anal rhs rhs_env - where - rhs_env = growAbsValEnvList env (filter isId bndrs `zip` repeat AbsTop) -\end{code} - -%************************************************************************ -%* * -\subsection[absApply]{Apply an abstract function to an abstract argument} -%* * -%************************************************************************ - -Easy ones first: - -\begin{code} -absApply :: AnalysisKind -> AbsVal -> AbsVal -> AbsVal - -absApply anal AbsBot arg = AbsBot - -- AbsBot represents the abstract bottom *function* too - -absApply StrAnal AbsTop arg = AbsTop -absApply AbsAnal AbsTop arg = if anyBot arg - then AbsBot - else AbsTop - -- To be conservative, we have to assume that a function about - -- which we know nothing (AbsTop) might look at some part of - -- its argument -\end{code} - -An @AbsFun@ with only one more argument needed---bind it and eval the -result. A @Lam@ with two or more args: return another @AbsFun@ with -an augmented environment. - -\begin{code} -absApply anal (AbsFun bndr_ty abs_fn) arg = abs_fn arg -\end{code} - -\begin{code} -absApply StrAnal (AbsApproxFun (d:ds) val) arg - = case ds of - [] -> val' - other -> AbsApproxFun ds val' -- Result is non-bot if there are still args - where - val' | evalStrictness d arg = AbsBot - | otherwise = val - -absApply AbsAnal (AbsApproxFun (d:ds) val) arg - = if evalAbsence d arg - then AbsBot -- Poison in arg means poison in the application - else case ds of - [] -> val - other -> AbsApproxFun ds val - -#ifdef DEBUG -absApply anal f@(AbsProd _) arg - = pprPanic ("absApply: Duff function: AbsProd." ++ show anal) ((ppr f) <+> (ppr arg)) -#endif -\end{code} - - - - -%************************************************************************ -%* * -\subsection[findStrictness]{Determine some binders' strictness} -%* * -%************************************************************************ - -\begin{code} -findStrictness :: Id - -> AbsVal -- Abstract strictness value of function - -> AbsVal -- Abstract absence value of function - -> StrictnessInfo -- Resulting strictness annotation - -findStrictness id (AbsApproxFun str_ds str_res) (AbsApproxFun abs_ds _) - -- You might think there's really no point in describing detailed - -- strictness for a divergent function; - -- If it's fully applied we get bottom regardless of the - -- argument. If it's not fully applied we don't get bottom. - -- Finally, we don't want to regard the args of a divergent function - -- as 'interesting' for inlining purposes (see Simplify.prepareArgs) - -- - -- HOWEVER, if we make diverging functions appear lazy, they - -- don't get wrappers, and then we get dreadful reboxing. - -- See notes with WwLib.worthSplitting - = find_strictness id str_ds str_res abs_ds - -findStrictness id str_val abs_val - | isBot str_val = mkStrictnessInfo ([], True) - | otherwise = NoStrictnessInfo - --- The list of absence demands passed to combineDemands --- can be shorter than the list of absence demands --- --- lookup = \ dEq -> letrec { --- lookup = \ key ds -> ...lookup... --- } --- in lookup --- Here the strictness value takes three args, but the absence value --- takes only one, for reasons I don't quite understand (see cheapFixpoint) - -find_strictness id orig_str_ds orig_str_res orig_abs_ds - = mkStrictnessInfo (go orig_str_ds orig_abs_ds, res_bot) - where - res_bot = isBot orig_str_res - - go str_ds abs_ds = zipWith mk_dmd str_ds (abs_ds ++ repeat wwLazy) - - mk_dmd str_dmd (WwLazy True) - = WARN( not (res_bot || isLazy str_dmd), - ppr id <+> ppr orig_str_ds <+> ppr orig_abs_ds ) - -- If the arg isn't used we jolly well don't expect the function - -- to be strict in it. Unless the function diverges. - WwLazy True -- Best of all - - mk_dmd (WwUnpack u str_ds) - (WwUnpack _ abs_ds) = WwUnpack u (go str_ds abs_ds) - - mk_dmd str_dmd abs_dmd = str_dmd -\end{code} - - -\begin{code} -findDemand dmd str_env abs_env expr binder - = findRecDemand str_fn abs_fn (idType binder) - where - str_fn val = evalStrictness dmd (absEval StrAnal expr (addOneToAbsValEnv str_env binder val)) - abs_fn val = not (evalAbsence dmd (absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val))) - -findDemandAlts dmd str_env abs_env alts binder - = findRecDemand str_fn abs_fn (idType binder) - where - str_fn val = evalStrictness dmd (absEvalAlts StrAnal alts (addOneToAbsValEnv str_env binder val)) - abs_fn val = not (evalAbsence dmd (absEvalAlts AbsAnal alts (addOneToAbsValEnv abs_env binder val))) -\end{code} - -@findRecDemand@ is where we finally convert strictness/absence info -into ``Demands'' which we can pin on Ids (etc.). - -NOTE: What do we do if something is {\em both} strict and absent? -Should \tr{f x y z = error "foo"} says that \tr{f}'s arguments are all -strict (because of bottoming effect of \tr{error}) or all absent -(because they're not used)? - -Well, for practical reasons, we prefer absence over strictness. In -particular, it makes the ``default defaults'' for class methods (the -ones that say \tr{defm.foo dict = error "I don't exist"}) come out -nicely [saying ``the dict isn't used''], rather than saying it is -strict in every component of the dictionary [massive gratuitious -casing to take the dict apart]. - -But you could have examples where going for strictness would be better -than absence. Consider: -\begin{verbatim} - let x = something big - in - f x y z + g x -\end{verbatim} - -If \tr{x} is marked absent in \tr{f}, but not strict, and \tr{g} is -lazy, then the thunk for \tr{x} will be built. If \tr{f} was strict, -then we'd let-to-case it: -\begin{verbatim} - case something big of - x -> f x y z + g x -\end{verbatim} -Ho hum. - -\begin{code} -findRecDemand :: (AbsVal -> Bool) -- True => function applied to this value yields Bot - -> (AbsVal -> Bool) -- True => function applied to this value yields no poison - -> Type -- The type of the argument - -> Demand - -findRecDemand str_fn abs_fn ty - = if isUnLiftedType ty then -- It's a primitive type! - wwPrim - - else if abs_fn AbsBot then -- It's absent - -- We prefer absence over strictness: see NOTE above. - WwLazy True - - else if not (opt_AllStrict || - (opt_NumbersStrict && is_numeric_type ty) || - str_fn AbsBot) then - WwLazy False -- It's not strict and we're not pretending - - else -- It's strict (or we're pretending it is)! - - case splitProductType_maybe ty of - - Nothing -> wwStrict -- Could have a test for wwEnum, but - -- we don't exploit it yet, so don't bother - - Just (tycon,_,data_con,cmpnt_tys) -- Single constructor case - | isRecursiveTyCon tycon -- Recursive data type; don't unpack - -> wwStrict -- (this applies to newtypes too: - -- e.g. data Void = MkVoid Void) - - | null compt_strict_infos -- A nullary data type - -> wwStrict - - | otherwise -- Some other data type - -> wwUnpack compt_strict_infos - - where - prod_len = length cmpnt_tys - compt_strict_infos - = [ findRecDemand - (\ cmpnt_val -> - str_fn (mkMainlyTopProd prod_len i cmpnt_val) - ) - (\ cmpnt_val -> - abs_fn (mkMainlyTopProd prod_len i cmpnt_val) - ) - cmpnt_ty - | (cmpnt_ty, i) <- cmpnt_tys `zip` [1..] ] - - where - is_numeric_type ty - = case (splitTyConApp_maybe ty) of -- NB: duplicates stuff done above - Nothing -> False - Just (tycon, _) -> tyConUnique tycon `is_elem` numericTyKeys - where - is_elem = isIn "is_numeric_type" - - -- mkMainlyTopProd: make an AbsProd that is all AbsTops ("n"-1 of - -- them) except for a given value in the "i"th position. - - mkMainlyTopProd :: Int -> Int -> AbsVal -> AbsVal - - mkMainlyTopProd n i val - = let - befores = nOfThem (i-1) AbsTop - afters = nOfThem (n-i) AbsTop - in - AbsProd (befores ++ (val : afters)) -\end{code} - -%************************************************************************ -%* * -\subsection[fixpoint]{Fixpointer for the strictness analyser} -%* * -%************************************************************************ - -The @fixpoint@ functions take a list of \tr{(binder, expr)} pairs, an -environment, and returns the abstract value of each binder. - -The @cheapFixpoint@ function makes a conservative approximation, -by binding each of the variables to Top in their own right hand sides. -That allows us to make rapid progress, at the cost of a less-than-wonderful -approximation. - -\begin{code} -cheapFixpoint :: AnalysisKind -> [Id] -> [CoreExpr] -> AbsValEnv -> [AbsVal] - -cheapFixpoint AbsAnal [id] [rhs] env - = [crudeAbsWiden (absEval AbsAnal rhs new_env)] - where - new_env = addOneToAbsValEnv env id AbsTop -- Unsafe starting point! - -- In the just-one-binding case, we guarantee to - -- find a fixed point in just one iteration, - -- because we are using only a two-point domain. - -- This improves matters in cases like: - -- - -- f x y = letrec g = ...g... - -- in g x - -- - -- Here, y isn't used at all, but if g is bound to - -- AbsBot we simply get AbsBot as the next - -- iteration too. - -cheapFixpoint anal ids rhss env - = [widen anal (absEval anal rhs new_env) | rhs <- rhss] - -- We do just one iteration, starting from a safe - -- approximation. This won't do a good job in situations - -- like: - -- \x -> letrec f = ...g... - -- g = ...f...x... - -- in - -- ...f... - -- Here, f will end up bound to Top after one iteration, - -- and hence we won't spot the strictness in x. - -- (A second iteration would solve this. ToDo: try the effect of - -- really searching for a fixed point.) - where - new_env = growAbsValEnvList env [(id,safe_val) | id <- ids] - - safe_val - = case anal of -- The safe starting point - StrAnal -> AbsTop - AbsAnal -> AbsBot -\end{code} - -\begin{code} -fixpoint :: AnalysisKind -> [Id] -> [CoreExpr] -> AbsValEnv -> [AbsVal] - -fixpoint anal [] _ env = [] - -fixpoint anal ids rhss env - = fix_loop initial_vals - where - initial_val id - = case anal of -- The (unsafe) starting point - AbsAnal -> AbsTop - StrAnal -> AbsBot - -- At one stage for StrAnal we said: - -- if (returnsRealWorld (idType id)) - -- then AbsTop -- this is a massively horrible hack (SLPJ 95/05) - -- but no one has the foggiest idea what this hack did, - -- and returnsRealWorld was a stub that always returned False - -- So this comment is all that is left of the hack! - - initial_vals = [ initial_val id | id <- ids ] - - fix_loop :: [AbsVal] -> [AbsVal] - - fix_loop current_widened_vals - = let - new_env = growAbsValEnvList env (ids `zip` current_widened_vals) - new_vals = [ absEval anal rhs new_env | rhs <- rhss ] - new_widened_vals = map (widen anal) new_vals - in - if (and (zipWith sameVal current_widened_vals new_widened_vals)) then - current_widened_vals - - -- NB: I was too chicken to make that a zipWithEqual, - -- lest I jump into a black hole. WDP 96/02 - - -- Return the widened values. We might get a slightly - -- better value by returning new_vals (which we used to - -- do, see below), but alas that means that whenever the - -- function is called we have to re-execute it, which is - -- expensive. - - -- OLD VERSION - -- new_vals - -- Return the un-widened values which may be a bit better - -- than the widened ones, and are guaranteed safe, since - -- they are one iteration beyond current_widened_vals, - -- which itself is a fixed point. - else - fix_loop new_widened_vals -\end{code} - -For absence analysis, we make do with a very very simple approach: -look for convergence in a two-point domain. - -We used to use just one iteration, starting with the variables bound -to @AbsBot@, which is safe. - -Prior to that, we used one iteration starting from @AbsTop@ (which -isn't safe). Why isn't @AbsTop@ safe? Consider: -\begin{verbatim} - letrec - x = ...p..d... - d = (x,y) - in - ... -\end{verbatim} -Here, if p is @AbsBot@, then we'd better {\em not} end up with a ``fixed -point'' of @d@ being @(AbsTop, AbsTop)@! An @AbsBot@ initial value is -safe because it gives poison more often than really necessary, and -thus may miss some absence, but will never claim absence when it ain't -so. - -Anyway, one iteration starting with everything bound to @AbsBot@ give -bad results for - - f = \ x -> ...f... - -Here, f would always end up bound to @AbsBot@, which ain't very -clever, because then it would introduce poison whenever it was -applied. Much better to start with f bound to @AbsTop@, and widen it -to @AbsBot@ if any poison shows up. In effect we look for convergence -in the two-point @AbsTop@/@AbsBot@ domain. - -What we miss (compared with the cleverer strictness analysis) is -spotting that in this case - - f = \ x y -> ...y...(f x y')... - -\tr{x} is actually absent, since it is only passed round the loop, never -used. But who cares about missing that? - -NB: despite only having a two-point domain, we may still have many -iterations, because there are several variables involved at once. - -\begin{code} -#endif /* OLD_STRICTNESS */ -\end{code} diff -ruN ghc-6.12.1/compiler/stranal/SaLib.lhs ghc-6.13.20091231/compiler/stranal/SaLib.lhs --- ghc-6.12.1/compiler/stranal/SaLib.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/stranal/SaLib.lhs 1969-12-31 16:00:00.000000000 -0800 @@ -1,137 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 -% -\section[SaLib]{Basic datatypes, functions for the strictness analyser} - -See also: the ``library'' for the ``back end'' (@SaBackLib@). - -\begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - -#ifndef OLD_STRICTNESS -module SaLib () where -#else - -module SaLib ( - AbsVal(..), - AnalysisKind(..), - AbsValEnv{-abstract-}, StrictEnv, AbsenceEnv, - mkAbsApproxFun, - nullAbsValEnv, addOneToAbsValEnv, growAbsValEnvList, - lookupAbsValEnv, - absValFromStrictness - ) where - -#include "HsVersions.h" - -import Type ( Type ) -import VarEnv -import IdInfo ( StrictnessInfo(..) ) -import Demand ( Demand ) -import Outputable -\end{code} - -%************************************************************************ -%* * -\subsection[AbsVal-datatype]{@AbsVal@: abstract values (and @AbsValEnv@)} -%* * -%************************************************************************ - -@AnalysisKind@ tells what kind of analysis is being done. - -\begin{code} -data AnalysisKind - = StrAnal -- We're doing strictness analysis - | AbsAnal -- We're doing absence analysis - deriving Show -\end{code} - -@AbsVal@ is the data type of HNF abstract values. - -\begin{code} -data AbsVal - = AbsTop -- AbsTop is the completely uninformative - -- value - - | AbsBot -- An expression whose abstract value is - -- AbsBot is sure to fail to terminate. - -- AbsBot represents the abstract - -- *function* bottom too. - - | AbsProd [AbsVal] -- (Lifted) product of abstract values - -- "Lifted" means that AbsBot is *different* from - -- AbsProd [AbsBot, ..., AbsBot] - - | AbsFun -- An abstract function, with the given: - Type -- Type of the *argument* to the function - (AbsVal -> AbsVal) -- The function - - | AbsApproxFun -- This is used to represent a coarse - [Demand] -- approximation to a function value. It's an - AbsVal -- abstract function which is strict in its - -- arguments if the Demand so indicates. - -- INVARIANT: the [Demand] is non-empty - - -- AbsApproxFun has to take a *list* of demands, no just one, - -- because function spaces are now lifted. Hence, (f bot top) - -- might be bot, but the partial application (f bot) is a *function*, - -- not bot. - -mkAbsApproxFun :: Demand -> AbsVal -> AbsVal -mkAbsApproxFun d (AbsApproxFun ds val) = AbsApproxFun (d:ds) val -mkAbsApproxFun d val = AbsApproxFun [d] val - -instance Outputable AbsVal where - ppr AbsTop = ptext (sLit "AbsTop") - ppr AbsBot = ptext (sLit "AbsBot") - ppr (AbsProd prod) = hsep [ptext (sLit "AbsProd"), ppr prod] - ppr (AbsFun bndr_ty body) = ptext (sLit "AbsFun") - ppr (AbsApproxFun demands val) - = ptext (sLit "AbsApprox") <+> brackets (interpp'SP demands) <+> ppr val -\end{code} - -%----------- - -An @AbsValEnv@ maps @Ids@ to @AbsVals@. Any unbound @Ids@ are -implicitly bound to @AbsTop@, the completely uninformative, -pessimistic value---see @absEval@ of a @Var@. - -\begin{code} -newtype AbsValEnv = AbsValEnv (IdEnv AbsVal) - -type StrictEnv = AbsValEnv -- Environment for strictness analysis -type AbsenceEnv = AbsValEnv -- Environment for absence analysis - -nullAbsValEnv -- this is the one and only way to create AbsValEnvs - = AbsValEnv emptyVarEnv - -addOneToAbsValEnv (AbsValEnv idenv) y z = AbsValEnv (extendVarEnv idenv y z) -growAbsValEnvList (AbsValEnv idenv) ys = AbsValEnv (extendVarEnvList idenv ys) - -lookupAbsValEnv (AbsValEnv idenv) y - = lookupVarEnv idenv y -\end{code} - -\begin{code} -absValFromStrictness :: AnalysisKind -> StrictnessInfo -> AbsVal - -absValFromStrictness anal NoStrictnessInfo = AbsTop -absValFromStrictness anal (StrictnessInfo args_info bot_result) - = case args_info of -- Check the invariant that the arg list on - [] -> res -- AbsApproxFun is non-empty - _ -> AbsApproxFun args_info res - where - res | not bot_result = AbsTop - | otherwise = case anal of - StrAnal -> AbsBot - AbsAnal -> AbsTop -\end{code} - -\begin{code} -#endif /* OLD_STRICTNESS */ -\end{code} diff -ruN ghc-6.12.1/compiler/stranal/StrictAnal.lhs ghc-6.13.20091231/compiler/stranal/StrictAnal.lhs --- ghc-6.12.1/compiler/stranal/StrictAnal.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/stranal/StrictAnal.lhs 1969-12-31 16:00:00.000000000 -0800 @@ -1,465 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 -% -\section[StrictAnal]{``Simple'' Mycroft-style strictness analyser} - -The original version(s) of all strictness-analyser code (except the -Semantique analyser) was written by Andy Gill. - -\begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - -#ifndef OLD_STRICTNESS -module StrictAnal ( ) where - -#else - -module StrictAnal ( saBinds ) where - -#include "HsVersions.h" - -import DynFlags ( DynFlags, DynFlag(..) ) -import CoreSyn -import Id ( setIdStrictness, setInlinePragma, - idDemandInfo, setIdDemandInfo, isBottomingId, - Id - ) -import CoreLint ( showPass, endPass ) -import ErrUtils ( dumpIfSet_dyn ) -import SaAbsInt -import SaLib -import Demand ( Demand, wwStrict, isStrict, isLazy ) -import Util ( zipWith3Equal, stretchZipWith, compareLength ) -import BasicTypes ( Activation( NeverActive ) ) -import Outputable -import FastTypes -import State -\end{code} - -%************************************************************************ -%* * -\subsection[Thoughts]{Random thoughts} -%* * -%************************************************************************ - -A note about worker-wrappering. If we have - - f :: Int -> Int - f = let v = - in \x -> - -and we deduce that f is strict, it is nevertheless NOT safe to worker-wapper to - - f = \x -> case x of Int x# -> fw x# - fw = \x# -> let x = Int x# - in - let v = - in - -because this obviously loses laziness, since now -is done each time. Alas. - -WATCH OUT! This can mean that something is unboxed only to be -boxed again. For example - - g x y = f x - -Here g is strict, and *will* split into worker-wrapper. A call to -g, with the wrapper inlined will then be - - case arg of Int a# -> gw a# - -Now g calls f, which has no wrapper, so it has to box it. - - gw = \a# -> f (Int a#) - -Alas and alack. - - -%************************************************************************ -%* * -\subsection[iface-StrictAnal]{Interface to the outside world} -%* * -%************************************************************************ - -@saBinds@ decorates bindings with strictness info. A later -worker-wrapper pass can use this info to create wrappers and -strict workers. - -\begin{code} -saBinds :: DynFlags -> [CoreBind] -> IO [CoreBind] -saBinds dflags binds - = do { - -- Mark each binder with its strictness -#ifndef OMIT_STRANAL_STATS - let { (binds_w_strictness, sa_stats) = runState $ (saTopBinds binds) nullSaStats }; - dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "Strictness analysis statistics" - (pp_stats sa_stats); -#else - let { binds_w_strictness = unSaM $ saTopBindsBinds binds }; -#endif - - return binds_w_strictness - } -\end{code} - -%************************************************************************ -%* * -\subsection[saBinds]{Strictness analysis of bindings} -%* * -%************************************************************************ - -[Some of the documentation about types, etc., in \tr{SaLib} may be -helpful for understanding this module.] - -@saTopBinds@ tags each binder in the program with its @Demand@. -That tells how each binder is {\em used}; if @Strict@, then the binder -is sure to be evaluated to HNF; if @NonStrict@ it may or may not be; -if @Absent@, then it certainly is not used. [DATED; ToDo: update] - -(The above info is actually recorded for posterity in each binder's -IdInfo, notably its @DemandInfo@.) - -We proceed by analysing the bindings top-to-bottom, building up an -environment which maps @Id@s to their abstract values (i.e., an -@AbsValEnv@ maps an @Id@ to its @AbsVal@). - -\begin{code} -saTopBinds :: [CoreBind] -> SaM [CoreBind] -- not exported - -saTopBinds binds - = let - starting_abs_env = nullAbsValEnv - in - do_it starting_abs_env starting_abs_env binds - where - do_it _ _ [] = return [] - do_it senv aenv (b:bs) = do - (senv2, aenv2, new_b) <- saTopBind senv aenv b - new_bs <- do_it senv2 aenv2 bs - return (new_b : new_bs) -\end{code} - -@saTopBind@ is only used for the top level. We don't add any demand -info to these ids because we can't work it out. In any case, it -doesn't do us any good to know whether top-level binders are sure to -be used; we can't turn top-level @let@s into @case@s. - -\begin{code} -saTopBind :: StrictEnv -> AbsenceEnv - -> CoreBind - -> SaM (StrictEnv, AbsenceEnv, CoreBind) - -saTopBind str_env abs_env (NonRec binder rhs) = do - new_rhs <- saExpr minDemand str_env abs_env rhs - let - str_rhs = absEval StrAnal rhs str_env - abs_rhs = absEval AbsAnal rhs abs_env - - widened_str_rhs = widen StrAnal str_rhs - widened_abs_rhs = widen AbsAnal abs_rhs - -- The widening above is done for efficiency reasons. - -- See notes on Let case in SaAbsInt.lhs - - new_binder - = addStrictnessInfoToTopId - widened_str_rhs widened_abs_rhs - binder - - -- Augment environments with a mapping of the - -- binder to its abstract values, computed by absEval - new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs - new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs - - return (new_str_env, new_abs_env, NonRec new_binder new_rhs) - -saTopBind str_env abs_env (Rec pairs) - = let - (binders,rhss) = unzip pairs - str_rhss = fixpoint StrAnal binders rhss str_env - abs_rhss = fixpoint AbsAnal binders rhss abs_env - -- fixpoint returns widened values - new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss) - new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss) - new_binders = zipWith3Equal "saTopBind" addStrictnessInfoToTopId - str_rhss abs_rhss binders - - new_rhss <- mapM (saExpr minDemand new_str_env new_abs_env) rhss - let - new_pairs = new_binders `zip` new_rhss - - return (new_str_env, new_abs_env, Rec new_pairs) - --- Hack alert! --- Top level divergent bindings are marked NOINLINE --- This avoids fruitless inlining of top level error functions -addStrictnessInfoToTopId str_val abs_val bndr - = if isBottomingId new_id then - new_id `setInlinePragma` NeverActive - else - new_id - where - new_id = addStrictnessInfoToId str_val abs_val bndr -\end{code} - -%************************************************************************ -%* * -\subsection[saExpr]{Strictness analysis of an expression} -%* * -%************************************************************************ - -@saExpr@ computes the strictness of an expression within a given -environment. - -\begin{code} -saExpr :: Demand -> StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr - -- The demand is the least demand we expect on the - -- expression. WwStrict is the least, because we're only - -- interested in the expression at all if it's being evaluated, - -- but the demand may be more. E.g. - -- f E - -- where f has strictness u(LL), will evaluate E with demand u(LL) - -minDemand = wwStrict -minDemands = repeat minDemand - --- When we find an application, do the arguments --- with demands gotten from the function -saApp str_env abs_env (fun, args) = do - args' <- sequence sa_args - fun' <- saExpr minDemand str_env abs_env fun - return (mkApps fun' args') - where - arg_dmds = case fun of - Var var -> case lookupAbsValEnv str_env var of - Just (AbsApproxFun ds _) - | compareLength ds args /= LT - -- 'ds' is at least as long as 'args'. - -> ds ++ minDemands - other -> minDemands - other -> minDemands - - sa_args = stretchZipWith isTypeArg (error "saApp:dmd") - sa_arg args arg_dmds - -- The arg_dmds are for value args only, we need to skip - -- over the type args when pairing up with the demands - -- Hence the stretchZipWith - - sa_arg arg dmd = saExpr dmd' str_env abs_env arg - where - -- Bring arg demand up to minDemand - dmd' | isLazy dmd = minDemand - | otherwise = dmd - -saExpr _ _ _ e@(Var _) = return e -saExpr _ _ _ e@(Lit _) = return e -saExpr _ _ _ e@(Type _) = return e - -saExpr dmd str_env abs_env (Lam bndr body) - = do -- Don't bother to set the demand-info on a lambda binder - -- We do that only for let(rec)-bound functions - new_body <- saExpr minDemand str_env abs_env body - return (Lam bndr new_body) - -saExpr dmd str_env abs_env e@(App fun arg) - = saApp str_env abs_env (collectArgs e) - -saExpr dmd str_env abs_env (Note note expr) = do - new_expr <- saExpr dmd str_env abs_env expr - return (Note note new_expr) - -saExpr dmd str_env abs_env (Case expr case_bndr alts) = do - new_expr <- saExpr minDemand str_env abs_env expr - new_alts <- mapM sa_alt alts - let - new_case_bndr = addDemandInfoToCaseBndr dmd str_env abs_env alts case_bndr - return (Case new_expr new_case_bndr new_alts) - where - sa_alt (con, binders, rhs) = do - new_rhs <- saExpr dmd str_env abs_env rhs - let - new_binders = map add_demand_info binders - add_demand_info bndr | isTyVar bndr = bndr - | otherwise = addDemandInfoToId dmd str_env abs_env rhs bndr - - tickCases new_binders -- stats - return (con, new_binders, new_rhs) - -saExpr dmd str_env abs_env (Let (NonRec binder rhs) body) = do - -- Analyse the RHS in the environment at hand - let - -- Find the demand on the RHS - rhs_dmd = findDemand dmd str_env abs_env body binder - - -- Bind this binder to the abstract value of the RHS; analyse - -- the body of the `let' in the extended environment. - str_rhs_val = absEval StrAnal rhs str_env - abs_rhs_val = absEval AbsAnal rhs abs_env - - widened_str_rhs = widen StrAnal str_rhs_val - widened_abs_rhs = widen AbsAnal abs_rhs_val - -- The widening above is done for efficiency reasons. - -- See notes on Let case in SaAbsInt.lhs - - new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs - new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs - - -- Now determine the strictness of this binder; use that info - -- to record DemandInfo/StrictnessInfo in the binder. - new_binder = addStrictnessInfoToId - widened_str_rhs widened_abs_rhs - (binder `setIdDemandInfo` rhs_dmd) - - tickLet new_binder -- stats - new_rhs <- saExpr rhs_dmd str_env abs_env rhs - new_body <- saExpr dmd new_str_env new_abs_env body - return (Let (NonRec new_binder new_rhs) new_body) - -saExpr dmd str_env abs_env (Let (Rec pairs) body) = do - let - (binders,rhss) = unzip pairs - str_vals = fixpoint StrAnal binders rhss str_env - abs_vals = fixpoint AbsAnal binders rhss abs_env - -- fixpoint returns widened values - new_str_env = growAbsValEnvList str_env (binders `zip` str_vals) - new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_vals) - - new_body <- saExpr dmd new_str_env new_abs_env body - new_rhss <- mapM (saExpr minDemand new_str_env new_abs_env) rhss - let --- DON'T add demand info in a Rec! --- a) it's useless: we can't do let-to-case --- b) it's incorrect. Consider --- letrec x = ...y... --- y = ...x... --- in ...x... --- When we ask whether y is demanded we'll bind y to bottom and --- evaluate the body of the letrec. But that will result in our --- deciding that y is absent, which is plain wrong! --- It's much easier simply not to do this. - - improved_binders = zipWith3Equal "saExpr" addStrictnessInfoToId - str_vals abs_vals binders - - new_pairs = improved_binders `zip` new_rhss - - return (Let (Rec new_pairs) new_body) -\end{code} - - -%************************************************************************ -%* * -\subsection[computeInfos]{Add computed info to binders} -%* * -%************************************************************************ - -Important note (Sept 93). @addStrictnessInfoToId@ is used only for -let(rec) bound variables, and is use to attach the strictness (not -demand) info to the binder. We are careful to restrict this -strictness info to the lambda-bound arguments which are actually -visible, at the top level, lest we accidentally lose laziness by -eagerly looking for an "extra" argument. So we "dig for lambdas" in a -rather syntactic way. - -A better idea might be to have some kind of arity analysis to -tell how many args could safely be grabbed. - -\begin{code} -addStrictnessInfoToId - :: AbsVal -- Abstract strictness value - -> AbsVal -- Ditto absence - -> Id -- The id - -> Id -- Augmented with strictness - -addStrictnessInfoToId str_val abs_val binder - = binder `setIdStrictness` findStrictness binder str_val abs_val -\end{code} - -\begin{code} -addDemandInfoToId :: Demand -> StrictEnv -> AbsenceEnv - -> CoreExpr -- The scope of the id - -> Id - -> Id -- Id augmented with Demand info - -addDemandInfoToId dmd str_env abs_env expr binder - = binder `setIdDemandInfo` (findDemand dmd str_env abs_env expr binder) - -addDemandInfoToCaseBndr dmd str_env abs_env alts binder - = binder `setIdDemandInfo` (findDemandAlts dmd str_env abs_env alts binder) -\end{code} - -%************************************************************************ -%* * -\subsection{Monad used herein for stats} -%* * -%************************************************************************ - -\begin{code} -data SaStats - = SaStats FastInt FastInt -- total/marked-demanded lambda-bound - FastInt FastInt -- total/marked-demanded case-bound - FastInt FastInt -- total/marked-demanded let-bound - -- (excl. top-level; excl. letrecs) - -nullSaStats = SaStats - (_ILIT(0)) (_ILIT(0)) - (_ILIT(0)) (_ILIT(0)) - (_ILIT(0)) (_ILIT(0)) - -tickLambda :: Id -> SaM () -tickCases :: [CoreBndr] -> SaM () -tickLet :: Id -> SaM () - -#ifndef OMIT_STRANAL_STATS -type SaM a = State SaStats a - -tickLambda var = modify $ \(SaStats tlam dlam tc dc tlet dlet) - -> case (tick_demanded var (0,0)) of { (totB, demandedB) -> - let tot = iUnbox totB ; demanded = iUnbox demandedB - in SaStats (tlam +# tot) (dlam +# demanded) tc dc tlet dlet) - -tickCases vars = modify $ \(SaStats tlam dlam tc dc tlet dlet) - = case (foldr tick_demanded (0,0) vars) of { (totB, demandedB) -> - let tot = iUnbox totB ; demanded = iUnbox demandedB - in SaStats tlam dlam (tc +# tot) (dc +# demanded) tlet dlet) - -tickLet var = modify $ \(SaStats tlam dlam tc dc tlet dlet) - = case (tick_demanded var (0,0)) of { (totB, demandedB) -> - let tot = iUnbox totB ; demanded = iUnbox demandedB - in SaStats tlam dlam tc dc (tlet +# tot) (dlet +# demanded)) - -tick_demanded var (tot, demanded) - | isTyVar var = (tot, demanded) - | otherwise - = (tot + 1, - if (isStrict (idDemandInfo var)) - then demanded + 1 - else demanded) - -pp_stats (SaStats tlam dlam tc dc tlet dlet) - = hcat [ptext (sLit "Lambda vars: "), int (iBox dlam), char '/', int (iBox tlam), - ptext (sLit "; Case vars: "), int (iBox dc), char '/', int (iBox tc), - ptext (sLit "; Let vars: "), int (iBox dlet), char '/', int (iBox tlet) - ] - -#else /* OMIT_STRANAL_STATS */ --- identity monad -newtype SaM a = SaM { unSaM :: a } - -instance Monad SaM where - return x = SaM x - SaM x >>= f = f x - -tickLambda var = panic "OMIT_STRANAL_STATS: tickLambda" -tickCases vars = panic "OMIT_STRANAL_STATS: tickCases" -tickLet var = panic "OMIT_STRANAL_STATS: tickLet" - -#endif /* OMIT_STRANAL_STATS */ - -#endif /* OLD_STRICTNESS */ -\end{code} diff -ruN ghc-6.12.1/compiler/stranal/WorkWrap.lhs ghc-6.13.20091231/compiler/stranal/WorkWrap.lhs --- ghc-6.12.1/compiler/stranal/WorkWrap.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/stranal/WorkWrap.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -7,19 +7,20 @@ module WorkWrap ( wwTopBinds, mkWrapper ) where import CoreSyn -import CoreUnfold ( certainlyWillInline ) -import CoreUtils ( exprType, exprIsHNF, mkInlineMe ) +import CoreUnfold ( certainlyWillInline, mkInlineRule, mkWwInlineRule ) +import CoreUtils ( exprType, exprIsHNF ) import CoreArity ( exprArity ) import Var import Id import Type ( Type ) import IdInfo -import NewDemand ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..), +import Demand ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..), Demands(..), mkTopDmdType, isBotRes, returnsCPR, topSig, isAbsent ) import UniqSupply import BasicTypes ( RecFlag(..), isNonRec, isNeverActive, - Activation, inlinePragmaActivation ) + Activation(..), InlinePragma(..), + inlinePragmaActivation, inlinePragmaRuleMatchInfo ) import VarEnv ( isEmptyVarEnv ) import Maybes ( orElse ) import WwLib @@ -102,11 +103,9 @@ \begin{code} wwExpr :: CoreExpr -> UniqSM CoreExpr -wwExpr e@(Type {}) = return e -wwExpr e@(Lit {}) = return e -wwExpr e@(Var {}) = return e -wwExpr e@(Note InlineMe _) = return e - -- Don't w/w inside InlineMe's +wwExpr e@(Type {}) = return e +wwExpr e@(Lit {}) = return e +wwExpr e@(Var {}) = return e wwExpr (Lam binder expr) = Lam binder <$> wwExpr expr @@ -144,30 +143,22 @@ front-end into the proper form, then calls @mkWwBodies@ to do the business. -We have to BE CAREFUL that we don't worker-wrapperize an Id that has -already been w-w'd! (You can end up with several liked-named Ids -bouncing around at the same time---absolute mischief.) So the -criterion we use is: if an Id already has an unfolding (for whatever -reason), then we don't w-w it. - The only reason this is monadised is for the unique supply. Note [Don't w/w inline things (a)] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's very important to refrain from w/w-ing an INLINE function -If we do so by mistake we transform - f = __inline (\x -> E) -into - f = __inline (\x -> case x of (a,b) -> fw E) - fw = \ab -> (__inline (\x -> E)) (a,b) -and the original __inline now vanishes, so E is no longer -inside its __inline wrapper. Death! Disaster! + +It's very important to refrain from w/w-ing an INLINE function (ie one +with an InlineRule) because the wrapper will then overwrite the +InlineRule unfolding. Furthermore, if the programmer has marked something as INLINE, we may lose by w/w'ing it. If the strictness analyser is run twice, this test also prevents -wrappers (which are INLINEd) from being re-done. +wrappers (which are INLINEd) from being re-done. (You can end up with +several liked-named Ids bouncing around at the same time---absolute +mischief.) Notice that we refrain from w/w'ing an INLINE function even if it is in a recursive group. It might not be the loop breaker. (We could @@ -175,11 +166,10 @@ Note [Don't w/w inline things (b)] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general, therefore, we refrain from w/w-ing *small* functions, -because they'll inline anyway. But we must take care: it may look -small now, but get to be big later after other inling has happened. -So we take the precaution of adding an INLINE pragma to any such -functions. +In general, we refrain from w/w-ing *small* functions, because they'll +inline anyway. But we must take care: it may look small now, but get +to be big later after other inling has happened. So we take the +precaution of adding an INLINE pragma to any such functions. I made this change when I observed a big function at the end of compilation with a useful strictness signature but no w-w. When @@ -187,6 +177,34 @@ percent improved allocation on one benchmark (bspt/Euclid.space). But nothing got worse. +Note [Wrapper activation] +~~~~~~~~~~~~~~~~~~~~~~~~~ +When should the wrapper inlining be active? It must not be active +earlier than the current Activation of the Id (eg it might have a +NOINLINE pragma). But in fact strictness analysis happens fairly +late in the pipeline, and we want to prioritise specialisations over +strictness. Eg if we have + module Foo where + f :: Num a => a -> Int -> a + f n 0 = n -- Strict in the Int, hence wrapper + f n x = f (n+n) (x-1) + + g :: Int -> Int + g x = f x x -- Provokes a specialisation for f + + module Bsr where + import Foo + + h :: Int -> Int + h x = f 3 x + +Then we want the specialisation for 'f' to kick in before the wrapper does. + +Now in fact the 'gentle' simplification pass encourages this, by +having rules on, but inlinings off. But that's kind of lucky. It seems +more robust to give the wrapper an Activation of (ActiveAfter 0), +so that it becomes active in an importing module at the same time that +it appears in the first place in the defining module. \begin{code} tryWW :: RecFlag @@ -214,19 +232,19 @@ | is_fun && worthSplittingFun wrap_dmds res_info = checkSize new_fn_id rhs $ - splitFun new_fn_id fn_info wrap_dmds res_info inline_act rhs + splitFun new_fn_id fn_info wrap_dmds res_info rhs | otherwise = return [ (new_fn_id, rhs) ] where fn_info = idInfo fn_id - maybe_fn_dmd = newDemandInfo fn_info + maybe_fn_dmd = demandInfo fn_info inline_act = inlinePragmaActivation (inlinePragInfo fn_info) -- In practice it always will have a strictness -- signature, even if it's a uninformative one - strict_sig = newStrictnessInfo fn_info `orElse` topSig + strict_sig = strictnessInfo fn_info `orElse` topSig StrictSig (DmdType env wrap_dmds res_info) = strict_sig -- new_fn_id has the DmdEnv zapped. @@ -235,26 +253,34 @@ -- (c) it becomes incorrect as things are cloned, because -- we don't push the substitution into it new_fn_id | isEmptyVarEnv env = fn_id - | otherwise = fn_id `setIdNewStrictness` + | otherwise = fn_id `setIdStrictness` StrictSig (mkTopDmdType wrap_dmds res_info) is_fun = notNull wrap_dmds is_thunk = not is_fun && not (exprIsHNF rhs) --------------------- -checkSize :: Id -> CoreExpr -> UniqSM [(Id,CoreExpr)] -> UniqSM [(Id,CoreExpr)] +checkSize :: Id -> CoreExpr + -> UniqSM [(Id,CoreExpr)] -> UniqSM [(Id,CoreExpr)] -- See Note [Don't w/w inline things (a) and (b)] checkSize fn_id rhs thing_inside - | certainlyWillInline unfolding = return [ (fn_id, mkInlineMe rhs) ] + | isStableUnfolding unfolding -- For DFuns and INLINE things, leave their + = return [ (fn_id, rhs) ] -- unfolding unchanged; but still attach + -- strictness info to the Id + + | certainlyWillInline unfolding + = return [ (fn_id `setIdUnfolding` inline_rule, rhs) ] -- Note [Don't w/w inline things (b)] + | otherwise = thing_inside where unfolding = idUnfolding fn_id + inline_rule = mkInlineRule unSaturatedOk rhs (unfoldingArity unfolding) --------------------- -splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> Activation -> Expr Var +splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> Expr Var -> UniqSM [(Id, CoreExpr)] -splitFun fn_id fn_info wrap_dmds res_info inline_act rhs +splitFun fn_id fn_info wrap_dmds res_info rhs = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) ) (do { -- The arity should match the signature @@ -263,32 +289,54 @@ ; let work_rhs = work_fn rhs work_id = mkWorkerId work_uniq fn_id (exprType work_rhs) - `setInlineActivation` inline_act + `setIdOccInfo` occInfo fn_info + -- Copy over occurrence info from parent + -- Notably whether it's a loop breaker + -- Doesn't matter much, since we will simplify next, but + -- seems right-er to do so + + `setInlineActivation` (inlinePragmaActivation inl_prag) -- Any inline activation (which sets when inlining is active) - -- on the original function is duplicated on the worker and wrapper + -- on the original function is duplicated on the worker -- It *matters* that the pragma stays on the wrapper -- It seems sensible to have it on the worker too, although we -- can't think of a compelling reason. (In ptic, INLINE things are -- not w/wd). However, the RuleMatchInfo is not transferred since -- it does not make sense for workers to be constructorlike. - `setIdNewStrictness` StrictSig (mkTopDmdType work_demands work_res_info) + + `setIdStrictness` StrictSig (mkTopDmdType work_demands work_res_info) -- Even though we may not be at top level, -- it's ok to give it an empty DmdEnv + `setIdArity` (exprArity work_rhs) -- Set the arity so that the Core Lint check that the -- arity is consistent with the demand type goes through - wrap_rhs = wrap_fn work_id - wrap_id = fn_id `setIdWorkerInfo` HasWorker work_id arity + wrap_rhs = wrap_fn work_id + wrap_prag = InlinePragma { inl_inline = True + , inl_act = ActiveAfter 0 + , inl_rule = rule_match_info } + + wrap_id = fn_id `setIdUnfolding` mkWwInlineRule work_id wrap_rhs arity + `setInlinePragma` wrap_prag + -- See Note [Wrapper activation] + -- The RuleMatchInfo is (and must be) unaffected + -- The inl_inline is bound to be False, else we would not be + -- making a wrapper + `setIdOccInfo` NoOccInfo + -- Zap any loop-breaker-ness, to avoid bleating from Lint + -- about a loop breaker with an INLINE rule ; return ([(work_id, work_rhs), (wrap_id, wrap_rhs)]) }) -- Worker first, because wrapper mentions it -- mkWwBodies has already built a wrap_rhs with an INLINE pragma wrapped around it where - fun_ty = idType fn_id - - arity = arityInfo fn_info -- The arity is set by the simplifier using exprEtaExpandArity - -- So it may be more than the number of top-level-visible lambdas + fun_ty = idType fn_id + inl_prag = inlinePragInfo fn_info + rule_match_info = inlinePragmaRuleMatchInfo inl_prag + arity = arityInfo fn_info + -- The arity is set by the simplifier using exprEtaExpandArity + -- So it may be more than the number of top-level-visible lambdas work_res_info | isBotRes res_info = BotRes -- Cpr stuff done by wrapper | otherwise = TopRes diff -ruN ghc-6.12.1/compiler/stranal/WwLib.lhs ghc-6.13.20091231/compiler/stranal/WwLib.lhs --- ghc-6.12.1/compiler/stranal/WwLib.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/stranal/WwLib.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -10,13 +10,13 @@ import CoreSyn import CoreUtils ( exprType ) -import Id ( Id, idType, mkSysLocal, idNewDemandInfo, setIdNewDemandInfo, +import Id ( Id, idType, mkSysLocal, idDemandInfo, setIdDemandInfo, isOneShotLambda, setOneShotLambda, setIdUnfolding, setIdInfo ) import IdInfo ( vanillaIdInfo ) import DataCon -import NewDemand ( Demand(..), DmdResult(..), Demands(..) ) +import Demand ( Demand(..), DmdResult(..), Demands(..) ) import MkId ( realWorldPrimId, voidArgId, mkRuntimeErrorApp, rUNTIME_ERROR_ID, mkUnpackCase, mkProductBox ) import TysWiredIn ( tupleCon ) @@ -133,8 +133,8 @@ return (id, id, res_ty) ; let (work_lam_args, work_call_args) = mkWorkerArgs work_args res_ty - ; return ([idNewDemandInfo v | v <- work_call_args, isId v], - Note InlineMe . wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var, + ; return ([idDemandInfo v | v <- work_call_args, isId v], + wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var, mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args) } -- We use an INLINE unconditionally, even if the wrapper turns out to be -- something trivial like @@ -278,9 +278,9 @@ applyToVars :: [Var] -> CoreExpr -> CoreExpr applyToVars vars fn = mkVarApps fn vars -mk_wrap_arg :: Unique -> Type -> NewDemand.Demand -> Bool -> Id +mk_wrap_arg :: Unique -> Type -> Demand -> Bool -> Id mk_wrap_arg uniq ty dmd one_shot - = set_one_shot one_shot (setIdNewDemandInfo (mkSysLocal (fsLit "w") uniq ty) dmd) + = set_one_shot one_shot (setIdDemandInfo (mkSysLocal (fsLit "w") uniq ty) dmd) where set_one_shot True id = setOneShotLambda id set_one_shot False id = id @@ -340,7 +340,7 @@ = return ([arg], nop_fn, nop_fn) | otherwise - = case idNewDemandInfo arg of + = case idDemandInfo arg of -- Absent case. We don't deal with absence for unlifted types, -- though, because it's not so easy to manufacture a placeholder @@ -392,7 +392,7 @@ -- If the wrapper argument is a one-shot lambda, then -- so should (all) the corresponding worker arguments be -- This bites when we do w/w on a case join point - set_worker_arg_info worker_arg demand = set_one_shot (setIdNewDemandInfo worker_arg demand) + set_worker_arg_info worker_arg demand = set_one_shot (setIdDemandInfo worker_arg demand) set_one_shot | isOneShotLambda arg = setOneShotLambda | otherwise = \x -> x diff -ruN ghc-6.12.1/compiler/typecheck/Inst.lhs ghc-6.13.20091231/compiler/typecheck/Inst.lhs --- ghc-6.12.1/compiler/typecheck/Inst.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/typecheck/Inst.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -246,7 +246,9 @@ -------------------------- instToDictBind :: Inst -> LHsExpr TcId -> TcDictBinds instToDictBind inst rhs - = unitBag (L (instSpan inst) (VarBind (instToId inst) rhs)) + = unitBag (L (instSpan inst) (VarBind { var_id = instToId inst + , var_rhs = rhs + , var_inline = False })) addInstToDictBind :: TcDictBinds -> Inst -> LHsExpr TcId -> TcDictBinds addInstToDictBind binds inst rhs = binds `unionBags` instToDictBind inst rhs diff -ruN ghc-6.12.1/compiler/typecheck/TcBinds.lhs ghc-6.13.20091231/compiler/typecheck/TcBinds.lhs --- ghc-6.12.1/compiler/typecheck/TcBinds.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/typecheck/TcBinds.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -45,6 +45,7 @@ import Outputable import FastString +import Data.List( partition ) import Control.Monad \end{code} @@ -350,7 +351,8 @@ -- BUILD THE POLYMORPHIC RESULT IDs ; let dict_vars = map instToVar dicts -- May include equality constraints - ; exports <- mapM (mkExport top_lvl prag_fn tyvars_to_gen (map varType dict_vars)) + ; exports <- mapM (mkExport top_lvl rec_group (length mono_bind_infos > 1) + prag_fn tyvars_to_gen (map varType dict_vars)) mono_bind_infos ; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports] @@ -365,9 +367,12 @@ -------------- -mkExport :: TopLevelFlag -> TcPragFun -> [TyVar] -> [TcType] +mkExport :: TopLevelFlag -> RecFlag + -> Bool -- More than one variable is bound, so we'll desugar to + -- a tuple, so INLINE pragmas won't work + -> TcPragFun -> [TyVar] -> [TcType] -> MonoBindInfo - -> TcM ([TyVar], Id, Id, [LPrag]) + -> TcM ([TyVar], Id, Id, [LSpecPrag]) -- mkExport generates exports with -- zonked type variables, -- zonked poly_ids @@ -379,16 +384,18 @@ -- Pre-condition: the inferred_tvs are already zonked -mkExport top_lvl prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id) +mkExport top_lvl rec_group multi_bind prag_fn inferred_tvs dict_tys + (poly_name, mb_sig, mono_id) = do { warn_missing_sigs <- doptM Opt_WarnMissingSigs ; let warn = isTopLevel top_lvl && warn_missing_sigs ; (tvs, poly_id) <- mk_poly_id warn mb_sig -- poly_id has a zonked type - ; prags <- tcPrags poly_id (prag_fn poly_name) + ; (poly_id', spec_prags) <- tcPrags rec_group multi_bind (notNull dict_tys) + poly_id (prag_fn poly_name) -- tcPrags requires a zonked poly_id - ; return (tvs, poly_id, mono_id, prags) } + ; return (tvs, poly_id', mono_id, spec_prags) } where poly_ty = mkForAllTys inferred_tvs (mkFunTys dict_tys (idType mono_id)) @@ -411,34 +418,89 @@ env = foldl add emptyNameEnv prs add env (n,p) = extendNameEnv_Acc (:) singleton env n p -tcPrags :: Id -> [LSig Name] -> TcM [LPrag] -tcPrags poly_id prags = mapM (wrapLocM tc_prag) prags - where - tc_prag prag = addErrCtxt (pragSigCtxt prag) $ - tcPrag poly_id prag - -pragSigCtxt :: Sig Name -> SDoc -pragSigCtxt prag = hang (ptext (sLit "In the pragma")) 2 (ppr prag) - -tcPrag :: TcId -> Sig Name -> TcM Prag +tcPrags :: RecFlag + -> Bool -- True <=> AbsBinds binds more than one variable + -> Bool -- True <=> function is overloaded + -> Id -> [LSig Name] + -> TcM (Id, [LSpecPrag]) +-- Add INLINE and SPECLIASE pragmas +-- INLINE prags are added to the Id directly +-- SPECIALISE prags are passed to the desugarer via [LSpecPrag] -- Pre-condition: the poly_id is zonked -- Reason: required by tcSubExp --- Most of the work of specialisation is done by --- the desugarer, guided by the SpecPrag -tcPrag poly_id (SpecSig _ hs_ty inl) - = do { let name = idName poly_id +tcPrags _rec_group _multi_bind _is_overloaded_id poly_id prag_sigs + = do { poly_id' <- tc_inl inl_sigs + + ; spec_prags <- mapM (wrapLocM (tcSpecPrag poly_id')) spec_sigs + +-- Commented out until bytestring library removes redundant pragmas +-- for packWith and unpackWith +-- ; unless (null spec_sigs || is_overloaded_id) warn_discarded_spec + + ; unless (null bad_sigs) warn_discarded_sigs + + ; return (poly_id', spec_prags) } + where + (inl_sigs, other_sigs) = partition isInlineLSig prag_sigs + (spec_sigs, bad_sigs) = partition isSpecLSig other_sigs + +-- warn_discarded_spec = warnPrags poly_id spec_sigs $ +-- ptext (sLit "SPECIALISE pragmas for non-overloaded function") + warn_dup_inline = warnPrags poly_id inl_sigs $ + ptext (sLit "Duplicate INLINE pragmas for") + warn_discarded_sigs = warnPrags poly_id bad_sigs $ + ptext (sLit "Discarding unexpected pragmas for") + + ----------- + tc_inl [] = return poly_id + tc_inl (L loc (InlineSig _ prag) : other_inls) + = do { unless (null other_inls) (setSrcSpan loc warn_dup_inline) + ; return (poly_id `setInlinePragma` prag) } + tc_inl _ = panic "tc_inl" + +{- Earlier we tried to warn about + (a) INLINE for recursive function + (b) INLINE for function that is part of a multi-binder group + Code fragments below. But we want to allow + {-# INLINE f #-} + f x = x : g y + g y = ....f...f.... + even though they are mutually recursive. + So I'm just omitting the warnings for now + + | multi_bind && isInlinePragma prag + = do { setSrcSpan loc $ addWarnTc multi_bind_warn + ; return poly_id } + | otherwise + ; when (isInlinePragma prag && isRec rec_group) + (setSrcSpan loc (addWarnTc rec_inline_warn)) + + rec_inline_warn = ptext (sLit "INLINE pragma for recursive binder") + <+> quotes (ppr poly_id) <+> ptext (sLit "may be discarded") + + multi_bind_warn = hang (ptext (sLit "Discarding INLINE pragma for") <+> quotes (ppr poly_id)) + 2 (ptext (sLit "because it is bound by a pattern, or mutual recursion") ) +-} + + +warnPrags :: Id -> [LSig Name] -> SDoc -> TcM () +warnPrags id bad_sigs herald + = addWarnTc (hang (herald <+> quotes (ppr id)) + 2 (ppr_sigs bad_sigs)) + where + ppr_sigs sigs = vcat (map (ppr . getLoc) sigs) + +-------------- +tcSpecPrag :: TcId -> Sig Name -> TcM SpecPrag +tcSpecPrag poly_id prag@(SpecSig _ hs_ty inl) + = addErrCtxt (spec_ctxt prag) $ + do { let name = idName poly_id ; spec_ty <- tcHsSigType (FunSigCtxt name) hs_ty ; co_fn <- tcSubExp (SpecPragOrigin name) (idType poly_id) spec_ty - ; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty inl) } -tcPrag poly_id (SpecInstSig hs_ty) - = do { let name = idName poly_id - ; (tyvars, theta, tau) <- tcHsInstHead hs_ty - ; let spec_ty = mkSigmaTy tyvars theta tau - ; co_fn <- tcSubExp (SpecPragOrigin name) (idType poly_id) spec_ty - ; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty defaultInlineSpec) } - -tcPrag _ (InlineSig _ inl) = return (InlinePrag inl) -tcPrag _ sig = pprPanic "tcPrag" (ppr sig) + ; return (SpecPrag co_fn inl) } + where + spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag) +tcSpecPrag _ sig = pprPanic "tcSpecPrag" (ppr sig) -------------- diff -ruN ghc-6.12.1/compiler/typecheck/TcClassDcl.lhs ghc-6.13.20091231/compiler/typecheck/TcClassDcl.lhs --- ghc-6.12.1/compiler/typecheck/TcClassDcl.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/typecheck/TcClassDcl.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -7,7 +7,7 @@ \begin{code} module TcClassDcl ( tcClassSigs, tcClassDecl2, - findMethodBind, tcInstanceMethodBody, + findMethodBind, instantiateMethod, tcInstanceMethodBody, mkGenericDefMethBind, getGenericInstances, mkDefMethRdrName, tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn ) where @@ -160,11 +160,11 @@ \begin{code} tcClassDecl2 :: LTyClDecl Name -- The class declaration - -> TcM (LHsBinds Id, [Id]) + -> TcM ([Id], LHsBinds Id) tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, tcdMeths = default_binds})) - = recoverM (return (emptyLHsBinds, [])) $ + = recoverM (return ([], emptyLHsBinds)) $ setSrcSpan loc $ do { clas <- tcLookupLocatedClass class_name @@ -186,7 +186,7 @@ ; inst_loc <- getInstLoc (SigOrigin rigid_info) ; this_dict <- newDictBndr inst_loc pred - ; let tc_dm = tcDefMeth rigid_info clas clas_tyvars [pred] + ; let tc_dm = tcDefMeth clas clas_tyvars this_dict default_binds sig_fn prag_fn -- tc_dm is called only for a sel_id @@ -200,39 +200,110 @@ -- the programmer supplied an explicit default decl for the class. -- (If necessary we can fix that, but we don't have a convenient Id to hand.) - ; (defm_binds, dm_ids) <- tcExtendTyVarEnv clas_tyvars $ + ; (dm_ids, defm_binds) <- tcExtendTyVarEnv clas_tyvars $ mapAndUnzipM tc_dm dm_sel_ids - ; return (unionManyBags defm_binds, dm_ids) } + ; return (dm_ids, listToBag defm_binds) } tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d) -tcDefMeth :: SkolemInfo -> Class -> [TyVar] -> ThetaType -> Inst -> LHsBinds Name +tcDefMeth :: Class -> [TyVar] -> Inst -> LHsBinds Name -> TcSigFun -> TcPragFun -> Id - -> TcM (LHsBinds Id, Id) -tcDefMeth rigid_info clas tyvars theta this_dict binds_in sig_fn prag_fn sel_id + -> TcM (Id, LHsBind Id) +tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn sel_id = do { let sel_name = idName sel_id - ; local_dm_name <- newLocalName sel_name + ; dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_name) + ; local_dm_name <- newLocalName sel_name + -- Base the local_dm_name on the selector name, becuase + -- type errors from tcInstanceMethodBody come from here + + -- See Note [Silly default-method bind] + -- (possibly out of date) + ; let meth_bind = findMethodBind sel_name local_dm_name binds_in `orElse` pprPanic "tcDefMeth" (ppr sel_id) -- We only call tcDefMeth on selectors for which -- there is a binding in binds_in - meth_sig_fn _ = sig_fn sel_name - meth_prag_fn _ = prag_fn sel_name + dm_sig_fn _ = sig_fn sel_name + dm_ty = idType sel_id + dm_id = mkDefaultMethodId dm_name dm_ty + local_dm_type = instantiateMethod clas sel_id (mkTyVarTys tyvars) + local_dm_id = mkLocalId local_dm_name local_dm_type + + ; (dm_id_w_inline, spec_prags) + <- tcPrags NonRecursive False True dm_id (prag_fn sel_name) + + ; tcInstanceMethodBody (instLoc this_dict) + tyvars [this_dict] + ([], emptyBag) + dm_id_w_inline local_dm_id + dm_sig_fn spec_prags meth_bind } + +--------------- +tcInstanceMethodBody :: InstLoc -> [TcTyVar] -> [Inst] + -> ([Inst], LHsBinds Id) -> Id -> Id + -> TcSigFun -> [LSpecPrag] -> LHsBind Name + -> TcM (Id, LHsBind Id) +tcInstanceMethodBody inst_loc tyvars dfun_dicts + (this_dict, this_bind) meth_id local_meth_id + meth_sig_fn spec_prags bind@(L loc _) + = do { -- Typecheck the binding, first extending the envt + -- so that when tcInstSig looks up the local_meth_id to find + -- its signature, we'll find it in the environment + ; ((tc_bind, _), lie) <- getLIE $ + tcExtendIdEnv [local_meth_id] $ + tcPolyBinds TopLevel meth_sig_fn no_prag_fn + NonRecursive NonRecursive + (unitBag bind) + + ; let avails = this_dict ++ dfun_dicts + -- Only need the this_dict stuff if there are type + -- variables involved; otherwise overlap is not possible + -- See Note [Subtle interaction of recursion and overlap] + -- in TcInstDcls + ; lie_binds <- tcSimplifyCheck inst_loc tyvars avails lie + + ; let full_bind = AbsBinds tyvars dfun_lam_vars + [(tyvars, meth_id, local_meth_id, spec_prags)] + (this_bind `unionBags` lie_binds + `unionBags` tc_bind) - ; (top_dm_id, bind) <- tcInstanceMethodBody rigid_info - clas tyvars [this_dict] theta (mkTyVarTys tyvars) - Nothing sel_id - local_dm_name - meth_sig_fn meth_prag_fn - meth_bind + dfun_lam_vars = map instToVar dfun_dicts -- Includes equalities - ; return (bind, top_dm_id) } + ; return (meth_id, L loc full_bind) } + where + no_prag_fn _ = [] -- No pragmas for local_meth_id; + -- they are all for meth_id +\end{code} +\begin{code} mkDefMethRdrName :: Name -> RdrName mkDefMethRdrName sel_name = mkDerivedRdrName sel_name mkDefaultMethodOcc +instantiateMethod :: Class -> Id -> [TcType] -> TcType +-- Take a class operation, say +-- op :: forall ab. C a => forall c. Ix c => (b,c) -> a +-- Instantiate it at [ty1,ty2] +-- Return the "local method type": +-- forall c. Ix x => (ty2,c) -> ty1 +instantiateMethod clas sel_id inst_tys + = ASSERT( ok_first_pred ) local_meth_ty + where + (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id) + rho_ty = ASSERT( length sel_tyvars == length inst_tys ) + substTyWith sel_tyvars inst_tys sel_rho + + (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty + `orElse` pprPanic "tcInstanceMethod" (ppr sel_id) + + ok_first_pred = case getClassPredTys_maybe first_pred of + Just (clas1, _tys) -> clas == clas1 + Nothing -> False + -- The first predicate should be of form (C a b) + -- where C is the class in question + + --------------------------- -- The renamer just puts the selector ID as the binder in the method binding -- but we must use the method name; so we substitute it here. Crude but simple. @@ -246,65 +317,6 @@ | op_name == sel_name = Just (L loc1 (bind { fun_id = L loc2 meth_name })) f _other = Nothing - ---------------- -tcInstanceMethodBody :: SkolemInfo -> Class -> [TcTyVar] -> [Inst] - -> TcThetaType -> [TcType] - -> Maybe (Inst, LHsBind Id) -> Id - -> Name -- The local method name - -> TcSigFun -> TcPragFun -> LHsBind Name - -> TcM (Id, LHsBinds Id) -tcInstanceMethodBody rigid_info clas tyvars dfun_dicts theta inst_tys - mb_this_bind sel_id local_meth_name - sig_fn prag_fn bind@(L loc _) - = do { let (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id) - rho_ty = ASSERT( length sel_tyvars == length inst_tys ) - substTyWith sel_tyvars inst_tys sel_rho - - (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty - `orElse` pprPanic "tcInstanceMethod" (ppr sel_id) - - local_meth_id = mkLocalId local_meth_name local_meth_ty - meth_ty = mkSigmaTy tyvars theta local_meth_ty - sel_name = idName sel_id - - -- The first predicate should be of form (C a b) - -- where C is the class in question - ; MASSERT( case getClassPredTys_maybe first_pred of - { Just (clas1, _tys) -> clas == clas1 ; Nothing -> False } ) - - -- Typecheck the binding, first extending the envt - -- so that when tcInstSig looks up the local_meth_id to find - -- its signature, we'll find it in the environment - ; ((tc_bind, _), lie) <- getLIE $ - tcExtendIdEnv [local_meth_id] $ - tcPolyBinds TopLevel sig_fn prag_fn - NonRecursive NonRecursive - (unitBag bind) - - ; meth_id <- case rigid_info of - ClsSkol _ -> do { dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_name) - ; return (mkDefaultMethodId dm_name meth_ty) } - _other -> do { meth_name <- newLocalName sel_name - ; return (mkLocalId meth_name meth_ty) } - - ; let (avails, this_dict_bind) - = case mb_this_bind of - Nothing -> (dfun_dicts, emptyBag) - Just (this, bind) -> (this : dfun_dicts, unitBag bind) - - ; inst_loc <- getInstLoc (SigOrigin rigid_info) - ; lie_binds <- tcSimplifyCheck inst_loc tyvars avails lie - - ; let full_bind = L loc $ - AbsBinds tyvars dfun_lam_vars - [(tyvars, meth_id, local_meth_id, [])] - (this_dict_bind `unionBags` lie_binds - `unionBags` tc_bind) - - dfun_lam_vars = map instToVar dfun_dicts -- Includes equalities - - ; return (meth_id, unitBag full_bind) } \end{code} Note [Polymorphic methods] @@ -363,7 +375,6 @@ instance C 1 where op Unit = ... - \begin{code} mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name) mkGenericDefMethBind clas inst_tys sel_id meth_name diff -ruN ghc-6.12.1/compiler/typecheck/TcDeriv.lhs ghc-6.13.20091231/compiler/typecheck/TcDeriv.lhs --- ghc-6.12.1/compiler/typecheck/TcDeriv.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/typecheck/TcDeriv.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -92,6 +92,10 @@ -- ds_newtype = True <=> Newtype deriving -- False <=> Vanilla deriving +type DerivContext = Maybe ThetaType + -- Nothing <=> Vanilla deriving; infer the context of the instance decl + -- Just theta <=> Standalone deriving: context supplied by programmer + type EarlyDerivSpec = Either DerivSpec DerivSpec -- Left ds => the context for the instance should be inferred -- In this case ds_theta is the list of all the @@ -362,8 +366,8 @@ ; let binds' = VanillaInst rn_binds [] standalone_deriv ; return (InstInfo { iSpec = inst, iBinds = binds' }, fvs) } where - (tyvars,_,clas,_) = instanceHead inst - clas_nm = className clas + (tyvars,_, clas,_) = instanceHead inst + clas_nm = className clas ----------------------------------------- mkGenericBinds :: Bool -> [LTyClDecl Name] -> TcM (LHsBinds RdrName) @@ -549,7 +553,7 @@ \begin{code} mkEqnHelp :: InstOrigin -> [TyVar] -> Class -> [Type] -> Type - -> Maybe ThetaType -- Just => context supplied (standalone deriving) + -> DerivContext -- Just => context supplied (standalone deriving) -- Nothing => context inferred (deriving on data decl) -> TcRn EarlyDerivSpec -- Make the EarlyDerivSpec for an instance @@ -584,7 +588,7 @@ mkNewTypeEqn orig dflags tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta } | otherwise - = failWithTc (derivingThingErr cls cls_tys tc_app + = failWithTc (derivingThingErr False cls cls_tys tc_app (ptext (sLit "The last argument of the instance must be a data or newtype application"))) \end{code} @@ -643,28 +647,28 @@ -> [Var] -- Universally quantified type variables in the instance -> Class -- Class for which we need to derive an instance -> [Type] -- Other parameters to the class except the last - -> TyCon -- Type constructor for which the instance is requested (last parameter to the type class) + -> TyCon -- Type constructor for which the instance is requested + -- (last parameter to the type class) -> [Type] -- Parameters to the type constructor -> TyCon -- rep of the above (for type families) -> [Type] -- rep of the above - -> Maybe ThetaType -- Context of the instance, for standalone deriving + -> DerivContext -- Context of the instance, for standalone deriving -> TcRn EarlyDerivSpec -- Return 'Nothing' if error mkDataTypeEqn orig dflags tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta - | isJust mtheta = go_for_it -- Do not test side conditions for standalone deriving - | otherwise = case checkSideConditions dflags cls cls_tys rep_tc of - -- NB: pass the *representation* tycon to checkSideConditions - CanDerive -> go_for_it - NonDerivableClass -> bale_out (nonStdErr cls) - DerivableClassError msg -> bale_out msg + = case checkSideConditions dflags mtheta cls cls_tys rep_tc of + -- NB: pass the *representation* tycon to checkSideConditions + CanDerive -> go_for_it + NonDerivableClass -> bale_out (nonStdErr cls) + DerivableClassError msg -> bale_out msg where go_for_it = mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta - bale_out msg = failWithTc (derivingThingErr cls cls_tys (mkTyConApp tycon tc_args) msg) + bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg) mk_data_eqn, mk_typeable_eqn :: InstOrigin -> [TyVar] -> Class - -> TyCon -> [TcType] -> TyCon -> [TcType] -> Maybe ThetaType + -> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext -> TcM EarlyDerivSpec mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta | getName cls `elem` typeableClassNames @@ -781,12 +785,14 @@ | DerivableClassError SDoc -- Standard class, but can't do it | NonDerivableClass -- Non-standard class -checkSideConditions :: DynFlags -> Class -> [TcType] -> TyCon -> DerivStatus -checkSideConditions dflags cls cls_tys rep_tc - | Just cond <- sideConditions cls +checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType] -> TyCon -> DerivStatus +checkSideConditions dflags mtheta cls cls_tys rep_tc + | Just cond <- sideConditions mtheta cls = case (cond (dflags, rep_tc)) of Just err -> DerivableClassError err -- Class-specific error - Nothing | null cls_tys -> CanDerive + Nothing | null cls_tys -> CanDerive -- All derivable classes are unary, so + -- cls_tys (the type args other than last) + -- should be null | otherwise -> DerivableClassError ty_args_why -- e.g. deriving( Eq s ) | otherwise = NonDerivableClass -- Not a standard class where @@ -795,8 +801,8 @@ nonStdErr :: Class -> SDoc nonStdErr cls = quotes (ppr cls) <+> ptext (sLit "is not a derivable class") -sideConditions :: Class -> Maybe Condition -sideConditions cls +sideConditions :: DerivContext -> Class -> Maybe Condition +sideConditions mtheta cls | cls_key == eqClassKey = Just cond_std | cls_key == ordClassKey = Just cond_std | cls_key == showClassKey = Just cond_std @@ -816,6 +822,7 @@ | otherwise = Nothing where cls_key = getUnique cls + cond_std = cond_stdOK mtheta type Condition = (DynFlags, TyCon) -> Maybe SDoc -- first Bool is whether or not we are allowed to derive Data and Typeable @@ -838,15 +845,19 @@ Nothing -> c2 tc -- c1 succeeds Just x -> Just x -- c1 fails -cond_std :: Condition -cond_std (_, rep_tc) - | null data_cons = Just no_cons_why - | not (null con_whys) = Just (vcat con_whys) +cond_stdOK :: DerivContext -> Condition +cond_stdOK (Just _) _ + = Nothing -- Don't check these conservative conditions for + -- standalone deriving; just generate the code +cond_stdOK Nothing (_, rep_tc) + | null data_cons = Just (no_cons_why $$ suggestion) + | not (null con_whys) = Just (vcat con_whys $$ suggestion) | otherwise = Nothing where - data_cons = tyConDataCons rep_tc - no_cons_why = quotes (pprSourceTyCon rep_tc) <+> - ptext (sLit "has no data constructors") + suggestion = ptext (sLit "Possible fix: use a standalone deriving declaration instead") + data_cons = tyConDataCons rep_tc + no_cons_why = quotes (pprSourceTyCon rep_tc) <+> + ptext (sLit "has no data constructors") con_whys = mapCatMaybes check_con data_cons @@ -1007,7 +1018,7 @@ \begin{code} mkNewTypeEqn :: InstOrigin -> DynFlags -> [Var] -> Class -> [Type] -> TyCon -> [Type] -> TyCon -> [Type] - -> Maybe ThetaType + -> DerivContext -> TcRn EarlyDerivSpec mkNewTypeEqn orig dflags tvs cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta @@ -1025,9 +1036,8 @@ ; return (if isJust mtheta then Right spec else Left spec) } - | isJust mtheta = go_for_it -- Do not check side conditions for standalone deriving | otherwise - = case checkSideConditions dflags cls cls_tys rep_tycon of + = case checkSideConditions dflags mtheta cls cls_tys rep_tycon of CanDerive -> go_for_it -- Use the standard H98 method DerivableClassError msg -> bale_out msg -- Error with standard class NonDerivableClass -- Must use newtype deriving @@ -1036,7 +1046,7 @@ where newtype_deriving = dopt Opt_GeneralizedNewtypeDeriving dflags go_for_it = mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta - bale_out msg = failWithTc (derivingThingErr cls cls_tys inst_ty msg) + bale_out msg = failWithTc (derivingThingErr newtype_deriving cls cls_tys inst_ty msg) non_std_err = nonStdErr cls $$ ptext (sLit "Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension") @@ -1146,10 +1156,9 @@ -- so for 'data' instance decls cant_derive_err - = vcat [ ptext (sLit "even with cunning newtype deriving:") - , if arity_ok then empty else arity_msg - , if eta_ok then empty else eta_msg - , if ats_ok then empty else ats_msg ] + = vcat [ ppUnless arity_ok arity_msg + , ppUnless eta_ok eta_msg + , ppUnless ats_ok ats_msg ] arity_msg = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1") eta_msg = ptext (sLit "cannot eta-reduce the representation type enough") ats_msg = ptext (sLit "the class has associated types") @@ -1440,12 +1449,15 @@ = hang (ptext (sLit "Derived instance") <+> quotes (pprClassPred cls (cls_tys ++ [inst_ty]))) 2 (ptext (sLit "requires illegal partial application of data type family") <+> ppr tc) -derivingThingErr :: Class -> [Type] -> Type -> Message -> Message -derivingThingErr clas tys ty why - = sep [hsep [ptext (sLit "Can't make a derived instance of"), - quotes (ppr pred)], - nest 2 (parens why)] +derivingThingErr :: Bool -> Class -> [Type] -> Type -> Message -> Message +derivingThingErr newtype_deriving clas tys ty why + = sep [(hang (ptext (sLit "Can't make a derived instance of")) + 2 (quotes (ppr pred)) + $$ nest 2 extra) <> colon, + nest 2 why] where + extra | newtype_deriving = ptext (sLit "(even with cunning newtype deriving)") + | otherwise = empty pred = mkClassPred clas (tys ++ [ty]) derivingHiddenErr :: TyCon -> SDoc diff -ruN ghc-6.12.1/compiler/typecheck/TcExpr.lhs ghc-6.13.20091231/compiler/typecheck/TcExpr.lhs --- ghc-6.12.1/compiler/typecheck/TcExpr.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/typecheck/TcExpr.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -850,12 +850,12 @@ -> BoxyRhoType -- Result type -> TcM (HsExpr TcId) tcId orig fun_name res_ty - = do { traceTc (text "tcId" <+> ppr fun_name <+> ppr res_ty) - ; (fun, fun_ty) <- lookupFun orig fun_name - + = do { (fun, fun_ty) <- lookupFun orig fun_name + ; traceTc (text "tcId" <+> ppr fun_name <+> (ppr fun_ty $$ ppr res_ty)) + -- Split up the function type ; let (tv_theta_prs, fun_tau) = tcMultiSplitSigmaTy fun_ty - qtvs = concatMap fst tv_theta_prs -- Quantified tyvars + qtvs = concatMap fst tv_theta_prs -- Quantified tyvars tau_qtvs = exactTyVarsOfType fun_tau -- Mentioned in the tau part ; qtv_tys <- preSubType qtvs tau_qtvs fun_tau res_ty @@ -863,6 +863,8 @@ ; let res_subst = zipTopTvSubst qtvs qtv_tys fun_tau' = substTy res_subst fun_tau + ; traceTc (text "tcId2" <+> ppr fun_name <+> (ppr qtvs $$ ppr qtv_tys)) + ; co_fn <- tcSubExp orig fun_tau' res_ty -- And pack up the results diff -ruN ghc-6.12.1/compiler/typecheck/TcForeign.lhs ghc-6.13.20091231/compiler/typecheck/TcForeign.lhs --- ghc-6.12.1/compiler/typecheck/TcForeign.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/typecheck/TcForeign.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -235,7 +235,7 @@ -- is *stable* (i.e. the compiler won't change it later), -- because this name will be referred to by the C code stub. id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc - return (L loc (VarBind id rhs), ForeignExport (L loc id) undefined spec) + return (mkVarBind id rhs, ForeignExport (L loc id) undefined spec) tcFExport d = pprPanic "tcFExport" (ppr d) \end{code} diff -ruN ghc-6.12.1/compiler/typecheck/TcGenDeriv.lhs ghc-6.13.20091231/compiler/typecheck/TcGenDeriv.lhs --- ghc-6.12.1/compiler/typecheck/TcGenDeriv.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/typecheck/TcGenDeriv.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -311,75 +311,80 @@ | Just (con, prim_tc) <- primWrapperType_maybe tycon = gen_PrimOrd_binds con prim_tc - | otherwise + | otherwise = (unitBag compare, aux_binds) - -- `AndMonoBinds` compare - -- The default declaration in PrelBase handles this + -- `AndMonoBinds` compare + -- The default declaration in PrelBase handles this where aux_binds | single_con_type = [] - | otherwise = [GenCon2Tag tycon] + | otherwise = [GenCon2Tag tycon] compare = L loc (mkFunBind (L loc compare_RDR) compare_matches) compare_matches = [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds] cmp_eq_binds = HsValBinds (ValBindsIn (unitBag cmp_eq) []) compare_rhs - | single_con_type = cmp_eq_Expr a_Expr b_Expr - | otherwise - = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] - (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR - (cmp_eq_Expr a_Expr b_Expr) -- True case - -- False case; they aren't equal - -- So we need to do a less-than comparison on the tags - (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)) + | single_con_type = cmp_eq_Expr a_Expr b_Expr + | otherwise + = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] + (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR + (cmp_eq_Expr a_Expr b_Expr) -- True case + -- False case; they aren't equal + -- So we need to do a less-than comparison on the tags + (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR + ltTag_Expr gtTag_Expr)) tycon_data_cons = tyConDataCons tycon single_con_type = isSingleton tycon_data_cons (nullary_cons, nonnullary_cons) | isNewTyCon tycon = ([], tyConDataCons tycon) - | otherwise = partition isNullarySrcDataCon tycon_data_cons + | otherwise = partition isNullarySrcDataCon tycon_data_cons cmp_eq = mk_FunBind loc cmp_eq_RDR cmp_eq_match cmp_eq_match | isEnumerationTyCon tycon - -- We know the tags are equal, so if it's an enumeration TyCon, - -- then there is nothing left to do - -- Catch this specially to avoid warnings - -- about overlapping patterns from the desugarer, - -- and to avoid unnecessary pattern-matching + -- We know the tags are equal, so if it's an + -- enumeration TyCon, + -- then there is nothing left to do + -- Catch this specially to avoid warnings + -- about overlapping patterns from the desugarer, + -- and to avoid unnecessary pattern-matching = [([nlWildPat,nlWildPat], eqTag_Expr)] | otherwise = map pats_etc nonnullary_cons ++ - (if single_con_type then -- Omit wildcards when there's just one - [] -- constructor, to silence desugarer - else + (if single_con_type then -- Omit wildcards when there's just one + [] -- constructor, to silence desugarer + else [([nlWildPat, nlWildPat], default_rhs)]) - default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about - -- inexhaustive patterns - | otherwise = eqTag_Expr -- Some nullary constructors; - -- Tags are equal, no args => return EQ + default_rhs | null nullary_cons = -- Keep desugarer from complaining about + -- inexhaustive patterns + impossible_Expr + | otherwise = -- Some nullary constructors; + -- Tags are equal, no args => return EQ + eqTag_Expr pats_etc data_con - = ([con1_pat, con2_pat], - nested_compare_expr tys_needed as_needed bs_needed) - where - con1_pat = nlConVarPat data_con_RDR as_needed - con2_pat = nlConVarPat data_con_RDR bs_needed - - data_con_RDR = getRdrName data_con - con_arity = length tys_needed - as_needed = take con_arity as_RDRs - bs_needed = take con_arity bs_RDRs - tys_needed = dataConOrigArgTys data_con - - nested_compare_expr [ty] [a] [b] - = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b) - - nested_compare_expr (ty:tys) (a:as) (b:bs) - = let eq_expr = nested_compare_expr tys as bs - in careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b) + = ([con1_pat, con2_pat], + nested_compare_expr tys_needed as_needed bs_needed) + where + con1_pat = nlConVarPat data_con_RDR as_needed + con2_pat = nlConVarPat data_con_RDR bs_needed + + data_con_RDR = getRdrName data_con + con_arity = length tys_needed + as_needed = take con_arity as_RDRs + bs_needed = take con_arity bs_RDRs + tys_needed = dataConOrigArgTys data_con + + nested_compare_expr [ty] [a] [b] + = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b) + + nested_compare_expr (ty:tys) (a:as) (b:bs) + = let eq_expr = nested_compare_expr tys as bs + in careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b) - nested_compare_expr _ _ _ = panic "nested_compare_expr" -- Args always equal length + -- Args always equal length + nested_compare_expr _ _ _ = panic "nested_compare_expr" \end{code} Note [Comparision of primitive types] @@ -566,8 +571,8 @@ data_cons = tyConDataCons tycon ----- enum-flavored: --------------------------- - min_bound_enum = mkVarBind loc minBound_RDR (nlHsVar data_con_1_RDR) - max_bound_enum = mkVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR) + min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR) + max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR) data_con_1 = head data_cons data_con_N = last data_cons @@ -577,9 +582,9 @@ ----- single-constructor-flavored: ------------- arity = dataConSourceArity data_con_1 - min_bound_1con = mkVarBind loc minBound_RDR $ + min_bound_1con = mkHsVarBind loc minBound_RDR $ nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR) - max_bound_1con = mkVarBind loc maxBound_RDR $ + max_bound_1con = mkHsVarBind loc maxBound_RDR $ nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR) \end{code} @@ -808,16 +813,16 @@ where ----------------------------------------------------------------------- default_readlist - = mkVarBind loc readList_RDR (nlHsVar readListDefault_RDR) + = mkHsVarBind loc readList_RDR (nlHsVar readListDefault_RDR) default_readlistprec - = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR) + = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR) ----------------------------------------------------------------------- data_cons = tyConDataCons tycon (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons - read_prec = mkVarBind loc readPrec_RDR + read_prec = mkHsVarBind loc readPrec_RDR (nlHsApp (nlHsVar parens_RDR) read_cons) read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons) @@ -961,7 +966,7 @@ = (listToBag [shows_prec, show_list], []) where ----------------------------------------------------------------------- - show_list = mkVarBind loc showList_RDR + show_list = mkHsVarBind loc showList_RDR (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0)))) ----------------------------------------------------------------------- shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc (tyConDataCons tycon)) @@ -1616,7 +1621,7 @@ rdr_name = tag2con_RDR tycon genAuxBind loc (GenMaxTag tycon) - = mkVarBind loc rdr_name + = mkHsVarBind loc rdr_name (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag))) where rdr_name = maxtag_RDR tycon @@ -1624,16 +1629,16 @@ data_cons -> toInteger ((length data_cons) - fIRST_TAG) genAuxBind loc (MkTyCon tycon) -- $dT - = mkVarBind loc (mk_data_type_name tycon) - ( nlHsVar mkDataType_RDR + = mkHsVarBind loc (mk_data_type_name tycon) + ( nlHsVar mkDataType_RDR `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon))) `nlHsApp` nlList constrs ) where constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon] genAuxBind loc (MkDataCon dc) -- $cT1 etc - = mkVarBind loc (mk_constr_name dc) - (nlHsApps mkConstr_RDR constr_args) + = mkHsVarBind loc (mk_constr_name dc) + (nlHsApps mkConstr_RDR constr_args) where constr_args = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag diff -ruN ghc-6.12.1/compiler/typecheck/TcHsSyn.lhs ghc-6.13.20091231/compiler/typecheck/TcHsSyn.lhs --- ghc-6.12.1/compiler/typecheck/TcHsSyn.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/typecheck/TcHsSyn.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -16,8 +16,6 @@ nlHsIntLit, shortCutLit, hsOverLitName, - mkArbitraryType, -- Put this elsewhere? - -- re-exported from TcMonad TcId, TcIdSet, TcDictBinds, @@ -39,7 +37,6 @@ import TcMType import TysPrim import TysWiredIn -import TyCon import DataCon import Name import Var @@ -52,7 +49,6 @@ import Util import Bag import Outputable -import FastString \end{code} \begin{code} @@ -337,10 +333,10 @@ ; new_ty <- zonkTcTypeToType env ty ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) } -zonk_bind env (VarBind { var_id = var, var_rhs = expr }) +zonk_bind env (VarBind { var_id = var, var_rhs = expr, var_inline = inl }) = zonkIdBndr env var `thenM` \ new_var -> zonkLExpr env expr `thenM` \ new_expr -> - returnM (VarBind { var_id = new_var, var_rhs = new_expr }) + returnM (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl }) zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms, fun_co_fn = co_fn }) = wrapLocM (zonkIdBndr env) var `thenM` \ new_var -> @@ -369,11 +365,9 @@ = zonkIdBndr env global `thenM` \ new_global -> mapM zonk_prag prags `thenM` \ new_prags -> returnM (tyvars, new_global, zonkIdOcc env local, new_prags) - zonk_prag prag@(L _ (InlinePrag {})) = return prag - zonk_prag (L loc (SpecPrag expr ty inl)) - = do { expr' <- zonkExpr env expr - ; ty' <- zonkTcTypeToType env ty - ; return (L loc (SpecPrag expr' ty' inl)) } + zonk_prag (L loc (SpecPrag co_fn inl)) + = do { (_, co_fn') <- zonkCoFn env co_fn + ; return (L loc (SpecPrag co_fn' inl)) } \end{code} %************************************************************************ @@ -604,7 +598,6 @@ ------------------------------------------------------------------------- zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper) zonkCoFn env WpHole = return (env, WpHole) -zonkCoFn env WpInline = return (env, WpInline) zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 ; (env2, c2') <- zonkCoFn env1 c2 ; return (env2, WpCompose c1' c2') } @@ -1017,76 +1010,7 @@ -- mutable tyvar to a fresh immutable one. So the mutable store -- plays the role of an environment. If we come across a mutable -- type variable that isn't so bound, it must be completely free. - zonk_unbound_tyvar tv = do { ty <- mkArbitraryType warn tv + zonk_unbound_tyvar tv = do { let ty = anyTypeOfKind (tyVarKind tv) ; writeMetaTyVar tv ty ; return ty } - where - warn span msg = setSrcSpan span (addWarnTc msg) - - -{- Note [Strangely-kinded void TyCons] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - See Trac #959 for more examples - -When the type checker finds a type variable with no binding, which -means it can be instantiated with an arbitrary type, it usually -instantiates it to Void. Eg. - - length [] -===> - length Void (Nil Void) - -But in really obscure programs, the type variable might have a kind -other than *, so we need to invent a suitably-kinded type. - -This commit uses - Void for kind * - List for kind *->* - Tuple for kind *->...*->* - -which deals with most cases. (Previously, it only dealt with -kind *.) - -In the other cases, it just makes up a TyCon with a suitable kind. If -this gets into an interface file, anyone reading that file won't -understand it. This is fixable (by making the client of the interface -file make up a TyCon too) but it is tiresome and never happens, so I -am leaving it. - -Meanwhile I have now fixed GHC to emit a civilized warning. - -} - -mkArbitraryType :: (SrcSpan -> SDoc -> TcRnIf g l a) -- How to complain - -> TcTyVar - -> TcRnIf g l Type -- Used by desugarer too --- Make up an arbitrary type whose kind is the same as the tyvar. --- We'll use this to instantiate the (unbound) tyvar. --- --- Also used by the desugarer; hence the (tiresome) parameter --- to use when generating a warning -mkArbitraryType warn tv - | liftedTypeKind `isSubKind` kind -- The vastly common case - = return anyPrimTy - | eqKind kind (tyConKind anyPrimTyCon1) -- @*->*@ - = return (mkTyConApp anyPrimTyCon1 []) -- No tuples this size - | all isLiftedTypeKind args -- @*-> ... ->*->*@ - , isLiftedTypeKind res -- Horrible hack to make less use - = return (mkTyConApp tup_tc []) -- of mkAnyPrimTyCon - | otherwise - = do { _ <- warn (getSrcSpan tv) msg - ; return (mkTyConApp (mkAnyPrimTyCon (getUnique tv) kind) []) } - -- Same name as the tyvar, apart from making it start with a colon (sigh) - -- I dread to think what will happen if this gets out into an - -- interface file. Catastrophe likely. Major sigh. - where - kind = tyVarKind tv - (args,res) = splitKindFunTys kind - tup_tc = tupleTyCon Boxed (length args) - - msg = vcat [ hang (ptext (sLit "Inventing strangely-kinded Any TyCon")) - 2 (ptext (sLit "of kind") <+> quotes (ppr kind)) - , nest 2 (ptext (sLit "from an instantiation of type variable") <+> quotes (ppr tv)) - , ptext (sLit "This warning can be suppressed by a type signature fixing") <+> quotes (ppr tv) - , nest 2 (ptext (sLit "but is harmless without -O (and usually harmless anyway).")) - , ptext (sLit "See http://hackage.haskell.org/trac/ghc/ticket/959 for details") ] -\end{code} +\end{code} \ No newline at end of file diff -ruN ghc-6.12.1/compiler/typecheck/TcInstDcls.lhs ghc-6.13.20091231/compiler/typecheck/TcInstDcls.lhs --- ghc-6.12.1/compiler/typecheck/TcInstDcls.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/typecheck/TcInstDcls.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -32,6 +32,9 @@ import DataCon import Class import Var +import CoreUnfold ( mkDFunUnfolding ) +import CoreUtils ( mkPiTypes ) +import PrelNames ( inlineIdName ) import Id import MkId import Name @@ -91,6 +94,7 @@ -- A top-level definition for each instance method -- Here op1_i, op2_i are the "instance method Ids" + -- The INLINE pragma comes from the user pragma {-# INLINE [2] op1_i #-} -- From the instance decl bindings op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b op1_i = /\a. \(d:C a). @@ -109,24 +113,21 @@ op2_i = /\a \d:C a. $dmop2 [a] (df_i a d) -- The dictionary function itself - {-# INLINE df_i #-} -- Always inline dictionary functions + {-# NOINLINE CONLIKE df_i #-} -- Never inline dictionary functions df_i :: forall a. C a -> C [a] - df_i = /\a. \d:C a. letrec d' = MkC (op1_i a d) - ($dmop2 [a] d') - in d' + df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d) -- But see Note [Default methods in instances] -- We can't apply the type checker to the default-method call -* The dictionary function itself is inlined as vigorously as we - possibly can, so that we expose that dictionary constructor to - selectors as much as poss. That is why the op_i stuff is in - *separate* bindings, so that the df_i binding is small enough - to inline. See Note [Inline dfuns unconditionally]. + -- Use a RULE to short-circuit applications of the class ops + {-# RULE "op1@C[a]" forall a, d:C a. + op1 [a] (df_i d) = op1_i a d #-} +Note [Instances and loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * Note that df_i may be mutually recursive with both op1_i and op2_i. It's crucial that df_i is not chosen as the loop breaker, even though op1_i has a (user-specified) INLINE pragma. - Not even once! Else op1_i, op2_i may be inlined into df_i. * Instead the idea is to inline df_i into op1_i, which may then select methods from the MkC record, and thereby break the recursion with @@ -137,8 +138,90 @@ * If op1_i is marked INLINE by the user there's a danger that we won't inline df_i in it, and that in turn means that (since it'll be a loop-breaker because df_i isn't), op1_i will ironically never be - inlined. We need to fix this somehow -- perhaps allowing inlining - of INLINE functions inside other INLINE functions. + inlined. But this is OK: the recursion breaking happens by way of + a RULE (the magic ClassOp rule above), and RULES work inside InlineRule + unfoldings. See Note [RULEs enabled in SimplGently] in SimplUtils + +Note [ClassOp/DFun selection] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +One thing we see a lot is stuff like + op2 (df d1 d2) +where 'op2' is a ClassOp and 'df' is DFun. Now, we could inline *both* +'op2' and 'df' to get + case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of + MkD _ op2 _ _ _ -> op2 +And that will reduce to ($cop2 d1 d2) which is what we wanted. + +But it's tricky to make this work in practice, because it requires us to +inline both 'op2' and 'df'. But neither is keen to inline without having +seen the other's result; and it's very easy to get code bloat (from the +big intermediate) if you inline a bit too much. + +Instead we use a cunning trick. + * We arrange that 'df' and 'op2' NEVER inline. + + * We arrange that 'df' is ALWAYS defined in the sylised form + df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ... + + * We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..]) + that lists its methods. + + * We make CoreUnfold.exprIsConApp_maybe spot a DFunUnfolding and return + a suitable constructor application -- inlining df "on the fly" as it + were. + + * We give the ClassOp 'op2' a BuiltinRule that extracts the right piece + iff its argument satisfies exprIsConApp_maybe. This is done in + MkId mkDictSelId + + * We make 'df' CONLIKE, so that shared uses stil match; eg + let d = df d1 d2 + in ...(op2 d)...(op1 d)... + +Note [Single-method classes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the class has just one method (or, more accurately, just one elemen +of {superclasses + methods}), then we want a different strategy. + + class C a where op :: a -> a + instance C a => C [a] where op = + +We translate the class decl into a newtype, which just gives +a top-level axiom: + + axiom Co:C a :: C a ~ (a->a) + + op :: forall a. C a -> (a -> a) + op a d = d |> (Co:C a) + + df :: forall a. C a => C [a] + {-# INLINE df #-} + df = $cop_list |> (forall a. C a -> (sym (Co:C a)) + + $cop_list :: forall a. C a => a -> a + $cop_list = + +So the ClassOp is just a cast; and so is the dictionary function. +(The latter doesn't even have any lambdas.) We can inline both freely. +No need for fancy BuiltIn rules. Indeed the BuiltinRule stuff does +not work well for newtypes because it uses exprIsConApp_maybe. + +The INLINE on df is vital, else $cop_list occurs just once and is inlined, +which is a disaster if $cop_list *itself* has an INLINE pragma. + +Notice, also, that we go to the trouble of generating a complicated cast, +rather than do this: + df = /\a. \d. MkD ($cop_list a d) +where the MkD "constructor" willl expand to a suitable cast: + df = /\a. \d. ($cop_list a d) |> (...) +Reason: suppose $cop_list has an INLINE pragma. We want to avoid the +nasty possibility that we eta-expand df, to get + df = (/\a \d \x. $cop_list a d x) |> (...) +and now $cop_list may get inlined into the df, rather than at +the actual call site. Of course, eta reduction may get there first, +but it seems less fragile to generate the Right Thing in the first place. +See Trac #3772. + Note [Subtle interaction of recursion and overlap] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -180,7 +263,7 @@ definition for 'this' in the definition of op1_i in the example above. We can typecheck the defintion of local_op1, and when doing tcSimplifyCheck we supply 'this' as a given dictionary. Only needed, though, if there -are some type variales involved; otherwise there can be no overlap and +are some type variables involved; otherwise there can be no overlap and none of this arises. Note [Tricky type variable scoping] @@ -201,93 +284,6 @@ and for , but that doesn't matter: the *renamer* will have complained if 'b' is mentioned in . -Note [Inline dfuns unconditionally] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The code above unconditionally inlines dict funs. Here's why. -Consider this program: - - test :: Int -> Int -> Bool - test x y = (x,y) == (y,x) || test y x - -- Recursive to avoid making it inline. - -This needs the (Eq (Int,Int)) instance. If we inline that dfun -the code we end up with is good: - - Test.$wtest = - \r -> case ==# [ww ww1] of wild { - PrelBase.False -> Test.$wtest ww1 ww; - PrelBase.True -> - case ==# [ww1 ww] of wild1 { - PrelBase.False -> Test.$wtest ww1 ww; - PrelBase.True -> PrelBase.True []; - }; - }; - Test.test = \r [w w1] - case w of w2 { - PrelBase.I# ww -> - case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; }; - }; - -If we don't inline the dfun, the code is not nearly as good: - - (==) = case PrelTup.$fEq(,) PrelBase.$fEqInt PrelBase.$fEqInt of tpl { - PrelBase.:DEq tpl1 tpl2 -> tpl2; - }; - - Test.$wtest = - \r [ww ww1] - let { y = PrelBase.I#! [ww1]; } in - let { x = PrelBase.I#! [ww]; } in - let { sat_slx = PrelTup.(,)! [y x]; } in - let { sat_sly = PrelTup.(,)! [x y]; - } in - case == sat_sly sat_slx of wild { - PrelBase.False -> Test.$wtest ww1 ww; - PrelBase.True -> PrelBase.True []; - }; - - Test.test = - \r [w w1] - case w of w2 { - PrelBase.I# ww -> - case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; }; - }; - -Why didn't GHC inline $fEq in those days? Because it looked big: - - PrelTup.zdfEqZ1T{-rcX-} - = \ @ a{-reT-} :: * @ b{-reS-} :: * - zddEq{-rf6-} _Ks :: {PrelBase.Eq{-23-} a{-reT-}} - zddEq1{-rf7-} _Ks :: {PrelBase.Eq{-23-} b{-reS-}} -> - let { - zeze{-rf0-} _Kl :: (b{-reS-} -> b{-reS-} -> PrelBase.Bool{-3c-}) - zeze{-rf0-} = PrelBase.zeze{-01L-}@ b{-reS-} zddEq1{-rf7-} } in - let { - zeze1{-rf3-} _Kl :: (a{-reT-} -> a{-reT-} -> PrelBase.Bool{-3c-}) - zeze1{-rf3-} = PrelBase.zeze{-01L-} @ a{-reT-} zddEq{-rf6-} } in - let { - zeze2{-reN-} :: ((a{-reT-}, b{-reS-}) -> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-}) - zeze2{-reN-} = \ ds{-rf5-} _Ks :: (a{-reT-}, b{-reS-}) - ds1{-rf4-} _Ks :: (a{-reT-}, b{-reS-}) -> - case ds{-rf5-} - of wild{-reW-} _Kd { (a1{-rf2-} _Ks, a2{-reZ-} _Ks) -> - case ds1{-rf4-} - of wild1{-reX-} _Kd { (b1{-rf1-} _Ks, b2{-reY-} _Ks) -> - PrelBase.zaza{-r4e-} - (zeze1{-rf3-} a1{-rf2-} b1{-rf1-}) - (zeze{-rf0-} a2{-reZ-} b2{-reY-}) - } - } } in - let { - a1{-reR-} :: ((a{-reT-}, b{-reS-})-> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-}) - a1{-reR-} = \ a2{-reV-} _Ks :: (a{-reT-}, b{-reS-}) - b1{-reU-} _Ks :: (a{-reT-}, b{-reS-}) -> - PrelBase.not{-r6I-} (zeze2{-reN-} a2{-reV-} b1{-reU-}) - } in - PrelBase.zdwZCDEq{-r8J-} @ (a{-reT-}, b{-reS-}) a1{-reR-} zeze2{-reN-}) - -and it's not as bad as it seems, because it's further dramatically -simplified: only zeze2 is extracted and its body is simplified. %************************************************************************ @@ -551,18 +547,19 @@ tcInstDecls2 tycl_decls inst_decls = do { -- (a) Default methods from class decls - (dm_binds_s, dm_ids_s) <- mapAndUnzipM tcClassDecl2 $ - filter (isClassDecl.unLoc) tycl_decls - ; tcExtendIdEnv (concat dm_ids_s) $ do + let class_decls = filter (isClassDecl . unLoc) tycl_decls + ; (dm_ids_s, dm_binds_s) <- mapAndUnzipM tcClassDecl2 class_decls + + ; tcExtendIdEnv (concat dm_ids_s) $ do -- (b) instance declarations - ; inst_binds_s <- mapM tcInstDecl2 inst_decls + { inst_binds_s <- mapM tcInstDecl2 inst_decls -- Done ; let binds = unionManyBags dm_binds_s `unionBags` unionManyBags inst_binds_s ; tcl_env <- getLclEnv -- Default method Ids in here - ; return (binds, tcl_env) } + ; return (binds, tcl_env) } } tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id) tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) @@ -571,8 +568,8 @@ addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ tc_inst_decl2 dfun_id ibinds where - dfun_id = instanceDFunId ispec - loc = getSrcSpan dfun_id + dfun_id = instanceDFunId ispec + loc = getSrcSpan dfun_id \end{code} @@ -661,7 +658,7 @@ ; let coerced_rep_dict = wrapId wrapper (instToId rep_dict) ; body <- make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict - ; let dict_bind = noLoc $ VarBind (instToId this_dict) (noLoc body) + ; let dict_bind = mkVarBind (instToId this_dict) (noLoc body) ; return (unitBag $ noLoc $ AbsBinds inst_tvs' (map instToVar dfun_dicts) @@ -708,6 +705,7 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv) = do { let rigid_info = InstSkol inst_ty = idType dfun_id + loc = getSrcSpan dfun_id -- Instantiate the instance decl with skolem constants ; (inst_tyvars', dfun_theta', inst_head') <- tcSkolSigType rigid_info inst_ty @@ -716,85 +714,145 @@ -- bizarre, but OK so long as you realise it! ; let (clas, inst_tys') = tcSplitDFunHead inst_head' - (class_tyvars, sc_theta, _, op_items) = classBigSig clas + (class_tyvars, sc_theta, sc_sels, op_items) = classBigSig clas -- Instantiate the super-class context with inst_tys sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys') sc_theta origin = SigOrigin rigid_info -- Create dictionary Ids from the specified instance contexts. - ; sc_loc <- getInstLoc InstScOrigin - ; sc_dicts <- newDictOccs sc_loc sc_theta' -- These are wanted ; inst_loc <- getInstLoc origin ; dfun_dicts <- newDictBndrs inst_loc dfun_theta' -- Includes equalities ; this_dict <- newDictBndr inst_loc (mkClassPred clas inst_tys') - -- Default-method Ids may be mentioned in synthesised RHSs, -- but they'll already be in the environment. - -- Typecheck the methods - ; let this_dict_id = instToId this_dict + + -- Cook up a binding for "this = df d1 .. dn", + -- to use in each method binding + -- Need to clone the dict in case it is floated out, and + -- then clashes with its friends + ; cloned_this <- cloneDict this_dict + ; let cloned_this_bind = mkVarBind (instToId cloned_this) $ + L loc $ wrapId app_wrapper dfun_id + app_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars') dfun_lam_vars = map instToVar dfun_dicts -- Includes equalities - prag_fn = mkPragFun uprags - loc = getSrcSpan dfun_id - tc_meth = tcInstanceMethod loc standalone_deriv - clas inst_tyvars' dfun_dicts - dfun_theta' inst_tys' - this_dict dfun_id - prag_fn monobinds - ; (meth_exprs, meth_binds) <- tcExtendTyVarEnv inst_tyvars' $ - mapAndUnzipM tc_meth op_items + nested_this_pair + | null inst_tyvars' && null dfun_theta' = (this_dict, emptyBag) + | otherwise = (cloned_this, unitBag cloned_this_bind) + + -- Deal with 'SPECIALISE instance' pragmas + -- See Note [SPECIALISE instance pragmas] + ; let spec_inst_sigs = filter isSpecInstLSig uprags + -- The filter removes the pragmas for methods + ; spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) spec_inst_sigs + + -- Typecheck the methods + ; let prag_fn = mkPragFun uprags + tc_meth = tcInstanceMethod loc standalone_deriv + clas inst_tyvars' + dfun_dicts inst_tys' + nested_this_pair + prag_fn spec_inst_prags monobinds + + ; (meth_ids, meth_binds) <- tcExtendTyVarEnv inst_tyvars' $ + mapAndUnzipM tc_meth op_items -- Figure out bindings for the superclass context - -- Don't include this_dict in the 'givens', else - -- sc_dicts get bound by just selecting from this_dict!! - ; sc_binds <- addErrCtxt superClassCtxt $ - tcSimplifySuperClasses inst_loc this_dict dfun_dicts sc_dicts - -- Note [Recursive superclasses] + ; sc_loc <- getInstLoc InstScOrigin + ; sc_dicts <- newDictOccs sc_loc sc_theta' -- These are wanted + ; let tc_sc = tcSuperClass inst_loc inst_tyvars' dfun_dicts nested_this_pair + ; (sc_ids, sc_binds) <- mapAndUnzipM tc_sc (sc_sels `zip` sc_dicts) - -- It's possible that the superclass stuff might unified something - -- in the envt with one of the inst_tyvars' + -- It's possible that the superclass stuff might unified + -- something in the envt with one of the inst_tyvars' ; checkSigTyVars inst_tyvars' - -- Deal with 'SPECIALISE instance' pragmas - ; prags <- tcPrags dfun_id (filter isSpecInstLSig uprags) - -- Create the result bindings - ; let dict_constr = classDataCon clas - inline_prag | null dfun_dicts = [] - | otherwise = [L loc (InlinePrag (alwaysInlineSpec FunLike))] - -- Always inline the dfun; this is an experimental decision - -- because it makes a big performance difference sometimes. - -- Often it means we can do the method selection, and then - -- inline the method as well. Marcin's idea; see comments below. - -- - -- BUT: don't inline it if it's a constant dictionary; - -- we'll get all the benefit without inlining, and we get - -- a **lot** of code duplication if we inline it - -- - -- See Note [Inline dfuns] below - - sc_dict_vars = map instToVar sc_dicts - dict_bind = L loc (VarBind this_dict_id dict_rhs) - dict_rhs = foldl (\ f a -> L loc (HsApp f (L loc a))) inst_constr meth_exprs - inst_constr = L loc $ wrapId (mkWpApps sc_dict_vars <.> mkWpTyApps inst_tys') - (dataConWrapId dict_constr) - -- We don't produce a binding for the dict_constr; instead we - -- rely on the simplifier to unfold this saturated application - -- We do this rather than generate an HsCon directly, because - -- it means that the special cases (e.g. dictionary with only one - -- member) are dealt with by the common MkId.mkDataConWrapId code rather - -- than needing to be repeated here. - - - main_bind = noLoc $ AbsBinds - inst_tyvars' - dfun_lam_vars - [(inst_tyvars', dfun_id, this_dict_id, inline_prag ++ prags)] - (dict_bind `consBag` sc_binds) + ; let this_dict_id = instToId this_dict + arg_ids = sc_ids ++ meth_ids + arg_binds = listToBag meth_binds `unionBags` + listToBag sc_binds ; showLIE (text "instance") - ; return (main_bind `consBag` unionManyBags meth_binds) } + ; case newTyConCo_maybe (classTyCon clas) of + Nothing -- A multi-method class + -> return (unitBag (L loc data_bind) `unionBags` arg_binds) + where + data_dfun_id = dfun_id -- Do not inline; instead give it a magic DFunFunfolding + -- See Note [ClassOp/DFun selection] + `setIdUnfolding` mkDFunUnfolding dict_constr arg_ids + `setInlinePragma` dfunInlinePragma + + data_bind = AbsBinds inst_tyvars' dfun_lam_vars + [(inst_tyvars', data_dfun_id, this_dict_id, spec_inst_prags)] + (unitBag dict_bind) + + dict_bind = mkVarBind this_dict_id dict_rhs + dict_rhs = foldl mk_app inst_constr arg_ids + dict_constr = classDataCon clas + inst_constr = L loc $ wrapId (mkWpTyApps inst_tys') + (dataConWrapId dict_constr) + -- We don't produce a binding for the dict_constr; instead we + -- rely on the simplifier to unfold this saturated application + -- We do this rather than generate an HsCon directly, because + -- it means that the special cases (e.g. dictionary with only one + -- member) are dealt with by the common MkId.mkDataConWrapId code rather + -- than needing to be repeated here. + + mk_app :: LHsExpr Id -> Id -> LHsExpr Id + mk_app fun arg_id = L loc (HsApp fun (L loc (wrapId arg_wrapper arg_id))) + arg_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars') + + Just the_nt_co -- (Just co) for a single-method class + -> return (unitBag (L loc nt_bind) `unionBags` arg_binds) + where + nt_dfun_id = dfun_id -- Just let the dfun inline; see Note [Single-method classes] + `setInlinePragma` alwaysInlinePragma + + local_nt_dfun = setIdType this_dict_id inst_ty -- A bit of a hack, but convenient + + nt_bind = AbsBinds [] [] + [([], nt_dfun_id, local_nt_dfun, spec_inst_prags)] + (unitBag (mkVarBind local_nt_dfun (L loc (wrapId nt_cast the_meth_id)))) + + the_meth_id = ASSERT( length arg_ids == 1 ) head arg_ids + nt_cast = WpCast $ mkPiTypes (inst_tyvars' ++ dfun_lam_vars) $ + mkSymCoercion (mkTyConApp the_nt_co inst_tys') + } + + +------------------------------ +tcSuperClass :: InstLoc -> [TyVar] -> [Inst] + -> (Inst, LHsBinds Id) + -> (Id, Inst) -> TcM (Id, LHsBind Id) +-- Build a top level decl like +-- sc_op = /\a \d. let this = ... in +-- let sc = ... in +-- sc +-- The "this" part is just-in-case (discarded if not used) +-- See Note [Recursive superclasses] +tcSuperClass inst_loc tyvars dicts (this_dict, this_bind) + (sc_sel, sc_dict) + = addErrCtxt superClassCtxt $ + do { sc_binds <- tcSimplifySuperClasses inst_loc + this_dict dicts [sc_dict] + -- Don't include this_dict in the 'givens', else + -- sc_dicts get bound by just selecting from this_dict!! + + ; uniq <- newUnique + ; let sc_op_ty = mkSigmaTy tyvars (map dictPred dicts) + (mkPredTy (dictPred sc_dict)) + sc_op_name = mkDerivedInternalName mkClassOpAuxOcc uniq + (getName sc_sel) + sc_op_id = mkLocalId sc_op_name sc_op_ty + sc_id = instToVar sc_dict + sc_op_bind = AbsBinds tyvars + (map instToVar dicts) + [(tyvars, sc_op_id, sc_id, [])] + (this_bind `unionBags` sc_binds) + + ; return (sc_op_id, noLoc sc_op_bind) } \end{code} Note [Recursive superclasses] @@ -805,6 +863,62 @@ loop. What we need is to add this_dict to Avails without adding its superclasses, and we currently have no way to do that. +Note [SPECIALISE instance pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + instance (Ix a, Ix b) => Ix (a,b) where + {-# SPECIALISE instance Ix (Int,Int) #-} + range (x,y) = ... + +We do *not* want to make a specialised version of the dictionary +function. Rather, we want specialised versions of each method. +Thus we should generate something like this: + + $dfIx :: (Ix a, Ix x) => Ix (a,b) + {- DFUN [$crange, ...] -} + $dfIx da db = Ix ($crange da db) (...other methods...) + + $dfIxPair :: (Ix a, Ix x) => Ix (a,b) + {- DFUN [$crangePair, ...] -} + $dfIxPair = Ix ($crangePair da db) (...other methods...) + + $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)] + {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-} + $crange da db = + + {-# RULE range ($dfIx da db) = $crange da db #-} + +Note that + + * The RULE is unaffected by the specialisation. We don't want to + specialise $dfIx, because then it would need a specialised RULE + which is a pain. The single RULE works fine at all specialisations. + See Note [How instance declarations are translated] above + + * Instead, we want to specialise the *method*, $crange + +In practice, rather than faking up a SPECIALISE pragama for each +method (which is painful, since we'd have to figure out its +specialised type), we call tcSpecPrag *as if* were going to specialise +$dfIx -- you can see that in the call to tcSpecInst. That generates a +SpecPrag which, as it turns out, can be used unchanged for each method. +The "it turns out" bit is delicate, but it works fine! + +\begin{code} +tcSpecInst :: Id -> Sig Name -> TcM SpecPrag +tcSpecInst dfun_id prag@(SpecInstSig hs_ty) + = addErrCtxt (spec_ctxt prag) $ + do { let name = idName dfun_id + ; (tyvars, theta, tau) <- tcHsInstHead hs_ty + ; let spec_ty = mkSigmaTy tyvars theta tau + ; co_fn <- tcSubExp (SpecPragOrigin name) (idType dfun_id) spec_ty + ; return (SpecPrag co_fn defaultInlinePragma) } + where + spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag) + +tcSpecInst _ _ = panic "tcSpecInst" +\end{code} %************************************************************************ %* * @@ -822,93 +936,118 @@ \begin{code} tcInstanceMethod :: SrcSpan -> Bool -> Class -> [TcTyVar] -> [Inst] - -> TcThetaType -> [TcType] - -> Inst -> Id - -> TcPragFun -> LHsBinds Name + -> [TcType] + -> (Inst, LHsBinds Id) -- "This" and its binding + -> TcPragFun -- Local prags + -> [LSpecPrag] -- Arising from 'SPECLALISE instance' + -> LHsBinds Name -> (Id, DefMeth) - -> TcM (HsExpr Id, LHsBinds Id) + -> TcM (Id, LHsBind Id) -- The returned inst_meth_ids all have types starting -- forall tvs. theta => ... -tcInstanceMethod loc standalone_deriv clas tyvars dfun_dicts theta inst_tys - this_dict dfun_id prag_fn binds_in (sel_id, dm_info) - = do { cloned_this <- cloneDict this_dict - -- Need to clone the dict in case it is floated out, and - -- then clashes with its friends - ; uniq1 <- newUnique - ; let local_meth_name = mkInternalName uniq1 sel_occ loc -- Same OccName - this_dict_bind = L loc $ VarBind (instToId cloned_this) $ - L loc $ wrapId meth_wrapper dfun_id - mb_this_bind | null tyvars = Nothing - | otherwise = Just (cloned_this, this_dict_bind) - -- Only need the this_dict stuff if there are type variables - -- involved; otherwise overlap is not possible - -- See Note [Subtle interaction of recursion and overlap] +tcInstanceMethod loc standalone_deriv clas tyvars dfun_dicts inst_tys + (this_dict, this_dict_bind) + prag_fn spec_inst_prags binds_in (sel_id, dm_info) + = do { uniq <- newUnique + ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name + ; local_meth_name <- newLocalName sel_name + -- Base the local_meth_name on the selector name, becuase + -- type errors from tcInstanceMethodBody come from here + + ; let local_meth_ty = instantiateMethod clas sel_id inst_tys + meth_ty = mkSigmaTy tyvars (map dictPred dfun_dicts) local_meth_ty + meth_id = mkLocalId meth_name meth_ty + local_meth_id = mkLocalId local_meth_name local_meth_ty + -------------- tc_body rn_bind = add_meth_ctxt rn_bind $ - do { (meth_id, tc_binds) <- tcInstanceMethodBody - InstSkol clas tyvars dfun_dicts theta inst_tys - mb_this_bind sel_id - local_meth_name - meth_sig_fn meth_prag_fn rn_bind - ; return (wrapId meth_wrapper meth_id, tc_binds) } - - ; case (findMethodBind sel_name local_meth_name binds_in, dm_info) of - -- There is a user-supplied method binding, so use it - (Just user_bind, _) -> tc_body user_bind + do { (meth_id1, spec_prags) <- tcPrags NonRecursive False True + meth_id (prag_fn sel_name) + ; tcInstanceMethodBody (instLoc this_dict) + tyvars dfun_dicts + ([this_dict], this_dict_bind) + meth_id1 local_meth_id + meth_sig_fn + (spec_inst_prags ++ spec_prags) + rn_bind } + -------------- + tc_default :: DefMeth -> TcM (Id, LHsBind Id) -- The user didn't supply a method binding, so we have to make -- up a default binding, in a way depending on the default-method info - (Nothing, GenDefMeth) -> do -- Derivable type classes stuff - { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id local_meth_name - ; tc_body meth_bind } - - (Nothing, NoDefMeth) -> do -- No default method in the class - { warn <- doptM Opt_WarnMissingMethods - ; warnTc (warn -- Warn only if -fwarn-missing-methods - && not (startsWithUnderscore (getOccName sel_id))) - -- Don't warn about _foo methods - omitted_meth_warn - ; return (error_rhs, emptyBag) } - - (Nothing, DefMeth) -> do -- An polymorphic default method - { -- Build the typechecked version directly, - -- without calling typecheck_method; - -- see Note [Default methods in instances] - dm_name <- lookupGlobalOccRn (mkDefMethRdrName sel_name) + tc_default NoDefMeth -- No default method at all + = do { warnMissingMethod sel_id + ; return (meth_id, mkVarBind meth_id $ + mkLHsWrap lam_wrapper error_rhs) } + + tc_default GenDefMeth -- Derivable type classes stuff + = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id local_meth_name + ; tc_body meth_bind } + + tc_default DefMeth -- An polymorphic default method + = do { -- Build the typechecked version directly, + -- without calling typecheck_method; + -- see Note [Default methods in instances] + -- Generate /\as.\ds. let this = df as ds + -- in $dm inst_tys this + -- The 'let' is necessary only because HsSyn doesn't allow + -- you to apply a function to a dictionary *expression*. + dm_name <- lookupGlobalOccRn (mkDefMethRdrName sel_name) -- Might not be imported, but will be an OrigName - ; dm_id <- tcLookupId dm_name - ; return (wrapId dm_wrapper dm_id, emptyBag) } } + ; dm_id <- tcLookupId dm_name + ; inline_id <- tcLookupId inlineIdName + ; let dm_inline_prag = idInlinePragma dm_id + dm_app = HsWrap (WpApp (instToId this_dict) <.> mkWpTyApps inst_tys) $ + HsVar dm_id + rhs | isInlinePragma dm_inline_prag -- See Note [INLINE and default methods] + = HsApp (L loc (HsWrap (WpTyApp local_meth_ty) (HsVar inline_id))) + (L loc dm_app) + | otherwise = dm_app + + meth_bind = L loc $ VarBind { var_id = local_meth_id + , var_rhs = L loc rhs + , var_inline = False } + meth_id1 = meth_id `setInlinePragma` dm_inline_prag + -- Copy the inline pragma (if any) from the default + -- method to this version. Note [INLINE and default methods] + + bind = AbsBinds { abs_tvs = tyvars, abs_dicts = dfun_lam_vars + , abs_exports = [( tyvars, meth_id1 + , local_meth_id, spec_inst_prags)] + , abs_binds = this_dict_bind `unionBags` unitBag meth_bind } + -- Default methods in an instance declaration can't have their own + -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but + -- currently they are rejected with + -- "INLINE pragma lacks an accompanying binding" + + ; return (meth_id1, L loc bind) } + + ; case findMethodBind sel_name local_meth_name binds_in of + Just user_bind -> tc_body user_bind -- User-supplied method binding + Nothing -> tc_default dm_info -- None supplied + } where sel_name = idName sel_id - sel_occ = nameOccName sel_name - this_dict_id = instToId this_dict - meth_prag_fn _ = prag_fn sel_name - meth_sig_fn _ = Just [] -- The 'Just' says "yes, there's a type sig" - -- But there are no scoped type variables from local_method_id - -- Only the ones from the instance decl itself, which are already - -- in scope. Example: - -- class C a where { op :: forall b. Eq b => ... } - -- instance C [c] where { op = } - -- In , 'c' is scope but 'b' is not! + meth_sig_fn _ = Just [] -- The 'Just' says "yes, there's a type sig" + -- But there are no scoped type variables from local_method_id + -- Only the ones from the instance decl itself, which are already + -- in scope. Example: + -- class C a where { op :: forall b. Eq b => ... } + -- instance C [c] where { op = } + -- In , 'c' is scope but 'b' is not! - error_rhs = HsApp error_fun error_msg + error_rhs = L loc $ HsApp error_fun error_msg error_fun = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID error_msg = L loc (HsLit (HsStringPrim (mkFastString error_string))) meth_tau = funResultTy (applyTys (idType sel_id) inst_tys) error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ]) - dm_wrapper = WpApp this_dict_id <.> mkWpTyApps inst_tys - - omitted_meth_warn :: SDoc - omitted_meth_warn = ptext (sLit "No explicit method nor default method for") - <+> quotes (ppr sel_id) - dfun_lam_vars = map instToVar dfun_dicts - meth_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys tyvars) + lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_lam_vars -- For instance decls that come from standalone deriving clauses -- we want to print out the full source code if there's an error @@ -925,29 +1064,89 @@ = vcat [ ptext (sLit "When typechecking a standalone-derived method for") <+> quotes (pprClassPred clas tys) <> colon , nest 2 $ pprSetDepth AllTheWay $ ppr bind ] + +warnMissingMethod :: Id -> TcM () +warnMissingMethod sel_id + = do { warn <- doptM Opt_WarnMissingMethods + ; warnTc (warn -- Warn only if -fwarn-missing-methods + && not (startsWithUnderscore (getOccName sel_id))) + -- Don't warn about _foo methods + (ptext (sLit "No explicit method nor default method for") + <+> quotes (ppr sel_id)) } \end{code} +Note [Export helper functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We arrange to export the "helper functions" of an instance declaration, +so that they are not subject to preInlineUnconditionally, even if their +RHS is trivial. Reason: they are mentioned in the DFunUnfolding of +the dict fun as Ids, not as CoreExprs, so we can't substitute a +non-variable for them. + +We could change this by making DFunUnfoldings have CoreExprs, but it +seems a bit simpler this way. + Note [Default methods in instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this class Baz v x where foo :: x -> x - foo y = y + foo y = instance Baz Int Int From the class decl we get $dmfoo :: forall v x. Baz v x => x -> x + $dmfoo y = Notice that the type is ambiguous. That's fine, though. The instance decl generates - $dBazIntInt = MkBaz ($dmfoo Int Int $dBazIntInt) + $dBazIntInt = MkBaz fooIntInt + fooIntInt = $dmfoo Int Int $dBazIntInt -BUT this does mean we must generate the dictionary translation directly, rather -than generating source-code and type-checking it. That was the bug ing -Trac #1061. In any case it's less work to generate the translated version! +BUT this does mean we must generate the dictionary translation of +fooIntInt directly, rather than generating source-code and +type-checking it. That was the bug in Trac #1061. In any case it's +less work to generate the translated version! + +Note [INLINE and default methods] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We *copy* any INLINE pragma from the default method to the instance. +Example: + class Foo a where + op1, op2 :: Bool -> a -> a + + {-# INLINE op1 #-} + op1 b x = op2 (not b) x + + instance Foo Int where + op2 b x = + +Then we generate: + + {-# INLINE $dmop1 #-} + $dmop1 d b x = op2 d (not b) x + + $fFooInt = MkD $cop1 $cop2 + + {-# INLINE $cop1 #-} + $cop1 = inline $dmop1 $fFooInt + + $cop2 = + +Note carefully: + a) We copy $dmop1's inline pragma to $cop1. Otherwise + we'll just inline the former in the latter and stop, which + isn't what the user expected + + b) We use the magic 'inline' Id to ensure that $dmop1 really is + inlined in $cop1, even though + (i) the latter itself has an INLINE pragma + (ii) $dmop1 is not saturated + That is important to allow the mutual recursion between $fooInt and + $cop1 to be broken %************************************************************************ @@ -967,7 +1166,7 @@ instDeclCtxt2 dfun_ty = inst_decl_ctxt (ppr (mkClassPred cls tys)) where - (_,_,cls,tys) = tcSplitDFunTy dfun_ty + (_,cls,tys) = tcSplitDFunTy dfun_ty inst_decl_ctxt :: SDoc -> SDoc inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc diff -ruN ghc-6.12.1/compiler/typecheck/TcMatches.lhs ghc-6.13.20091231/compiler/typecheck/TcMatches.lhs --- ghc-6.12.1/compiler/typecheck/TcMatches.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/typecheck/TcMatches.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -25,7 +25,6 @@ import TcBinds import TcUnify import TcSimplify -import MkCore import Name import TysWiredIn import PrelNames @@ -524,7 +523,7 @@ = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys - tup_ty = mkCoreTupTy tup_elt_tys + tup_ty = mkBoxedTupleTy tup_elt_tys ; tcExtendIdEnv tup_ids $ do { ((stmts', (ret_op', tup_rets)), stmts_ty) diff -ruN ghc-6.12.1/compiler/typecheck/TcRnDriver.lhs ghc-6.13.20091231/compiler/typecheck/TcRnDriver.lhs --- ghc-6.12.1/compiler/typecheck/TcRnDriver.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/typecheck/TcRnDriver.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -40,6 +40,7 @@ import TcExpr import TcRnMonad import TcType +import Coercion import Inst import FamInst import InstEnv @@ -74,6 +75,7 @@ import NameEnv import NameSet import TyCon +import TysPrim import TysWiredIn import SrcLoc import HscTypes @@ -176,6 +178,9 @@ tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ; traceRn (text "rn4b: after exportss") ; + -- Check that main is exported (must be after rnExports) + checkMainExported tcg_env ; + -- Compare the hi-boot iface (if any) with the real thing -- Must be done after processing the exports tcg_env <- checkHiBootIface tcg_env boot_iface ; @@ -555,6 +560,15 @@ -- Check the exports of the boot module, one by one ; mapM_ check_export boot_exports + -- Check instance declarations + ; mb_dfun_prs <- mapM check_inst boot_insts + ; let tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds, + tcg_type_env = extendTypeEnvWithIds local_type_env boot_dfuns } + dfun_prs = catMaybes mb_dfun_prs + boot_dfuns = map fst dfun_prs + dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun) + | (boot_dfun, dfun) <- dfun_prs ] + -- Check for no family instances ; unless (null boot_fam_insts) $ panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++ @@ -569,7 +583,7 @@ final_type_env = extendTypeEnvWithIds local_type_env boot_dfuns dfun_prs = catMaybes mb_dfun_prs boot_dfuns = map fst dfun_prs - dfun_binds = listToBag [ noLoc $ VarBind boot_dfun (nlHsVar dfun) + dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun) | (boot_dfun, dfun) <- dfun_prs ] ; failIfErrsM @@ -929,15 +943,16 @@ (mkTyConApp ioTyCon [res_ty]) ; co = mkWpTyApps [res_ty] ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr - ; main_bind = noLoc (VarBind root_main_id rhs) } + ; main_bind = mkVarBind root_main_id rhs } - ; return (tcg_env { tcg_binds = tcg_binds tcg_env + ; return (tcg_env { tcg_main = Just main_name, + tcg_binds = tcg_binds tcg_env `snocBag` main_bind, tcg_dus = tcg_dus tcg_env `plusDU` usesOnly (unitFV main_name) -- Record the use of 'main', so that we don't -- complain about it being defined but not used - }) + }) }}} where mod = tcg_mod tcg_env @@ -953,8 +968,13 @@ mainCtxt = ptext (sLit "When checking the type of the") <+> pp_main_fn noMainMsg = ptext (sLit "The") <+> pp_main_fn <+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod) - pp_main_fn | main_fn == main_RDR_Unqual = ptext (sLit "function") <+> quotes (ppr main_fn) - | otherwise = ptext (sLit "main function") <+> quotes (ppr main_fn) + pp_main_fn = ppMainFn main_fn + +ppMainFn main_fn + | main_fn == main_RDR_Unqual + = ptext (sLit "function") <+> quotes (ppr main_fn) + | otherwise + = ptext (sLit "main function") <+> quotes (ppr main_fn) -- | Get the unqualified name of the function to use as the \"main\" for the main module. -- Either returns the default name or the one configured on the command line with -main-is @@ -962,6 +982,17 @@ getMainFun dflags = case (mainFunIs dflags) of Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) Nothing -> main_RDR_Unqual + +checkMainExported :: TcGblEnv -> TcM () +checkMainExported tcg_env = do + dflags <- getDOpts + case tcg_main tcg_env of + Nothing -> return () -- not the main module + Just main_name -> do + let main_mod = mainModIs dflags + checkTc (main_name `elem` concatMap availNames (tcg_exports tcg_env)) $ + ptext (sLit "The") <+> ppMainFn (nameRdrName main_name) <+> + ptext (sLit "is not exported by module") <+> quotes (ppr main_mod) \end{code} Note [Root-main Id] @@ -1571,8 +1602,12 @@ where le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2 ppr_tycon tycon - | isCoercionTyCon tycon = ptext (sLit "coercion") <+> ppr tycon + | isCoercionTyCon tycon + = sep [ptext (sLit "coercion") <+> ppr tycon <+> ppr tvs + , nest 2 (dcolon <+> pprEqPred (coercionKind (mkTyConApp tycon (mkTyVarTys tvs))))] | otherwise = ppr (tyThingToIfaceDecl (ATyCon tycon)) + where + tvs = take (tyConArity tycon) alphaTyVars ppr_rules :: [CoreRule] -> SDoc ppr_rules [] = empty diff -ruN ghc-6.12.1/compiler/typecheck/TcRnMonad.lhs ghc-6.13.20091231/compiler/typecheck/TcRnMonad.lhs --- ghc-6.12.1/compiler/typecheck/TcRnMonad.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/typecheck/TcRnMonad.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -115,7 +115,8 @@ tcg_dfun_n = dfun_n_var, tcg_keep = keep_var, tcg_doc_hdr = Nothing, - tcg_hpc = False + tcg_hpc = False, + tcg_main = Nothing } ; lcl_env = TcLclEnv { tcl_errs = errs_var, diff -ruN ghc-6.12.1/compiler/typecheck/TcRnTypes.lhs ghc-6.13.20091231/compiler/typecheck/TcRnTypes.lhs --- ghc-6.12.1/compiler/typecheck/TcRnTypes.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/typecheck/TcRnTypes.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -247,8 +247,12 @@ tcg_fords :: [LForeignDecl Id], -- ...Foreign import & exports tcg_doc_hdr :: Maybe LHsDocString, -- ^ Maybe Haddock header docs - tcg_hpc :: AnyHpcUsage -- ^ @True@ if any part of the prog uses hpc - -- instrumentation. + tcg_hpc :: AnyHpcUsage, -- ^ @True@ if any part of the + -- prog uses hpc instrumentation. + + tcg_main :: Maybe Name -- ^ The Name of the main + -- function, if this module is + -- the main module. } data RecFieldEnv diff -ruN ghc-6.12.1/compiler/typecheck/TcRules.lhs ghc-6.13.20091231/compiler/typecheck/TcRules.lhs --- ghc-6.12.1/compiler/typecheck/TcRules.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/typecheck/TcRules.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -24,6 +24,22 @@ import FastString \end{code} +Note [Typechecking rules] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We *infer* the typ of the LHS, and use that type to *check* the type of +the RHS. That means that higher-rank rules work reasonably well. Here's +an example (test simplCore/should_compile/rule2.hs) produced by Roman: + + foo :: (forall m. m a -> m b) -> m a -> m b + foo f = ... + + bar :: (forall m. m a -> m a) -> m a -> m a + bar f = ... + + {-# RULES "foo/bar" foo = bar #-} + +He wanted the rule to typecheck. + \begin{code} tcRules :: [LRuleDecl Name] -> TcM [LRuleDecl TcId] tcRules decls = mapM (wrapLocM tcRule) decls @@ -32,15 +48,14 @@ tcRule (HsRule name act vars lhs fv_lhs rhs fv_rhs) = addErrCtxt (ruleCtxt name) $ do traceTc (ptext (sLit "---- Rule ------") <+> ppr name) - rule_ty <- newFlexiTyVarTy openTypeKind -- Deal with the tyvars mentioned in signatures - (ids, lhs', rhs', lhs_lie, rhs_lie) <- + (ids, lhs', rhs', lhs_lie, rhs_lie, rule_ty) <- tcRuleBndrs vars $ \ ids -> do - -- Now LHS and RHS - (lhs', lhs_lie) <- getLIE (tcMonoExpr lhs rule_ty) + -- Now LHS and RHS; see Note [Typechecking rules] + ((lhs', rule_ty), lhs_lie) <- getLIE (tcInferRho lhs) (rhs', rhs_lie) <- getLIE (tcMonoExpr rhs rule_ty) - return (ids, lhs', rhs', lhs_lie, rhs_lie) + return (ids, lhs', rhs', lhs_lie, rhs_lie, rule_ty) -- Check that LHS has no overloading at all (lhs_dicts, lhs_binds) <- tcSimplifyRuleLhs lhs_lie diff -ruN ghc-6.12.1/compiler/typecheck/TcSimplify.lhs ghc-6.13.20091231/compiler/typecheck/TcSimplify.lhs --- ghc-6.12.1/compiler/typecheck/TcSimplify.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/typecheck/TcSimplify.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -1018,16 +1018,17 @@ <.> mkWpTyApps eq_cotvs <.> mkWpTyApps (mkTyVarTys all_tvs) bind | [dict_irred_id] <- dict_irred_ids - = VarBind dict_irred_id rhs + = mkVarBind dict_irred_id rhs | otherwise - = PatBind { pat_lhs = lpat + = L span $ + PatBind { pat_lhs = lpat , pat_rhs = unguardedGRHSs rhs , pat_rhs_ty = hsLPatType lpat , bind_fvs = placeHolderNames } ; traceTc $ text "makeImplicationBind" <+> ppr implic_inst - ; return ([implic_inst], unitBag (L span bind)) + ; return ([implic_inst], unitBag bind) } ----------------------------------------------------------- @@ -1491,7 +1492,7 @@ -- (for example) squash {Monad (ST s)} into {}. It's not enough -- just to float all constraints -- - -- At top level, we *do* squash methods becuase we want to + -- At top level, we *do* squash methods because we want to -- expose implicit parameters to the test that follows ; let is_nested_group = isNotTopLevel top_lvl try_me inst | isFreeWrtTyVars qtvs inst, @@ -2381,11 +2382,7 @@ eq_cotvs = map instToVar extra_eq_givens dict_ids = map instToId extra_dict_givens - -- Note [Always inline implication constraints] - wrap_inline | null dict_ids = idHsWrapper - | otherwise = WpInline - co = wrap_inline - <.> mkWpTyLams tvs + co = mkWpTyLams tvs <.> mkWpTyLams eq_cotvs <.> mkWpLams dict_ids <.> WpLet (binds `unionBags` bind) @@ -2397,12 +2394,15 @@ . filter (not . isEqInst) $ wanteds payload = mkBigLHsTup dict_bndrs - ; traceTc (vcat [text "reduceImplication" <+> ppr name, ppr simpler_implic_insts, text "->" <+> ppr rhs]) - ; return (unitBag (L loc (VarBind (instToId orig_implic) rhs)), + ; return (unitBag (L loc (VarBind { var_id= instToId orig_implic + , var_rhs = rhs + , var_inline = notNull dict_ids } + -- See Note [Always inline implication constraints] + )), simpler_implic_insts) } } diff -ruN ghc-6.12.1/compiler/typecheck/TcSplice.lhs ghc-6.13.20091231/compiler/typecheck/TcSplice.lhs --- ghc-6.12.1/compiler/typecheck/TcSplice.lhs 2009-12-10 10:11:33.000000000 -0800 +++ ghc-6.13.20091231/compiler/typecheck/TcSplice.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -433,19 +433,22 @@ ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr meta_exp_ty) -- Run the expression - ; traceTc (text "About to run" <+> ppr zonked_q_expr) - ; expr2 <- runMetaE convertToHsExpr zonked_q_expr - - ; traceTc (text "Got result" <+> ppr expr2) - + ; expr2 <- runMetaE zonked_q_expr ; showSplice "expression" expr (ppr expr2) -- Rename it, but bale out if there are errors -- otherwise the type checker just gives more spurious errors - ; (exp3, _fvs) <- checkNoErrs (rnLExpr expr2) + ; addErrCtxt (spliceResultDoc expr) $ do + { (exp3, _fvs) <- checkNoErrs (rnLExpr expr2) + + ; exp4 <- tcMonoExpr exp3 res_ty + ; return (unLoc exp4) } } - ; exp4 <- tcMonoExpr exp3 res_ty - ; return (unLoc exp4) } +spliceResultDoc :: LHsExpr Name -> SDoc +spliceResultDoc expr + = sep [ ptext (sLit "In the result of the splice:") + , nest 2 (char '$' <> pprParendExpr expr) + , ptext (sLit "To see what the splice expanded to, use -ddump-splices")] ------------------- tcTopSpliceExpr :: TcM (LHsExpr Id) -> TcM (LHsExpr Id) @@ -521,20 +524,16 @@ ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr meta_ty) -- Run the expression - ; traceTc (text "About to run" <+> ppr zonked_q_expr) - ; hs_ty2 <- runMetaT convertToHsType zonked_q_expr - - ; traceTc (text "Got result" <+> ppr hs_ty2) - + ; hs_ty2 <- runMetaT zonked_q_expr ; showSplice "type" expr (ppr hs_ty2) - + -- Rename it, but bale out if there are errors -- otherwise the type checker just gives more spurious errors - ; let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2 + ; addErrCtxt (spliceResultDoc expr) $ do + { let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2 ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2) - ; (ty4, kind) <- kcLHsType hs_ty3 - ; return (unLoc ty4, kind) } + ; return (unLoc ty4, kind) }} \end{code} %************************************************************************ @@ -555,13 +554,10 @@ ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr list_q) -- Run the expression - ; traceTc (text "About to run" <+> ppr zonked_q_expr) - ; decls <- runMetaD convertToHsDecls zonked_q_expr - - ; traceTc (text "Got result" <+> vcat (map ppr decls)) - ; showSplice "declarations" - expr + ; decls <- runMetaD zonked_q_expr + ; showSplice "declarations" expr (ppr (getLoc expr) $$ (vcat (map ppr decls))) + ; return decls } \end{code} @@ -640,11 +636,10 @@ runQuasiQuote :: Outputable hs_syn => HsQuasiQuote Name -- Contains term of type QuasiQuoter, and the String -> Name -- Of type QuasiQuoter -> String -> Q th_syn - -> String -- Documentation string only -> Name -- Name of th_syn type - -> (SrcSpan -> th_syn -> Either Message hs_syn) + -> MetaOps th_syn hs_syn -> TcM hs_syn -runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector desc meta_ty convert +runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector meta_ty meta_ops = do { -- Check that the quoter is not locally defined, otherwise the TH -- machinery will not be able to run the quasiquote. ; this_mod <- getModule @@ -667,18 +662,13 @@ ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr meta_exp_ty) -- Run the expression - ; traceTc (text "About to run" <+> ppr zonked_q_expr) - ; result <- runMetaQ convert zonked_q_expr - ; traceTc (text "Got result" <+> ppr result) - ; showSplice desc quoteExpr (ppr result) - ; return result - } + ; result <- runMetaQ meta_ops zonked_q_expr + ; showSplice (mt_desc meta_ops) quoteExpr (ppr result) -runQuasiQuoteExpr quasiquote - = runQuasiQuote quasiquote quoteExpName "expression" expQTyConName convertToHsExpr + ; return result } -runQuasiQuotePat quasiquote - = runQuasiQuote quasiquote quotePatName "pattern" patQTyConName convertToPat +runQuasiQuoteExpr quasiquote = runQuasiQuote quasiquote quoteExpName expQTyConName exprMetaOps +runQuasiQuotePat quasiquote = runQuasiQuote quasiquote quotePatName patQTyConName patMetaOps quoteStageError :: Name -> SDoc quoteStageError quoter @@ -694,51 +684,70 @@ %************************************************************************ \begin{code} -runMetaAW :: (AnnotationWrapper -> output) +data MetaOps th_syn hs_syn + = MT { mt_desc :: String -- Type of beast (expression, type etc) + , mt_show :: th_syn -> String -- How to show the th_syn thing + , mt_cvt :: SrcSpan -> th_syn -> Either Message hs_syn + -- How to convert to hs_syn + } + +exprMetaOps :: MetaOps TH.Exp (LHsExpr RdrName) +exprMetaOps = MT { mt_desc = "expression", mt_show = TH.pprint, mt_cvt = convertToHsExpr } + +patMetaOps :: MetaOps TH.Pat (LPat RdrName) +patMetaOps = MT { mt_desc = "pattern", mt_show = TH.pprint, mt_cvt = convertToPat } + +typeMetaOps :: MetaOps TH.Type (LHsType RdrName) +typeMetaOps = MT { mt_desc = "type", mt_show = TH.pprint, mt_cvt = convertToHsType } + +declMetaOps :: MetaOps [TH.Dec] [LHsDecl RdrName] +declMetaOps = MT { mt_desc = "declarations", mt_show = TH.pprint, mt_cvt = convertToHsDecls } + +---------------- +runMetaAW :: Outputable output + => (AnnotationWrapper -> output) -> LHsExpr Id -- Of type AnnotationWrapper -> TcM output runMetaAW k = runMeta False (\_ -> return . Right . k) -- We turn off showing the code in meta-level exceptions because doing so exposes -- the toAnnotationWrapper function that we slap around the users code -runQThen :: (SrcSpan -> input -> Either Message output) - -> SrcSpan - -> TH.Q input - -> TcM (Either Message output) -runQThen f expr_span what = TH.runQ what >>= (return . f expr_span) - -runMetaQ :: (SrcSpan -> input -> Either Message output) +----------------- +runMetaQ :: Outputable hs_syn + => MetaOps th_syn hs_syn -> LHsExpr Id - -> TcM output -runMetaQ = runMeta True . runQThen + -> TcM hs_syn +runMetaQ (MT { mt_show = show_th, mt_cvt = cvt }) expr + = runMeta True run_and_cvt expr + where + run_and_cvt expr_span hval + = do { th_result <- TH.runQ hval + ; traceTc (text "Got TH result:" <+> text (show_th th_result)) + ; return (cvt expr_span th_result) } -runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName)) - -> LHsExpr Id -- Of type (Q Exp) +runMetaE :: LHsExpr Id -- Of type (Q Exp) -> TcM (LHsExpr RdrName) -runMetaE = runMetaQ +runMetaE = runMetaQ exprMetaOps -runMetaP :: (SrcSpan -> TH.Pat -> Either Message (Pat RdrName)) - -> LHsExpr Id -- Of type (Q Pat) - -> TcM (Pat RdrName) -runMetaP = runMetaQ - -runMetaT :: (SrcSpan -> TH.Type -> Either Message (LHsType RdrName)) - -> LHsExpr Id -- Of type (Q Type) +runMetaT :: LHsExpr Id -- Of type (Q Type) -> TcM (LHsType RdrName) -runMetaT = runMetaQ +runMetaT = runMetaQ typeMetaOps -runMetaD :: (SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName]) - -> LHsExpr Id -- Of type Q [Dec] +runMetaD :: LHsExpr Id -- Of type Q [Dec] -> TcM [LHsDecl RdrName] -runMetaD = runMetaQ +runMetaD = runMetaQ declMetaOps -runMeta :: Bool -- Whether code should be printed in the exception message - -> (SrcSpan -> input -> TcM (Either Message output)) - -> LHsExpr Id -- Of type X - -> TcM output -- Of type t +--------------- +runMeta :: (Outputable hs_syn) + => Bool -- Whether code should be printed in the exception message + -> (SrcSpan -> x -> TcM (Either Message hs_syn)) -- How to run x + -> LHsExpr Id -- Of type x; typically x = Q TH.Exp, or something like that + -> TcM hs_syn -- Of type t runMeta show_code run_and_convert expr - = do { -- Desugar - ds_expr <- initDsTc (dsLExpr expr) + = do { traceTc (text "About to run" <+> ppr expr) + + -- Desugar + ; ds_expr <- initDsTc (dsLExpr expr) -- Compile and link it; might fail if linking fails ; hsc_env <- getTopEnv ; src_span <- getSrcSpanM @@ -766,15 +775,14 @@ do { mb_result <- run_and_convert expr_span (unsafeCoerce# hval) ; case mb_result of Left err -> failWithTc err - Right result -> return $! result } + Right result -> do { traceTc (ptext (sLit "Got HsSyn result:") <+> ppr result) + ; return $! result } } ; case either_tval of Right v -> return v - Left se -> - case fromException se of - Just IOEnvFailure -> - failM -- Error already in Tc monad - _ -> failWithTc (mk_msg "run" se) -- Exception + Left se -> case fromException se of + Just IOEnvFailure -> failM -- Error already in Tc monad + _ -> failWithTc (mk_msg "run" se) -- Exception }}} where mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:", @@ -963,8 +971,8 @@ ; fix <- reifyFixity (idName id) ; let v = reifyName id ; case idDetails id of - ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix) - _ -> return (TH.VarI v ty Nothing fix) + ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix) + _ -> return (TH.VarI v ty Nothing fix) } reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc diff -ruN ghc-6.12.1/compiler/typecheck/TcType.lhs ghc-6.13.20091231/compiler/typecheck/TcType.lhs --- ghc-6.12.1/compiler/typecheck/TcType.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/typecheck/TcType.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -643,7 +643,6 @@ These tcSplit functions are like their non-Tc analogues, but a) they do not look through newtypes b) they do not look through PredTys - c) [future] they ignore usage-type annotations However, they are non-monadic and do not follow through mutable type variables. It's up to you to make sure this doesn't matter. @@ -804,18 +803,29 @@ tcIsTyVarTy ty = maybeToBool (tcGetTyVar_maybe ty) ----------------------- -tcSplitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type]) +tcSplitDFunTy :: Type -> ([TyVar], Class, [Type]) -- Split the type of a dictionary function +-- We don't use tcSplitSigmaTy, because a DFun may (with NDP) +-- have non-Pred arguments, such as +-- df :: forall m. (forall b. Eq b => Eq (m b)) -> C m tcSplitDFunTy ty - = case tcSplitSigmaTy ty of { (tvs, theta, tau) -> - case tcSplitDFunHead tau of { (clas, tys) -> - (tvs, theta, clas, tys) }} + = case tcSplitForAllTys ty of { (tvs, rho) -> + case tcSplitDFunHead (drop_pred_tys rho) of { (clas, tys) -> + (tvs, clas, tys) }} + where + -- Discard the context of the dfun. This can be a mix of + -- coercion and class constraints; or (in the general NDP case) + -- some other function argument + drop_pred_tys ty | Just ty' <- tcView ty = drop_pred_tys ty' + drop_pred_tys (ForAllTy tv ty) = ASSERT( isCoVar tv ) drop_pred_tys ty + drop_pred_tys (FunTy _ ty) = drop_pred_tys ty + drop_pred_tys ty = ty tcSplitDFunHead :: Type -> (Class, [Type]) tcSplitDFunHead tau = case tcSplitPredTy_maybe tau of Just (ClassP clas tys) -> (clas, tys) - _ -> panic "tcSplitDFunHead" + _ -> pprPanic "tcSplitDFunHead" (ppr tau) tcInstHeadTyNotSynonym :: Type -> Bool -- Used in Haskell-98 mode, for the argument types of an instance head diff -ruN ghc-6.12.1/compiler/typecheck/TcUnify.lhs ghc-6.13.20091231/compiler/typecheck/TcUnify.lhs --- ghc-6.12.1/compiler/typecheck/TcUnify.lhs 2009-12-10 10:11:33.000000000 -0800 +++ ghc-6.13.20091231/compiler/typecheck/TcUnify.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -1213,29 +1213,6 @@ identicalOpenSynTyConApp = idxTys1 `tcEqTypes` idxTys2 -- See Note [OpenSynTyCon app] - -- If we can reduce a family app => proceed with reduct - -- NB: We use isOpenSynTyCon, not isOpenSynTyConApp as we also must - -- defer oversaturated applications! - go outer sty1 ty1@(TyConApp con1 _) sty2 ty2 - | isOpenSynTyCon con1 - = do { (coi1, ty1') <- tcNormaliseFamInst ty1 - ; case coi1 of - IdCo -> defer -- no reduction, see [Deferred Unification] - _ -> liftM (coi1 `mkTransCoI`) $ go outer sty1 ty1' sty2 ty2 - } - - -- If we can reduce a family app => proceed with reduct - -- NB: We use isOpenSynTyCon, not isOpenSynTyConApp as we also must - -- defer oversaturated applications! - go outer sty1 ty1 sty2 ty2@(TyConApp con2 _) - | isOpenSynTyCon con2 - = do { (coi2, ty2') <- tcNormaliseFamInst ty2 - ; case coi2 of - IdCo -> defer -- no reduction, see [Deferred Unification] - _ -> liftM (`mkTransCoI` mkSymCoI coi2) $ - go outer sty1 ty1 sty2 ty2' - } - -- Functions; just check the two parts go _ _ (FunTy fun1 arg1) _ (FunTy fun2 arg2) = do { coi_l <- uTys nb1 fun1 nb2 fun2 @@ -1261,6 +1238,30 @@ ; coi_t <- uTys nb1 t1 nb2 t2 ; return $ mkAppTyCoI s1 coi_s t1 coi_t } + -- If we can reduce a family app => proceed with reduct + -- NB1: We use isOpenSynTyCon, not isOpenSynTyConApp as we also must + -- defer oversaturated applications! + -- + -- NB2: Do this *after* trying decomposing applications, so that decompose + -- (m a) ~ (F Int b) + -- where F has arity 1 + go _ _ ty1@(TyConApp con1 _) _ ty2 + | isOpenSynTyCon con1 + = do { (coi1, ty1') <- tcNormaliseFamInst ty1 + ; case coi1 of + IdCo -> defer -- no reduction, see [Deferred Unification] + _ -> liftM (coi1 `mkTransCoI`) $ uTys nb1 ty1' nb2 ty2 + } + + go _ _ ty1 _ ty2@(TyConApp con2 _) + | isOpenSynTyCon con2 + = do { (coi2, ty2') <- tcNormaliseFamInst ty2 + ; case coi2 of + IdCo -> defer -- no reduction, see [Deferred Unification] + _ -> liftM (`mkTransCoI` mkSymCoI coi2) $ + uTys nb1 ty1 nb2 ty2' + } + -- Anything else fails go outer _ _ _ _ = bale_out outer diff -ruN ghc-6.12.1/compiler/types/Coercion.lhs ghc-6.13.20091231/compiler/types/Coercion.lhs --- ghc-6.12.1/compiler/types/Coercion.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/types/Coercion.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -3,7 +3,6 @@ % \begin{code} -{-# OPTIONS -fno-warn-incomplete-patterns #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See @@ -21,8 +20,8 @@ -- * Main data type Coercion, - mkCoKind, mkReflCoKind, splitCoercionKind_maybe, splitCoercionKind, - coercionKind, coercionKinds, coercionKindPredTy, isIdentityCoercion, + mkCoKind, mkCoPredTy, coVarKind, coVarKind_maybe, + coercionKind, coercionKinds, isIdentityCoercion, -- ** Equality predicates isEqPred, mkEqPred, getEqPredTys, isEqPredTy, @@ -30,19 +29,27 @@ -- ** Coercion transformations mkCoercion, mkSymCoercion, mkTransCoercion, - mkLeftCoercion, mkRightCoercion, mkRightCoercions, + mkLeftCoercion, mkRightCoercion, mkInstCoercion, mkAppCoercion, mkTyConCoercion, mkFunCoercion, mkForAllCoercion, mkInstsCoercion, mkUnsafeCoercion, mkNewTypeCoercion, mkFamInstCoercion, mkAppsCoercion, + mkCsel1Coercion, mkCsel2Coercion, mkCselRCoercion, splitNewTypeRepCo_maybe, instNewTyCon_maybe, decomposeCo, unsafeCoercionTyCon, symCoercionTyCon, transCoercionTyCon, leftCoercionTyCon, rightCoercionTyCon, instCoercionTyCon, -- needed by TysWiredIn + csel1CoercionTyCon, csel2CoercionTyCon, cselRCoercionTyCon, + + -- ** Decomposition + decompLR_maybe, decompCsel_maybe, decompInst_maybe, + + -- ** Optimisation + optCoercion, -- ** Comparison - coreEqCoercion, + coreEqCoercion, coreEqCoercion2, -- * CoercionI CoercionI(..), @@ -62,10 +69,13 @@ import TyCon import Class import Var +import VarEnv import Name import PrelNames import Util +import Control.Monad import BasicTypes +import MonadUtils import Outputable import FastString @@ -95,6 +105,40 @@ ------------------------------------------------------- -- and some coercion kind stuff +coVarKind :: CoVar -> (Type,Type) +-- c :: t1 ~ t2 +coVarKind cv = case coVarKind_maybe cv of + Just ts -> ts + Nothing -> pprPanic "coVarKind" (ppr cv $$ ppr (tyVarKind cv)) + +coVarKind_maybe :: CoVar -> Maybe (Type,Type) +coVarKind_maybe cv = splitCoKind_maybe (tyVarKind cv) + +-- | Take a 'CoercionKind' apart into the two types it relates: see also 'mkCoKind'. +-- Panics if the argument is not a valid 'CoercionKind' +splitCoKind_maybe :: Kind -> Maybe (Type, Type) +splitCoKind_maybe co | Just co' <- kindView co = splitCoKind_maybe co' +splitCoKind_maybe (PredTy (EqPred ty1 ty2)) = Just (ty1, ty2) +splitCoKind_maybe _ = Nothing + +-- | Makes a 'CoercionKind' from two types: the types whose equality +-- is proven by the relevant 'Coercion' +mkCoKind :: Type -> Type -> CoercionKind +mkCoKind ty1 ty2 = PredTy (EqPred ty1 ty2) + +-- | (mkCoPredTy s t r) produces the type: (s~t) => r +mkCoPredTy :: Type -> Type -> Type -> Type +mkCoPredTy s t r = ForAllTy (mkWildCoVar (mkCoKind s t)) r + +splitCoPredTy_maybe :: Type -> Maybe (Type, Type, Type) +splitCoPredTy_maybe ty + | Just (cv,r) <- splitForAllTy_maybe ty + , isCoVar cv + , Just (s,t) <- coVarKind_maybe cv + = Just (s,t,r) + | otherwise + = Nothing + -- | Tests whether a type is just a type equality predicate isEqPredTy :: Type -> Bool isEqPredTy (PredTy pred) = isEqPred pred @@ -110,46 +154,29 @@ getEqPredTys (EqPred ty1 ty2) = (ty1, ty2) getEqPredTys other = pprPanic "getEqPredTys" (ppr other) --- | Makes a 'CoercionKind' from two types: the types whose equality is proven by the relevant 'Coercion' -mkCoKind :: Type -> Type -> CoercionKind -mkCoKind ty1 ty2 = PredTy (EqPred ty1 ty2) - --- | Create a reflexive 'CoercionKind' that asserts that a type can be coerced to itself -mkReflCoKind :: Type -> CoercionKind -mkReflCoKind ty = mkCoKind ty ty - --- | Take a 'CoercionKind' apart into the two types it relates: see also 'mkCoKind'. --- Panics if the argument is not a valid 'CoercionKind' -splitCoercionKind :: CoercionKind -> (Type, Type) -splitCoercionKind co | Just co' <- kindView co = splitCoercionKind co' -splitCoercionKind (PredTy (EqPred ty1 ty2)) = (ty1, ty2) - --- | Take a 'CoercionKind' apart into the two types it relates, if possible. See also 'splitCoercionKind' -splitCoercionKind_maybe :: Kind -> Maybe (Type, Type) -splitCoercionKind_maybe co | Just co' <- kindView co = splitCoercionKind_maybe co' -splitCoercionKind_maybe (PredTy (EqPred ty1 ty2)) = Just (ty1, ty2) -splitCoercionKind_maybe _ = Nothing - -- | If it is the case that -- -- > c :: (t1 ~ t2) -- -- i.e. the kind of @c@ is a 'CoercionKind' relating @t1@ and @t2@, then @coercionKind c = (t1, t2)@. --- See also 'coercionKindPredTy' coercionKind :: Coercion -> (Type, Type) -coercionKind ty@(TyVarTy a) | isCoVar a = splitCoercionKind (tyVarKind a) +coercionKind ty@(TyVarTy a) | isCoVar a = coVarKind a | otherwise = (ty, ty) coercionKind (AppTy ty1 ty2) - = let (t1, t2) = coercionKind ty1 - (s1, s2) = coercionKind ty2 in - (mkAppTy t1 s1, mkAppTy t2 s2) -coercionKind (TyConApp tc args) + = let (s1, t1) = coercionKind ty1 + (s2, t2) = coercionKind ty2 in + (mkAppTy s1 s2, mkAppTy t1 t2) +coercionKind co@(TyConApp tc args) | Just (ar, rule) <- isCoercionTyCon_maybe tc -- CoercionTyCons carry their kinding rule, so we use it here - = ASSERT( length args >= ar ) -- Always saturated - let (ty1,ty2) = rule (take ar args) -- Apply the rule to the right number of args - (tys1, tys2) = coercionKinds (drop ar args) - in (mkAppTys ty1 tys1, mkAppTys ty2 tys2) + = WARN( not (length args >= ar), ppr co ) -- Always saturated + (let (ty1,ty2) = runID (rule (return . typeKind) + (return . coercionKind) + False (take ar args)) + -- Apply the rule to the right number of args + -- Always succeeds (if term is well-kinded!) + (tys1, tys2) = coercionKinds (drop ar args) + in (mkAppTys ty1 tys1, mkAppTys ty2 tys2)) | otherwise = let (lArgs, rArgs) = coercionKinds args in @@ -158,13 +185,40 @@ = let (t1, t2) = coercionKind ty1 (s1, s2) = coercionKind ty2 in (mkFunTy t1 s1, mkFunTy t2 s2) -coercionKind (ForAllTy tv ty) + +coercionKind (ForAllTy tv ty) + | isCoVar tv +-- c1 :: s1~s2 c2 :: t1~t2 c3 :: r1~r2 +-- ---------------------------------------------- +-- c1~c2 => c3 :: (s1~t1) => r1 ~ (s2~t2) => r2 +-- or +-- forall (_:c1~c2) + = let (c1,c2) = coVarKind tv + (s1,s2) = coercionKind c1 + (t1,t2) = coercionKind c2 + (r1,r2) = coercionKind ty + in + (mkCoPredTy s1 t1 r1, mkCoPredTy s2 t2 r2) + + | otherwise +-- c1 :: s1~s2 c2 :: t1~t2 c3 :: r1~r2 +-- ---------------------------------------------- +-- forall a:k. c :: forall a:k. t1 ~ forall a:k. t2 = let (ty1, ty2) = coercionKind ty in (ForAllTy tv ty1, ForAllTy tv ty2) + coercionKind (PredTy (EqPred c1 c2)) - = let k1 = coercionKindPredTy c1 + = pprTrace "coercionKind" (pprEqPred (c1,c2)) $ + let k1 = coercionKindPredTy c1 k2 = coercionKindPredTy c2 in (k1,k2) + -- These should not show up in coercions at all + -- becuase they are in the form of for-alls + where + coercionKindPredTy c = let (t1, t2) = coercionKind c in mkCoKind t1 t2 + + + coercionKind (PredTy (ClassP cl args)) = let (lArgs, rArgs) = coercionKinds args in (PredTy (ClassP cl lArgs), PredTy (ClassP cl rArgs)) @@ -172,11 +226,6 @@ = let (ty1, ty2) = coercionKind ty in (PredTy (IParam name ty1), PredTy (IParam name ty2)) --- | Recover the 'CoercionKind' corresponding to a particular 'Coerceion'. See also 'coercionKind' --- and 'mkCoKind' -coercionKindPredTy :: Coercion -> CoercionKind -coercionKindPredTy c = let (t1, t2) = coercionKind c in mkCoKind t1 t2 - -- | Apply 'coercionKind' to multiple 'Coercion's coercionKinds :: [Coercion] -> ([Type], [Type]) coercionKinds tys = unzip $ map coercionKind tys @@ -186,11 +235,17 @@ isIdentityCoercion co = case coercionKind co of (t1,t2) -> t1 `coreEqType` t2 +\end{code} -------------------------------------- --- Coercion kind and type mk's --- (make saturated TyConApp CoercionTyCon{...} args) +%************************************************************************ +%* * + Building coercions +%* * +%************************************************************************ + +Coercion kind and type mk's (make saturated TyConApp CoercionTyCon{...} args) +\begin{code} -- | Make a coercion from the specified coercion 'TyCon' and the 'Type' arguments to -- that coercion. Try to use the @mk*Coercion@ family of functions instead of using this function -- if possible @@ -228,167 +283,41 @@ -- ^ Create a symmetric version of the given 'Coercion' that asserts equality -- between the same types but in the other "direction", so a kind of @t1 ~ t2@ -- becomes the kind @t2 ~ t1@. --- --- This function attempts to simplify the generated 'Coercion' by removing --- redundant applications of @sym@. This is done by pushing this new @sym@ --- down into the 'Coercion' and exploiting the fact that @sym (sym co) = co@. -mkSymCoercion co - | Just co' <- coreView co = mkSymCoercion co' - -mkSymCoercion (ForAllTy tv ty) = ForAllTy tv (mkSymCoercion ty) -mkSymCoercion (AppTy co1 co2) = AppTy (mkSymCoercion co1) (mkSymCoercion co2) -mkSymCoercion (FunTy co1 co2) = FunTy (mkSymCoercion co1) (mkSymCoercion co2) - -mkSymCoercion (TyConApp tc cos) - | not (isCoercionTyCon tc) = mkTyConApp tc (map mkSymCoercion cos) - -mkSymCoercion (TyConApp tc [co]) - | tc `hasKey` symCoercionTyConKey = co -- sym (sym co) --> co - | tc `hasKey` leftCoercionTyConKey = mkLeftCoercion (mkSymCoercion co) - | tc `hasKey` rightCoercionTyConKey = mkRightCoercion (mkSymCoercion co) - -mkSymCoercion (TyConApp tc [co1,co2]) - | tc `hasKey` transCoercionTyConKey - -- sym (co1 `trans` co2) --> (sym co2) `trans (sym co2) - -- Note reversal of arguments! - = mkTransCoercion (mkSymCoercion co2) (mkSymCoercion co1) - - | tc `hasKey` instCoercionTyConKey - -- sym (co @ ty) --> (sym co) @ ty - -- Note: sym is not applied to 'ty' - = mkInstCoercion (mkSymCoercion co1) co2 - -mkSymCoercion (TyConApp tc cos) -- Other coercion tycons, such as those - = mkCoercion symCoercionTyCon [TyConApp tc cos] -- arising from newtypes - -mkSymCoercion (TyVarTy tv) - | isCoVar tv = mkCoercion symCoercionTyCon [TyVarTy tv] - | otherwise = TyVarTy tv -- Reflexive - -------------------------------- --- ToDo: we should be cleverer about transitivity +mkSymCoercion g = mkCoercion symCoercionTyCon [g] mkTransCoercion :: Coercion -> Coercion -> Coercion -- ^ Create a new 'Coercion' by exploiting transitivity on the two given 'Coercion's. --- --- This function attempts to simplify the generated 'Coercion' by exploiting the fact that --- @sym g `trans` g = id@. -mkTransCoercion g1 g2 -- sym g `trans` g = id - | (t1,_) <- coercionKind g1 - , (_,t2) <- coercionKind g2 - , t1 `coreEqType` t2 - = t1 - - | otherwise - = mkCoercion transCoercionTyCon [g1, g2] - - -------------------------------- --- Smart constructors for left and right +mkTransCoercion g1 g2 = mkCoercion transCoercionTyCon [g1, g2] mkLeftCoercion :: Coercion -> Coercion -- ^ From an application 'Coercion' build a 'Coercion' that asserts the equality of -- the "functions" on either side of the type equality. So if @c@ has kind @f x ~ g y@ then: -- -- > mkLeftCoercion c :: f ~ g -mkLeftCoercion co - | Just (co', _) <- splitAppCoercion_maybe co = co' - | otherwise = mkCoercion leftCoercionTyCon [co] +mkLeftCoercion co = mkCoercion leftCoercionTyCon [co] mkRightCoercion :: Coercion -> Coercion -- ^ From an application 'Coercion' build a 'Coercion' that asserts the equality of -- the "arguments" on either side of the type equality. So if @c@ has kind @f x ~ g y@ then: -- -- > mkLeftCoercion c :: x ~ y -mkRightCoercion co - | Just (_, co2) <- splitAppCoercion_maybe co = co2 - | otherwise = mkCoercion rightCoercionTyCon [co] - -mkRightCoercions :: Int -> Coercion -> [Coercion] --- ^ As 'mkRightCoercion', but finds the 'Coercion's available on the right side of @n@ --- nested application 'Coercion's, manufacturing new left or right cooercions as necessary --- if suffficiently many are not directly available. -mkRightCoercions n co - = go n co [] - where - go n co acc - | n > 0 - = case splitAppCoercion_maybe co of - Just (co1,co2) -> go (n-1) co1 (co2:acc) - Nothing -> go (n-1) (mkCoercion leftCoercionTyCon [co]) (mkCoercion rightCoercionTyCon [co]:acc) - | otherwise - = acc +mkRightCoercion co = mkCoercion rightCoercionTyCon [co] +mkCsel1Coercion, mkCsel2Coercion, mkCselRCoercion :: Coercion -> Coercion +mkCsel1Coercion co = mkCoercion csel1CoercionTyCon [co] +mkCsel2Coercion co = mkCoercion csel2CoercionTyCon [co] +mkCselRCoercion co = mkCoercion cselRCoercionTyCon [co] +------------------------------- mkInstCoercion :: Coercion -> Type -> Coercion -- ^ Instantiates a 'Coercion' with a 'Type' argument. If possible, it immediately performs -- the resulting beta-reduction, otherwise it creates a suspended instantiation. -mkInstCoercion co ty - | Just (tv,co') <- splitForAllTy_maybe co - = substTyWith [tv] [ty] co' -- (forall a.co) @ ty --> co[ty/a] - | otherwise - = mkCoercion instCoercionTyCon [co, ty] +mkInstCoercion co ty = mkCoercion instCoercionTyCon [co, ty] mkInstsCoercion :: Coercion -> [Type] -> Coercion -- ^ As 'mkInstCoercion', but instantiates the coercion with a number of type arguments, left-to-right mkInstsCoercion co tys = foldl mkInstCoercion co tys -{- -splitSymCoercion_maybe :: Coercion -> Maybe Coercion -splitSymCoercion_maybe (TyConApp tc [co]) = - if tc `hasKey` symCoercionTyConKey - then Just co - else Nothing -splitSymCoercion_maybe co = Nothing --} - -splitAppCoercion_maybe :: Coercion -> Maybe (Coercion, Coercion) --- ^ Splits a coercion application, being careful *not* to split @left c@ etc. --- This is because those are really syntactic constructs, not applications -splitAppCoercion_maybe co | Just co' <- coreView co = splitAppCoercion_maybe co' -splitAppCoercion_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2) -splitAppCoercion_maybe (AppTy ty1 ty2) = Just (ty1, ty2) -splitAppCoercion_maybe (TyConApp tc tys) - | not (isCoercionTyCon tc) - = case snocView tys of - Just (tys', ty') -> Just (TyConApp tc tys', ty') - Nothing -> Nothing -splitAppCoercion_maybe _ = Nothing - -{- -splitTransCoercion_maybe :: Coercion -> Maybe (Coercion, Coercion) -splitTransCoercion_maybe (TyConApp tc [ty1, ty2]) - = if tc `hasKey` transCoercionTyConKey then - Just (ty1, ty2) - else - Nothing -splitTransCoercion_maybe other = Nothing - -splitInstCoercion_maybe :: Coercion -> Maybe (Coercion, Type) -splitInstCoercion_maybe (TyConApp tc [ty1, ty2]) - = if tc `hasKey` instCoercionTyConKey then - Just (ty1, ty2) - else - Nothing -splitInstCoercion_maybe other = Nothing - -splitLeftCoercion_maybe :: Coercion -> Maybe Coercion -splitLeftCoercion_maybe (TyConApp tc [co]) - = if tc `hasKey` leftCoercionTyConKey then - Just co - else - Nothing -splitLeftCoercion_maybe other = Nothing - -splitRightCoercion_maybe :: Coercion -> Maybe Coercion -splitRightCoercion_maybe (TyConApp tc [co]) - = if tc `hasKey` rightCoercionTyConKey then - Just co - else - Nothing -splitRightCoercion_maybe other = Nothing --} - -- | Manufacture a coercion from this air. Needless to say, this is not usually safe, -- but it is used when we know we are dealing with bottom, which is one case in which -- it is safe. This is also used implement the @unsafeCoerce#@ primitive. @@ -409,8 +338,12 @@ where co_con_arity = length tvs - rule args = ASSERT( co_con_arity == length args ) - (TyConApp tycon args, substTyWith tvs args rhs_ty) + rule :: CoTyConKindChecker + rule kc_ty _kc_co checking args + = do { ks <- mapM kc_ty args + ; unless (not checking || kindAppOk (tyConKind tycon) ks) + (fail "Argument kind mis-match") + ; return (TyConApp tycon args, substTyWith tvs args rhs_ty) } -- | Create a coercion identifying a @data@, @newtype@ or @type@ representation type -- and its family instance. It has the form @Co tvs :: F ts ~ R tvs@, where @Co@ is @@ -426,110 +359,191 @@ = mkCoercionTyCon name coArity rule where coArity = length tvs - rule args = (substTyWith tvs args $ -- with sigma = [tys/tvs], - TyConApp family instTys, -- sigma (F ts) - TyConApp rep_tycon args) -- ~ R tys --------------------------------------- --- Coercion Type Constructors... + rule :: CoTyConKindChecker + rule kc_ty _kc_co checking args + = do { ks <- mapM kc_ty args + ; unless (not checking || kindAppOk (tyConKind rep_tycon) ks) + (fail "Argument kind mis-match") + ; return (substTyWith tvs args $ -- with sigma = [tys/tvs], + TyConApp family instTys -- sigma (F ts) + , TyConApp rep_tycon args) } -- ~ R tys + +kindAppOk :: Kind -> [Kind] -> Bool +kindAppOk _ [] = True +kindAppOk kfn (k:ks) + = case splitKindFunTy_maybe kfn of + Just (kfa, kfb) | k `isSubKind` kfa -> kindAppOk kfb ks + _other -> False +\end{code} --- Example. The coercion ((sym c) (sym d) (sym e)) --- will be represented by (TyConApp sym [c, sym d, sym e]) --- If sym c :: p1=q1 --- sym d :: p2=q2 --- sym e :: p3=q3 --- then ((sym c) (sym d) (sym e)) :: (p1 p2 p3)=(q1 q2 q3) - --- | Coercion type constructors: avoid using these directly and instead use the @mk*Coercion@ and @split*Coercion@ family --- of functions if possible. -symCoercionTyCon, transCoercionTyCon, leftCoercionTyCon, rightCoercionTyCon, instCoercionTyCon, unsafeCoercionTyCon :: TyCon + +%************************************************************************ +%* * + Coercion Type Constructors +%* * +%************************************************************************ + +Example. The coercion ((sym c) (sym d) (sym e)) +will be represented by (TyConApp sym [c, sym d, sym e]) +If sym c :: p1=q1 + sym d :: p2=q2 + sym e :: p3=q3 +then ((sym c) (sym d) (sym e)) :: (p1 p2 p3)=(q1 q2 q3) + +\begin{code} +-- | Coercion type constructors: avoid using these directly and instead use +-- the @mk*Coercion@ and @split*Coercion@ family of functions if possible. +-- -- Each coercion TyCon is built with the special CoercionTyCon record and -- carries its own kinding rule. Such CoercionTyCons must be fully applied -- by any TyConApp in which they are applied, however they may also be over -- applied (see example above) and the kinding function must deal with this. -symCoercionTyCon = - mkCoercionTyCon symCoercionTyConName 1 flipCoercionKindOf +symCoercionTyCon, transCoercionTyCon, leftCoercionTyCon, + rightCoercionTyCon, instCoercionTyCon, unsafeCoercionTyCon, + csel1CoercionTyCon, csel2CoercionTyCon, cselRCoercionTyCon :: TyCon + +symCoercionTyCon + = mkCoercionTyCon symCoercionTyConName 1 kc_sym where - flipCoercionKindOf (co:rest) = ASSERT( null rest ) (ty2, ty1) - where - (ty1, ty2) = coercionKind co - -transCoercionTyCon = - mkCoercionTyCon transCoercionTyConName 2 composeCoercionKindsOf - where - composeCoercionKindsOf (co1:co2:rest) - = ASSERT( null rest ) - WARN( not (r1 `coreEqType` a2), - text "Strange! Type mismatch in trans coercion, probably a bug" - $$ - ppr r1 <+> text "=/=" <+> ppr a2) - (a1, r2) - where - (a1, r1) = coercionKind co1 - (a2, r2) = coercionKind co2 - -leftCoercionTyCon = - mkCoercionTyCon leftCoercionTyConName 1 leftProjectCoercionKindOf - where - leftProjectCoercionKindOf (co:rest) = ASSERT( null rest ) (ty1, ty2) - where - (ty1,ty2) = fst (splitCoercionKindOf co) - -rightCoercionTyCon = - mkCoercionTyCon rightCoercionTyConName 1 rightProjectCoercionKindOf - where - rightProjectCoercionKindOf (co:rest) = ASSERT( null rest ) (ty1, ty2) - where - (ty1,ty2) = snd (splitCoercionKindOf co) + kc_sym :: CoTyConKindChecker + kc_sym _kc_ty kc_co _ (co:_) + = do { (ty1,ty2) <- kc_co co + ; return (ty2,ty1) } + kc_sym _ _ _ _ = panic "kc_sym" -splitCoercionKindOf :: Type -> ((Type,Type), (Type,Type)) +transCoercionTyCon + = mkCoercionTyCon transCoercionTyConName 2 kc_trans + where + kc_trans :: CoTyConKindChecker + kc_trans _kc_ty kc_co checking (co1:co2:_) + = do { (a1, r1) <- kc_co co1 + ; (a2, r2) <- kc_co co2 + ; unless (not checking || (r1 `coreEqType` a2)) + (fail "Trans coercion mis-match") + ; return (a1, r2) } + kc_trans _ _ _ _ = panic "kc_sym" + +--------------------------------------------------- +leftCoercionTyCon = mkCoercionTyCon leftCoercionTyConName 1 (kcLR_help fst) +rightCoercionTyCon = mkCoercionTyCon rightCoercionTyConName 1 (kcLR_help snd) + +kcLR_help :: (forall a. (a,a)->a) -> CoTyConKindChecker +kcLR_help select _kc_ty kc_co _checking (co : _) + = do { (ty1, ty2) <- kc_co co + ; case decompLR_maybe ty1 ty2 of + Nothing -> fail "decompLR" + Just res -> return (select res) } +kcLR_help _ _ _ _ _ = panic "kcLR_help" + +decompLR_maybe :: Type -> Type -> Maybe ((Type,Type), (Type,Type)) -- Helper for left and right. Finds coercion kind of its input and -- returns the left and right projections of the coercion... -- -- if c :: t1 s1 ~ t2 s2 then splitCoercionKindOf c = ((t1, t2), (s1, s2)) -splitCoercionKindOf co - | Just (ty1, ty2) <- splitCoercionKind_maybe (coercionKindPredTy co) - , Just (ty_fun1, ty_arg1) <- splitAppTy_maybe ty1 +decompLR_maybe ty1 ty2 + | Just (ty_fun1, ty_arg1) <- splitAppTy_maybe ty1 , Just (ty_fun2, ty_arg2) <- splitAppTy_maybe ty2 - = ((ty_fun1, ty_fun2),(ty_arg1, ty_arg2)) -splitCoercionKindOf co - = pprPanic "Coercion.splitCoercionKindOf" - (ppr co $$ ppr (coercionKindPredTy co)) + = Just ((ty_fun1, ty_fun2),(ty_arg1, ty_arg2)) +decompLR_maybe _ _ = Nothing +--------------------------------------------------- instCoercionTyCon - = mkCoercionTyCon instCoercionTyConName 2 instCoercionKind + = mkCoercionTyCon instCoercionTyConName 2 kcInst_help where - instantiateCo t s = - let Just (tv, ty) = splitForAllTy_maybe t in - substTyWith [tv] [s] ty - - instCoercionKind (co1:ty:rest) = ASSERT( null rest ) - (instantiateCo t1 ty, instantiateCo t2 ty) - where (t1, t2) = coercionKind co1 + kcInst_help :: CoTyConKindChecker + kcInst_help kc_ty kc_co checking (co : ty : _) + = do { (t1,t2) <- kc_co co + ; k <- kc_ty ty + ; case decompInst_maybe t1 t2 of + Nothing -> fail "decompInst" + Just ((tv1,tv2), (ty1,ty2)) -> do + { unless (not checking || (k `isSubKind` tyVarKind tv1)) + (fail "Coercion instantation kind mis-match") + ; return (substTyWith [tv1] [ty] ty1, + substTyWith [tv2] [ty] ty2) } } + kcInst_help _ _ _ _ = panic "kcInst_help" + +decompInst_maybe :: Type -> Type -> Maybe ((TyVar,TyVar), (Type,Type)) +decompInst_maybe ty1 ty2 + | Just (tv1,r1) <- splitForAllTy_maybe ty1 + , Just (tv2,r2) <- splitForAllTy_maybe ty2 + = Just ((tv1,tv2), (r1,r2)) +decompInst_maybe _ _ = Nothing +--------------------------------------------------- unsafeCoercionTyCon - = mkCoercionTyCon unsafeCoercionTyConName 2 unsafeCoercionKind + = mkCoercionTyCon unsafeCoercionTyConName 2 kc_unsafe where - unsafeCoercionKind (ty1:ty2:rest) = ASSERT( null rest ) (ty1,ty2) + kc_unsafe kc_ty _kc_co _checking (ty1:ty2:_) + = do { _ <- kc_ty ty1 + ; _ <- kc_ty ty2 + ; return (ty1,ty2) } + kc_unsafe _ _ _ _ = panic "kc_unsafe" +--------------------------------------------------- +-- The csel* family + +csel1CoercionTyCon = mkCoercionTyCon csel1CoercionTyConName 1 (kcCsel_help fstOf3) +csel2CoercionTyCon = mkCoercionTyCon csel2CoercionTyConName 1 (kcCsel_help sndOf3) +cselRCoercionTyCon = mkCoercionTyCon cselRCoercionTyConName 1 (kcCsel_help thirdOf3) + +kcCsel_help :: (forall a. (a,a,a) -> a) -> CoTyConKindChecker +kcCsel_help select _kc_ty kc_co _checking (co : _) + = do { (ty1,ty2) <- kc_co co + ; case decompCsel_maybe ty1 ty2 of + Nothing -> fail "decompCsel" + Just res -> return (select res) } +kcCsel_help _ _ _ _ _ = panic "kcCsel_help" + +decompCsel_maybe :: Type -> Type -> Maybe ((Type,Type), (Type,Type), (Type,Type)) +-- If co :: (s1~t1 => r1) ~ (s2~t2 => r2) +-- Then csel1 co :: s1 ~ s2 +-- csel2 co :: t1 ~ t2 +-- cselR co :: r1 ~ r2 +decompCsel_maybe ty1 ty2 + | Just (s1, t1, r1) <- splitCoPredTy_maybe ty1 + , Just (s2, t2, r2) <- splitCoPredTy_maybe ty2 + = Just ((s1,s2), (t1,t2), (r1,r2)) +decompCsel_maybe _ _ = Nothing + +fstOf3 :: (a,b,c) -> a +sndOf3 :: (a,b,c) -> b +thirdOf3 :: (a,b,c) -> c +fstOf3 (a,_,_) = a +sndOf3 (_,b,_) = b +thirdOf3 (_,_,c) = c + -------------------------------------- --- ...and their names +-- Their Names + +transCoercionTyConName, symCoercionTyConName, leftCoercionTyConName, + rightCoercionTyConName, instCoercionTyConName, unsafeCoercionTyConName, + csel1CoercionTyConName, csel2CoercionTyConName, cselRCoercionTyConName :: Name + +transCoercionTyConName = mkCoConName (fsLit "trans") transCoercionTyConKey transCoercionTyCon +symCoercionTyConName = mkCoConName (fsLit "sym") symCoercionTyConKey symCoercionTyCon +leftCoercionTyConName = mkCoConName (fsLit "left") leftCoercionTyConKey leftCoercionTyCon +rightCoercionTyConName = mkCoConName (fsLit "right") rightCoercionTyConKey rightCoercionTyCon +instCoercionTyConName = mkCoConName (fsLit "inst") instCoercionTyConKey instCoercionTyCon +csel1CoercionTyConName = mkCoConName (fsLit "csel1") csel1CoercionTyConKey csel1CoercionTyCon +csel2CoercionTyConName = mkCoConName (fsLit "csel2") csel2CoercionTyConKey csel2CoercionTyCon +cselRCoercionTyConName = mkCoConName (fsLit "cselR") cselRCoercionTyConKey cselRCoercionTyCon +unsafeCoercionTyConName = mkCoConName (fsLit "CoUnsafe") unsafeCoercionTyConKey unsafeCoercionTyCon mkCoConName :: FastString -> Unique -> TyCon -> Name mkCoConName occ key coCon = mkWiredInName gHC_PRIM (mkTcOccFS occ) key (ATyCon coCon) BuiltInSyntax - -transCoercionTyConName, symCoercionTyConName, leftCoercionTyConName, rightCoercionTyConName, instCoercionTyConName, unsafeCoercionTyConName :: Name - -transCoercionTyConName = mkCoConName (fsLit "trans") transCoercionTyConKey transCoercionTyCon -symCoercionTyConName = mkCoConName (fsLit "sym") symCoercionTyConKey symCoercionTyCon -leftCoercionTyConName = mkCoConName (fsLit "left") leftCoercionTyConKey leftCoercionTyCon -rightCoercionTyConName = mkCoConName (fsLit "right") rightCoercionTyConKey rightCoercionTyCon -instCoercionTyConName = mkCoConName (fsLit "inst") instCoercionTyConKey instCoercionTyCon -unsafeCoercionTyConName = mkCoConName (fsLit "CoUnsafe") unsafeCoercionTyConKey unsafeCoercionTyCon +\end{code} +%************************************************************************ +%* * + Newtypes +%* * +%************************************************************************ +\begin{code} instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, CoercionI) -- ^ If @co :: T ts ~ rep_ty@ then: -- @@ -568,9 +582,18 @@ -- | Determines syntactic equality of coercions coreEqCoercion :: Coercion -> Coercion -> Bool coreEqCoercion = coreEqType + +coreEqCoercion2 :: RnEnv2 -> Coercion -> Coercion -> Bool +coreEqCoercion2 = coreEqType2 \end{code} +%************************************************************************ +%* * + CoercionI and its constructors +%* * +%************************************************************************ + -------------------------------------- -- CoercionI smart constructors -- lifted smart constructors of ordinary coercions @@ -632,7 +655,7 @@ mkAppTyCoI ty1 coi1 ty2 coi2 = ACo $ AppTy (fromCoI coi1 ty1) (fromCoI coi2 ty2) --- | Smart constructor for function-'Coercion's on 'CoercionI', see also 'mkFunCoercion' + mkFunTyCoI :: Type -> CoercionI -> Type -> CoercionI -> CoercionI mkFunTyCoI _ IdCo _ IdCo = IdCo mkFunTyCoI ty1 coi1 ty2 coi2 = @@ -646,7 +669,8 @@ -- | Extract a 'Coercion' from a 'CoercionI' if it represents one. If it is the identity coercion, -- panic fromACo :: CoercionI -> Coercion -fromACo (ACo co) = co +fromACo (ACo co) = co +fromACo (IdCo {}) = panic "fromACo" -- | Smart constructor for class 'Coercion's on 'CoercionI'. Satisfies: -- @@ -667,3 +691,235 @@ mkEqPredCoI ty1 IdCo _ (ACo co2) = ACo $ PredTy $ EqPred ty1 co2 mkEqPredCoI _ (ACo co1) ty2 coi2 = ACo $ PredTy $ EqPred co1 (fromCoI coi2 ty2) \end{code} + +%************************************************************************ +%* * + Optimising coercions +%* * +%************************************************************************ + +\begin{code} +optCoercion :: TvSubst -> Coercion -> NormalCo +-- ^ optCoercion applies a substitution to a coercion, +-- *and* optimises it to reduce its size +optCoercion env co = opt_co env False co + +type NormalCo = Coercion + -- Invariants: + -- * The substitution has been fully applied + -- * For trans coercions (co1 `trans` co2) + -- co1 is not a trans, and neither co1 nor co2 is identity + -- * If the coercion is the identity, it has no CoVars of CoTyCons in it (just types) + +type NormalNonIdCo = NormalCo -- Extra invariant: not the identity + +opt_co, opt_co' :: TvSubst + -> Bool -- True <=> return (sym co) + -> Coercion + -> NormalCo +opt_co = opt_co' +-- opt_co sym co = pprTrace "opt_co {" (ppr sym <+> ppr co) $ +-- co1 `seq` +-- pprTrace "opt_co done }" (ppr co1) +-- WARN( not same_co_kind, ppr co <+> dcolon <+> pprEqPred (s1,t1) +-- $$ ppr co1 <+> dcolon <+> pprEqPred (s2,t2) ) +-- co1 +-- where +-- co1 = opt_co' sym co +-- same_co_kind = s1 `coreEqType` s2 && t1 `coreEqType` t2 +-- (s,t) = coercionKind co +-- (s1,t1) | sym = (t,s) +-- | otherwise = (s,t) +-- (s2,t2) = coercionKind co1 + +opt_co' env sym (AppTy ty1 ty2) = mkAppTy (opt_co env sym ty1) (opt_co env sym ty2) +opt_co' env sym (FunTy ty1 ty2) = FunTy (opt_co env sym ty1) (opt_co env sym ty2) +opt_co' env sym (PredTy (ClassP cls tys)) = PredTy (ClassP cls (map (opt_co env sym) tys)) +opt_co' env sym (PredTy (IParam n ty)) = PredTy (IParam n (opt_co env sym ty)) +opt_co' _ _ co@(PredTy (EqPred {})) = pprPanic "optCoercion" (ppr co) + +opt_co' env sym co@(TyVarTy tv) + | Just ty <- lookupTyVar env tv = opt_co' (zapTvSubstEnv env) sym ty + | not (isCoVar tv) = co -- Identity; does not mention a CoVar + | ty1 `coreEqType` ty2 = ty1 -- Identity; ..ditto.. + | not sym = co + | otherwise = mkSymCoercion co + where + (ty1,ty2) = coVarKind tv + +opt_co' env sym (ForAllTy tv cor) + | isCoVar tv = mkCoPredTy (opt_co env sym co1) (opt_co env sym co2) (opt_co env sym cor) + | otherwise = case substTyVarBndr env tv of + (env', tv') -> ForAllTy tv' (opt_co env' sym cor) + where + (co1,co2) = coVarKind tv + +opt_co' env sym (TyConApp tc cos) + | isCoercionTyCon tc + = foldl mkAppTy + (opt_co_tc_app env sym tc (take arity cos)) + (map (opt_co env sym) (drop arity cos)) + | otherwise + = TyConApp tc (map (opt_co env sym) cos) + where + arity = tyConArity tc + +-------- +opt_co_tc_app :: TvSubst -> Bool -> TyCon -> [Coercion] -> NormalCo +-- Used for CoercionTyCons only +-- Arguments are *not* already simplified/substituted +opt_co_tc_app env sym tc cos + | tc `hasKey` symCoercionTyConKey + = opt_co env (not sym) co1 + + | tc `hasKey` transCoercionTyConKey + = if sym then opt_trans opt_co2 opt_co1 -- sym (g `o` h) = sym h `o` sym g + else opt_trans opt_co1 opt_co2 + + | tc `hasKey` leftCoercionTyConKey + , Just (opt_co1_left, _) <- splitAppTy_maybe opt_co1 + = opt_co1_left -- sym (left g) = left (sym g) + -- The opt_co has the sym pushed into it + + | tc `hasKey` rightCoercionTyConKey + , Just (_, opt_co1_right) <- splitAppTy_maybe opt_co1 + = opt_co1_right + + | tc `hasKey` csel1CoercionTyConKey + , Just (s1,_,_) <- splitCoPredTy_maybe opt_co1 + = s1 + + | tc `hasKey` csel2CoercionTyConKey + , Just (_,s2,_) <- splitCoPredTy_maybe opt_co1 + = s2 + + | tc `hasKey` cselRCoercionTyConKey + , Just (_,_,r) <- splitCoPredTy_maybe opt_co1 + = r + + | tc `hasKey` instCoercionTyConKey -- See if the first arg + -- is already a forall + , Just (tv, co1_body) <- splitForAllTy_maybe co1 + , let ty = substTy env co2 + = opt_co (extendTvSubst env tv ty) sym co1_body + + | tc `hasKey` instCoercionTyConKey -- See if is *now* a forall + , Just (tv, opt_co1_body) <- splitForAllTy_maybe opt_co1 + , let ty = substTy env co2 + = substTyWith [tv] [ty] opt_co1_body -- An inefficient one-variable substitution + + | otherwise -- Do *not* push sym inside top-level axioms + -- e.g. if g is a top-level axiom + -- g a : F a ~ a + -- Then (sym (g ty)) /= g (sym ty) !! + = if sym then mkSymCoercion the_co + else the_co + where + (co1 : cos1) = cos + (co2 : _) = cos1 + + -- These opt_cos have the sym pushed into them + opt_co1 = opt_co env sym co1 + opt_co2 = opt_co env sym co2 + + -- However the_co does *not* have sym pushed into it + the_co = TyConApp tc (map (opt_co env False) cos) + +------------- +opt_trans :: NormalCo -> NormalCo -> NormalCo +opt_trans co1 co2 + | isIdNormCo co1 = co2 + | otherwise = opt_trans1 co1 co2 + +opt_trans1 :: NormalNonIdCo -> NormalCo -> NormalCo +-- First arg is not the identity +opt_trans1 co1 co2 + | isIdNormCo co2 = co1 + | otherwise = opt_trans2 co1 co2 + +opt_trans2 :: NormalNonIdCo -> NormalNonIdCo -> NormalCo +-- Neither arg is the identity +opt_trans2 (TyConApp tc [co1a,co1b]) co2 + | tc `hasKey` transCoercionTyConKey + = opt_trans1 co1a (opt_trans2 co1b co2) + +opt_trans2 co1 co2 + | Just co <- opt_trans_rule co1 co2 + = co + +opt_trans2 co1 (TyConApp tc [co2a,co2b]) + | tc `hasKey` transCoercionTyConKey + , Just co1_2a <- opt_trans_rule co1 co2a + = if isIdNormCo co1_2a + then co2b + else opt_trans2 co1_2a co2b + +opt_trans2 co1 co2 + = mkTransCoercion co1 co2 + +------ +opt_trans_rule :: NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo +opt_trans_rule (TyConApp tc [co1]) co2 + | tc `hasKey` symCoercionTyConKey + , co1 `coreEqType` co2 + , (_,ty2) <- coercionKind co2 + = Just ty2 + +opt_trans_rule co1 (TyConApp tc [co2]) + | tc `hasKey` symCoercionTyConKey + , co1 `coreEqType` co2 + , (ty1,_) <- coercionKind co1 + = Just ty1 + +opt_trans_rule (TyConApp tc1 [co1,ty1]) (TyConApp tc2 [co2,ty2]) + | tc1 `hasKey` instCoercionTyConKey + , tc1 == tc2 + , ty1 `coreEqType` ty2 + = Just (mkInstCoercion (opt_trans2 co1 co2) ty1) + +opt_trans_rule (TyConApp tc1 cos1) (TyConApp tc2 cos2) + | not (isCoercionTyCon tc1) || + getUnique tc1 `elem` [ leftCoercionTyConKey, rightCoercionTyConKey + , csel1CoercionTyConKey, csel2CoercionTyConKey + , cselRCoercionTyConKey ] --Yuk! + , tc1 == tc2 -- Works for left,right, and csel* family + -- BUT NOT equality axioms + -- E.g. (g Int) `trans` (g Bool) + -- /= g (Int . Bool) + = Just (TyConApp tc1 (zipWith opt_trans cos1 cos2)) + +opt_trans_rule co1 co2 + | Just (co1a, co1b) <- splitAppTy_maybe co1 + , Just (co2a, co2b) <- splitAppTy_maybe co2 + = Just (mkAppTy (opt_trans co1a co2a) (opt_trans co1b co2b)) + + | Just (s1,t1,r1) <- splitCoPredTy_maybe co1 + , Just (s2,t2,r2) <- splitCoPredTy_maybe co1 + = Just (mkCoPredTy (opt_trans s1 s2) + (opt_trans t1 t2) + (opt_trans r1 r2)) + + | Just (tv1,r1) <- splitForAllTy_maybe co1 + , Just (tv2,r2) <- splitForAllTy_maybe co2 + , not (isCoVar tv1) -- Both have same kind + , let r2' = substTyWith [tv2] [TyVarTy tv1] r2 + = Just (ForAllTy tv1 (opt_trans2 r1 r2')) + +opt_trans_rule _ _ = Nothing + + +------------- +isIdNormCo :: NormalCo -> Bool +-- Cheap identity test: look for coercions with no coercion variables at all +-- So it'll return False for (sym g `trans` g) +isIdNormCo ty = go ty + where + go (TyVarTy tv) = not (isCoVar tv) + go (AppTy t1 t2) = go t1 && go t2 + go (FunTy t1 t2) = go t1 && go t2 + go (ForAllTy tv ty) = go (tyVarKind tv) && go ty + go (TyConApp tc tys) = not (isCoercionTyCon tc) && all go tys + go (PredTy (IParam _ ty)) = go ty + go (PredTy (ClassP _ tys)) = all go tys + go (PredTy (EqPred t1 t2)) = go t1 && go t2 +\end{code} diff -ruN ghc-6.12.1/compiler/types/InstEnv.lhs ghc-6.13.20091231/compiler/types/InstEnv.lhs --- ghc-6.12.1/compiler/types/InstEnv.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/types/InstEnv.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -59,7 +59,7 @@ -- INVARIANT: is_dfun Id has type -- forall is_tvs. (...) => is_cls is_tys - , is_dfun :: DFunId + , is_dfun :: DFunId -- See Note [Haddock assumptions] , is_flag :: OverlapFlag -- See detailed comments with -- the decl of BasicTypes.OverlapFlag } @@ -99,7 +99,20 @@ (This is so that we can use the matching substitution to instantiate the dfun's context.) - +Note [Haddock assumptions] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +For normal user-written instances, Haddock relies on + + * the SrcSpan of + * the Name of + * the is_dfun of + * an Instance + +being equal to + + * the SrcSpan of + * the instance head type of + * the InstDecl used to construct the Instance. \begin{code} instanceDFunId :: Instance -> DFunId @@ -116,7 +129,7 @@ -- are ok; hence the assert ispec { is_dfun = dfun, is_tvs = mkVarSet tvs, is_tys = tys } where - (tvs, _, _, tys) = tcSplitDFunTy (idType dfun) + (tvs, _, tys) = tcSplitDFunTy (idType dfun) instanceRoughTcs :: Instance -> [Maybe Name] instanceRoughTcs = is_tcs @@ -140,16 +153,20 @@ -- Prints the Instance as an instance declaration pprInstanceHdr ispec@(Instance { is_flag = flag }) = ptext (sLit "instance") <+> ppr flag - <+> sep [pprThetaArrow theta, pprClassPred clas tys] + <+> sep [pprThetaArrow theta, ppr res_ty] where - (_, theta, clas, tys) = instanceHead ispec + (_, theta, res_ty) = tcSplitSigmaTy (idType (is_dfun ispec)) -- Print without the for-all, which the programmer doesn't write pprInstances :: [Instance] -> SDoc pprInstances ispecs = vcat (map pprInstance ispecs) -instanceHead :: Instance -> ([TyVar], [PredType], Class, [Type]) -instanceHead ispec = tcSplitDFunTy (idType (is_dfun ispec)) +instanceHead :: Instance -> ([TyVar], ThetaType, Class, [Type]) +instanceHead ispec + = (tvs, theta, cls, tys) + where + (tvs, theta, tau) = tcSplitSigmaTy (idType (is_dfun ispec)) + (cls, tys) = tcSplitDFunHead tau mkLocalInstance :: DFunId -> OverlapFlag -> Instance -- Used for local instances, where we can safely pull on the DFunId @@ -158,7 +175,7 @@ is_tvs = mkVarSet tvs, is_tys = tys, is_cls = className cls, is_tcs = roughMatchTcs tys } where - (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun) + (tvs, cls, tys) = tcSplitDFunTy (idType dfun) mkImportedInstance :: Name -> [Maybe Name] -> DFunId -> OverlapFlag -> Instance @@ -169,7 +186,7 @@ is_tvs = mkVarSet tvs, is_tys = tys, is_cls = cls, is_tcs = mb_tcs } where - (tvs, _, _, tys) = tcSplitDFunTy (idType dfun) + (tvs, _, tys) = tcSplitDFunTy (idType dfun) roughMatchTcs :: [Type] -> [Maybe Name] roughMatchTcs tys = map rough tys diff -ruN ghc-6.12.1/compiler/types/TyCon.lhs ghc-6.13.20091231/compiler/types/TyCon.lhs --- ghc-6.12.1/compiler/types/TyCon.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/types/TyCon.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -8,7 +8,7 @@ \begin{code} module TyCon( -- * Main TyCon data types - TyCon, FieldLabel, + TyCon, FieldLabel, CoTyConKindChecker, AlgTyConRhs(..), visibleDataCons, TyConParent(..), @@ -20,13 +20,14 @@ mkClassTyCon, mkFunTyCon, mkPrimTyCon, - mkVoidPrimTyCon, + mkKindTyCon, mkLiftedPrimTyCon, mkTupleTyCon, mkSynTyCon, mkSuperKindTyCon, mkCoercionTyCon, mkForeignTyCon, + mkAnyTyCon, -- ** Predicates on TyCons isAlgTyCon, @@ -35,9 +36,9 @@ isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, isSynTyCon, isClosedSynTyCon, isOpenSynTyCon, - isSuperKindTyCon, + isSuperKindTyCon, isDecomposableTyCon, isCoercionTyCon, isCoercionTyCon_maybe, - isForeignTyCon, + isForeignTyCon, isAnyTyCon, tyConHasKind, isInjectiveTyCon, isDataTyCon, isProductTyCon, isEnumerationTyCon, @@ -103,7 +104,7 @@ %************************************************************************ \begin{code} --- | Represents type constructors. Type constructors are introduced by things such as: +-- | TyCons represent type constructors. Type constructors are introduced by things such as: -- -- 1) Data declarations: @data Foo = ...@ creates the @Foo@ type constructor of kind @*@ -- @@ -123,7 +124,7 @@ FunTyCon { tyConUnique :: Unique, tyConName :: Name, - tyConKind :: Kind, + tc_kind :: Kind, tyConArity :: Arity } @@ -132,7 +133,7 @@ | AlgTyCon { tyConUnique :: Unique, tyConName :: Name, - tyConKind :: Kind, + tc_kind :: Kind, tyConArity :: Arity, tyConTyVars :: [TyVar], -- ^ The type variables used in the type constructor. @@ -150,6 +151,7 @@ -- that doesn't mean it's a true GADT; only that the "where" -- form was used. This field is used only to guide -- pretty-printing + algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data type (always empty for GADTs). -- A \"stupid theta\" is the context to the left of an algebraic type -- declaration, e.g. @Eq a@ in the declaration @data Eq a => T a ...@. @@ -169,7 +171,7 @@ | TupleTyCon { tyConUnique :: Unique, tyConName :: Name, - tyConKind :: Kind, + tc_kind :: Kind, tyConArity :: Arity, tyConBoxed :: Boxity, tyConTyVars :: [TyVar], @@ -181,7 +183,7 @@ | SynTyCon { tyConUnique :: Unique, tyConName :: Name, - tyConKind :: Kind, + tc_kind :: Kind, tyConArity :: Arity, tyConTyVars :: [TyVar], -- Bound tyvars @@ -197,33 +199,44 @@ | PrimTyCon { tyConUnique :: Unique, tyConName :: Name, - tyConKind :: Kind, - tyConArity :: Arity, -- SLPJ Oct06: I'm not sure what the significance - -- of the arity of a primtycon is! - - primTyConRep :: PrimRep, - -- ^ Many primitive tycons are unboxed, but some are - -- boxed (represented by pointers). This 'PrimRep' holds - -- that information - - isUnLifted :: Bool, -- ^ Most primitive tycons are unlifted (may not contain bottom) - -- but foreign-imported ones may be lifted - tyConExtName :: Maybe FastString -- ^ @Just e@ for foreign-imported types, holds the name of the imported thing + tc_kind :: Kind, + tyConArity :: Arity, -- SLPJ Oct06: I'm not sure what the significance + -- of the arity of a primtycon is! + + primTyConRep :: PrimRep, -- ^ Many primitive tycons are unboxed, but some are + -- boxed (represented by pointers). This 'PrimRep' holds + -- that information. + -- Only relevant if tc_kind = * + + isUnLifted :: Bool, -- ^ Most primitive tycons are unlifted (may not contain bottom) + -- but foreign-imported ones may be lifted + + tyConExtName :: Maybe FastString -- ^ @Just e@ for foreign-imported types, + -- holds the name of the imported thing } -- | Type coercions, such as @(~)@, @sym@, @trans@, @left@ and @right@. - -- INVARIANT: coercions are always fully applied + -- INVARIANT: Coercion TyCons are always fully applied + -- But note that a CoercionTyCon can be over-saturated in a type. + -- E.g. (sym g1) Int will be represented as (TyConApp sym [g1,Int]) | CoercionTyCon { tyConUnique :: Unique, tyConName :: Name, tyConArity :: Arity, - coKindFun :: [Type] -> (Type,Type) - -- ^ Function that when given a list of the type arguments to the 'TyCon' - -- constructs the types that the resulting coercion relates. - -- - -- INVARIANT: 'coKindFun' is always applied to exactly 'tyConArity' args - -- E.g. for @trans (c1 :: ta=tb) (c2 :: tb=tc)@, the 'coKindFun' returns - -- the kind as a pair of types: @(ta, tc)@ + coKindFun :: CoTyConKindChecker + } + + -- | Any types. Like tuples, this is a potentially-infinite family of TyCons + -- one for each distinct Kind. They have no values at all. + -- Because there are infinitely many of them (like tuples) they are + -- defined in GHC.Prim and have names like "Any(*->*)". + -- Their Unique is derived from the OccName. + -- See Note [Any types] in TysPrim + | AnyTyCon { + tyConUnique :: Unique, + tyConName :: Name, + tc_kind :: Kind -- Never = *; that is done via PrimTyCon + -- See Note [Any types] in TysPrim } -- | Super-kinds. These are "kinds-of-kinds" and are never seen in Haskell source programs. @@ -237,6 +250,23 @@ tyConName :: Name } +type CoTyConKindChecker = forall m. Monad m => CoTyConKindCheckerFun m + +type CoTyConKindCheckerFun m + = (Type -> m Kind) -- Kind checker for types + -> (Type -> m (Type,Type)) -- and for coercions + -> Bool -- True => apply consistency checks + -> [Type] -- Exactly right number of args + -> m (Type, Type) -- Kind of this application + + -- ^ Function that when given a list of the type arguments to the 'TyCon' + -- constructs the types that the resulting coercion relates. + -- Returns Nothing if ill-kinded. + -- + -- INVARIANT: 'coKindFun' is always applied to exactly 'tyConArity' args + -- E.g. for @trans (c1 :: ta=tb) (c2 :: tb=tc)@, the 'coKindFun' returns + -- the kind as a pair of types: @(ta, tc)@ + -- | Names of the fields in an algebraic record type type FieldLabel = Name @@ -561,7 +591,7 @@ = FunTyCon { tyConUnique = nameUnique name, tyConName = name, - tyConKind = kind, + tc_kind = kind, tyConArity = 2 } @@ -581,7 +611,7 @@ = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, - tyConKind = kind, + tc_kind = kind, tyConArity = length tyvars, tyConTyVars = tyvars, algTcStupidTheta = stupid, @@ -609,7 +639,7 @@ = TupleTyCon { tyConUnique = nameUnique name, tyConName = name, - tyConKind = kind, + tc_kind = kind, tyConArity = arity, tyConBoxed = boxed, tyConTyVars = tyvars, @@ -630,7 +660,7 @@ = PrimTyCon { tyConName = name, tyConUnique = nameUnique name, - tyConKind = kind, + tc_kind = kind, tyConArity = arity, primTyConRep = PtrRep, -- they all do isUnLifted = False, @@ -643,10 +673,10 @@ mkPrimTyCon name kind arity rep = mkPrimTyCon' name kind arity rep True --- | Create the special void 'TyCon' which is unlifted and has 'VoidRep' -mkVoidPrimTyCon :: Name -> Kind -> Arity -> TyCon -mkVoidPrimTyCon name kind arity - = mkPrimTyCon' name kind arity VoidRep True +-- | Kind constructors +mkKindTyCon :: Name -> Kind -> TyCon +mkKindTyCon name kind + = mkPrimTyCon' name kind 0 VoidRep True -- | Create a lifted primitive 'TyCon' such as @RealWorld@ mkLiftedPrimTyCon :: Name -> Kind -> Arity -> PrimRep -> TyCon @@ -658,7 +688,7 @@ = PrimTyCon { tyConName = name, tyConUnique = nameUnique name, - tyConKind = kind, + tc_kind = kind, tyConArity = arity, primTyConRep = rep, isUnLifted = is_unlifted, @@ -671,7 +701,7 @@ = SynTyCon { tyConName = name, tyConUnique = nameUnique name, - tyConKind = kind, + tc_kind = kind, tyConArity = length tyvars, tyConTyVars = tyvars, synTcRhs = rhs, @@ -679,15 +709,29 @@ } -- | Create a coercion 'TyCon' -mkCoercionTyCon :: Name -> Arity -> ([Type] -> (Type,Type)) -> TyCon -mkCoercionTyCon name arity kindRule +mkCoercionTyCon :: Name -> Arity + -> CoTyConKindChecker + -> TyCon +mkCoercionTyCon name arity rule_fn = CoercionTyCon { - tyConName = name, + tyConName = name, tyConUnique = nameUnique name, - tyConArity = arity, - coKindFun = kindRule + tyConArity = arity, +#ifdef DEBUG + coKindFun = \ ty co fail args -> + ASSERT2( length args == arity, ppr name ) + rule_fn ty co fail args +#else + coKindFun = rule_fn +#endif } +mkAnyTyCon :: Name -> Kind -> TyCon +mkAnyTyCon name kind + = AnyTyCon { tyConName = name, + tc_kind = kind, + tyConUnique = nameUnique name } + -- | Create a super-kind 'TyCon' mkSuperKindTyCon :: Name -> TyCon -- Super kinds always have arity zero mkSuperKindTyCon name @@ -755,6 +799,11 @@ isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True isNewTyCon _ = False +tyConHasKind :: TyCon -> Bool +tyConHasKind (SuperKindTyCon {}) = False +tyConHasKind (CoercionTyCon {}) = False +tyConHasKind _ = True + -- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it expands -- into, and (possibly) a coercion from the representation type to the @newtype@. -- Returns @Nothing@ if this is not possible. @@ -800,6 +849,13 @@ isOpenSynTyCon :: TyCon -> Bool isOpenSynTyCon tycon = isSynTyCon tycon && isOpenTyCon tycon +isDecomposableTyCon :: TyCon -> Bool +-- True iff we can deocmpose (T a b c) into ((T a b) c) +-- Specifically NOT true of synonyms (open and otherwise) and coercions +isDecomposableTyCon (SynTyCon {}) = False +isDecomposableTyCon (CoercionTyCon {}) = False +isDecomposableTyCon _other = True + -- | Is this an algebraic 'TyCon' declared with the GADT syntax? isGadtSyntaxTyCon :: TyCon -> Bool isGadtSyntaxTyCon (AlgTyCon { algTcGadtSyntax = res }) = res @@ -808,6 +864,7 @@ -- | Is this an algebraic 'TyCon' which is just an enumeration of values? isEnumerationTyCon :: TyCon -> Bool isEnumerationTyCon (AlgTyCon {algTcRhs = DataTyCon { is_enum = res }}) = res +isEnumerationTyCon (TupleTyCon {tyConArity = arity}) = arity == 0 isEnumerationTyCon _ = False -- | Is this a 'TyCon', synonym or otherwise, that may have further instances appear? @@ -907,10 +964,15 @@ isSuperKindTyCon (SuperKindTyCon {}) = True isSuperKindTyCon _ = False +-- | Is this an AnyTyCon? +isAnyTyCon :: TyCon -> Bool +isAnyTyCon (AnyTyCon {}) = True +isAnyTyCon _ = False + -- | Attempt to pull a 'TyCon' apart into the arity and 'coKindFun' of -- a coercion 'TyCon'. Returns @Nothing@ if the 'TyCon' is not of the -- appropriate kind -isCoercionTyCon_maybe :: TyCon -> Maybe (Arity, [Type] -> (Type,Type)) +isCoercionTyCon_maybe :: Monad m => TyCon -> Maybe (Arity, CoTyConKindCheckerFun m) isCoercionTyCon_maybe (CoercionTyCon {tyConArity = ar, coKindFun = rule}) = Just (ar, rule) isCoercionTyCon_maybe _ = Nothing @@ -995,6 +1057,15 @@ tyConHasGenerics (TupleTyCon {hasGenerics = hg}) = hg tyConHasGenerics _ = False -- Synonyms +tyConKind :: TyCon -> Kind +tyConKind (FunTyCon { tc_kind = k }) = k +tyConKind (AlgTyCon { tc_kind = k }) = k +tyConKind (TupleTyCon { tc_kind = k }) = k +tyConKind (SynTyCon { tc_kind = k }) = k +tyConKind (PrimTyCon { tc_kind = k }) = k +tyConKind (AnyTyCon { tc_kind = k }) = k +tyConKind tc = pprPanic "tyConKind" (ppr tc) + -- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no constructors -- could be found tyConDataCons :: TyCon -> [DataCon] @@ -1023,8 +1094,9 @@ -- | Extract an 'AlgTyConRhs' with information about data constructors from an algebraic or tuple -- 'TyCon'. Panics for any other sort of 'TyCon' algTyConRhs :: TyCon -> AlgTyConRhs -algTyConRhs (AlgTyCon {algTcRhs = rhs}) = rhs -algTyConRhs (TupleTyCon {dataCon = con}) = DataTyCon { data_cons = [con], is_enum = False } +algTyConRhs (AlgTyCon {algTcRhs = rhs}) = rhs +algTyConRhs (TupleTyCon {dataCon = con, tyConArity = arity}) + = DataTyCon { data_cons = [con], is_enum = arity == 0 } algTyConRhs other = pprPanic "algTyConRhs" (ppr other) \end{code} @@ -1097,13 +1169,10 @@ -- has more than one constructor, or represents a primitive or function type constructor then -- @Nothing@ is returned. In any other case, the function panics tyConSingleDataCon_maybe :: TyCon -> Maybe DataCon -tyConSingleDataCon_maybe (AlgTyCon {algTcRhs = DataTyCon {data_cons = [c] }}) = Just c -tyConSingleDataCon_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = c }}) = Just c -tyConSingleDataCon_maybe (AlgTyCon {}) = Nothing -tyConSingleDataCon_maybe (TupleTyCon {dataCon = con}) = Just con -tyConSingleDataCon_maybe (PrimTyCon {}) = Nothing -tyConSingleDataCon_maybe (FunTyCon {}) = Nothing -- case at funty -tyConSingleDataCon_maybe tc = pprPanic "tyConSingleDataCon_maybe: unexpected tycon " $ ppr tc +tyConSingleDataCon_maybe (TupleTyCon {dataCon = c}) = Just c +tyConSingleDataCon_maybe (AlgTyCon {algTcRhs = DataTyCon { data_cons = [c] }}) = Just c +tyConSingleDataCon_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = c }}) = Just c +tyConSingleDataCon_maybe _ = Nothing \end{code} \begin{code} diff -ruN ghc-6.12.1/compiler/types/Type.lhs ghc-6.13.20091231/compiler/types/Type.lhs --- ghc-6.12.1/compiler/types/Type.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/types/Type.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -64,7 +64,7 @@ Kind, SimpleKind, KindVar, -- ** Deconstructing Kinds - kindFunResult, splitKindFunTys, splitKindFunTysN, + kindFunResult, splitKindFunTys, splitKindFunTysN, splitKindFunTy_maybe, -- ** Common Kinds and SuperKinds liftedTypeKind, unliftedTypeKind, openTypeKind, @@ -98,7 +98,8 @@ tidyKind, -- * Type comparison - coreEqType, tcEqType, tcEqTypes, tcCmpType, tcCmpTypes, + coreEqType, coreEqType2, + tcEqType, tcEqTypes, tcCmpType, tcCmpTypes, tcEqPred, tcEqPredX, tcCmpPred, tcEqTypeX, tcPartOfType, tcPartOfPred, -- * Forcing evaluation of types @@ -122,7 +123,8 @@ emptyTvSubstEnv, emptyTvSubst, mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst, - getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, + getTvSubstEnv, setTvSubstEnv, zapTvSubstEnv, getTvInScope, + extendTvInScope, extendTvInScopeList, extendTvSubst, extendTvSubstList, isInScope, composeTvSubst, zipTyEnv, isEmptyTvSubst, @@ -132,7 +134,7 @@ -- * Pretty-printing pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, pprForAll, - pprPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind, + pprPred, pprEqPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind, pprSourceTyCon ) where @@ -403,7 +405,7 @@ repSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2) repSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) repSplitAppTy_maybe (TyConApp tc tys) - | not (isOpenSynTyCon tc) || length tys > tyConArity tc + | isDecomposableTyCon tc || length tys > tyConArity tc = case snocView tys of -- never create unsaturated type family apps Just (tys', ty') -> Just (TyConApp tc tys', ty') Nothing -> Nothing @@ -427,9 +429,9 @@ split _ (AppTy ty arg) args = split ty ty (arg:args) split _ (TyConApp tc tc_args) args = let -- keep type families saturated - n | isOpenSynTyCon tc = tyConArity tc - | otherwise = 0 - (tc_args1, tc_args2) = splitAt n tc_args + n | isDecomposableTyCon tc = 0 + | otherwise = tyConArity tc + (tc_args1, tc_args2) = splitAt n tc_args in (TyConApp tc tc_args1, tc_args2 ++ args) split _ (FunTy ty1 ty2) args = ASSERT( null args ) @@ -446,8 +448,8 @@ \begin{code} mkFunTy :: Type -> Type -> Type -- ^ Creates a function type from the given argument and result type -mkFunTy (PredTy (EqPred ty1 ty2)) res = mkForAllTy (mkWildCoVar (PredTy (EqPred ty1 ty2))) res -mkFunTy arg res = FunTy arg res +mkFunTy arg@(PredTy (EqPred {})) res = ForAllTy (mkWildCoVar arg) res +mkFunTy arg res = FunTy arg res mkFunTys :: [Type] -> Type -> Type mkFunTys tys ty = foldr mkFunTy ty tys @@ -681,7 +683,7 @@ \begin{code} mkForAllTy :: TyVar -> Type -> Type mkForAllTy tyvar ty - = mkForAllTys [tyvar] ty + = ForAllTy tyvar ty -- | Wraps foralls over the type using the provided 'TyVar's from left to right mkForAllTys :: [TyVar] -> Type -> Type @@ -1140,11 +1142,14 @@ \begin{code} -- | Type equality test for Core types (i.e. ignores predicate-types, synonyms etc.) coreEqType :: Type -> Type -> Bool -coreEqType t1 t2 - = eq rn_env t1 t2 +coreEqType t1 t2 = coreEqType2 rn_env t1 t2 where rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType t1 `unionVarSet` tyVarsOfType t2)) +coreEqType2 :: RnEnv2 -> Type -> Type -> Bool +coreEqType2 rn_env t1 t2 + = eq rn_env t1 t2 + where eq env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 == rnOccR env tv2 eq env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = eq (rnBndr2 env tv1 tv2) t1 t2 eq env (AppTy s1 t1) (AppTy s2 t2) = eq env s1 s2 && eq env t1 t2 @@ -1433,8 +1438,14 @@ setTvSubstEnv :: TvSubst -> TvSubstEnv -> TvSubst setTvSubstEnv (TvSubst in_scope _) env = TvSubst in_scope env -extendTvInScope :: TvSubst -> [Var] -> TvSubst -extendTvInScope (TvSubst in_scope env) vars = TvSubst (extendInScopeSetList in_scope vars) env +zapTvSubstEnv :: TvSubst -> TvSubst +zapTvSubstEnv (TvSubst in_scope _) = TvSubst in_scope emptyVarEnv + +extendTvInScope :: TvSubst -> Var -> TvSubst +extendTvInScope (TvSubst in_scope env) var = TvSubst (extendInScopeSet in_scope var) env + +extendTvInScopeList :: TvSubst -> [Var] -> TvSubst +extendTvInScopeList (TvSubst in_scope env) vars = TvSubst (extendInScopeSetList in_scope vars) env extendTvSubst :: TvSubst -> TyVar -> Type -> TvSubst extendTvSubst (TvSubst in_scope env) tv ty = TvSubst in_scope (extendVarEnv env tv ty) @@ -1720,6 +1731,9 @@ splitKindFunTys :: Kind -> ([Kind],Kind) splitKindFunTys k = splitFunTys k +splitKindFunTy_maybe :: Kind -> Maybe (Kind,Kind) +splitKindFunTy_maybe = splitFunTy_maybe + -- | Essentially 'splitFunTysN' on kinds splitKindFunTysN :: Int -> Kind -> ([Kind],Kind) splitKindFunTysN k = splitFunTysN k diff -ruN ghc-6.12.1/compiler/types/TypeRep.lhs ghc-6.13.20091231/compiler/types/TypeRep.lhs --- ghc-6.12.1/compiler/types/TypeRep.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/types/TypeRep.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -20,7 +20,7 @@ -- Pretty-printing pprType, pprParendType, pprTypeApp, pprTyThing, pprTyThingCategory, - pprPred, pprTheta, pprForAll, pprThetaArrow, pprClassPred, + pprPred, pprEqPred, pprTheta, pprForAll, pprThetaArrow, pprClassPred, -- Kinds liftedTypeKind, unliftedTypeKind, openTypeKind, @@ -304,14 +304,11 @@ tySuperKindTyCon = mkSuperKindTyCon tySuperKindTyConName coSuperKindTyCon = mkSuperKindTyCon coSuperKindTyConName -liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName -openTypeKindTyCon = mkKindTyCon openTypeKindTyConName -unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName -ubxTupleKindTyCon = mkKindTyCon ubxTupleKindTyConName -argTypeKindTyCon = mkKindTyCon argTypeKindTyConName - -mkKindTyCon :: Name -> TyCon -mkKindTyCon name = mkVoidPrimTyCon name tySuperKind 0 +liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName tySuperKind +openTypeKindTyCon = mkKindTyCon openTypeKindTyConName tySuperKind +unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName tySuperKind +ubxTupleKindTyCon = mkKindTyCon ubxTupleKindTyConName tySuperKind +argTypeKindTyCon = mkKindTyCon argTypeKindTyConName tySuperKind -------------------------- -- ... and now their names @@ -431,9 +428,12 @@ pprPred :: PredType -> SDoc pprPred (ClassP cls tys) = pprClassPred cls tys pprPred (IParam ip ty) = ppr ip <> dcolon <> pprType ty -pprPred (EqPred ty1 ty2) = sep [ ppr_type FunPrec ty1 - , nest 2 (ptext (sLit "~")) - , ppr_type FunPrec ty2] +pprPred (EqPred ty1 ty2) = pprEqPred (ty1,ty2) + +pprEqPred :: (Type,Type) -> SDoc +pprEqPred (ty1,ty2) = sep [ ppr_type FunPrec ty1 + , nest 2 (ptext (sLit "~")) + , ppr_type FunPrec ty2] -- Precedence looks like (->) so that we get -- Maybe a ~ Bool -- (a->a) ~ Bool @@ -471,7 +471,8 @@ ppr_type _ (TyVarTy tv) -- Note [Infix type variables] | isSymOcc (getOccName tv) = parens (ppr tv) | otherwise = ppr tv -ppr_type _ (PredTy pred) = ifPprDebug (ptext (sLit "")) <> (ppr pred) +ppr_type p (PredTy pred) = maybeParen p TyConPrec $ + ifPprDebug (ptext (sLit "")) <> (ppr pred) ppr_type p (TyConApp tc tys) = ppr_tc_app p tc tys ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $ diff -ruN ghc-6.12.1/compiler/types/Unify.lhs ghc-6.13.20091231/compiler/types/Unify.lhs --- ghc-6.12.1/compiler/types/Unify.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/types/Unify.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -206,7 +206,7 @@ -- Match the kind of the template tyvar with the kind of Type -- Note [Matching kinds] match_kind menv subst tv ty - | isCoVar tv = do { let (ty1,ty2) = splitCoercionKind (tyVarKind tv) + | isCoVar tv = do { let (ty1,ty2) = coVarKind tv (ty3,ty4) = coercionKind ty ; subst1 <- match menv subst ty1 ty3 ; match menv subst1 ty2 ty4 } diff -ruN ghc-6.12.1/compiler/utils/Bag.lhs ghc-6.13.20091231/compiler/utils/Bag.lhs --- ghc-6.12.1/compiler/utils/Bag.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/utils/Bag.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -11,7 +11,7 @@ emptyBag, unitBag, unionBags, unionManyBags, mapBag, - elemBag, + elemBag, lengthBag, filterBag, partitionBag, concatBag, foldBag, foldrBag, foldlBag, isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, listToBag, bagToList, @@ -22,6 +22,9 @@ import Util ( isSingleton ) import Data.List ( partition ) + +infixr 3 `consBag` +infixl 3 `snocBag` \end{code} @@ -38,6 +41,12 @@ unitBag :: a -> Bag a unitBag = UnitBag +lengthBag :: Bag a -> Int +lengthBag EmptyBag = 0 +lengthBag (UnitBag {}) = 1 +lengthBag (TwoBags b1 b2) = lengthBag b1 + lengthBag b2 +lengthBag (ListBag xs) = length xs + elemBag :: Eq a => a -> Bag a -> Bool elemBag _ EmptyBag = False elemBag x (UnitBag y) = x == y diff -ruN ghc-6.12.1/compiler/utils/MonadUtils.hs ghc-6.13.20091231/compiler/utils/MonadUtils.hs --- ghc-6.12.1/compiler/utils/MonadUtils.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/utils/MonadUtils.hs 2009-12-31 10:14:17.000000000 -0800 @@ -8,6 +8,8 @@ , MonadFix(..) , MonadIO(..) + + , ID, runID , liftIO1, liftIO2, liftIO3, liftIO4 @@ -22,6 +24,8 @@ , maybeMapM ) where +import Outputable + ---------------------------------------------------------------------------------------- -- Detection of available libraries ---------------------------------------------------------------------------------------- @@ -43,6 +47,20 @@ import Control.Monad.Fix ---------------------------------------------------------------------------------------- +-- The ID monad +---------------------------------------------------------------------------------------- + +newtype ID a = ID a +instance Monad ID where + return x = ID x + (ID x) >>= f = f x + _ >> y = y + fail s = panic s + +runID :: ID a -> a +runID (ID x) = x + +---------------------------------------------------------------------------------------- -- MTL ---------------------------------------------------------------------------------------- diff -ruN ghc-6.12.1/compiler/utils/Outputable.lhs ghc-6.13.20091231/compiler/utils/Outputable.lhs --- ghc-6.12.1/compiler/utils/Outputable.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/utils/Outputable.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -25,6 +25,7 @@ parens, cparen, brackets, braces, quotes, doubleQuotes, angleBrackets, semi, comma, colon, dcolon, space, equals, dot, arrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, + blankLine, (<>), (<+>), hcat, hsep, ($$), ($+$), vcat, sep, cat, @@ -56,7 +57,7 @@ ifPprDebug, qualName, qualModule, mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle, mkUserStyle, Depth(..), - + -- * Error handling and debugging utilities pprPanic, assertPprPanic, pprPanicFastInt, pprPgmError, pprTrace, warnPprTrace, @@ -291,7 +292,7 @@ Pretty.printDoc PageMode h (better_doc defaultDumpStyle) hFlush h where - better_doc = doc $$ text "" + better_doc = doc $$ blankLine printForUser :: Handle -> PrintUnqualified -> SDoc -> IO () printForUser handle unqual doc @@ -397,23 +398,24 @@ pp_d = d sty semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc -lparen, rparen, lbrack, rbrack, lbrace, rbrace :: SDoc +lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc -semi _sty = Pretty.semi -comma _sty = Pretty.comma -colon _sty = Pretty.colon -equals _sty = Pretty.equals -space _sty = Pretty.space -dcolon _sty = Pretty.ptext (sLit "::") -arrow _sty = Pretty.ptext (sLit "->") -underscore = char '_' -dot = char '.' -lparen _sty = Pretty.lparen -rparen _sty = Pretty.rparen -lbrack _sty = Pretty.lbrack -rbrack _sty = Pretty.rbrack -lbrace _sty = Pretty.lbrace -rbrace _sty = Pretty.rbrace +blankLine _sty = Pretty.ptext (sLit "") +dcolon _sty = Pretty.ptext (sLit "::") +arrow _sty = Pretty.ptext (sLit "->") +semi _sty = Pretty.semi +comma _sty = Pretty.comma +colon _sty = Pretty.colon +equals _sty = Pretty.equals +space _sty = Pretty.space +underscore = char '_' +dot = char '.' +lparen _sty = Pretty.lparen +rparen _sty = Pretty.rparen +lbrack _sty = Pretty.lbrack +rbrack _sty = Pretty.rbrack +lbrace _sty = Pretty.lbrace +rbrace _sty = Pretty.rbrace nest :: Int -> SDoc -> SDoc -- ^ Indent 'SDoc' some specified amount @@ -788,7 +790,7 @@ warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x warnPprTrace False _file _line _msg x = x warnPprTrace True file line msg x - = trace (show (doc PprDebug)) x + = trace (show (doc defaultDumpStyle)) x where doc = sep [hsep [text "WARNING: file", text file, text "line", int line], msg] diff -ruN ghc-6.12.1/compiler/utils/UniqFM.lhs ghc-6.13.20091231/compiler/utils/UniqFM.lhs --- ghc-6.12.1/compiler/utils/UniqFM.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/utils/UniqFM.lhs 2009-12-31 10:14:18.000000000 -0800 @@ -48,7 +48,7 @@ isNullUFM, lookupUFM, lookupUFM_Directly, lookupWithDefaultUFM, lookupWithDefaultUFM_Directly, - eltsUFM, keysUFM, + eltsUFM, keysUFM, splitUFM, ufmToList ) where @@ -130,6 +130,8 @@ elemUFM :: Uniquable key => key -> UniqFM elt -> Bool elemUFM_Directly:: Unique -> UniqFM elt -> Bool +splitUFM :: Uniquable key => UniqFM elt -> key -> (UniqFM elt, Maybe elt, UniqFM elt) + -- Splits a UFM into things less than, equal to, and greater than the key lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt lookupUFM_Directly -- when you've got the Unique already :: UniqFM elt -> Unique -> Maybe elt @@ -137,7 +139,6 @@ :: Uniquable key => UniqFM elt -> elt -> key -> elt lookupWithDefaultUFM_Directly :: UniqFM elt -> elt -> Unique -> elt - keysUFM :: UniqFM elt -> [Unique] -- Get the keys eltsUFM :: UniqFM elt -> [elt] ufmToList :: UniqFM elt -> [(Unique, elt)] @@ -358,7 +359,7 @@ (mix_trees t2 t2') -- Now the 4 different other ways; all like this: -- - -- Given j >^ j' (and, say, j > j') + -- Given j >^ j' (and, say, j > j') -- -- j j' j -- / \ + / \ ==> / \ @@ -608,6 +609,25 @@ | otherwise = lookup_tree t2 lookup_tree EmptyUFM = panic "lookup Failed" + +------------------- +splitUFM fm key = split fm (getKeyFastInt (getUnique key)) + +split :: UniqFM a -> FastInt -> (UniqFM a, Maybe a, UniqFM a) +-- Splits a UFM into things less than, equal to, and greater than the key +split EmptyUFM _ = (EmptyUFM, Nothing, EmptyUFM) +split fm i = go fm + where + go (LeafUFM j b) | i <# j = (EmptyUFM, Nothing, LeafUFM j b) + | i ># j = (LeafUFM j b, Nothing, EmptyUFM) + | otherwise = (EmptyUFM, Just b, EmptyUFM) + + go (NodeUFM j p t1 t2) + | j ># i + , (lt, eq, gt) <- go t1 = (lt, eq, mkSLNodeUFM (NodeUFMData j p) gt t2) + | (lt, eq, gt) <- go t2 = (mkLSNodeUFM (NodeUFMData j p) t1 lt, eq, gt) + + go EmptyUFM = panic "splitUFM failed" \end{code} folds are *wonderful* things. diff -ruN ghc-6.12.1/compiler/utils/Util.lhs ghc-6.13.20091231/compiler/utils/Util.lhs --- ghc-6.12.1/compiler/utils/Util.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/utils/Util.lhs 2009-12-31 10:14:17.000000000 -0800 @@ -386,36 +386,27 @@ isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool # ifndef DEBUG -isIn _msg x ys = elem__ x ys -isn'tIn _msg x ys = notElem__ x ys - ---these are here to be SPECIALIZEd (automagically) -elem__ :: Eq a => a -> [a] -> Bool -elem__ _ [] = False -elem__ x (y:ys) = x == y || elem__ x ys - -notElem__ :: Eq a => a -> [a] -> Bool -notElem__ _ [] = True -notElem__ x (y:ys) = x /= y && notElem__ x ys +isIn _msg x ys = x `elem` ys +isn'tIn _msg x ys = x `notElem` ys # else /* DEBUG */ isIn msg x ys - = elem (_ILIT(0)) x ys + = elem100 (_ILIT(0)) x ys where - elem _ _ [] = False - elem i x (y:ys) + elem100 _ _ [] = False + elem100 i x (y:ys) | i ># _ILIT(100) = trace ("Over-long elem in " ++ msg) - (x `List.elem` (y:ys)) - | otherwise = x == y || elem (i +# _ILIT(1)) x ys + (x `elem` (y:ys)) + | otherwise = x == y || elem100 (i +# _ILIT(1)) x ys isn'tIn msg x ys - = notElem (_ILIT(0)) x ys + = notElem100 (_ILIT(0)) x ys where - notElem _ _ [] = True - notElem i x (y:ys) + notElem100 _ _ [] = True + notElem100 i x (y:ys) | i ># _ILIT(100) = trace ("Over-long notElem in " ++ msg) - (x `List.notElem` (y:ys)) - | otherwise = x /= y && notElem (i +# _ILIT(1)) x ys + (x `notElem` (y:ys)) + | otherwise = x /= y && notElem100 (i +# _ILIT(1)) x ys # endif /* DEBUG */ \end{code} diff -ruN ghc-6.12.1/compiler/vectorise/VectBuiltIn.hs ghc-6.13.20091231/compiler/vectorise/VectBuiltIn.hs --- ghc-6.12.1/compiler/vectorise/VectBuiltIn.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/vectorise/VectBuiltIn.hs 2009-12-31 10:14:18.000000000 -0800 @@ -1,6 +1,6 @@ module VectBuiltIn ( Builtins(..), sumTyCon, prodTyCon, prodDataCon, - selTy, selReplicate, selPick, selElements, + selTy, selReplicate, selPick, selTags, selElements, combinePDVar, scalarZip, closureCtrFun, initBuiltins, initBuiltinVars, initBuiltinTyCons, initBuiltinDataCons, initBuiltinPAs, initBuiltinPRs, @@ -11,11 +11,12 @@ import DsMonad import IfaceEnv ( lookupOrig ) +import InstEnv import Module import DataCon ( DataCon, dataConName, dataConWorkId ) import TyCon ( TyCon, tyConName, tyConDataCons ) -import Class ( Class ) +import Class ( Class, classTyCon ) import CoreSyn ( CoreExpr, Expr(..) ) import Var ( Var ) import Id ( mkSysLocal ) @@ -26,11 +27,11 @@ import TypeRep ( funTyCon ) import Type ( Type, mkTyConApp ) import TysPrim -import TysWiredIn ( unitTyCon, unitDataCon, +import TysWiredIn ( unitDataCon, tupleTyCon, tupleCon, - intTyCon, intTyConName, - doubleTyCon, doubleTyConName, - boolTyCon, boolTyConName, trueDataCon, falseDataCon, + intTyCon, + doubleTyCon, + boolTyCon, trueDataCon, falseDataCon, parrTyConName ) import PrelNames ( word8TyConName, gHC_PARR ) import BasicTypes ( Boxity(..) ) @@ -92,6 +93,8 @@ where mk = mkModule pkg . mkModuleNameFS +dph_Orphans :: [Modules -> Module] +dph_Orphans = [dph_Repr, dph_Instances] data Builtins = Builtins { dphModules :: Modules @@ -108,20 +111,21 @@ , selTys :: Array Int Type , selReplicates :: Array Int CoreExpr , selPicks :: Array Int CoreExpr + , selTagss :: Array Int CoreExpr , selEls :: Array (Int, Int) CoreExpr , sumTyCons :: Array Int TyCon , closureTyCon :: TyCon , voidVar :: Var , pvoidVar :: Var + , fromVoidVar :: Var , punitVar :: Var - , mkPRVar :: Var , closureVar :: Var , applyVar :: Var , liftedClosureVar :: Var , liftedApplyVar :: Var , replicatePDVar :: Var , emptyPDVar :: Var - , packPDVar :: Var + , packByTagPDVar :: Var , combinePDVars :: Array Int Var , scalarClass :: Class , scalarZips :: Array Int Var @@ -146,6 +150,9 @@ selPick :: Int -> Builtins -> CoreExpr selPick = indexBuiltin "selPick" selPicks +selTags :: Int -> Builtins -> CoreExpr +selTags = indexBuiltin "selTags" selTagss + selElements :: Int -> Int -> Builtins -> CoreExpr selElements i j = indexBuiltin "selElements" selEls (i,j) @@ -153,9 +160,8 @@ sumTyCon = indexBuiltin "sumTyCon" sumTyCons prodTyCon :: Int -> Builtins -> TyCon -prodTyCon n bi - | n == 1 = wrapTyCon bi - | n >= 0 && n <= mAX_DPH_PROD = tupleTyCon Boxed n +prodTyCon n _ + | n >= 2 && n <= mAX_DPH_PROD = tupleTyCon Boxed n | otherwise = pprPanic "prodTyCon" (ppr n) prodDataCon :: Int -> Builtins -> DataCon @@ -175,13 +181,14 @@ initBuiltins :: PackageId -> DsM Builtins initBuiltins pkg = do + mapM_ load dph_Orphans parrayTyCon <- externalTyCon dph_PArray (fsLit "PArray") let [parrayDataCon] = tyConDataCons parrayTyCon pdataTyCon <- externalTyCon dph_PArray (fsLit "PData") - paTyCon <- externalTyCon dph_PArray (fsLit "PA") + paTyCon <- externalClassTyCon dph_PArray (fsLit "PA") let [paDataCon] = tyConDataCons paTyCon preprTyCon <- externalTyCon dph_PArray (fsLit "PRepr") - prTyCon <- externalTyCon dph_PArray (fsLit "PR") + prTyCon <- externalClassTyCon dph_PArray (fsLit "PR") let [prDataCon] = tyConDataCons prTyCon closureTyCon <- externalTyCon dph_Closure (fsLit ":->") @@ -193,6 +200,8 @@ (numbered "replicate" 2 mAX_DPH_SUM) sel_picks <- mapM (externalFun dph_Selector) (numbered "pick" 2 mAX_DPH_SUM) + sel_tags <- mapM (externalFun dph_Selector) + (numbered "tagsSel" 2 mAX_DPH_SUM) sel_els <- mapM mk_elements [(i,j) | i <- [2..mAX_DPH_SUM], j <- [0..i-1]] sum_tcs <- mapM (externalTyCon dph_Repr) @@ -201,27 +210,28 @@ let selTys = listArray (2, mAX_DPH_SUM) sel_tys selReplicates = listArray (2, mAX_DPH_SUM) sel_replicates selPicks = listArray (2, mAX_DPH_SUM) sel_picks + selTagss = listArray (2, mAX_DPH_SUM) sel_tags selEls = array ((2,0), (mAX_DPH_SUM, mAX_DPH_SUM)) sel_els sumTyCons = listArray (2, mAX_DPH_SUM) sum_tcs voidVar <- externalVar dph_Repr (fsLit "void") pvoidVar <- externalVar dph_Repr (fsLit "pvoid") + fromVoidVar <- externalVar dph_Repr (fsLit "fromVoid") punitVar <- externalVar dph_Repr (fsLit "punit") - mkPRVar <- externalVar dph_PArray (fsLit "mkPR") closureVar <- externalVar dph_Closure (fsLit "closure") applyVar <- externalVar dph_Closure (fsLit "$:") liftedClosureVar <- externalVar dph_Closure (fsLit "liftedClosure") liftedApplyVar <- externalVar dph_Closure (fsLit "liftedApply") replicatePDVar <- externalVar dph_PArray (fsLit "replicatePD") emptyPDVar <- externalVar dph_PArray (fsLit "emptyPD") - packPDVar <- externalVar dph_PArray (fsLit "packPD") + packByTagPDVar <- externalVar dph_PArray (fsLit "packByTagPD") combines <- mapM (externalVar dph_PArray) [mkFastString ("combine" ++ show i ++ "PD") | i <- [2..mAX_DPH_COMBINE]] let combinePDVars = listArray (2, mAX_DPH_COMBINE) combines - scalarClass <- externalClass dph_Scalar (fsLit "Scalar") + scalarClass <- externalClass dph_PArray (fsLit "Scalar") scalar_map <- externalVar dph_Scalar (fsLit "scalar_map") scalar_zip2 <- externalVar dph_Scalar (fsLit "scalar_zipWith") scalar_zips <- mapM (externalVar dph_Scalar) @@ -250,20 +260,21 @@ , selTys = selTys , selReplicates = selReplicates , selPicks = selPicks + , selTagss = selTagss , selEls = selEls , sumTyCons = sumTyCons , closureTyCon = closureTyCon , voidVar = voidVar , pvoidVar = pvoidVar + , fromVoidVar = fromVoidVar , punitVar = punitVar - , mkPRVar = mkPRVar , closureVar = closureVar , applyVar = applyVar , liftedClosureVar = liftedClosureVar , liftedApplyVar = liftedApplyVar , replicatePDVar = replicatePDVar , emptyPDVar = emptyPDVar - , packPDVar = packPDVar + , packByTagPDVar = packByTagPDVar , combinePDVars = combinePDVars , scalarClass = scalarClass , scalarZips = scalarZips @@ -280,6 +291,11 @@ }) = dph_Modules pkg + load get_mod = dsLoadModule doc mod + where + mod = get_mod modules + doc = ppr mod <+> ptext (sLit "is a DPH module") + numbered :: String -> Int -> Int -> [FastString] numbered pfx m n = [mkFastString (pfx ++ show i) | i <- [m..n]] @@ -454,66 +470,19 @@ defaultDataCons :: [DataCon] defaultDataCons = [trueDataCon, falseDataCon, unitDataCon] -initBuiltinDicts :: [(Name, Module, FastString)] -> DsM [(Name, Var)] -initBuiltinDicts ps - = do - dicts <- zipWithM externalVar mods fss - return $ zip tcs dicts - where - (tcs, mods, fss) = unzip3 ps - -initBuiltinPAs :: Builtins -> DsM [(Name, Var)] -initBuiltinPAs = initBuiltinDicts . builtinPAs +initBuiltinPAs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)] +initBuiltinPAs (Builtins { dphModules = mods }) insts + = liftM (initBuiltinDicts insts) (externalClass (dph_PArray mods) (fsLit "PA")) + +initBuiltinPRs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)] +initBuiltinPRs (Builtins { dphModules = mods }) insts + = liftM (initBuiltinDicts insts) (externalClass (dph_PArray mods) (fsLit "PR")) -builtinPAs :: Builtins -> [(Name, Module, FastString)] -builtinPAs bi@(Builtins { dphModules = mods }) - = [ - mk (tyConName $ closureTyCon bi) (dph_Closure mods) (fsLit "dPA_Clo") - , mk (tyConName $ voidTyCon bi) (dph_Repr mods) (fsLit "dPA_Void") - , mk (tyConName $ parrayTyCon bi) (dph_Instances mods) (fsLit "dPA_PArray") - , mk unitTyConName (dph_Instances mods) (fsLit "dPA_Unit") - - , mk intTyConName (dph_Instances mods) (fsLit "dPA_Int") - , mk word8TyConName (dph_Instances mods) (fsLit "dPA_Word8") - , mk doubleTyConName (dph_Instances mods) (fsLit "dPA_Double") - , mk boolTyConName (dph_Instances mods) (fsLit "dPA_Bool") - ] - ++ tups +initBuiltinDicts :: (InstEnv, InstEnv) -> Class -> [(Name, Var)] +initBuiltinDicts insts cls = map find $ classInstances insts cls where - mk name mod fs = (name, mod, fs) - - tups = map mk_tup [2..mAX_DPH_PROD] - mk_tup n = mk (tyConName $ tupleTyCon Boxed n) - (dph_Instances mods) - (mkFastString $ "dPA_" ++ show n) - -initBuiltinPRs :: Builtins -> DsM [(Name, Var)] -initBuiltinPRs = initBuiltinDicts . builtinPRs - -builtinPRs :: Builtins -> [(Name, Module, FastString)] -builtinPRs bi@(Builtins { dphModules = mods }) = - [ - mk (tyConName unitTyCon) (dph_Repr mods) (fsLit "dPR_Unit") - , mk (tyConName $ voidTyCon bi) (dph_Repr mods) (fsLit "dPR_Void") - , mk (tyConName $ wrapTyCon bi) (dph_Repr mods) (fsLit "dPR_Wrap") - , mk (tyConName $ closureTyCon bi) (dph_Closure mods) (fsLit "dPR_Clo") - - -- temporary - , mk intTyConName (dph_Instances mods) (fsLit "dPR_Int") - , mk word8TyConName (dph_Instances mods) (fsLit "dPR_Word8") - , mk doubleTyConName (dph_Instances mods) (fsLit "dPR_Double") - ] - - ++ map mk_sum [2..mAX_DPH_SUM] - ++ map mk_prod [2..mAX_DPH_PROD] - where - mk name mod fs = (name, mod, fs) - - mk_sum n = (tyConName $ sumTyCon n bi, dph_Repr mods, - mkFastString ("dPR_Sum" ++ show n)) - - mk_prod n = (tyConName $ prodTyCon n bi, dph_Repr mods, - mkFastString ("dPR_" ++ show n)) + find i | [Just tc] <- instanceRoughTcs i = (tc, instanceDFunId i) + | otherwise = pprPanic "Invalid DPH instance" (ppr i) initBuiltinBoxedTyCons :: Builtins -> DsM [(Name, TyCon)] initBuiltinBoxedTyCons = return . builtinBoxedTyCons @@ -621,6 +590,9 @@ externalTyCon mod fs = dsLookupTyCon =<< lookupOrig mod (mkTcOccFS fs) +externalClassTyCon :: Module -> FastString -> DsM TyCon +externalClassTyCon mod fs = liftM classTyCon (externalClass mod fs) + externalType :: Module -> FastString -> DsM Type externalType mod fs = do @@ -629,11 +601,7 @@ externalClass :: Module -> FastString -> DsM Class externalClass mod fs - = dsLookupClass =<< lookupOrig mod (mkTcOccFS fs) - -unitTyConName :: Name -unitTyConName = tyConName unitTyCon - + = dsLookupClass =<< lookupOrig mod (mkClsOccFS fs) primMethod :: TyCon -> String -> Builtins -> DsM (Maybe Var) primMethod tycon method (Builtins { dphModules = mods }) diff -ruN ghc-6.12.1/compiler/vectorise/VectCore.hs ghc-6.13.20091231/compiler/vectorise/VectCore.hs --- ghc-6.12.1/compiler/vectorise/VectCore.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/vectorise/VectCore.hs 2009-12-31 10:14:17.000000000 -0800 @@ -10,13 +10,12 @@ vVar, vType, vNote, vLet, vLams, vLamsWithoutLC, vVarApps, - vCaseDEFAULT, vInlineMe + vCaseDEFAULT ) where #include "HsVersions.h" import CoreSyn -import CoreUtils ( mkInlineMe ) import Type ( Type ) import Var @@ -83,6 +82,3 @@ where mkDEFAULT e = [(DEFAULT, [], e)] -vInlineMe :: VExpr -> VExpr -vInlineMe (vexpr, lexpr) = (mkInlineMe vexpr, mkInlineMe lexpr) - diff -ruN ghc-6.12.1/compiler/vectorise/VectMonad.hs ghc-6.13.20091231/compiler/vectorise/VectMonad.hs --- ghc-6.12.1/compiler/vectorise/VectMonad.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/vectorise/VectMonad.hs 2009-12-31 10:14:17.000000000 -0800 @@ -10,7 +10,7 @@ newExportedVar, newLocalVar, newLocalVars, newDummyVar, newTyVar, Builtins(..), sumTyCon, prodTyCon, prodDataCon, - selTy, selReplicate, selPick, selElements, + selTy, selReplicate, selPick, selTags, selElements, combinePDVar, scalarZip, closureCtrFun, builtin, builtins, @@ -543,8 +543,6 @@ builtin_vars <- initBuiltinVars builtins builtin_tycons <- initBuiltinTyCons builtins let builtin_datacons = initBuiltinDataCons builtins - builtin_pas <- initBuiltinPAs builtins - builtin_prs <- initBuiltinPRs builtins builtin_boxed <- initBuiltinBoxedTyCons builtins builtin_scalars <- initBuiltinScalars builtins @@ -552,6 +550,9 @@ let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts) instEnvs = (eps_inst_env eps, mg_inst_env guts) + builtin_prs <- initBuiltinPRs builtins instEnvs + builtin_pas <- initBuiltinPAs builtins instEnvs + let genv = extendImportedVarsEnv builtin_vars . extendScalars builtin_scalars . extendTyConsEnv builtin_tycons diff -ruN ghc-6.12.1/compiler/vectorise/Vectorise.hs ghc-6.13.20091231/compiler/vectorise/Vectorise.hs --- ghc-6.12.1/compiler/vectorise/Vectorise.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/vectorise/Vectorise.hs 2009-12-31 10:14:18.000000000 -0800 @@ -12,6 +12,7 @@ import Module ( PackageId ) import CoreSyn import CoreUtils +import CoreUnfold ( mkInlineRule ) import MkCore ( mkWildCase ) import CoreFVs import CoreMonad ( CoreM, getHscEnv ) @@ -24,13 +25,16 @@ import VarSet import Id import OccName +import BasicTypes ( isLoopBreaker ) import Literal ( Literal, mkMachInt ) import TysWiredIn +import TysPrim ( intPrimTy ) import Outputable import FastString -import Control.Monad ( liftM, liftM2, zipWithM ) +import Util ( zipLazy ) +import Control.Monad import Data.List ( sortBy, unzip4 ) vectorise :: PackageId -> ModGuts -> CoreM ModGuts @@ -66,8 +70,8 @@ vectTopBind :: CoreBind -> VM CoreBind vectTopBind b@(NonRec var expr) = do - var' <- vectTopBinder var - expr' <- vectTopRhs var expr + (inline, expr') <- vectTopRhs var expr + var' <- vectTopBinder var inline expr' hs <- takeHoisted cexpr <- tryConvert var var' expr return . Rec $ (var, cexpr) : (var', expr') : hs @@ -76,8 +80,13 @@ vectTopBind b@(Rec bs) = do - vars' <- mapM vectTopBinder vars - exprs' <- zipWithM vectTopRhs vars exprs + (vars', _, exprs') <- fixV $ \ ~(_, inlines, rhss) -> + do + vars' <- sequence [vectTopBinder var inline rhs + | (var, ~(inline, rhs)) + <- zipLazy vars (zip inlines rhss)] + (inlines', exprs') <- mapAndUnzipM (uncurry vectTopRhs) bs + return (vars', inlines', exprs') hs <- takeHoisted cexprs <- sequence $ zipWith3 tryConvert vars vars' exprs return . Rec $ zip vars cexprs ++ zip vars' exprs' ++ hs @@ -86,20 +95,28 @@ where (vars, exprs) = unzip bs -vectTopBinder :: Var -> VM Var -vectTopBinder var +-- NOTE: vectTopBinder *MUST* be lazy in inline and expr because of how it is +-- used inside of fixV in vectTopBind +vectTopBinder :: Var -> Inline -> CoreExpr -> VM Var +vectTopBinder var inline expr = do vty <- vectType (idType var) - var' <- cloneId mkVectOcc var vty + var' <- liftM (`setIdUnfolding` unfolding) $ cloneId mkVectOcc var vty defGlobalVar var var' return var' + where + unfolding = case inline of + Inline arity -> mkInlineRule needSaturated expr arity + DontInline -> noUnfolding -vectTopRhs :: Var -> CoreExpr -> VM CoreExpr +vectTopRhs :: Var -> CoreExpr -> VM (Inline, CoreExpr) vectTopRhs var expr - = do - closedV . liftM vectorised - . inBind var - $ vectPolyExpr (freeVars expr) + = closedV + $ do + (inline, vexpr) <- inBind var + $ vectPolyExpr (isLoopBreaker $ idOccInfo var) + (freeVars expr) + return (inline, vectorised vexpr) tryConvert :: Var -> Var -> CoreExpr -> VM CoreExpr tryConvert var vect_var rhs @@ -186,14 +203,19 @@ lexpr <- liftPD (Lit lit) return (Lit lit, lexpr) -vectPolyExpr :: CoreExprWithFVs -> VM VExpr -vectPolyExpr (_, AnnNote note expr) - = liftM (vNote note) $ vectPolyExpr expr -vectPolyExpr expr - = polyAbstract tvs $ \abstract -> - do - mono' <- vectFnExpr False mono - return $ mapVect abstract mono' +vectPolyExpr :: Bool -> CoreExprWithFVs -> VM (Inline, VExpr) +vectPolyExpr loop_breaker (_, AnnNote note expr) + = do + (inline, expr') <- vectPolyExpr loop_breaker expr + return (inline, vNote note expr') +vectPolyExpr loop_breaker expr + = do + arity <- polyArity tvs + polyAbstract tvs $ \args -> + do + (inline, mono') <- vectFnExpr False loop_breaker mono + return (addInlineArity inline arity, + mapVect (mkLams $ tvs ++ args) mono') where (tvs, mono) = collectAnnTypeBinders expr @@ -244,7 +266,7 @@ vectExpr (_, AnnLet (AnnNonRec bndr rhs) body) = do - vrhs <- localV . inBind bndr $ vectPolyExpr rhs + vrhs <- localV . inBind bndr . liftM snd $ vectPolyExpr False rhs (vbndr, vbody) <- vectBndrIn bndr (vectExpr body) return $ vLet (vNonRec vbndr vrhs) vbody @@ -253,17 +275,18 @@ (vbndrs, (vrhss, vbody)) <- vectBndrsIn bndrs $ liftM2 (,) (zipWithM vect_rhs bndrs rhss) - (vectPolyExpr body) + (vectExpr body) return $ vLet (vRec vbndrs vrhss) vbody where (bndrs, rhss) = unzip bs vect_rhs bndr rhs = localV . inBind bndr - $ vectExpr rhs + . liftM snd + $ vectPolyExpr (isLoopBreaker $ idOccInfo bndr) rhs vectExpr e@(_, AnnLam bndr _) - | isId bndr = vectFnExpr True e + | isId bndr = liftM snd $ vectFnExpr True False e {- onlyIfV (isEmptyVarSet fvs) (vectScalarLam bs $ deAnnotate body) `orElseV` vectLam True fvs bs body @@ -273,14 +296,17 @@ vectExpr e = cantVectorise "Can't vectorise expression" (ppr $ deAnnotate e) -vectFnExpr :: Bool -> CoreExprWithFVs -> VM VExpr -vectFnExpr inline e@(fvs, AnnLam bndr _) - | isId bndr = onlyIfV (isEmptyVarSet fvs) (vectScalarLam bs $ deAnnotate body) - `orElseV` vectLam inline fvs bs body +vectFnExpr :: Bool -> Bool -> CoreExprWithFVs -> VM (Inline, VExpr) +vectFnExpr inline loop_breaker e@(fvs, AnnLam bndr _) + | isId bndr = onlyIfV (isEmptyVarSet fvs) + (mark DontInline . vectScalarLam bs $ deAnnotate body) + `orElseV` mark inlineMe (vectLam inline loop_breaker fvs bs body) where (bs,body) = collectAnnValBinders e -vectFnExpr _ e = vectExpr e +vectFnExpr _ _ e = mark DontInline $ vectExpr e +mark :: Inline -> VM a -> VM (Inline, a) +mark b p = do { x <- p; return (b,x) } vectScalarLam :: [Var] -> CoreExpr -> VM VExpr vectScalarLam args body @@ -290,11 +316,11 @@ && is_scalar_ty res_ty && is_scalar (extendVarSetList scalars args) body) $ do - fn_var <- hoistExpr (fsLit "fn") (mkLams args body) + fn_var <- hoistExpr (fsLit "fn") (mkLams args body) DontInline zipf <- zipScalars arg_tys res_ty clo <- scalarClosure arg_tys res_ty (Var fn_var) (zipf `App` Var fn_var) - clo_var <- hoistExpr (fsLit "clo") clo + clo_var <- hoistExpr (fsLit "clo") clo DontInline lclo <- liftPD (Var clo_var) return (Var clo_var, lclo) where @@ -313,8 +339,8 @@ is_scalar vs (App e1 e2) = is_scalar vs e1 && is_scalar vs e2 is_scalar _ _ = False -vectLam :: Bool -> VarSet -> [Var] -> CoreExprWithFVs -> VM VExpr -vectLam inline fvs bs body +vectLam :: Bool -> Bool -> VarSet -> [Var] -> CoreExprWithFVs -> VM VExpr +vectLam inline loop_breaker fvs bs body = do tyvars <- localTyVars (vs, vvs) <- readLEnv $ \env -> @@ -325,14 +351,28 @@ res_ty <- vectType (exprType $ deAnnotate body) buildClosures tyvars vvs arg_tys res_ty - . hoistPolyVExpr tyvars + . hoistPolyVExpr tyvars (maybe_inline (length vs + length bs)) $ do lc <- builtin liftingContext (vbndrs, vbody) <- vectBndrsIn (vs ++ bs) (vectExpr body) - return . maybe_inline $ vLams lc vbndrs vbody + vbody' <- break_loop lc res_ty vbody + return $ vLams lc vbndrs vbody' where - maybe_inline = if inline then vInlineMe else id + maybe_inline n | inline = Inline n + | otherwise = DontInline + + break_loop lc ty (ve, le) + | loop_breaker + = do + empty <- emptyPD ty + lty <- mkPDataType ty + return (ve, mkWildCase (Var lc) intPrimTy lty + [(DEFAULT, [], le), + (LitAlt (mkMachInt 0), [], empty)]) + + | otherwise = return (ve, le) + vectTyAppExpr :: CoreExprWithFVs -> [Type] -> VM VExpr vectTyAppExpr (_, AnnVar v) tys = vectPolyVar v tys @@ -440,16 +480,14 @@ cmp _ DEFAULT = GT cmp _ _ = panic "vectAlgCase/cmp" - proc_alt arity sel vty lty (DataAlt dc, bndrs, body) + proc_alt arity sel _ lty (DataAlt dc, bndrs, body) = do vect_dc <- maybeV (lookupDataCon dc) let ntag = dataConTagZ vect_dc tag = mkDataConTag vect_dc fvs = freeVarsOf body `delVarSetList` bndrs - pick <- builtin (selPick arity) - let flags_expr = mkApps pick [sel, tag] - flags_var <- newLocalVar (fsLit "flags") (exprType flags_expr) + sel_tags <- liftM (`App` sel) (builtin (selTags arity)) lc <- builtin liftingContext elems <- builtin (selElements arity ntag) @@ -457,15 +495,17 @@ <- vectBndrsIn bndrs . localV $ do - binds <- mapM (pack_var (Var lc) (Var flags_var)) + binds <- mapM (pack_var (Var lc) sel_tags tag) . filter isLocalId $ varSetElems fvs (ve, le) <- vectExpr body - empty <- emptyPD vty return (ve, Case (elems `App` sel) lc lty - [(DEFAULT, [], Let (NonRec flags_var flags_expr) - $ mkLets (concat binds) le), - (LitAlt (mkMachInt 0), [], empty)]) + [(DEFAULT, [], (mkLets (concat binds) le))]) + -- empty <- emptyPD vty + -- return (ve, Case (elems `App` sel) lc lty + -- [(DEFAULT, [], Let (NonRec flags_var flags_expr) + -- $ mkLets (concat binds) le), + -- (LitAlt (mkMachInt 0), [], empty)]) let (vect_bndrs, lift_bndrs) = unzip vbndrs return (vect_dc, vect_bndrs, lift_bndrs, vbody) @@ -473,14 +513,14 @@ mk_vect_alt vect_dc bndrs body = (DataAlt vect_dc, bndrs, body) - pack_var len flags v + pack_var len tags t v = do r <- lookupVar v case r of Local (vv, lv) -> do lv' <- cloneVar lv - expr <- packPD (idType vv) (Var lv) len flags + expr <- packByTagPD (idType vv) (Var lv) len tags t updLEnv (\env -> env { local_vars = extendVarEnv (local_vars env) v (vv, lv') }) return [(NonRec lv' expr)] diff -ruN ghc-6.12.1/compiler/vectorise/VectType.hs ghc-6.13.20091231/compiler/vectorise/VectType.hs --- ghc-6.12.1/compiler/vectorise/VectType.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/vectorise/VectType.hs 2009-12-31 10:14:18.000000000 -0800 @@ -11,6 +11,7 @@ import HscTypes ( TypeEnv, extendTypeEnvList, typeEnvTyCons ) import CoreSyn import CoreUtils +import CoreUnfold import MkCore ( mkWildCase ) import BuildTyCl import DataCon @@ -20,9 +21,11 @@ import Coercion import FamInstEnv ( FamInst, mkLocalFamInst ) import OccName +import Id import MkId -import BasicTypes ( StrictnessMark(..), boolToRecFlag ) -import Var ( Var, TyVar ) +import BasicTypes ( StrictnessMark(..), boolToRecFlag, + alwaysInlinePragma, dfunInlinePragma ) +import Var ( Var, TyVar, varType ) import Name ( Name, getOccName ) import NameEnv @@ -35,6 +38,7 @@ import Outputable import FastString +import MonadUtils ( zipWith3M, foldrM, concatMapM ) import Control.Monad ( liftM, liftM2, zipWithM, zipWithM_, mapAndUnzipM ) import Data.List ( inits, tails, zipWith4, zipWith5 ) @@ -118,24 +122,28 @@ let orig_tcs = keep_tcs ++ conv_tcs vect_tcs = keep_tcs ++ new_tcs - repr_tcs <- zipWithM buildPReprTyCon orig_tcs vect_tcs - pdata_tcs <- zipWithM buildPDataTyCon orig_tcs vect_tcs - dfuns <- mapM mkPADFun vect_tcs - defTyConPAs (zip vect_tcs dfuns) - binds <- sequence (zipWith5 buildTyConBindings orig_tcs - vect_tcs - repr_tcs - pdata_tcs - dfuns) + (_, binds, inst_tcs) <- fixV $ \ ~(dfuns', _, _) -> + do + defTyConPAs (zipLazy vect_tcs dfuns') + reprs <- mapM tyConRepr vect_tcs + repr_tcs <- zipWith3M buildPReprTyCon orig_tcs vect_tcs reprs + pdata_tcs <- zipWith3M buildPDataTyCon orig_tcs vect_tcs reprs + dfuns <- sequence $ zipWith5 buildTyConBindings orig_tcs + vect_tcs + repr_tcs + pdata_tcs + reprs + binds <- takeHoisted + return (dfuns, binds, repr_tcs ++ pdata_tcs) - let all_new_tcs = new_tcs ++ repr_tcs ++ pdata_tcs + let all_new_tcs = new_tcs ++ inst_tcs let new_env = extendTypeEnvList env (map ATyCon all_new_tcs ++ [ADataCon dc | tc <- all_new_tcs , dc <- tyConDataCons tc]) - return (new_env, map mkLocalFamInst (repr_tcs ++ pdata_tcs), concat binds) + return (new_env, map mkLocalFamInst inst_tcs, binds) where tycons = typeEnvTyCons env groups = tyConGroups tycons @@ -213,11 +221,13 @@ mk_fam_inst fam_tc arg_tc = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc]) -buildPReprTyCon :: TyCon -> TyCon -> VM TyCon -buildPReprTyCon orig_tc vect_tc + +buildPReprTyCon :: TyCon -> TyCon -> SumRepr -> VM TyCon +buildPReprTyCon orig_tc vect_tc repr = do name <- cloneName mkPReprTyConOcc (tyConName orig_tc) - rhs_ty <- buildPReprType vect_tc + -- rhs_ty <- buildPReprType vect_tc + rhs_ty <- sumReprType repr prepr_tc <- builtin preprTyCon liftDs $ buildSynTyCon name tyvars @@ -227,129 +237,219 @@ where tyvars = tyConTyVars vect_tc -buildPReprType :: TyCon -> VM Type -buildPReprType vect_tc = sum_type . map dataConRepArgTys $ tyConDataCons vect_tc - where - sum_type [] = voidType - sum_type [tys] = prod_type tys - sum_type _ = do - (sum_tc, _, _, args) <- reprSumTyCons vect_tc - return $ mkTyConApp sum_tc args - - prod_type [] = voidType - prod_type [ty] = return ty - prod_type tys = do - prod_tc <- builtin (prodTyCon (length tys)) - return $ mkTyConApp prod_tc tys - -reprSumTyCons :: TyCon -> VM (TyCon, TyCon, Type, [Type]) -reprSumTyCons vect_tc - = do - tc <- builtin (sumTyCon arity) - args <- mapM (prod . dataConRepArgTys) cons - (pdata_tc, _) <- pdataReprTyCon (mkTyConApp tc args) - sel_ty <- builtin (selTy arity) - return (tc, pdata_tc, sel_ty, args) - where - cons = tyConDataCons vect_tc - arity = length cons - - prod [] = voidType - prod [ty] = return ty - prod tys = do - prod_tc <- builtin (prodTyCon (length tys)) - return $ mkTyConApp prod_tc tys +data CompRepr = Keep Type + CoreExpr -- PR dictionary for the type + | Wrap Type + +data ProdRepr = EmptyProd + | UnaryProd CompRepr + | Prod { repr_tup_tc :: TyCon -- representation tuple tycon + , repr_ptup_tc :: TyCon -- PData representation tycon + , repr_comp_tys :: [Type] -- representation types of + , repr_comps :: [CompRepr] -- components + } +data ConRepr = ConRepr DataCon ProdRepr + +data SumRepr = EmptySum + | UnarySum ConRepr + | Sum { repr_sum_tc :: TyCon -- representation sum tycon + , repr_psum_tc :: TyCon -- PData representation tycon + , repr_sel_ty :: Type -- type of selector + , repr_con_tys :: [Type] -- representation types of + , repr_cons :: [ConRepr] -- components + } + +tyConRepr :: TyCon -> VM SumRepr +tyConRepr tc = sum_repr (tyConDataCons tc) + where + sum_repr [] = return EmptySum + sum_repr [con] = liftM UnarySum (con_repr con) + sum_repr cons = do + rs <- mapM con_repr cons + sum_tc <- builtin (sumTyCon arity) + tys <- mapM conReprType rs + (psum_tc, _) <- pdataReprTyCon (mkTyConApp sum_tc tys) + sel_ty <- builtin (selTy arity) + return $ Sum { repr_sum_tc = sum_tc + , repr_psum_tc = psum_tc + , repr_sel_ty = sel_ty + , repr_con_tys = tys + , repr_cons = rs + } + where + arity = length cons + + con_repr con = liftM (ConRepr con) (prod_repr (dataConRepArgTys con)) -buildToPRepr :: TyCon -> TyCon -> TyCon -> VM CoreExpr -buildToPRepr vect_tc repr_tc _ + prod_repr [] = return EmptyProd + prod_repr [ty] = liftM UnaryProd (comp_repr ty) + prod_repr tys = do + rs <- mapM comp_repr tys + tup_tc <- builtin (prodTyCon arity) + tys' <- mapM compReprType rs + (ptup_tc, _) <- pdataReprTyCon (mkTyConApp tup_tc tys') + return $ Prod { repr_tup_tc = tup_tc + , repr_ptup_tc = ptup_tc + , repr_comp_tys = tys' + , repr_comps = rs + } + where + arity = length tys + + comp_repr ty = liftM (Keep ty) (prDictOfType ty) + `orElseV` return (Wrap ty) + +sumReprType :: SumRepr -> VM Type +sumReprType EmptySum = voidType +sumReprType (UnarySum r) = conReprType r +sumReprType (Sum { repr_sum_tc = sum_tc, repr_con_tys = tys }) + = return $ mkTyConApp sum_tc tys + +conReprType :: ConRepr -> VM Type +conReprType (ConRepr _ r) = prodReprType r + +prodReprType :: ProdRepr -> VM Type +prodReprType EmptyProd = voidType +prodReprType (UnaryProd r) = compReprType r +prodReprType (Prod { repr_tup_tc = tup_tc, repr_comp_tys = tys }) + = return $ mkTyConApp tup_tc tys + +compReprType :: CompRepr -> VM Type +compReprType (Keep ty _) = return ty +compReprType (Wrap ty) = do + wrap_tc <- builtin wrapTyCon + return $ mkTyConApp wrap_tc [ty] + +compOrigType :: CompRepr -> Type +compOrigType (Keep ty _) = ty +compOrigType (Wrap ty) = ty + +buildToPRepr :: TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr +buildToPRepr vect_tc repr_tc _ repr = do let arg_ty = mkTyConApp vect_tc ty_args res_ty <- mkPReprType arg_ty arg <- newLocalVar (fsLit "x") arg_ty - result <- to_sum (Var arg) arg_ty res_ty (tyConDataCons vect_tc) + result <- to_sum (Var arg) arg_ty res_ty repr return $ Lam arg result where ty_args = mkTyVarTys (tyConTyVars vect_tc) - wrap = wrapFamInstBody repr_tc ty_args + wrap_repr_inst = wrapFamInstBody repr_tc ty_args - to_sum _ _ _ [] + to_sum _ _ _ EmptySum = do void <- builtin voidVar - return $ wrap (Var void) + return $ wrap_repr_inst $ Var void - to_sum arg arg_ty res_ty [con] + to_sum arg arg_ty res_ty (UnarySum r) = do - (prod, vars) <- to_prod (dataConRepArgTys con) + (pat, vars, body) <- con_alt r return $ mkWildCase arg arg_ty res_ty - [(DataAlt con, vars, wrap prod)] + [(pat, vars, wrap_repr_inst body)] - to_sum arg arg_ty res_ty cons + to_sum arg arg_ty res_ty (Sum { repr_sum_tc = sum_tc + , repr_con_tys = tys + , repr_cons = cons }) = do - (prods, vars) <- mapAndUnzipM (to_prod . dataConRepArgTys) cons - (sum_tc, _, _, sum_ty_args) <- reprSumTyCons vect_tc - let sum_cons = [mkConApp con (map Type sum_ty_args) - | con <- tyConDataCons sum_tc] - return . mkWildCase arg arg_ty res_ty - $ zipWith4 mk_alt cons vars sum_cons prods - where - mk_alt con vars sum_con expr - = (DataAlt con, vars, wrap $ sum_con `App` expr) + alts <- mapM con_alt cons + let alts' = [(pat, vars, wrap_repr_inst + $ mkConApp sum_con (map Type tys ++ [body])) + | ((pat, vars, body), sum_con) + <- zip alts (tyConDataCons sum_tc)] + return $ mkWildCase arg arg_ty res_ty alts' - to_prod [] + con_alt (ConRepr con r) + = do + (vars, body) <- to_prod r + return (DataAlt con, vars, body) + + to_prod EmptyProd = do void <- builtin voidVar - return (Var void, []) - to_prod [ty] + return ([], Var void) + + to_prod (UnaryProd comp) = do - var <- newLocalVar (fsLit "x") ty - return (Var var, [var]) - to_prod tys - = do - prod_con <- builtin (prodDataCon (length tys)) - vars <- newLocalVars (fsLit "x") tys - return (mkConApp prod_con (map Type tys ++ map Var vars), vars) + var <- newLocalVar (fsLit "x") (compOrigType comp) + body <- to_comp (Var var) comp + return ([var], body) + + to_prod(Prod { repr_tup_tc = tup_tc + , repr_comp_tys = tys + , repr_comps = comps }) + = do + vars <- newLocalVars (fsLit "x") (map compOrigType comps) + exprs <- zipWithM to_comp (map Var vars) comps + return (vars, mkConApp tup_con (map Type tys ++ exprs)) + where + [tup_con] = tyConDataCons tup_tc -buildFromPRepr :: TyCon -> TyCon -> TyCon -> VM CoreExpr -buildFromPRepr vect_tc repr_tc _ + to_comp expr (Keep _ _) = return expr + to_comp expr (Wrap ty) = do + wrap_tc <- builtin wrapTyCon + return $ wrapNewTypeBody wrap_tc [ty] expr + + +buildFromPRepr :: TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr +buildFromPRepr vect_tc repr_tc _ repr = do arg_ty <- mkPReprType res_ty arg <- newLocalVar (fsLit "x") arg_ty result <- from_sum (unwrapFamInstScrut repr_tc ty_args (Var arg)) - (tyConDataCons vect_tc) + repr return $ Lam arg result where ty_args = mkTyVarTys (tyConTyVars vect_tc) res_ty = mkTyConApp vect_tc ty_args - from_sum _ [] = pprPanic "buildFromPRepr" (ppr vect_tc) - from_sum expr [con] = from_prod expr con - from_sum expr cons - = do - (sum_tc, _, _, sum_ty_args) <- reprSumTyCons vect_tc - let sum_cons = tyConDataCons sum_tc - vars <- newLocalVars (fsLit "x") sum_ty_args - prods <- zipWithM from_prod (map Var vars) cons - return . mkWildCase expr (exprType expr) res_ty - $ zipWith3 mk_alt sum_cons vars prods - where - mk_alt con var expr = (DataAlt con, [var], expr) - - from_prod expr con - = case dataConRepArgTys con of - [] -> return $ apply_con [] - [_] -> return $ apply_con [expr] - tys -> do - prod_con <- builtin (prodDataCon (length tys)) - vars <- newLocalVars (fsLit "y") tys - return $ mkWildCase expr (exprType expr) res_ty - [(DataAlt prod_con, vars, apply_con (map Var vars))] + from_sum _ EmptySum + = do + dummy <- builtin fromVoidVar + return $ Var dummy `App` Type res_ty + + from_sum expr (UnarySum r) = from_con expr r + from_sum expr (Sum { repr_sum_tc = sum_tc + , repr_con_tys = tys + , repr_cons = cons }) + = do + vars <- newLocalVars (fsLit "x") tys + es <- zipWithM from_con (map Var vars) cons + return $ mkWildCase expr (exprType expr) res_ty + [(DataAlt con, [var], e) + | (con, var, e) <- zip3 (tyConDataCons sum_tc) vars es] + + from_con expr (ConRepr con r) + = from_prod expr (mkConApp con $ map Type ty_args) r + + from_prod _ con EmptyProd = return con + from_prod expr con (UnaryProd r) + = do + e <- from_comp expr r + return $ con `App` e + + from_prod expr con (Prod { repr_tup_tc = tup_tc + , repr_comp_tys = tys + , repr_comps = comps + }) + = do + vars <- newLocalVars (fsLit "y") tys + es <- zipWithM from_comp (map Var vars) comps + return $ mkWildCase expr (exprType expr) res_ty + [(DataAlt tup_con, vars, con `mkApps` es)] where - apply_con exprs = mkConApp con (map Type ty_args) `mkApps` exprs + [tup_con] = tyConDataCons tup_tc -buildToArrPRepr :: TyCon -> TyCon -> TyCon -> VM CoreExpr -buildToArrPRepr vect_tc prepr_tc pdata_tc + from_comp expr (Keep _ _) = return expr + from_comp expr (Wrap ty) + = do + wrap <- builtin wrapTyCon + return $ unwrapNewTypeBody wrap [ty] expr + + +buildToArrPRepr :: TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr +buildToArrPRepr vect_tc prepr_tc pdata_tc r = do arg_ty <- mkPDataType el_ty res_ty <- mkPDataType =<< mkPReprType el_ty @@ -363,7 +463,7 @@ scrut = unwrapFamInstScrut pdata_tc ty_args (Var arg) - (vars, result) <- to_sum (tyConDataCons vect_tc) + (vars, result) <- to_sum r return . Lam arg $ mkWildCase scrut (mkTyConApp pdata_tc ty_args) res_ty @@ -374,42 +474,64 @@ [pdata_dc] = tyConDataCons pdata_tc - to_sum [] = do - pvoid <- builtin pvoidVar - return ([], Var pvoid) - to_sum [con] = to_prod con - to_sum cons = do - (vars, exprs) <- mapAndUnzipM to_prod cons - (_, pdata_tc, sel_ty, arg_tys) <- reprSumTyCons vect_tc - sel <- newLocalVar (fsLit "sel") sel_ty - let [pdata_con] = tyConDataCons pdata_tc - result = wrapFamInstBody pdata_tc arg_tys - . mkConApp pdata_con - $ map Type arg_tys ++ (Var sel : exprs) - return (sel : concat vars, result) - - to_prod con - | [] <- tys = do - pvoid <- builtin pvoidVar - return ([], Var pvoid) - | [ty] <- tys = do - var <- newLocalVar (fsLit "x") ty - return ([var], Var var) - | otherwise - = do - vars <- newLocalVars (fsLit "x") tys - prod_tc <- builtin (prodTyCon (length tys)) - (pdata_prod_tc, _) <- pdataReprTyCon (mkTyConApp prod_tc tys) - let [pdata_prod_con] = tyConDataCons pdata_prod_tc - result = wrapFamInstBody pdata_prod_tc tys - . mkConApp pdata_prod_con - $ map Type tys ++ map Var vars - return (vars, result) + + to_sum EmptySum = do + pvoid <- builtin pvoidVar + return ([], Var pvoid) + to_sum (UnarySum r) = to_con r + to_sum (Sum { repr_psum_tc = psum_tc + , repr_sel_ty = sel_ty + , repr_con_tys = tys + , repr_cons = cons + }) + = do + (vars, exprs) <- mapAndUnzipM to_con cons + sel <- newLocalVar (fsLit "sel") sel_ty + return (sel : concat vars, mk_result (Var sel) exprs) where - tys = dataConRepArgTys con + [psum_con] = tyConDataCons psum_tc + mk_result sel exprs = wrapFamInstBody psum_tc tys + $ mkConApp psum_con + $ map Type tys ++ (sel : exprs) + + to_con (ConRepr _ r) = to_prod r + + to_prod EmptyProd = do + pvoid <- builtin pvoidVar + return ([], Var pvoid) + to_prod (UnaryProd r) + = do + pty <- mkPDataType (compOrigType r) + var <- newLocalVar (fsLit "x") pty + expr <- to_comp (Var var) r + return ([var], expr) + + to_prod (Prod { repr_ptup_tc = ptup_tc + , repr_comp_tys = tys + , repr_comps = comps }) + = do + ptys <- mapM (mkPDataType . compOrigType) comps + vars <- newLocalVars (fsLit "x") ptys + es <- zipWithM to_comp (map Var vars) comps + return (vars, mk_result es) + where + [ptup_con] = tyConDataCons ptup_tc + mk_result exprs = wrapFamInstBody ptup_tc tys + $ mkConApp ptup_con + $ map Type tys ++ exprs -buildFromArrPRepr :: TyCon -> TyCon -> TyCon -> VM CoreExpr -buildFromArrPRepr vect_tc prepr_tc pdata_tc + to_comp expr (Keep _ _) = return expr + + -- FIXME: this is bound to be wrong! + to_comp expr (Wrap ty) + = do + wrap_tc <- builtin wrapTyCon + (pwrap_tc, _) <- pdataReprTyCon (mkTyConApp wrap_tc [ty]) + return $ wrapNewTypeBody pwrap_tc [ty] expr + + +buildFromArrPRepr :: TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr +buildFromArrPRepr vect_tc prepr_tc pdata_tc r = do arg_ty <- mkPDataType =<< mkPReprType el_ty res_ty <- mkPDataType el_ty @@ -422,61 +544,84 @@ scrut = mkCoerce co (Var arg) - (args, mk) <- from_sum res_ty scrut (tyConDataCons vect_tc) + mk_result args = wrapFamInstBody pdata_tc var_tys + $ mkConApp pdata_con + $ map Type var_tys ++ args + + (expr, _) <- fixV $ \ ~(_, args) -> + from_sum res_ty (mk_result args) scrut r + + return $ Lam arg expr + + -- (args, mk) <- from_sum res_ty scrut r - let result = wrapFamInstBody pdata_tc var_tys - . mkConApp pdata_dc - $ map Type var_tys ++ args + -- let result = wrapFamInstBody pdata_tc var_tys + -- . mkConApp pdata_dc + -- $ map Type var_tys ++ args - return $ Lam arg (mk result) + -- return $ Lam arg (mk result) where var_tys = mkTyVarTys $ tyConTyVars vect_tc el_ty = mkTyConApp vect_tc var_tys - [pdata_dc] = tyConDataCons pdata_tc + [pdata_con] = tyConDataCons pdata_tc - from_sum res_ty expr [] = return ([], mk) - where - mk body = mkWildCase expr (exprType expr) res_ty [(DEFAULT, [], body)] - from_sum res_ty expr [con] = from_prod res_ty expr con - from_sum res_ty expr cons + from_sum _ res _ EmptySum = return (res, []) + from_sum res_ty res expr (UnarySum r) = from_con res_ty res expr r + from_sum res_ty res expr (Sum { repr_psum_tc = psum_tc + , repr_sel_ty = sel_ty + , repr_con_tys = tys + , repr_cons = cons }) = do - (_, pdata_tc, sel_ty, arg_tys) <- reprSumTyCons vect_tc sel <- newLocalVar (fsLit "sel") sel_ty - vars <- newLocalVars (fsLit "xs") arg_tys - rs <- zipWithM (from_prod res_ty) (map Var vars) cons - let (prods, mks) = unzip rs - [pdata_con] = tyConDataCons pdata_tc - scrut = unwrapFamInstScrut pdata_tc arg_tys expr - - mk body = mkWildCase scrut (exprType scrut) res_ty - [(DataAlt pdata_con, sel : vars, foldr ($) body mks)] - return (Var sel : concat prods, mk) + ptys <- mapM mkPDataType tys + vars <- newLocalVars (fsLit "xs") ptys + (res', args) <- fold from_con res_ty res (map Var vars) cons + let scrut = unwrapFamInstScrut psum_tc tys expr + body = mkWildCase scrut (exprType scrut) res_ty + [(DataAlt psum_con, sel : vars, res')] + return (body, Var sel : args) + where + [psum_con] = tyConDataCons psum_tc - from_prod res_ty expr con - | [] <- tys = return ([], id) - | [_] <- tys = return ([expr], id) - | otherwise - = do - prod_tc <- builtin (prodTyCon (length tys)) - (pdata_tc, _) <- pdataReprTyCon (mkTyConApp prod_tc tys) - pdata_tys <- mapM mkPDataType tys - vars <- newLocalVars (fsLit "ys") pdata_tys - let [pdata_con] = tyConDataCons pdata_tc - scrut = unwrapFamInstScrut pdata_tc tys expr + from_con res_ty res expr (ConRepr _ r) = from_prod res_ty res expr r - mk body = mkWildCase scrut (exprType scrut) res_ty - [(DataAlt pdata_con, vars, body)] + from_prod _ res _ EmptyProd = return (res, []) + from_prod res_ty res expr (UnaryProd r) + = from_comp res_ty res expr r + from_prod res_ty res expr (Prod { repr_ptup_tc = ptup_tc + , repr_comp_tys = tys + , repr_comps = comps }) + = do + ptys <- mapM mkPDataType tys + vars <- newLocalVars (fsLit "ys") ptys + (res', args) <- fold from_comp res_ty res (map Var vars) comps + let scrut = unwrapFamInstScrut ptup_tc tys expr + body = mkWildCase scrut (exprType scrut) res_ty + [(DataAlt ptup_con, vars, res')] + return (body, args) + where + [ptup_con] = tyConDataCons ptup_tc + + from_comp _ res expr (Keep _ _) = return (res, [expr]) + from_comp _ res expr (Wrap ty) + = do + wrap_tc <- builtin wrapTyCon + (pwrap_tc, _) <- pdataReprTyCon (mkTyConApp wrap_tc [ty]) + return (res, [unwrapNewTypeBody pwrap_tc [ty] + $ unwrapFamInstScrut pwrap_tc [ty] expr]) - return (map Var vars, mk) + fold f res_ty res exprs rs = foldrM f' (res, []) (zip exprs rs) where - tys = dataConRepArgTys con + f' (expr, r) (res, args) = do + (res', args') <- f res_ty res expr r + return (res', args' ++ args) -buildPRDict :: TyCon -> TyCon -> TyCon -> VM CoreExpr -buildPRDict vect_tc prepr_tc _ +buildPRDict :: TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr +buildPRDict vect_tc prepr_tc _ r = do - dict <- sum_dict (tyConDataCons vect_tc) + dict <- sum_dict r pr_co <- mkBuiltinCo prTyCon let co = mkAppCoercion pr_co . mkSymCoercion @@ -486,30 +631,38 @@ ty_args = mkTyVarTys (tyConTyVars vect_tc) Just arg_co = tyConFamilyCoercion_maybe prepr_tc - sum_dict [] = prDFunOfTyCon =<< builtin voidTyCon - sum_dict [con] = prod_dict con - sum_dict cons = do - dicts <- mapM prod_dict cons - (sum_tc, _, _, sum_ty_args) <- reprSumTyCons vect_tc - dfun <- prDFunOfTyCon sum_tc - return $ dfun `mkTyApps` sum_ty_args `mkApps` dicts - - prod_dict con - | [] <- tys = prDFunOfTyCon =<< builtin voidTyCon - | [ty] <- tys = mkPR ty - | otherwise = do - dicts <- mapM mkPR tys - prod_tc <- builtin (prodTyCon (length tys)) - dfun <- prDFunOfTyCon prod_tc - return $ dfun `mkTyApps` tys `mkApps` dicts - where - tys = dataConRepArgTys con + sum_dict EmptySum = prDFunOfTyCon =<< builtin voidTyCon + sum_dict (UnarySum r) = con_dict r + sum_dict (Sum { repr_sum_tc = sum_tc + , repr_con_tys = tys + , repr_cons = cons + }) + = do + dicts <- mapM con_dict cons + dfun <- prDFunOfTyCon sum_tc + return $ dfun `mkTyApps` tys `mkApps` dicts + + con_dict (ConRepr _ r) = prod_dict r + + prod_dict EmptyProd = prDFunOfTyCon =<< builtin voidTyCon + prod_dict (UnaryProd r) = comp_dict r + prod_dict (Prod { repr_tup_tc = tup_tc + , repr_comp_tys = tys + , repr_comps = comps }) + = do + dicts <- mapM comp_dict comps + dfun <- prDFunOfTyCon tup_tc + return $ dfun `mkTyApps` tys `mkApps` dicts + + comp_dict (Keep _ pr) = return pr + comp_dict (Wrap ty) = wrapPR ty -buildPDataTyCon :: TyCon -> TyCon -> VM TyCon -buildPDataTyCon orig_tc vect_tc = fixV $ \repr_tc -> + +buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM TyCon +buildPDataTyCon orig_tc vect_tc repr = fixV $ \repr_tc -> do name' <- cloneName mkPDataTyConOcc orig_name - rhs <- buildPDataTyConRhs orig_name vect_tc repr_tc + rhs <- buildPDataTyConRhs orig_name vect_tc repr_tc repr pdata <- builtin pdataTyCon liftDs $ buildAlgTyCon name' @@ -526,17 +679,17 @@ rec_flag = boolToRecFlag (isRecursiveTyCon vect_tc) -buildPDataTyConRhs :: Name -> TyCon -> TyCon -> VM AlgTyConRhs -buildPDataTyConRhs orig_name vect_tc repr_tc +buildPDataTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs +buildPDataTyConRhs orig_name vect_tc repr_tc repr = do - data_con <- buildPDataDataCon orig_name vect_tc repr_tc + data_con <- buildPDataDataCon orig_name vect_tc repr_tc repr return $ DataTyCon { data_cons = [data_con], is_enum = False } -buildPDataDataCon :: Name -> TyCon -> TyCon -> VM DataCon -buildPDataDataCon orig_name vect_tc repr_tc +buildPDataDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon +buildPDataDataCon orig_name vect_tc repr_tc repr = do dc_name <- cloneName mkPDataDataConOcc orig_name - comp_tys <- components + comp_tys <- sum_tys repr liftDs $ buildDataCon dc_name False -- not infix @@ -551,29 +704,28 @@ repr_tc where tvs = tyConTyVars vect_tc - cons = tyConDataCons vect_tc - arity = length cons - components - | arity > 1 = liftM2 (:) (builtin (selTy arity)) data_components - | otherwise = data_components - - data_components = mapM mkPDataType - . concat - $ map dataConRepArgTys cons - -mkPADFun :: TyCon -> VM Var -mkPADFun vect_tc - = newExportedVar (mkPADFunOcc $ getOccName vect_tc) =<< paDFunType vect_tc - -buildTyConBindings :: TyCon -> TyCon -> TyCon -> TyCon -> Var - -> VM [(Var, CoreExpr)] -buildTyConBindings orig_tc vect_tc prepr_tc pdata_tc dfun + sum_tys EmptySum = return [] + sum_tys (UnarySum r) = con_tys r + sum_tys (Sum { repr_sel_ty = sel_ty + , repr_cons = cons }) + = liftM (sel_ty :) (concatMapM con_tys cons) + + con_tys (ConRepr _ r) = prod_tys r + + prod_tys EmptyProd = return [] + prod_tys (UnaryProd r) = liftM singleton (comp_ty r) + prod_tys (Prod { repr_comps = comps }) = mapM comp_ty comps + + comp_ty r = mkPDataType (compOrigType r) + + +buildTyConBindings :: TyCon -> TyCon -> TyCon -> TyCon -> SumRepr + -> VM Var +buildTyConBindings orig_tc vect_tc prepr_tc pdata_tc repr = do vectDataConWorkers orig_tc vect_tc pdata_tc - dict <- buildPADict vect_tc prepr_tc pdata_tc dfun - binds <- takeHoisted - return $ (dfun, dict) : binds + buildPADict vect_tc prepr_tc pdata_tc repr vectDataConWorkers :: TyCon -> TyCon -> TyCon -> VM () vectDataConWorkers orig_tc vect_tc arr_tc @@ -628,46 +780,72 @@ def_worker data_con arg_tys mk_body = do + arity <- polyArity tyvars body <- closedV . inBind orig_worker - . polyAbstract tyvars $ \abstract -> - liftM (abstract . vectorised) + . polyAbstract tyvars $ \args -> + liftM (mkLams (tyvars ++ args) . vectorised) $ buildClosures tyvars [] arg_tys res_ty mk_body - vect_worker <- cloneId mkVectOcc orig_worker (exprType body) + raw_worker <- cloneId mkVectOcc orig_worker (exprType body) + let vect_worker = raw_worker `setIdUnfolding` + mkInlineRule needSaturated body arity defGlobalVar orig_worker vect_worker return (vect_worker, body) where orig_worker = dataConWorkId data_con -buildPADict :: TyCon -> TyCon -> TyCon -> Var -> VM CoreExpr -buildPADict vect_tc prepr_tc arr_tc _ - = polyAbstract tvs $ \abstract -> +buildPADict :: TyCon -> TyCon -> TyCon -> SumRepr -> VM Var +buildPADict vect_tc prepr_tc arr_tc repr + = polyAbstract tvs $ \args -> do - meth_binds <- mapM mk_method paMethods - let meth_exprs = map (Var . fst) meth_binds + method_ids <- mapM (method args) paMethods + + pa_tc <- builtin paTyCon + pa_con <- builtin paDataCon + let dict = mkLams (tvs ++ args) + $ mkConApp pa_con + $ Type inst_ty : map (method_call args) method_ids - pa_dc <- builtin paDataCon - let dict = mkConApp pa_dc (Type (mkTyConApp vect_tc arg_tys) : meth_exprs) - body = Let (Rec meth_binds) dict - return . mkInlineMe $ abstract body + dfun_ty = mkForAllTys tvs + $ mkFunTys (map varType args) (mkTyConApp pa_tc [inst_ty]) + + raw_dfun <- newExportedVar dfun_name dfun_ty + let dfun = raw_dfun `setIdUnfolding` mkDFunUnfolding pa_con method_ids + `setInlinePragma` dfunInlinePragma + + hoistBinding dfun dict + return dfun where - tvs = tyConTyVars arr_tc + tvs = tyConTyVars vect_tc arg_tys = mkTyVarTys tvs + inst_ty = mkTyConApp vect_tc arg_tys + + dfun_name = mkPADFunOcc (getOccName vect_tc) - mk_method (name, build) + method args (name, build) = localV $ do - body <- build vect_tc prepr_tc arr_tc - var <- newLocalVar name (exprType body) - return (var, mkInlineMe body) - -paMethods :: [(FastString, TyCon -> TyCon -> TyCon -> VM CoreExpr)] -paMethods = [(fsLit "toPRepr", buildToPRepr), - (fsLit "fromPRepr", buildFromPRepr), - (fsLit "toArrPRepr", buildToArrPRepr), - (fsLit "fromArrPRepr", buildFromArrPRepr), - (fsLit "dictPRepr", buildPRDict)] + expr <- build vect_tc prepr_tc arr_tc repr + let body = mkLams (tvs ++ args) expr + raw_var <- newExportedVar (method_name name) (exprType body) + let var = raw_var + `setIdUnfolding` mkInlineRule needSaturated body (length args) + `setInlinePragma` alwaysInlinePragma + hoistBinding var body + return var + + method_call args id = mkApps (Var id) (map Type arg_tys ++ map Var args) + + method_name name = mkVarOcc $ occNameString dfun_name ++ ('$' : name) + + +paMethods :: [(String, TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr)] +paMethods = [("dictPRepr", buildPRDict), + ("toPRepr", buildToPRepr), + ("fromPRepr", buildFromPRepr), + ("toArrPRepr", buildToArrPRepr), + ("fromArrPRepr", buildFromArrPRepr)] -- | Split the given tycons into two sets depending on whether they have to be -- converted (first list) or not (second list). The first argument contains diff -ruN ghc-6.12.1/compiler/vectorise/VectUtils.hs ghc-6.13.20091231/compiler/vectorise/VectUtils.hs --- ghc-6.12.1/compiler/vectorise/VectUtils.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/compiler/vectorise/VectUtils.hs 2009-12-31 10:14:18.000000000 -0800 @@ -5,17 +5,18 @@ newLocalVVar, - mkBuiltinCo, voidType, + mkBuiltinCo, voidType, mkWrapType, mkPADictType, mkPArrayType, mkPDataType, mkPReprType, mkPArray, pdataReprTyCon, pdataReprDataCon, mkVScrut, - prDFunOfTyCon, + prDictOfType, prDFunOfTyCon, paDictArgType, paDictOfType, paDFunType, - paMethod, mkPR, replicatePD, emptyPD, packPD, + paMethod, wrapPR, replicatePD, emptyPD, packByTagPD, combinePD, liftPD, zipScalars, scalarClosure, - polyAbstract, polyApply, polyVApply, + polyAbstract, polyApply, polyVApply, polyArity, + Inline(..), addInlineArity, inlineMe, hoistBinding, hoistExpr, hoistPolyVExpr, takeHoisted, buildClosure, buildClosures, mkClosureApp @@ -24,9 +25,10 @@ import VectCore import VectMonad -import MkCore ( mkCoreTup, mkCoreTupTy, mkWildCase ) +import MkCore ( mkCoreTup, mkWildCase ) import CoreSyn import CoreUtils +import CoreUnfold ( mkInlineRule ) import Coercion import Type import TypeRep @@ -34,6 +36,7 @@ import DataCon import Var import MkId ( unwrapFamInstScrut ) +import Id ( setIdUnfolding ) import TysWiredIn import BasicTypes ( Boxity(..) ) import Literal ( Literal, mkMachInt ) @@ -43,7 +46,6 @@ import Control.Monad - collectAnnTypeArgs :: AnnExpr b ann -> (AnnExpr b ann, [Type]) collectAnnTypeArgs expr = go expr [] where @@ -98,7 +100,10 @@ mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2] voidType :: VM Type -voidType = mkBuiltinTyConApp voidTyCon [] +voidType = mkBuiltinTyConApp VectMonad.voidTyCon [] + +mkWrapType :: Type -> VM Type +mkWrapType ty = mkBuiltinTyConApp wrapTyCon [ty] mkClosureTypes :: [Type] -> Type -> VM Type mkClosureTypes = mkBuiltinTyConApps closureTyCon @@ -228,12 +233,32 @@ dict <- paDictOfType ty return $ mkApps (Var fn) [Type ty, dict] -mkPR :: Type -> VM CoreExpr -mkPR ty +prDictOfType :: Type -> VM CoreExpr +prDictOfType ty = prDictOfTyApp ty_fn ty_args + where + (ty_fn, ty_args) = splitAppTys ty + +prDictOfTyApp :: Type -> [Type] -> VM CoreExpr +prDictOfTyApp ty_fn ty_args + | Just ty_fn' <- coreView ty_fn = prDictOfTyApp ty_fn' ty_args +prDictOfTyApp (TyConApp tc _) ty_args + = do + dfun <- liftM Var $ maybeV (lookupTyConPR tc) + prDFunApply dfun ty_args +prDictOfTyApp _ _ = noV + +prDFunApply :: CoreExpr -> [Type] -> VM CoreExpr +prDFunApply dfun tys = do - fn <- builtin mkPRVar - dict <- paDictOfType ty - return $ mkApps (Var fn) [Type ty, dict] + dicts <- mapM prDictOfType tys + return $ mkApps (mkTyApps dfun tys) dicts + +wrapPR :: Type -> VM CoreExpr +wrapPR ty + = do + pa_dict <- paDictOfType ty + pr_dfun <- prDFunOfTyCon =<< builtin wrapTyCon + return $ mkApps pr_dfun [Type ty, pa_dict] replicatePD :: CoreExpr -> CoreExpr -> VM CoreExpr replicatePD len x = liftM (`mkApps` [len,x]) @@ -242,9 +267,11 @@ emptyPD :: Type -> VM CoreExpr emptyPD = paMethod emptyPDVar "emptyPD" -packPD :: Type -> CoreExpr -> CoreExpr -> CoreExpr -> VM CoreExpr -packPD ty xs len sel = liftM (`mkApps` [xs, len, sel]) - (paMethod packPDVar "packPD" ty) +packByTagPD :: Type -> CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr + -> VM CoreExpr +packByTagPD ty xs len tags t + = liftM (`mkApps` [xs, len, tags, t]) + (paMethod packByTagPDVar "packByTagPD" ty) combinePD :: Type -> CoreExpr -> CoreExpr -> [CoreExpr] -> VM CoreExpr @@ -286,13 +313,14 @@ lv <- newLocalVar fs lty return (vv,lv) -polyAbstract :: [TyVar] -> ((CoreExpr -> CoreExpr) -> VM a) -> VM a +polyAbstract :: [TyVar] -> ([Var] -> VM a) -> VM a polyAbstract tvs p = localV $ do mdicts <- mapM mk_dict_var tvs - zipWithM_ (\tv -> maybe (defLocalTyVar tv) (defLocalTyVarWithPA tv . Var)) tvs mdicts - p (mk_lams mdicts) + zipWithM_ (\tv -> maybe (defLocalTyVar tv) + (defLocalTyVarWithPA tv . Var)) tvs mdicts + p (mk_args mdicts) where mk_dict_var tv = do r <- paDictArgType tv @@ -300,7 +328,12 @@ Just ty -> liftM Just (newLocalVar (fsLit "dPA") ty) Nothing -> return Nothing - mk_lams mdicts = mkLams (tvs ++ [dict | Just dict <- mdicts]) + mk_args mdicts = [dict | Just dict <- mdicts] + +polyArity :: [TyVar] -> VM Int +polyArity tvs = do + tys <- mapM paDictArgType tvs + return $ length [() | Just _ <- tys] polyApply :: CoreExpr -> [Type] -> VM CoreExpr polyApply expr tys @@ -314,31 +347,48 @@ dicts <- mapM paDictOfType tys return $ mapVect (\e -> e `mkTyApps` tys `mkApps` dicts) expr + +data Inline = Inline Int -- arity + | DontInline + +addInlineArity :: Inline -> Int -> Inline +addInlineArity (Inline m) n = Inline (m+n) +addInlineArity DontInline _ = DontInline + +inlineMe :: Inline +inlineMe = Inline 0 + hoistBinding :: Var -> CoreExpr -> VM () hoistBinding v e = updGEnv $ \env -> env { global_bindings = (v,e) : global_bindings env } -hoistExpr :: FastString -> CoreExpr -> VM Var -hoistExpr fs expr +hoistExpr :: FastString -> CoreExpr -> Inline -> VM Var +hoistExpr fs expr inl = do - var <- newLocalVar fs (exprType expr) + var <- mk_inline `liftM` newLocalVar fs (exprType expr) hoistBinding var expr return var + where + mk_inline var = case inl of + Inline arity -> var `setIdUnfolding` + mkInlineRule needSaturated expr arity + DontInline -> var -hoistVExpr :: VExpr -> VM VVar -hoistVExpr (ve, le) +hoistVExpr :: VExpr -> Inline -> VM VVar +hoistVExpr (ve, le) inl = do fs <- getBindName - vv <- hoistExpr ('v' `consFS` fs) ve - lv <- hoistExpr ('l' `consFS` fs) le + vv <- hoistExpr ('v' `consFS` fs) ve inl + lv <- hoistExpr ('l' `consFS` fs) le (addInlineArity inl 1) return (vv, lv) -hoistPolyVExpr :: [TyVar] -> VM VExpr -> VM VExpr -hoistPolyVExpr tvs p +hoistPolyVExpr :: [TyVar] -> Inline -> VM VExpr -> VM VExpr +hoistPolyVExpr tvs inline p = do - expr <- closedV . polyAbstract tvs $ \abstract -> - liftM (mapVect abstract) p - fn <- hoistVExpr expr + inline' <- liftM (addInlineArity inline) (polyArity tvs) + expr <- closedV . polyAbstract tvs $ \args -> + liftM (mapVect (mkLams $ tvs ++ args)) p + fn <- hoistVExpr expr inline' polyVApply (vVar fn) (mkTyVarTys tvs) takeHoisted :: VM [(Var, CoreExpr)] @@ -384,14 +434,15 @@ buildClosures _ _ [] _ mk_body = mk_body buildClosures tvs vars [arg_ty] res_ty mk_body - = liftM vInlineMe (buildClosure tvs vars arg_ty res_ty mk_body) + = -- liftM vInlineMe $ + buildClosure tvs vars arg_ty res_ty mk_body buildClosures tvs vars (arg_ty : arg_tys) res_ty mk_body = do res_ty' <- mkClosureTypes arg_tys res_ty arg <- newLocalVVar (fsLit "x") arg_ty - liftM vInlineMe - . buildClosure tvs vars arg_ty res_ty' - . hoistPolyVExpr tvs + -- liftM vInlineMe + buildClosure tvs vars arg_ty res_ty' + . hoistPolyVExpr tvs (Inline (length vars + 1)) $ do lc <- builtin liftingContext clo <- buildClosures tvs (vars ++ [arg]) arg_tys res_ty mk_body @@ -409,11 +460,11 @@ env_bndr <- newLocalVVar (fsLit "env") env_ty arg_bndr <- newLocalVVar (fsLit "arg") arg_ty - fn <- hoistPolyVExpr tvs + fn <- hoistPolyVExpr tvs (Inline 2) $ do lc <- builtin liftingContext body <- mk_body - return . vInlineMe + return -- . vInlineMe . vLams lc [env_bndr, arg_bndr] $ bind (vVar env_bndr) (vVarApps lc body (vars ++ [arg_bndr])) @@ -459,5 +510,5 @@ where (vvs, lvs) = unzip vs tys = map vVarType vs - ty = mkCoreTupTy tys + ty = mkBoxedTupleTy tys diff -ruN ghc-6.12.1/configure ghc-6.13.20091231/configure --- ghc-6.12.1/configure 2009-12-10 10:31:41.000000000 -0800 +++ ghc-6.13.20091231/configure 2009-12-31 10:32:46.000000000 -0800 @@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.61 for The Glorious Glasgow Haskell Compilation System 6.12.1. +# Generated by GNU Autoconf 2.61 for The Glorious Glasgow Haskell Compilation System 6.13. # # Report bugs to . # @@ -574,8 +574,8 @@ # Identity of this package. PACKAGE_NAME='The Glorious Glasgow Haskell Compilation System' PACKAGE_TARNAME='ghc' -PACKAGE_VERSION='6.12.1' -PACKAGE_STRING='The Glorious Glasgow Haskell Compilation System 6.12.1' +PACKAGE_VERSION='6.13' +PACKAGE_STRING='The Glorious Glasgow Haskell Compilation System 6.13' PACKAGE_BUGREPORT='glasgow-haskell-bugs@haskell.org' ac_unique_file="mk/config.mk.in" @@ -733,6 +733,8 @@ TimeCmd TarCmd PatchCmd +DtraceCmd +HaveDtrace HSCOLOUR XmllintCmd XsltprocCmd @@ -747,7 +749,6 @@ GREP EGREP HaveLibMingwEx -LIBM HaveLibDL ALLOCA LeadingUnderscore @@ -1274,7 +1275,7 @@ # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -\`configure' configures The Glorious Glasgow Haskell Compilation System 6.12.1 to adapt to many kinds of systems. +\`configure' configures The Glorious Glasgow Haskell Compilation System 6.13 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1340,7 +1341,7 @@ if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of The Glorious Glasgow Haskell Compilation System 6.12.1:";; + short | recursive ) echo "Configuration of The Glorious Glasgow Haskell Compilation System 6.13:";; esac cat <<\_ACEOF @@ -1444,7 +1445,7 @@ test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -The Glorious Glasgow Haskell Compilation System configure 6.12.1 +The Glorious Glasgow Haskell Compilation System configure 6.13 generated by GNU Autoconf 2.61 Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, @@ -1458,7 +1459,7 @@ This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by The Glorious Glasgow Haskell Compilation System $as_me 6.12.1, which was +It was created by The Glorious Glasgow Haskell Compilation System $as_me 6.13, which was generated by GNU Autoconf 2.61. Invocation command line was $ $0 $@ @@ -1813,7 +1814,7 @@ # Set this to YES for a released version, otherwise NO -: ${RELEASE=YES} +: ${RELEASE=NO} # The primary version (e.g. 6.7, 6.6.1) is set in the AC_INIT line # above. If this is not a released version, then we will append the @@ -2483,7 +2484,7 @@ checkOS() { case $1 in - linux|freebsd|netbsd|openbsd|dragonfly|osf1|osf3|hpux|linuxaout|kfreebsdgnu|freebsd2|solaris2|cygwin32|mingw32|darwin|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix) + linux|freebsd|netbsd|openbsd|dragonfly|osf1|osf3|hpux|linuxaout|kfreebsdgnu|freebsd2|solaris2|cygwin32|mingw32|darwin|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix|haiku) ;; *) echo "Unknown OS '$1'" @@ -2703,8 +2704,6 @@ test inplace/mingw -ot ghc-tarballs/mingw/gcc-core*.tar.gz || test inplace/mingw -ot ghc-tarballs/mingw/libcrypt*.tar.bz2 || test inplace/mingw -ot ghc-tarballs/mingw/mingw-runtime*.tar.gz || - test inplace/mingw -ot ghc-tarballs/mingw/msysCORE*.tar.gz || - test inplace/mingw -ot ghc-tarballs/mingw/perl*.tar.bz2 || test inplace/mingw -ot ghc-tarballs/mingw/w32api*.tar.gz then { echo "$as_me:$LINENO: Making in-tree mingw tree" >&5 @@ -5194,6 +5193,54 @@ test -n "$PatchCmd" || PatchCmd="patch" +HaveDtrace=NO +# Extract the first word of "dtrace", so it can be a program name with args. +set dummy dtrace; ac_word=$2 +{ echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; } +if test "${ac_cv_path_DtraceCmd+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + case $DtraceCmd in + [\\/]* | ?:[\\/]*) + ac_cv_path_DtraceCmd="$DtraceCmd" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + ac_cv_path_DtraceCmd="$as_dir/$ac_word$ac_exec_ext" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done +done +IFS=$as_save_IFS + + ;; +esac +fi +DtraceCmd=$ac_cv_path_DtraceCmd +if test -n "$DtraceCmd"; then + { echo "$as_me:$LINENO: result: $DtraceCmd" >&5 +echo "${ECHO_T}$DtraceCmd" >&6; } +else + { echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6; } +fi + + +if test -n "$DtraceCmd"; then + if test "x$TargetOS_CPP-$TargetVendor_CPP" == "xdarwin-apple"; then + HaveDtrace=YES + fi +fi + + # Extract the first word of "HsColour", so it can be a program name with args. set dummy HsColour; ac_word=$2 { echo "$as_me:$LINENO: checking for $ac_word" >&5 @@ -6565,7 +6612,8 @@ -for ac_header in bfd.h ctype.h dirent.h dlfcn.h errno.h fcntl.h grp.h limits.h locale.h nlist.h pthread.h pwd.h signal.h sys/mman.h sys/resource.h sys/time.h sys/timeb.h sys/timers.h sys/times.h sys/utsname.h sys/wait.h termios.h time.h utime.h windows.h winsock.h sched.h + +for ac_header in bfd.h ctype.h dirent.h dlfcn.h errno.h fcntl.h grp.h limits.h locale.h nlist.h pthread.h pwd.h signal.h sys/mman.h sys/resource.h sys/select.h sys/time.h sys/timeb.h sys/timers.h sys/times.h sys/utsname.h sys/wait.h termios.h time.h utime.h windows.h winsock.h sched.h do as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then @@ -17641,14 +17689,12 @@ fi - -{ echo "$as_me:$LINENO: checking for xmalloc in -liberty" >&5 -echo $ECHO_N "checking for xmalloc in -liberty... $ECHO_C" >&6; } -if test "${ac_cv_lib_iberty_xmalloc+set}" = set; then +{ echo "$as_me:$LINENO: checking for library containing atan" >&5 +echo $ECHO_N "checking for library containing atan... $ECHO_C" >&6; } +if test "${ac_cv_search_atan+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else - ac_check_lib_save_LIBS=$LIBS -LIBS="-liberty $LIBS" + ac_func_search_save_LIBS=$LIBS cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF @@ -17662,16 +17708,23 @@ #ifdef __cplusplus extern "C" #endif -char xmalloc (); +char atan (); int main () { -return xmalloc (); +return atan (); ; return 0; } _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext +for ac_lib in '' m; do + if test -z "$ac_lib"; then + ac_res="none required" + else + ac_res=-l$ac_lib + LIBS="-l$ac_lib $ac_func_search_save_LIBS" + fi + rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; @@ -17689,37 +17742,49 @@ test ! -s conftest.err } && test -s conftest$ac_exeext && $as_test_x conftest$ac_exeext; then - ac_cv_lib_iberty_xmalloc=yes + ac_cv_search_atan=$ac_res else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 - ac_cv_lib_iberty_xmalloc=no + fi rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext -LIBS=$ac_check_lib_save_LIBS + conftest$ac_exeext + if test "${ac_cv_search_atan+set}" = set; then + break fi -{ echo "$as_me:$LINENO: result: $ac_cv_lib_iberty_xmalloc" >&5 -echo "${ECHO_T}$ac_cv_lib_iberty_xmalloc" >&6; } -if test $ac_cv_lib_iberty_xmalloc = yes; then - cat >>confdefs.h <<_ACEOF -#define HAVE_LIBIBERTY 1 -_ACEOF +done +if test "${ac_cv_search_atan+set}" = set; then + : +else + ac_cv_search_atan=no +fi +rm conftest.$ac_ext +LIBS=$ac_func_search_save_LIBS +fi +{ echo "$as_me:$LINENO: result: $ac_cv_search_atan" >&5 +echo "${ECHO_T}$ac_cv_search_atan" >&6; } +ac_res=$ac_cv_search_atan +if test "$ac_res" != no; then + test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - LIBS="-liberty $LIBS" +cat >>confdefs.h <<\_ACEOF +#define HAVE_LIBM 1 +_ACEOF fi -{ echo "$as_me:$LINENO: checking for bfd_init in -lbfd" >&5 -echo $ECHO_N "checking for bfd_init in -lbfd... $ECHO_C" >&6; } -if test "${ac_cv_lib_bfd_bfd_init+set}" = set; then + +{ echo "$as_me:$LINENO: checking for xmalloc in -liberty" >&5 +echo $ECHO_N "checking for xmalloc in -liberty... $ECHO_C" >&6; } +if test "${ac_cv_lib_iberty_xmalloc+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS -LIBS="-lbfd $LIBS" +LIBS="-liberty $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF @@ -17733,11 +17798,11 @@ #ifdef __cplusplus extern "C" #endif -char bfd_init (); +char xmalloc (); int main () { -return bfd_init (); +return xmalloc (); ; return 0; } @@ -17760,125 +17825,37 @@ test ! -s conftest.err } && test -s conftest$ac_exeext && $as_test_x conftest$ac_exeext; then - ac_cv_lib_bfd_bfd_init=yes + ac_cv_lib_iberty_xmalloc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 - ac_cv_lib_bfd_bfd_init=no + ac_cv_lib_iberty_xmalloc=no fi rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ echo "$as_me:$LINENO: result: $ac_cv_lib_bfd_bfd_init" >&5 -echo "${ECHO_T}$ac_cv_lib_bfd_bfd_init" >&6; } -if test $ac_cv_lib_bfd_bfd_init = yes; then +{ echo "$as_me:$LINENO: result: $ac_cv_lib_iberty_xmalloc" >&5 +echo "${ECHO_T}$ac_cv_lib_iberty_xmalloc" >&6; } +if test $ac_cv_lib_iberty_xmalloc = yes; then cat >>confdefs.h <<_ACEOF -#define HAVE_LIBBFD 1 -_ACEOF - - LIBS="-lbfd $LIBS" - -fi - - -{ echo "$as_me:$LINENO: checking for atan" >&5 -echo $ECHO_N "checking for atan... $ECHO_C" >&6; } -if test "${ac_cv_func_atan+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ +#define HAVE_LIBIBERTY 1 _ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -/* Define atan to an innocuous variant, in case declares atan. - For example, HP-UX 11i declares gettimeofday. */ -#define atan innocuous_atan - -/* System header to define __stub macros and hopefully few prototypes, - which can conflict with char atan (); below. - Prefer to if __STDC__ is defined, since - exists even on freestanding compilers. */ -#ifdef __STDC__ -# include -#else -# include -#endif - -#undef atan - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char atan (); -/* The GNU C library defines this for functions which it implements - to always fail with ENOSYS. Some functions are actually named - something starting with __ and the normal name is an alias. */ -#if defined __stub_atan || defined __stub___atan -choke me -#endif - -int -main () -{ -return atan (); - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && - $as_test_x conftest$ac_exeext; then - ac_cv_func_atan=yes -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 + LIBS="-liberty $LIBS" - ac_cv_func_atan=no fi -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext -fi -{ echo "$as_me:$LINENO: result: $ac_cv_func_atan" >&5 -echo "${ECHO_T}$ac_cv_func_atan" >&6; } -if test $ac_cv_func_atan = yes; then - fp_libm_not_needed=yes;LIBM= -else - fp_libm_not_needed=dunno -fi -if test x"$fp_libm_not_needed" = xdunno; then - { echo "$as_me:$LINENO: checking for atan in -lm" >&5 -echo $ECHO_N "checking for atan in -lm... $ECHO_C" >&6; } -if test "${ac_cv_lib_m_atan+set}" = set; then +{ echo "$as_me:$LINENO: checking for bfd_init in -lbfd" >&5 +echo $ECHO_N "checking for bfd_init in -lbfd... $ECHO_C" >&6; } +if test "${ac_cv_lib_bfd_bfd_init+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS -LIBS="-lm $LIBS" +LIBS="-lbfd $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF @@ -17892,11 +17869,11 @@ #ifdef __cplusplus extern "C" #endif -char atan (); +char bfd_init (); int main () { -return atan (); +return bfd_init (); ; return 0; } @@ -17919,25 +17896,26 @@ test ! -s conftest.err } && test -s conftest$ac_exeext && $as_test_x conftest$ac_exeext; then - ac_cv_lib_m_atan=yes + ac_cv_lib_bfd_bfd_init=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 - ac_cv_lib_m_atan=no + ac_cv_lib_bfd_bfd_init=no fi rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ echo "$as_me:$LINENO: result: $ac_cv_lib_m_atan" >&5 -echo "${ECHO_T}$ac_cv_lib_m_atan" >&6; } -if test $ac_cv_lib_m_atan = yes; then - LIBS="-lm $LIBS"; LIBM="-lm" -else - LIBM= -fi +{ echo "$as_me:$LINENO: result: $ac_cv_lib_bfd_bfd_init" >&5 +echo "${ECHO_T}$ac_cv_lib_bfd_bfd_init" >&6; } +if test $ac_cv_lib_bfd_bfd_init = yes; then + cat >>confdefs.h <<_ACEOF +#define HAVE_LIBBFD 1 +_ACEOF + + LIBS="-lbfd $LIBS" fi @@ -20865,7 +20843,7 @@ # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by The Glorious Glasgow Haskell Compilation System $as_me 6.12.1, which was +This file was extended by The Glorious Glasgow Haskell Compilation System $as_me 6.13, which was generated by GNU Autoconf 2.61. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -20918,7 +20896,7 @@ _ACEOF cat >>$CONFIG_STATUS <<_ACEOF ac_cs_version="\\ -The Glorious Glasgow Haskell Compilation System config.status 6.12.1 +The Glorious Glasgow Haskell Compilation System config.status 6.13 configured by $0, generated by GNU Autoconf 2.61, with options \\"`echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`\\" @@ -21259,6 +21237,8 @@ TimeCmd!$TimeCmd$ac_delim TarCmd!$TarCmd$ac_delim PatchCmd!$PatchCmd$ac_delim +DtraceCmd!$DtraceCmd$ac_delim +HaveDtrace!$HaveDtrace$ac_delim HSCOLOUR!$HSCOLOUR$ac_delim XmllintCmd!$XmllintCmd$ac_delim XsltprocCmd!$XsltprocCmd$ac_delim @@ -21273,7 +21253,6 @@ GREP!$GREP$ac_delim EGREP!$EGREP$ac_delim HaveLibMingwEx!$HaveLibMingwEx$ac_delim -LIBM!$LIBM$ac_delim HaveLibDL!$HaveLibDL$ac_delim ALLOCA!$ALLOCA$ac_delim LeadingUnderscore!$LeadingUnderscore$ac_delim @@ -21290,7 +21269,7 @@ LTLIBOBJS!$LTLIBOBJS$ac_delim _ACEOF - if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 50; then + if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 51; then break elif $ac_last_try; then { { echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5 diff -ruN ghc-6.12.1/configure.ac ghc-6.13.20091231/configure.ac --- ghc-6.12.1/configure.ac 2009-12-10 10:11:33.000000000 -0800 +++ ghc-6.13.20091231/configure.ac 2009-12-31 10:14:18.000000000 -0800 @@ -13,10 +13,10 @@ # see what flags are available. (Better yet, read the documentation!) # -AC_INIT([The Glorious Glasgow Haskell Compilation System], [6.12.1], [glasgow-haskell-bugs@haskell.org], [ghc]) +AC_INIT([The Glorious Glasgow Haskell Compilation System], [6.13], [glasgow-haskell-bugs@haskell.org], [ghc]) # Set this to YES for a released version, otherwise NO -: ${RELEASE=YES} +: ${RELEASE=NO} # The primary version (e.g. 6.7, 6.6.1) is set in the AC_INIT line # above. If this is not a released version, then we will append the @@ -296,7 +296,7 @@ checkOS() { case $1 in - linux|freebsd|netbsd|openbsd|dragonfly|osf1|osf3|hpux|linuxaout|kfreebsdgnu|freebsd2|solaris2|cygwin32|mingw32|darwin|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix) + linux|freebsd|netbsd|openbsd|dragonfly|osf1|osf3|hpux|linuxaout|kfreebsdgnu|freebsd2|solaris2|cygwin32|mingw32|darwin|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix|haiku) ;; *) echo "Unknown OS '$1'" @@ -391,8 +391,6 @@ test inplace/mingw -ot ghc-tarballs/mingw/gcc-core*.tar.gz || test inplace/mingw -ot ghc-tarballs/mingw/libcrypt*.tar.bz2 || test inplace/mingw -ot ghc-tarballs/mingw/mingw-runtime*.tar.gz || - test inplace/mingw -ot ghc-tarballs/mingw/msysCORE*.tar.gz || - test inplace/mingw -ot ghc-tarballs/mingw/perl*.tar.bz2 || test inplace/mingw -ot ghc-tarballs/mingw/w32api*.tar.gz then AC_MSG_NOTICE([Making in-tree mingw tree]) @@ -560,6 +558,16 @@ dnl if GNU patch is named gpatch, look for it first AC_PATH_PROGS(PatchCmd,gpatch patch, patch) +dnl ** check for dtrace (currently only implemented for Mac OS X) +HaveDtrace=NO +AC_PATH_PROG(DtraceCmd,dtrace) +if test -n "$DtraceCmd"; then + if test "x$TargetOS_CPP-$TargetVendor_CPP" == "xdarwin-apple"; then + HaveDtrace=YES + fi +fi +AC_SUBST(HaveDtrace) + AC_PATH_PROG(HSCOLOUR,HsColour) # HsColour is passed to Cabal, so we need a native path if test "x$HostPlatform" = "xi386-unknown-mingw32" && \ @@ -608,7 +616,7 @@ AC_SYS_LARGEFILE dnl ** check for specific header (.h) files that we are interested in -AC_CHECK_HEADERS([bfd.h ctype.h dirent.h dlfcn.h errno.h fcntl.h grp.h limits.h locale.h nlist.h pthread.h pwd.h signal.h sys/mman.h sys/resource.h sys/time.h sys/timeb.h sys/timers.h sys/times.h sys/utsname.h sys/wait.h termios.h time.h utime.h windows.h winsock.h sched.h]) +AC_CHECK_HEADERS([bfd.h ctype.h dirent.h dlfcn.h errno.h fcntl.h grp.h limits.h locale.h nlist.h pthread.h pwd.h signal.h sys/mman.h sys/resource.h sys/select.h sys/time.h sys/timeb.h sys/timers.h sys/times.h sys/utsname.h sys/wait.h termios.h time.h utime.h windows.h winsock.h sched.h]) dnl ** check if it is safe to include both and AC_HEADER_TIME @@ -715,18 +723,19 @@ AC_DEFINE([HAVE_MINGWEX], [1], [Define to 1 if you have the mingwex library.]) fi +dnl ** check for math library +dnl Keep that check as early as possible. +dnl as we need to know whether we need libm +dnl for math functions or not +dnl (see http://hackage.haskell.org/trac/ghc/ticket/3730) +AC_SEARCH_LIBS(atan, m, + [AC_DEFINE([HAVE_LIBM], [1], [Define to 1 if you need to link with libm])]) + dnl ** check whether this machine has BFD and liberty installed (used for debugging) dnl the order of these tests matters: bfd needs liberty AC_CHECK_LIB(iberty, xmalloc) AC_CHECK_LIB(bfd, bfd_init) -dnl ** check for math library -AC_CHECK_FUNC(atan,[fp_libm_not_needed=yes;LIBM=],[fp_libm_not_needed=dunno]) -if test x"$fp_libm_not_needed" = xdunno; then - AC_CHECK_LIB([m], [atan], [LIBS="-lm $LIBS"; LIBM="-lm"],[LIBM=]) -fi -AC_SUBST([LIBM]) - dnl ################################################################ dnl Check for libraries dnl ################################################################ diff -ruN ghc-6.12.1/distrib/configure.ac ghc-6.13.20091231/distrib/configure.ac --- ghc-6.12.1/distrib/configure.ac 2009-12-10 10:32:19.000000000 -0800 +++ ghc-6.13.20091231/distrib/configure.ac 2009-12-31 10:33:23.000000000 -0800 @@ -4,7 +4,7 @@ #!/bin/sh # -AC_INIT([The Glorious Glasgow Haskell Compilation System], [6.12.1], [glasgow-haskell-bugs@haskell.org], [ghc]) +AC_INIT([The Glorious Glasgow Haskell Compilation System], [6.13.20091231], [glasgow-haskell-bugs@haskell.org], [ghc]) FP_FIND_ROOT diff -ruN ghc-6.12.1/distrib/ghc.iss ghc-6.13.20091231/distrib/ghc.iss --- ghc-6.12.1/distrib/ghc.iss 2009-12-10 10:32:19.000000000 -0800 +++ ghc-6.13.20091231/distrib/ghc.iss 2009-12-31 10:33:23.000000000 -0800 @@ -1,8 +1,8 @@ [Setup] AppName=GHC -AppVerName=GHC 6.12.1 -DefaultDirName={sd}\ghc\ghc-6.12.1 +AppVerName=GHC 6.13.20091231 +DefaultDirName={sd}\ghc\ghc-6.13.20091231 UsePreviousAppDir=no DefaultGroupName=GHC UninstallDisplayIcon={app}\bin\ghci.exe @@ -14,13 +14,13 @@ [Files] -Source: "bindistprep\ghc-6.12.1\*"; DestDir: "{app}"; Flags: recursesubdirs +Source: "bindistprep\ghc-6.13.20091231\*"; DestDir: "{app}"; Flags: recursesubdirs [Icons] -Name: "{group}\6.12.1\GHCi"; Filename: "{app}\bin\ghci.exe" -Name: "{group}\6.12.1\GHC Documentation"; Filename: "{app}\doc\index.html" -Name: "{group}\6.12.1\GHC Library Documentation"; Filename: "{app}\doc\libraries\index.html" -Name: "{group}\6.12.1\GHC Flag Reference"; Filename: "{app}\doc\users_guide\flag-reference.html" +Name: "{group}\6.13.20091231\GHCi"; Filename: "{app}\bin\ghci.exe" +Name: "{group}\6.13.20091231\GHC Documentation"; Filename: "{app}\doc\index.html" +Name: "{group}\6.13.20091231\GHC Library Documentation"; Filename: "{app}\doc\libraries\index.html" +Name: "{group}\6.13.20091231\GHC Flag Reference"; Filename: "{app}\doc\users_guide\flag-reference.html" [Registry] ; set up icon associations @@ -34,7 +34,7 @@ ; these flags were always set in the past, by the installer ; some programs may rely on them to find GHC -Root: HKCU; Subkey: "Software\Haskell\GHC\ghc-6.12.1"; ValueType: string; ValueName: "InstallDir"; ValueData: "{app}"; Flags: uninsdeletekey +Root: HKCU; Subkey: "Software\Haskell\GHC\ghc-6.13.20091231"; ValueType: string; ValueName: "InstallDir"; ValueData: "{app}"; Flags: uninsdeletekey Root: HKCU; Subkey: "Software\Haskell\GHC"; ValueType: string; ValueName: "InstallDir"; ValueData: "{app}"; Flags: uninsdeletevalue ; set the PATH variable, for both GHC and Cabal diff -ruN ghc-6.12.1/docs/users_guide/6.12.1-notes.xml ghc-6.13.20091231/docs/users_guide/6.12.1-notes.xml --- ghc-6.12.1/docs/users_guide/6.12.1-notes.xml 2009-12-10 10:11:33.000000000 -0800 +++ ghc-6.13.20091231/docs/users_guide/6.12.1-notes.xml 2009-12-31 10:14:17.000000000 -0800 @@ -9,73 +9,6 @@ - Highlights - - - - Considerably improved support for parallel execution. GHC 6.10 - would execute parallel Haskell programs, but performance was - often not very good. Simon Marlow has done lots of performance - tuning in 6.12, removing many of the accidental (and largely - invisible) gotchas that made parallel programs run slowly. - - - - - As part of this parallel-performance tuning, Satnam Singh and - Simon Marlow have developed ThreadScope, a GUI that lets you - see what is going on inside your parallel program. It's a huge - step forward from "It takes 4 seconds with 1 processor, and 3 - seconds with 8 processors; now what?". ThreadScope will be - released separately from GHC, but at more or less the same - time as GHC 6.12. - - - - - Dynamic linking is now supported on Linux, and support for - other platforms will follow. Thanks for this most recently go - to the Industrial Haskell Group who pushed it into a - fully-working state; dynamic linking is the culmination of the - work of several people over recent years. One effect of - dynamic linking is that binaries shrink dramatically, because - the run-time system and libraries are shared. Perhaps more - importantly, it is possible to make dynamic plugins from - Haskell code that can be used from other applications. - - - - - The I/O libraries are now Unicode-aware, so your Haskell - programs should now handle text files containing non-ascii - characters, without special effort. - - - - - The package system has been made more robust, by associating - each installed package with a unique identifier based on its - exposed ABI. Now, cases where the user re-installs a package - without recompiling packages that depend on it will be - detected, and the packages with broken dependencies will be - disabled. Previously, this would lead to obscure compilation - errors, or worse, segfaulting programs. - - - This change involved a lot of internal restructuring, but it - paves the way for future improvements to the way packages are - handled. For instance, in the future we expect to track - profiled packages independently of non-profiled ones, and we - hope to make it possible to upgrade a package in an - ABI-compatible way, without recompiling the packages that - depend on it. This latter facility will be especially - important as we move towards using more shared libraries. - - - - - - Language changes @@ -96,13 +29,6 @@ - It is now possible to derive instances for GADT datatypes, - provided the standard instance code is valid for the datatype. - - - - - The new DeriveFunctor, DeriveFoldable and DeriveTraversable language extensions @@ -121,24 +47,6 @@ - The new ExplicitForAll language extension - enables explicit forall's in types. - See for more information. - - - - - - The new DoRec language extension - provides new syntax for recursive do-notation, and the old - RecursiveDo language extension has been - deprecated. - See for more information. - - - - - Some improvements have been made to record puns: @@ -240,8 +148,7 @@ The ImpredicativeTypes extension is no - longer enabled by -fglasgow-exts, and - has been deprecated. + longer enabled by -fglasgow-exts. @@ -571,7 +478,7 @@ Prelude> :set prompt "Loaded: %s\n> " Loaded: Prelude -> +> @@ -730,7 +637,7 @@ - + Libraries @@ -921,7 +828,7 @@ - Version number 1.8.0.2 (was 1.6.0.3) + Version number 1.8.0.0 (was 1.6.0.3) diff -ruN ghc-6.12.1/docs/users_guide/debugging.xml ghc-6.13.20091231/docs/users_guide/debugging.xml --- ghc-6.12.1/docs/users_guide/debugging.xml 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/docs/users_guide/debugging.xml 2009-12-31 10:14:18.000000000 -0800 @@ -120,8 +120,9 @@ - dumps all rewrite rules (including those generated - by the specialisation pass) + dumps all rewrite rules specified in this module; + see . + @@ -437,6 +438,17 @@ + + + + + Suppress the printing of coercions in Core dumps to make them +shorter. + + + + + diff -ruN ghc-6.12.1/docs/users_guide/flags.xml ghc-6.13.20091231/docs/users_guide/flags.xml --- ghc-6.12.1/docs/users_guide/flags.xml 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/docs/users_guide/flags.xml 2009-12-31 10:14:18.000000000 -0800 @@ -1371,6 +1371,13 @@ + + Turn on specialisation of overloaded functions. Implied by . + dynamic + -fno-specialise + + + Turn on full laziness (floating bindings outwards). Implied by . dynamic @@ -1378,12 +1385,19 @@ - + + Turn on the float-in transformation. Implied by . + dynamic + -fno-float-in + + + + Switch on all rewrite rules (including rules generated by automatic specialisation of overloaded functions). Implied by . dynamic - + @@ -1393,6 +1407,14 @@ -fno-strictness + + =n + Run an additional strictness analysis before simplifier +phase n + dynamic + - + + Turn on the SpecConstr transformation. Implied by . @@ -1844,6 +1866,15 @@ dynamic - + + path + Set the install name (via -install_name passed to Apple's + linker), specifying the full install path of the library file. Any libraries + or executables that link with it later will pick up that path as their + runtime search location for it. (Darwin/MacOS X only) + dynamic + - + @@ -2307,6 +2338,12 @@ - + + Suppress the printing of coercions in Core dumps to make them shorter. + static + - + + Don't output pragma info in dumps static diff -ruN ghc-6.12.1/docs/users_guide/ghci.xml ghc-6.13.20091231/docs/users_guide/ghci.xml --- ghc-6.12.1/docs/users_guide/ghci.xml 2009-12-10 10:11:33.000000000 -0800 +++ ghc-6.13.20091231/docs/users_guide/ghci.xml 2009-12-31 10:14:18.000000000 -0800 @@ -2918,6 +2918,13 @@ because this is normally what you want in an interpreter: output appears as it is generated. + + If you want line-buffered behaviour, as in GHC, you can + start your program thus: + + main = do { hSetBuffering stdout LineBuffering; ... } + + diff -ruN ghc-6.12.1/docs/users_guide/glasgow_exts.xml ghc-6.13.20091231/docs/users_guide/glasgow_exts.xml --- ghc-6.12.1/docs/users_guide/glasgow_exts.xml 2009-12-10 10:11:33.000000000 -0800 +++ ghc-6.13.20091231/docs/users_guide/glasgow_exts.xml 2009-12-31 10:14:18.000000000 -0800 @@ -351,6 +351,15 @@ Name + + + :: @@ -399,6 +408,52 @@ MIDLINE HORIZONTAL ELLIPSIS + + + + -< + ↢ + 0x2919 + LEFTWARDS ARROW-TAIL + + + + + + >- + ↣ + 0x291A + RIGHTWARDS ARROW-TAIL + + + + + + -<< + + 0x291B + LEFTWARDS DOUBLE ARROW-TAIL + + + + + + >>- + + 0x291C + RIGHTWARDS DOUBLE ARROW-TAIL + + + + + + * + ★ + 0x2605 + BLACK STAR + + + @@ -3950,6 +4005,51 @@ (You need to do this.) +Warning: overlapping instances must be used with care. They +can give rise to incoherence (ie different instance choices are made +in different parts of the program) even without . Consider: + +{-# LANGUAGE OverlappingInstances #-} +module Help where + + class MyShow a where + myshow :: a -> String + + instance MyShow a => MyShow [a] where + myshow xs = concatMap myshow xs + + showHelp :: MyShow a => [a] -> String + showHelp xs = myshow xs + +{-# LANGUAGE FlexibleInstances, OverlappingInstances #-} +module Main where + import Help + + data T = MkT + + instance MyShow T where + myshow x = "Used generic instance" + + instance MyShow [T] where + myshow xs = "Used more specific instance" + + main = do { print (myshow [MkT]); print (showHelp [MkT]) } + +In function showHelp GHC sees no overlapping +instances, and so uses the MyShow [a] instance +without complaint. In the call to myshow in main, +GHC resolves the MyShow [T] constraint using the overlapping +instance declaration in module Main. As a result, +the program prints + + "Used more specific instance" + "Used generic instance" + +(An alternative possible behaviour, not currently implemented, +would be to reject module Help +on the grounds that a later instance declaration might overlap the local one.) + + The willingness to be overlapped or incoherent is a property of the instance declaration itself, controlled by the presence or otherwise of the @@ -7541,6 +7641,14 @@ portable). + + CONLIKE modifier + CONLIKE + An INLINE or NOINLINE pragma may have a CONLIKE modifier, + which affects matching in RULEs (only). See . + + + Phase control @@ -8176,18 +8284,24 @@ - + + + + + + + +How rules interact with INLINE/NOINLINE and CONLIKE pragmas Ordinary inlining happens at the same time as rule rewriting, which may lead to unexpected results. Consider this (artificial) example f x = x -{-# RULES "f" f True = False #-} - g y = f y - h z = g True + +{-# RULES "f" f True = False #-} Since f's right-hand side is small, it is inlined into g, to give @@ -8201,14 +8315,37 @@ The way to get predictable behaviour is to use a NOINLINE -pragma on f, to ensure +pragma, or an INLINE[phase] pragma, on f, to ensure that it is not inlined until its RULEs have had a chance to fire. - - - + +GHC is very cautious about duplicating work. For example, consider + +f k z xs = let xs = build g + in ...(foldr k z xs)...sum xs... +{-# RULES "foldr/build" forall k z g. foldr k z (build g) = g k z #-} + +Since xs is used twice, GHC does not fire the foldr/build rule. Rightly +so, because it might take a lot of work to compute xs, which would be +duplicated if the rule fired. + + +Sometimes, however, this approach is over-cautious, and we do want the +rule to fire, even though doing so would duplicate redex. There is no way that GHC can work out +when this is a good idea, so we provide the CONLIKE pragma to declare it, thus: + +{-# INLINE[1] CONLIKE f #-} +f x = blah + +CONLIKE is a modifier to an INLINE or NOINLINE pragam. It specifies that an application +of f to one argument (in general, the number of arguments to the left of the '=' sign) +should be considered cheap enough to duplicate, if such a duplication would make rule +fire. (The name "CONLIKE" is short for "constructor-like", because constructors certainly +have such a property.) +The CONLIKE pragam is a modifier to INLINE/NOINLINE because it really only makes sense to match +f on the LHS of a rule if you are sure that f is +not going to be inlined before the rule has a chance to fire. - @@ -8468,8 +8605,8 @@ - -Controlling what's going on + +Controlling what's going on in rewrite rules @@ -8477,18 +8614,28 @@ - Use to see what transformation rules GHC is using. +Use to see the rules that are defined +in this module. +This includes rules generated by the specialisation pass, but excludes +rules imported from other modules. - + Use to see what rules are being fired. If you add you get a more detailed listing. + + + Use to see in great detail what rules are being fired. +If you add you get a still more detailed listing. + + + The definition of (say) build in GHC/Base.lhs looks like this: diff -ruN ghc-6.12.1/docs/users_guide/phases.xml ghc-6.13.20091231/docs/users_guide/phases.xml --- ghc-6.12.1/docs/users_guide/phases.xml 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/docs/users_guide/phases.xml 2009-12-31 10:14:18.000000000 -0800 @@ -1072,6 +1072,24 @@ library entirely. + + + + + + + + + On Darwin/MacOS X, dynamic libraries are stamped at build time with an + "install name", which is the ultimate install path of the library file. + Any libraries or executables that subsequently link against it will pick + up that path as their runtime search location for it. By default, ghc sets + the install name to the location where the library is built. This option + allows you to override it with the specified file path. (It passes + -install_name to Apple's linker.) Ignored on other + platforms. + + diff -ruN ghc-6.12.1/docs/users_guide/shared_libs.xml ghc-6.13.20091231/docs/users_guide/shared_libs.xml --- ghc-6.12.1/docs/users_guide/shared_libs.xml 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/docs/users_guide/shared_libs.xml 2009-12-31 10:14:18.000000000 -0800 @@ -242,6 +242,19 @@ Similarly it would be possible to use a subdirectory relative to the executable e.g. -optl-Wl,-rpath,'$ORIGIN/lib'. + + The standard assumption on Darwin/MacOS X is that dynamic libraries will + be stamped at build time with an "install name", which is the full + ultimate install path of the library file. Any libraries or executables + that subsequently link against it (even if it hasn't been installed yet) + will pick up that path as their runtime search location for it. When + compiling with ghc directly, the install name is set by default to the + location where it is built. You can override this with the + -dylib-install-name option (which passes + -install_name to the Apple linker). Cabal does this + for you. It automatically sets the install name for dynamic libraries to + the absolute path of the ultimate install location. + diff -ruN ghc-6.12.1/docs/users_guide/using.xml ghc-6.13.20091231/docs/users_guide/using.xml --- ghc-6.12.1/docs/users_guide/using.xml 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/docs/users_guide/using.xml 2009-12-31 10:14:17.000000000 -0800 @@ -1667,6 +1667,26 @@ + + + + + Turns off the float-in transformation. + + + + + + + + + + Turns off the automatic specialisation of overloaded functions. + + + + + diff -ruN ghc-6.12.1/ghc/ghc.mk ghc-6.13.20091231/ghc/ghc.mk --- ghc-6.12.1/ghc/ghc.mk 2009-12-10 10:11:33.000000000 -0800 +++ ghc-6.13.20091231/ghc/ghc.mk 2009-12-31 10:14:18.000000000 -0800 @@ -18,6 +18,14 @@ ghc_stage2_HC_OPTS = $(GhcStage2HcOpts) ghc_stage3_HC_OPTS = $(GhcStage3HcOpts) +ghc_stage2_CC_OPTS = -Iincludes +ghc_stage3_CC_OPTS = -Iincludes + +ghc_stage1_C_FILES_NODEPS = ghc/hschooks.c + +ghc_stage2_MKDEPENDC_OPTS = -DMAKING_GHC_BUILD_SYSTEM_DEPENDENCIES +ghc_stage3_MKDEPENDC_OPTS = -DMAKING_GHC_BUILD_SYSTEM_DEPENDENCIES + ifeq "$(GhcWithInterpreter)" "YES" ghc_stage2_HC_OPTS += -DGHCI ghc_stage3_HC_OPTS += -DGHCI @@ -118,9 +126,9 @@ ghc/stage3/build/tmp/$(ghc_stage3_PROG) : $(compiler_stage3_v_LIB) # Modules here import HsVersions.h, so we need ghc_boot_platform.h -$(ghc_stage1_depfile) : compiler/stage1/$(PLATFORM_H) -$(ghc_stage2_depfile) : compiler/stage2/$(PLATFORM_H) -$(ghc_stage3_depfile) : compiler/stage3/$(PLATFORM_H) +$(ghc_stage1_depfile_haskell) : compiler/stage1/$(PLATFORM_H) +$(ghc_stage2_depfile_haskell) : compiler/stage2/$(PLATFORM_H) +$(ghc_stage3_depfile_haskell) : compiler/stage3/$(PLATFORM_H) all_ghc_stage1 : $(GHC_STAGE1) all_ghc_stage2 : $(GHC_STAGE2) diff -ruN ghc-6.12.1/ghc/InteractiveUI.hs ghc-6.13.20091231/ghc/InteractiveUI.hs --- ghc-6.12.1/ghc/InteractiveUI.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/ghc/InteractiveUI.hs 2009-12-31 10:14:18.000000000 -0800 @@ -2164,9 +2164,9 @@ where file = GHC.srcSpanFile span line1 = GHC.srcSpanStartLine span - col1 = GHC.srcSpanStartCol span + col1 = GHC.srcSpanStartCol span - 1 line2 = GHC.srcSpanEndLine span - col2 = GHC.srcSpanEndCol span + col2 = GHC.srcSpanEndCol span - 1 pad_before | line1 == 1 = 0 | otherwise = 1 diff -ruN ghc-6.12.1/ghc.mk ghc-6.13.20091231/ghc.mk --- ghc-6.12.1/ghc.mk 2009-12-10 10:11:33.000000000 -0800 +++ ghc-6.13.20091231/ghc.mk 2009-12-31 10:14:18.000000000 -0800 @@ -39,8 +39,6 @@ # # * per-source-file dependencies instead of one .depend file? # * eliminate undefined variables, and use --warn-undefined-variables? -# * perhaps we should make all the output dirs in the .depend rule, to -# avoid all these mkdirhier calls? # * put outputs from different ways in different subdirs of distdir/build, # then we don't have to use -osuf/-hisuf. We would have to install # them in different places too, so we'd need ghc-pkg support for packages @@ -85,7 +83,7 @@ # We need second expansion for the way we handle directories, so that # | $$$$(dir $$$$@)/. -# expands to the directoy of a rule that uses a % pattern. +# expands to the directory of a rule that uses a % pattern. .SECONDEXPANSION: default : all @@ -178,15 +176,12 @@ # We want package-data.mk for show endif -# We don't haddock base3-compat, as it has the same package name as base -libraries/base3-compat_dist-install_DO_HADDOCK = NO - # We don't haddock the bootstrapping libraries libraries/hpc_dist-boot_DO_HADDOCK = NO libraries/Cabal_dist-boot_DO_HADDOCK = NO libraries/extensible-exceptions_dist-boot_DO_HADDOCK = NO libraries/filepath_dist-boot_DO_HADDOCK = NO -libraries/ghc-binary_dist-boot_DO_HADDOCK = NO +libraries/binary_dist-boot_DO_HADDOCK = NO libraries/bin-package-db_dist-boot_DO_HADDOCK = NO # ----------------------------------------------------------------------------- @@ -333,11 +328,9 @@ $(eval $(call addPackage,haskell98)) $(eval $(call addPackage,hpc)) $(eval $(call addPackage,pretty)) -$(eval $(call addPackage,syb)) $(eval $(call addPackage,template-haskell)) -$(eval $(call addPackage,base3-compat)) $(eval $(call addPackage,Cabal)) -$(eval $(call addPackage,ghc-binary)) +$(eval $(call addPackage,binary)) $(eval $(call addPackage,bin-package-db)) $(eval $(call addPackage,mtl)) $(eval $(call addPackage,utf8-string)) @@ -358,7 +351,7 @@ # We assume that the stage0 compiler has a suitable bytestring package, # so we don't have to include it below. -BOOT_PKGS = Cabal hpc extensible-exceptions ghc-binary bin-package-db +BOOT_PKGS = Cabal hpc extensible-exceptions binary bin-package-db # The actual .a and .so/.dll files: needed for dependencies. ALL_STAGE1_LIBS = $(foreach lib,$(PACKAGES),$(libraries/$(lib)_dist-install_v_LIB)) @@ -374,24 +367,29 @@ # We cannot run ghc-cabal to configure a package until we have # configured and registered all of its dependencies. So the following -# hack forces all the configure steps to happen in exactly the order -# given in the PACKAGES variable above. Ideally we should use the -# correct dependencies here to allow more parallelism, but we don't -# know the dependencies until we've generated the pacakge-data.mk -# files. +# hack forces all the configure steps to happen in exactly the following order: +# +# $(PACKAGES) ghc(stage2) $(PACKAGES_STAGE2) +# +# Ideally we should use the correct dependencies here to allow more +# parallelism, but we don't know the dependencies until we've +# generated the pacakge-data.mk files. define fixed_pkg_dep -libraries/$1/$2/package-data.mk : $$(GHC_PKG_INPLACE) $$(if $$(fixed_pkg_prev),libraries/$$(fixed_pkg_prev)/$2/package-data.mk) -fixed_pkg_prev:=$1 +libraries/$1/$2/package-data.mk : $$(GHC_PKG_INPLACE) $$(fixed_pkg_prev) +fixed_pkg_prev:=libraries/$1/$2/package-data.mk endef ifneq "$(BINDIST)" "YES" fixed_pkg_prev= -$(foreach pkg,$(PACKAGES) $(PACKAGES_STAGE2),$(eval $(call fixed_pkg_dep,$(pkg),dist-install))) +$(foreach pkg,$(PACKAGES),$(eval $(call fixed_pkg_dep,$(pkg),dist-install))) + +# the GHC package doesn't live in libraries/, so we add its dependency manually: +compiler/stage2/package-data.mk: $(fixed_pkg_prev) +fixed_pkg_prev:=compiler/stage2/package-data.mk + +# and continue with PACKAGES_STAGE2, which depend on GHC: +$(foreach pkg,$(PACKAGES_STAGE2),$(eval $(call fixed_pkg_dep,$(pkg),dist-install))) -# We assume that the stage2 compiler depends on all the libraries, so -# they all get added to the package database before we try to configure -# it -compiler/stage2/package-data.mk: $(foreach pkg,$(PACKAGES) $(PACKAGES_STAGE2),libraries/$(pkg)/dist-install/package-data.mk) ghc/stage1/package-data.mk: compiler/stage1/package-data.mk ghc/stage2/package-data.mk: compiler/stage2/package-data.mk # haddock depends on ghc and some libraries, but depending on GHC's @@ -400,6 +398,7 @@ utils/haddock/dist/package-data.mk: compiler/stage2/package-data.mk utils/hsc2hs/dist-install/package-data.mk: compiler/stage2/package-data.mk +utils/compare_sizes/dist/package-data.mk: compiler/stage2/package-data.mk # add the final two package.conf dependencies: ghc-prim depends on RTS, # and RTS depends on libffi. @@ -440,8 +439,7 @@ PRIMOPS_TXT = $(GHC_COMPILER_DIR)/prelude/primops.txt -libraries/ghc-prim/dist-install/build/GHC/PrimopWrappers.hs : $(GENPRIMOP_INPLACE) $(PRIMOPS_TXT) - "$(MKDIRHIER)" $(dir $@) +libraries/ghc-prim/dist-install/build/GHC/PrimopWrappers.hs : $(GENPRIMOP_INPLACE) $(PRIMOPS_TXT) | $$(dir $$@)/. "$(GENPRIMOP_INPLACE)" --make-haskell-wrappers <$(PRIMOPS_TXT) >$@ libraries/ghc-prim/GHC/Prim.hs : $(GENPRIMOP_INPLACE) $(PRIMOPS_TXT) @@ -489,7 +487,6 @@ ifneq "$(BINDIST)" "YES" BUILD_DIRS += \ - $(GHC_MKDEPENDC_DIR) \ $(GHC_MKDIRHIER_DIR) endif @@ -533,7 +530,7 @@ ifneq "$(CLEANING)" "YES" BUILD_DIRS += \ - $(patsubst %, libraries/%, $(PACKAGES) $(PACKAGES_STAGE2)) + $(patsubst %, libraries/%, $(PACKAGES)) endif ifneq "$(BootingFromHc)" "YES" @@ -557,6 +554,15 @@ $(GHC_TOUCHY_DIR) endif +BUILD_DIRS += utils/count_lines +BUILD_DIRS += utils/compare_sizes + +ifneq "$(CLEANING)" "YES" +# After compiler/, because these packages depend on it +BUILD_DIRS += \ + $(patsubst %, libraries/%, $(PACKAGES_STAGE2)) +endif + # XXX libraries/% must come before any programs built with stage1, see # Note [lib-depends]. @@ -593,6 +599,7 @@ utils/hpc_dist_DISABLE = YES utils/hsc2hs_dist-install_DISABLE = YES utils/ghc-pkg_dist-install_DISABLE = YES +utils/compare_sizes_dist_DISABLE = YES compiler_stage2_DISABLE = YES compiler_stage3_DISABLE = YES ghc_stage2_DISABLE = YES @@ -623,12 +630,6 @@ # XXX Hack; remove this $(foreach pkg,$(PACKAGES_STAGE2),$(eval libraries/$(pkg)_dist-install_HC_OPTS += -Wwarn)) -# XXX we configure packages with the bootstrapping compiler (for -# dependency reasons, see the phase ordering), which doesn't -# necessarily support all the extensions we need, and Cabal filters -# out the ones it thinks aren't supported. -libraries/base3-compat_dist-install_HC_OPTS += -XPackageImports - # A useful pseudo-target .PHONY: stage1_libs stage1_libs : $(ALL_STAGE1_LIBS) @@ -668,7 +669,7 @@ $(eval $(call build-package,libraries/hpc,dist-boot,0)) $(eval $(call build-package,libraries/extensible-exceptions,dist-boot,0)) $(eval $(call build-package,libraries/Cabal,dist-boot,0)) -$(eval $(call build-package,libraries/ghc-binary,dist-boot,0)) +$(eval $(call build-package,libraries/binary,dist-boot,0)) $(eval $(call build-package,libraries/bin-package-db,dist-boot,0)) # register the boot packages in strict sequence, because running @@ -685,8 +686,8 @@ # These are necessary because the bootstrapping compiler may not know # about cross-package dependencies: -$(compiler_stage1_depfile) : $(BOOT_LIBS) -$(ghc_stage1_depfile) : $(compiler_stage1_v_LIB) +$(compiler_stage1_depfile_haskell) : $(BOOT_LIBS) +$(ghc_stage1_depfile_haskell) : $(compiler_stage1_v_LIB) # A few careful dependencies between bootstrapping packages. When we # can rely on the stage 0 compiler being able to generate @@ -695,10 +696,19 @@ # # If you miss any out here, then 'make -j8' will probably tell you. # -libraries/bin-package-db/dist-boot/build/Distribution/InstalledPackageInfo/Binary.$(v_osuf) : libraries/ghc-binary/dist-boot/build/Data/Binary.$(v_hisuf) libraries/Cabal/dist-boot/build/Distribution/InstalledPackageInfo.$(v_hisuf) +libraries/bin-package-db/dist-boot/build/Distribution/InstalledPackageInfo/Binary.$(v_osuf) : libraries/binary/dist-boot/build/Data/Binary.$(v_hisuf) libraries/Cabal/dist-boot/build/Distribution/InstalledPackageInfo.$(v_hisuf) $(foreach pkg,$(BOOT_PKGS),$(eval libraries/$(pkg)_dist-boot_HC_OPTS += $$(GhcBootLibHcOpts))) +# Make sure we have all the GHCi libs by the time we've built +# ghc-stage2. DPH includes a bit of Template Haskell which needs the +# GHCI libs, and we don't have a better way to express that dependency. +# +GHCI_LIBS = $(foreach lib,$(PACKAGES),$(libraries/$(lib)_dist-install_GHCI_LIB)) \ + $(compiler_stage2_GHCI_LIB) + +ghc/stage2/build/tmp/$(ghc_stage2_PROG) : $(GHCI_LIBS) + endif # ----------------------------------------------------------------------------- @@ -725,13 +735,13 @@ endif # BINDIST libraries/ghc-prim/dist-install/build/autogen/GHC/Prim.hs: \ - $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE) $(MKDIRHIER) - "$(MKDIRHIER)" $(dir $@) + $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE) \ + | $$(dir $$@)/. "$(GENPRIMOP_INPLACE)" --make-haskell-source < $< > $@ libraries/ghc-prim/dist-install/build/autogen/GHC/PrimopWrappers.hs: \ - $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE) $(MKDIRHIER) - "$(MKDIRHIER)" $(dir $@) + $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE) \ + | $$(dir $$@)/. "$(GENPRIMOP_INPLACE)" --make-haskell-wrappers < $< > $@ # ----------------------------------------------------------------------------- @@ -745,9 +755,6 @@ $(INSTALL_DIR) "$(DESTDIR)$(bindir)" for i in $(INSTALL_BINS); do \ $(INSTALL_PROGRAM) $(INSTALL_BIN_OPTS) $$i "$(DESTDIR)$(bindir)" ; \ - if test "$(darwin_TARGET_OS)" = "1"; then \ - sh mk/fix_install_names.sh $(ghclibdir) "$(DESTDIR)$(bindir)/$$i" ; \ - fi ; \ done install_libs: $(INSTALL_LIBS) @@ -762,8 +769,7 @@ *.so) \ $(INSTALL_SHLIB) $(INSTALL_OPTS) $$i "$(DESTDIR)$(ghclibdir)" ;; \ *.dylib) \ - $(INSTALL_SHLIB) $(INSTALL_OPTS) $$i "$(DESTDIR)$(ghclibdir)"; \ - install_name_tool -id "$(DESTDIR)$(ghclibdir)/`basename $$i`" "$(DESTDIR)$(ghclibdir)/`basename $$i`" ;; \ + $(INSTALL_SHLIB) $(INSTALL_OPTS) $$i "$(DESTDIR)$(ghclibdir)";; \ *) \ $(INSTALL_DATA) $(INSTALL_OPTS) $$i "$(DESTDIR)$(ghclibdir)"; \ esac; \ @@ -847,7 +853,7 @@ endif INSTALLED_PACKAGES = $(filter-out haskeline mtl terminfo,$(PACKAGES)) -HIDDEN_PACKAGES = ghc-binary +HIDDEN_PACKAGES = binary define set_INSTALL_DISTDIR # $1 = libraries/base, $2 = dist-install @@ -926,7 +932,6 @@ $(wildcard libraries/*/dist-install/doc/) \ $(filter-out extra-gcc-opts,$(INSTALL_LIBS)) \ $(filter-out %/project.mk mk/config.mk %/mk/install.mk,$(MAKEFILE_LIST)) \ - mk/fix_install_names.sh \ mk/project.mk \ mk/install.mk.in \ bindist.mk \ diff -ruN ghc-6.12.1/ghc.spec ghc-6.13.20091231/ghc.spec --- ghc-6.12.1/ghc.spec 2009-12-10 10:32:19.000000000 -0800 +++ ghc-6.13.20091231/ghc.spec 2009-12-31 10:33:23.000000000 -0800 @@ -11,7 +11,7 @@ # This file is subject to the same free software license as GHC. %define name ghc -%define version 6.12.1 +%define version 6.13.20091231 %define release 1 Name: %{name} diff -ruN ghc-6.12.1/includes/Cmm.h ghc-6.13.20091231/includes/Cmm.h --- ghc-6.12.1/includes/Cmm.h 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/includes/Cmm.h 2009-12-31 10:14:18.000000000 -0800 @@ -380,11 +380,12 @@ HP_CHK_GEN(alloc,liveness,reentry); \ TICK_ALLOC_HEAP_NOCTR(alloc); -// allocateLocal() allocates from the nursery, so we check to see +// allocate() allocates from the nursery, so we check to see // whether the nursery is nearly empty in any function that uses -// allocateLocal() - this includes many of the primops. +// allocate() - this includes many of the primops. #define MAYBE_GC(liveness,reentry) \ - if (bdescr_link(CurrentNursery) == NULL || CInt[alloc_blocks] >= CInt[alloc_blocks_lim]) { \ + if (bdescr_link(CurrentNursery) == NULL || \ + generation_n_new_large_blocks(W_[g0]) >= CInt[alloc_blocks_lim]) { \ R9 = liveness; \ R10 = reentry; \ HpAlloc = 0; \ @@ -462,6 +463,9 @@ #define StgFunInfoExtra_bitmap(i) StgFunInfoExtraFwd_bitmap(i) #endif +#define mutArrPtrsCardWords(n) \ + ROUNDUP_BYTES_TO_WDS(((n) + (1 << MUT_ARR_PTRS_CARD_BITS) - 1) >> MUT_ARR_PTRS_CARD_BITS) + /* ----------------------------------------------------------------------------- Voluntary Yields/Blocks diff -ruN ghc-6.12.1/includes/ghc.mk ghc-6.13.20091231/includes/ghc.mk --- ghc-6.12.1/includes/ghc.mk 2009-12-10 10:11:33.000000000 -0800 +++ ghc-6.13.20091231/includes/ghc.mk 2009-12-31 10:14:18.000000000 -0800 @@ -129,7 +129,7 @@ $(eval $(call build-prog,includes,dist-derivedconstants,0)) -$(includes_dist-derivedconstants_depfile) : $(includes_H_CONFIG) $(includes_H_PLATFORM) $(wildcard includes/*.h) $(wildcard rts/*.h) +$(includes_dist-derivedconstants_depfile_c_asm) : $(includes_H_CONFIG) $(includes_H_PLATFORM) $(wildcard includes/*.h) $(wildcard rts/*.h) includes/dist-derivedconstants/build/mkDerivedConstants.o : $(includes_H_CONFIG) $(includes_H_PLATFORM) ifneq "$(BINDIST)" "YES" @@ -159,7 +159,7 @@ $(eval $(call build-prog,includes,dist-ghcconstants,0)) ifneq "$(BINDIST)" "YES" -$(includes_dist-ghcconstants_depfile) : $(includes_H_CONFIG) $(includes_H_PLATFORM) $(wildcard includes/*.h) $(wildcard rts/*.h) +$(includes_dist-ghcconstants_depfile_c_asm) : $(includes_H_CONFIG) $(includes_H_PLATFORM) $(wildcard includes/*.h) $(wildcard rts/*.h) includes/dist-ghcconstants/build/mkDerivedConstants.o : $(includes_H_CONFIG) $(includes_H_PLATFORM) diff -ruN ghc-6.12.1/includes/HaskellConstants.hs ghc-6.13.20091231/includes/HaskellConstants.hs --- ghc-6.12.1/includes/HaskellConstants.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/includes/HaskellConstants.hs 2009-12-31 10:14:18.000000000 -0800 @@ -62,6 +62,9 @@ mIN_CHARLIKE = MIN_CHARLIKE mAX_CHARLIKE = MAX_CHARLIKE +mUT_ARR_PTRS_CARD_BITS :: Int +mUT_ARR_PTRS_CARD_BITS = MUT_ARR_PTRS_CARD_BITS + -- A section of code-generator-related MAGIC CONSTANTS. mAX_Vanilla_REG :: Int diff -ruN ghc-6.12.1/includes/HsFFI.h ghc-6.13.20091231/includes/HsFFI.h --- ghc-6.12.1/includes/HsFFI.h 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/includes/HsFFI.h 2009-12-31 10:14:18.000000000 -0800 @@ -100,9 +100,11 @@ #if SIZEOF_VOID_P == 8 #define HS_INT_MIN __INT64_MIN #define HS_INT_MAX __INT64_MAX +#define HS_WORD_MAX __UINT64_MAX #elif SIZEOF_VOID_P == 4 #define HS_INT_MIN __INT32_MIN #define HS_INT_MAX __INT32_MAX +#define HS_WORD_MAX __UINT32_MAX #else #error GHC untested on this architecture: sizeof(void *) != 4 or 8 #endif diff -ruN ghc-6.12.1/includes/mkDerivedConstants.c ghc-6.13.20091231/includes/mkDerivedConstants.c --- ghc-6.12.1/includes/mkDerivedConstants.c 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/includes/mkDerivedConstants.c 2009-12-31 10:14:18.000000000 -0800 @@ -230,6 +230,7 @@ field_offset(StgRegTable, rCurrentNursery); field_offset(StgRegTable, rHpAlloc); struct_field(StgRegTable, rRet); + struct_field(StgRegTable, rNursery); def_offset("stgEagerBlackholeInfo", FUN_OFFSET(stgEagerBlackholeInfo)); def_offset("stgGCEnter1", FUN_OFFSET(stgGCEnter1)); @@ -248,6 +249,7 @@ struct_size(generation); struct_field(generation, mut_list); + struct_field(generation, n_new_large_blocks); struct_size(CostCentreStack); struct_field(CostCentreStack, ccsID); @@ -277,6 +279,7 @@ closure_size(StgMutArrPtrs); closure_field(StgMutArrPtrs, ptrs); + closure_field(StgMutArrPtrs, size); closure_size(StgArrWords); closure_field(StgArrWords, words); diff -ruN ghc-6.12.1/includes/rts/Constants.h ghc-6.13.20091231/includes/rts/Constants.h --- ghc-6.12.1/includes/rts/Constants.h 2009-12-10 10:11:33.000000000 -0800 +++ ghc-6.13.20091231/includes/rts/Constants.h 2009-12-31 10:14:18.000000000 -0800 @@ -66,6 +66,13 @@ #define MAX_CHARLIKE 255 #define MIN_CHARLIKE 0 +/* Each byte in the card table for an StgMutaArrPtrs covers + * (1<lock), 1, 0); if (r == 0) { p->spin++; + busy_wait_nop(); goto spin; } } @@ -76,6 +77,7 @@ StgWord32 r = 0; do { r = cas((StgVolatilePtr)p, 1, 0); + busy_wait_nop(); } while(r == 0); } diff -ruN ghc-6.12.1/includes/rts/storage/Block.h ghc-6.13.20091231/includes/rts/storage/Block.h --- ghc-6.12.1/includes/rts/storage/Block.h 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/includes/rts/storage/Block.h 2009-12-31 10:14:18.000000000 -0800 @@ -48,22 +48,26 @@ #ifndef CMINUSMINUS typedef struct bdescr_ { - StgPtr start; /* start addr of memory */ - StgPtr free; /* first free byte of memory */ - struct bdescr_ *link; /* used for chaining blocks together */ - union { - struct bdescr_ *back; /* used (occasionally) for doubly-linked lists*/ - StgWord *bitmap; - StgPtr scan; /* scan pointer for copying GC */ - } u; - unsigned int gen_no; /* generation */ - struct step_ *step; /* step */ - StgWord32 blocks; /* no. of blocks (if grp head, 0 otherwise) */ - StgWord32 flags; /* block is in to-space */ + StgPtr start; /* start addr of memory */ + StgPtr free; /* first free byte of memory */ + struct bdescr_ *link; /* used for chaining blocks together */ + union { + struct bdescr_ *back; /* used (occasionally) for doubly-linked lists*/ + StgWord *bitmap; + StgPtr scan; /* scan pointer for copying GC */ + } u; + + struct generation_ *gen; /* generation */ + struct generation_ *dest; /* destination gen */ + + StgWord32 blocks; /* no. of blocks (if grp head, 0 otherwise) */ + + StgWord16 gen_no; + StgWord16 flags; /* block flags, see below */ #if SIZEOF_VOID_P == 8 - StgWord32 _padding[2]; + StgWord32 _padding[2]; #else - StgWord32 _padding[0]; + StgWord32 _padding[0]; #endif } bdescr; #endif diff -ruN ghc-6.12.1/includes/rts/storage/ClosureMacros.h ghc-6.13.20091231/includes/rts/storage/ClosureMacros.h --- ghc-6.12.1/includes/rts/storage/ClosureMacros.h 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/includes/rts/storage/ClosureMacros.h 2009-12-31 10:14:18.000000000 -0800 @@ -278,7 +278,7 @@ { return sizeofW(StgArrWords) + x->words; } INLINE_HEADER StgOffset mut_arr_ptrs_sizeW( StgMutArrPtrs* x ) -{ return sizeofW(StgMutArrPtrs) + x->ptrs; } +{ return sizeofW(StgMutArrPtrs) + x->size; } INLINE_HEADER StgWord tso_sizeW ( StgTSO *tso ) { return TSO_STRUCT_SIZEW + tso->stack_size; } @@ -392,4 +392,32 @@ } } +/* ----------------------------------------------------------------------------- + StgMutArrPtrs macros + + An StgMutArrPtrs has a card table to indicate which elements are + dirty for the generational GC. The card table is an array of + bytes, where each byte covers (1 << MUT_ARR_PTRS_CARD_BITS) + elements. The card table is directly after the array data itself. + -------------------------------------------------------------------------- */ + +// The number of card bytes needed +INLINE_HEADER lnat mutArrPtrsCards (lnat elems) +{ + return (lnat)((elems + (1 << MUT_ARR_PTRS_CARD_BITS) - 1) + >> MUT_ARR_PTRS_CARD_BITS); +} + +// The number of words in the card table +INLINE_HEADER lnat mutArrPtrsCardTableSize (lnat elems) +{ + return ROUNDUP_BYTES_TO_WDS(mutArrPtrsCards(elems)); +} + +// The address of the card for a particular card number +INLINE_HEADER StgWord8 *mutArrPtrsCard (StgMutArrPtrs *a, lnat n) +{ + return ((StgWord8 *)&(a->payload[a->ptrs]) + n); +} + #endif /* RTS_STORAGE_CLOSUREMACROS_H */ diff -ruN ghc-6.12.1/includes/rts/storage/Closures.h ghc-6.13.20091231/includes/rts/storage/Closures.h --- ghc-6.12.1/includes/rts/storage/Closures.h 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/includes/rts/storage/Closures.h 2009-12-31 10:14:18.000000000 -0800 @@ -136,7 +136,9 @@ typedef struct { StgHeader header; StgWord ptrs; + StgWord size; // ptrs plus card table StgClosure *payload[FLEXIBLE_ARRAY]; + // see also: StgMutArrPtrs macros in ClosureMacros.h } StgMutArrPtrs; typedef struct { diff -ruN ghc-6.12.1/includes/rts/storage/GC.h ghc-6.13.20091231/includes/rts/storage/GC.h --- ghc-6.12.1/includes/rts/storage/GC.h 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/includes/rts/storage/GC.h 2009-12-31 10:14:18.000000000 -0800 @@ -53,32 +53,37 @@ * * ------------------------------------------------------------------------- */ -typedef struct step_ { - unsigned int no; // step number in this generation - unsigned int abs_no; // absolute step number +typedef struct nursery_ { + bdescr * blocks; + unsigned int n_blocks; +} nursery; - struct generation_ * gen; // generation this step belongs to - unsigned int gen_no; // generation number (cached) - - bdescr * blocks; // blocks in this step - unsigned int n_blocks; // number of blocks - unsigned int n_words; // number of words +typedef struct generation_ { + unsigned int no; // generation number - struct step_ * to; // destination step for live objects + bdescr * blocks; // blocks in this gen + unsigned int n_blocks; // number of blocks + unsigned int n_words; // number of words + + bdescr * large_objects; // large objects (doubly linked) + unsigned int n_large_blocks; // no. of blocks used by large objs + unsigned int n_new_large_blocks; // count freshly allocated large objects - bdescr * large_objects; // large objects (doubly linked) - unsigned int n_large_blocks; // no. of blocks used by large objs + unsigned int max_blocks; // max blocks + bdescr *mut_list; // mut objects in this gen (not G0) - StgTSO * threads; // threads in this step + StgTSO * threads; // threads in this gen // linked via global_link + struct generation_ *to; // destination gen for live objects + + // stats information + unsigned int collections; + unsigned int par_collections; + unsigned int failed_promotions; // ------------------------------------ // Fields below are used during GC only - // During GC, if we are collecting this step, blocks and n_blocks - // are copied into the following two fields. After GC, these blocks - // are freed. - #if defined(THREADED_RTS) char pad[128]; // make sure the following is // on a separate cache line. @@ -89,10 +94,15 @@ int mark; // mark (not copy)? (old gen only) int compact; // compact (not sweep)? (old gen only) + // During GC, if we are collecting this gen, blocks and n_blocks + // are copied into the following two fields. After GC, these blocks + // are freed. bdescr * old_blocks; // bdescr of first from-space block unsigned int n_old_blocks; // number of blocks in from-space unsigned int live_estimate; // for sweeping: estimate of live data + bdescr * saved_mut_list; + bdescr * part_blocks; // partially-full scanned blocks unsigned int n_part_blocks; // count of above @@ -102,52 +112,23 @@ bdescr * bitmap; // bitmap for compacting collection StgTSO * old_threads; - -} step; - - -typedef struct generation_ { - unsigned int no; // generation number - step * steps; // steps - unsigned int n_steps; // number of steps - unsigned int max_blocks; // max blocks in step 0 - bdescr *mut_list; // mut objects in this gen (not G0) - - // stats information - unsigned int collections; - unsigned int par_collections; - unsigned int failed_promotions; - - // temporary use during GC: - bdescr *saved_mut_list; } generation; extern generation * generations; - extern generation * g0; -extern step * g0s0; extern generation * oldest_gen; -extern step * all_steps; -extern nat total_steps; /* ----------------------------------------------------------------------------- Generic allocation - StgPtr allocateInGen(generation *g, nat n) - Allocates a chunk of contiguous store - n words long in generation g, - returning a pointer to the first word. - Always succeeds. - - StgPtr allocate(nat n) Equaivalent to allocateInGen(g0) - - StgPtr allocateLocal(Capability *cap, nat n) + StgPtr allocate(Capability *cap, nat n) Allocates memory from the nursery in the current Capability. This can be done without taking a global lock, unlike allocate(). - StgPtr allocatePinned(nat n) Allocates a chunk of contiguous store + StgPtr allocatePinned(Capability *cap, nat n) + Allocates a chunk of contiguous store n words long, which is at a fixed address (won't be moved by GC). Returns a pointer to the first word. @@ -163,27 +144,16 @@ allocatePinned, for the benefit of the ticky-ticky profiler. - rtsBool doYouWantToGC(void) Returns True if the storage manager is - ready to perform a GC, False otherwise. - - lnat allocatedBytes(void) Returns the number of bytes allocated - via allocate() since the last GC. - Used in the reporting of statistics. - -------------------------------------------------------------------------- */ -StgPtr allocate ( lnat n ); -StgPtr allocateInGen ( generation *g, lnat n ); -StgPtr allocateLocal ( Capability *cap, lnat n ); -StgPtr allocatePinned ( lnat n ); -lnat allocatedBytes ( void ); +StgPtr allocate ( Capability *cap, lnat n ); +StgPtr allocatePinned ( Capability *cap, lnat n ); /* memory allocator for executable memory */ void * allocateExec(unsigned int len, void **exec_addr); void freeExec (void *p); // Used by GC checks in external .cmm code: -extern nat alloc_blocks; extern nat alloc_blocks_lim; /* ----------------------------------------------------------------------------- @@ -197,8 +167,8 @@ The CAF table - used to let us revert CAFs in GHCi -------------------------------------------------------------------------- */ -void newCAF (StgClosure*); -void newDynCAF (StgClosure *); +void newCAF (StgRegTable *reg, StgClosure *); +void newDynCAF (StgRegTable *reg, StgClosure *); void revertCAFs (void); /* ----------------------------------------------------------------------------- @@ -214,4 +184,11 @@ /* (needed when dynamic libraries are used). */ extern rtsBool keepCAFs; +INLINE_HEADER void initBdescr(bdescr *bd, generation *gen, generation *dest) +{ + bd->gen = gen; + bd->gen_no = gen->no; + bd->dest = dest; +} + #endif /* RTS_STORAGE_GC_H */ diff -ruN ghc-6.12.1/includes/RtsAPI.h ghc-6.13.20091231/includes/RtsAPI.h --- ghc-6.12.1/includes/RtsAPI.h 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/includes/RtsAPI.h 2009-12-31 10:14:18.000000000 -0800 @@ -48,6 +48,7 @@ extern void setProgArgv ( int argc, char *argv[] ); extern void getFullProgArgv ( int *argc, char **argv[] ); extern void setFullProgArgv ( int argc, char *argv[] ); +extern void freeFullProgArgv ( void ) ; #ifndef mingw32_HOST_OS extern void shutdownHaskellAndSignal (int sig); @@ -162,10 +163,22 @@ These are used by foreign export and foreign import "wrapper" stubs. ----------------------------------------------------------------------- */ +// When producing Windows DLLs the we need to know which symbols are in the +// local package/DLL vs external ones. +// +// Note that RtsAPI.h is also included by foreign export stubs in +// the base package itself. +// +#if defined(mingw32_TARGET_OS) && defined(__PIC__) && !defined(COMPILING_BASE_PACKAGE) +__declspec(dllimport) extern StgWord base_GHCziTopHandler_runIO_closure[]; +__declspec(dllimport) extern StgWord base_GHCziTopHandler_runNonIO_closure[]; +#else extern StgWord base_GHCziTopHandler_runIO_closure[]; extern StgWord base_GHCziTopHandler_runNonIO_closure[]; -#define runIO_closure base_GHCziTopHandler_runIO_closure -#define runNonIO_closure base_GHCziTopHandler_runNonIO_closure +#endif + +#define runIO_closure base_GHCziTopHandler_runIO_closure +#define runNonIO_closure base_GHCziTopHandler_runNonIO_closure /* ------------------------------------------------------------------------ */ diff -ruN ghc-6.12.1/includes/RtsFlags.h ghc-6.13.20091231/includes/RtsFlags.h --- ghc-6.12.1/includes/RtsFlags.h 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/includes/RtsFlags.h 2009-12-31 10:14:18.000000000 -0800 @@ -1,2 +1,5 @@ +#ifndef MAKING_GHC_BUILD_SYSTEM_DEPENDENCIES #warning RtsFlags.h is DEPRECATED; please just #include "Rts.h" +#endif + #include "Rts.h" diff -ruN ghc-6.12.1/includes/stg/DLL.h ghc-6.13.20091231/includes/stg/DLL.h --- ghc-6.12.1/includes/stg/DLL.h 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/includes/stg/DLL.h 2009-12-31 10:14:18.000000000 -0800 @@ -52,6 +52,7 @@ # endif #endif + #ifdef COMPILING_STDLIB #define DLL_IMPORT_STDLIB #else diff -ruN ghc-6.12.1/includes/stg/MiscClosures.h ghc-6.13.20091231/includes/stg/MiscClosures.h --- ghc-6.12.1/includes/stg/MiscClosures.h 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/includes/stg/MiscClosures.h 2009-12-31 10:14:18.000000000 -0800 @@ -618,7 +618,7 @@ extern StgWord stg_stack_save_entries[]; // Storage.c -extern unsigned int RTS_VAR(alloc_blocks); +extern unsigned int RTS_VAR(g0); extern unsigned int RTS_VAR(alloc_blocks_lim); extern StgWord RTS_VAR(weak_ptr_list); extern StgWord RTS_VAR(atomic_modify_mutvar_mutex); diff -ruN ghc-6.12.1/includes/stg/Regs.h ghc-6.13.20091231/includes/stg/Regs.h --- ghc-6.12.1/includes/stg/Regs.h 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/includes/stg/Regs.h 2009-12-31 10:14:18.000000000 -0800 @@ -80,10 +80,10 @@ StgPtr rSpLim; StgPtr rHp; StgPtr rHpLim; - struct StgTSO_ *rCurrentTSO; - struct step_ *rNursery; - struct bdescr_ *rCurrentNursery; /* Hp/HpLim point into this block */ - struct bdescr_ *rCurrentAlloc; /* for allocation using allocate() */ + struct StgTSO_ * rCurrentTSO; + struct nursery_ * rNursery; + struct bdescr_ * rCurrentNursery; /* Hp/HpLim point into this block */ + struct bdescr_ * rCurrentAlloc; /* for allocation using allocate() */ StgWord rHpAlloc; /* number of *bytes* being allocated in heap */ StgWord rRet; // holds the return code of the thread } StgRegTable; diff -ruN ghc-6.12.1/includes/stg/SMP.h ghc-6.13.20091231/includes/stg/SMP.h --- ghc-6.12.1/includes/stg/SMP.h 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/includes/stg/SMP.h 2009-12-31 10:14:17.000000000 -0800 @@ -64,6 +64,13 @@ */ EXTERN_INLINE StgWord atomic_dec(StgVolatilePtr p); +/* + * Busy-wait nop: this is a hint to the CPU that we are currently in a + * busy-wait loop waiting for another CPU to change something. On a + * hypertreaded CPU it should yield to another thread, for example. + */ +EXTERN_INLINE void busy_wait_nop(void); + #endif // !IN_STG_CODE /* @@ -216,6 +223,17 @@ #endif } +EXTERN_INLINE void +busy_wait_nop(void) +{ +#if defined(i386_HOST_ARCH) || defined(x86_64_HOST_ARCH) + __asm__ __volatile__ ("rep; nop"); + // +#else + // nothing +#endif +} + #endif // !IN_STG_CODE /* diff -ruN ghc-6.12.1/includes/stg/Ticky.h ghc-6.13.20091231/includes/stg/Ticky.h --- ghc-6.12.1/includes/stg/Ticky.h 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/includes/stg/Ticky.h 2009-12-31 10:14:17.000000000 -0800 @@ -130,8 +130,6 @@ EXTERN StgInt GC_FAILED_PROMOTION_ctr INIT(0); -EXTERN StgInt GC_WORDS_COPIED_ctr INIT(0); - EXTERN StgInt ALLOC_UP_THK_ctr INIT(0); EXTERN StgInt ALLOC_SE_THK_ctr INIT(0); EXTERN StgInt ALLOC_THK_adm INIT(0); @@ -191,7 +189,6 @@ #define TICK_UPD_NEW_IND() #define TICK_UPD_SQUEEZED() #define TICK_ALLOC_HEAP_NOCTR(x) -#define TICK_GC_WORDS_COPIED(x) #define TICK_GC_FAILED_PROMOTION() #define TICK_ALLOC_TSO(g,s) #define TICK_ALLOC_UP_THK(g,s) diff -ruN ghc-6.12.1/libffi/ghc.mk ghc-6.13.20091231/libffi/ghc.mk --- ghc-6.12.1/libffi/ghc.mk 2009-12-10 10:11:33.000000000 -0800 +++ ghc-6.13.20091231/libffi/ghc.mk 2009-12-31 10:14:18.000000000 -0800 @@ -84,10 +84,14 @@ libffi_DYNAMIC_LIBS = $(libffi_HS_DYN_LIB) else libffi_DYNAMIC_PROG = +ifeq "$(darwin_TARGET_OS)" "1" +libffi_DYNAMIC_LIBS = libffi/libffi$(soext) libffi/libffi.5$(soext) libffi/libffi.5.0.9$(soext) +else libffi_DYNAMIC_LIBS = libffi/dist-install/build/libffi.so \ libffi/dist-install/build/libffi.so.5 \ libffi/dist-install/build/libffi.so.5.0.9 endif +endif ifeq "$(BuildSharedLibs)" "YES" libffi_EnableShared=yes @@ -150,9 +154,17 @@ libffi/dist-install/build/ffi.h: $(libffi_STAMP_CONFIGURE) | $$(dir $$@)/. "$(CP)" libffi/build/include/ffi.h $@ + $(libffi_STAMP_BUILD): $(libffi_STAMP_CONFIGURE) | libffi/dist-install/build/. $(MAKE) -C libffi/build MAKEFLAGS= cd libffi/build && ./libtool --mode=install cp libffi.la $(TOP)/libffi/dist-install/build + + # We actually want both static and dllized libraries, because we build + # the runtime system both ways. libffi_convenience.a is the static version. +ifeq "$(Windows)" "YES" + cp libffi/build/.libs/libffi_convenience.a $(libffi_STATIC_LIB) +endif + touch $@ $(libffi_STATIC_LIB): $(libffi_STAMP_BUILD) @@ -192,6 +204,10 @@ # Rename libffi.so to libHSffi...so $(libffi_HS_DYN_LIB): $(libffi_DYNAMIC_LIBS) | $$(dir $$@)/. "$(CP)" $(word 1,$(libffi_DYNAMIC_LIBS)) $(libffi_HS_DYN_LIB) +ifeq "$(darwin_TARGET_OS)" "1" + # Ensure library's install name is correct before anyone links with it. + install_name_tool -id $(ghclibdir)/$(libffi_HS_DYN_LIB_NAME) $(libffi_HS_DYN_LIB) +endif $(eval $(call all-target,libffi,$(libffi_HS_DYN_LIB))) endif diff -ruN ghc-6.12.1/libffi/libffi.dllize-3.0.8.patch ghc-6.13.20091231/libffi/libffi.dllize-3.0.8.patch --- ghc-6.12.1/libffi/libffi.dllize-3.0.8.patch 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/libffi/libffi.dllize-3.0.8.patch 2009-12-31 10:14:18.000000000 -0800 @@ -41,7 +41,7 @@ #define @TARGET@ #endif -+#if @LIBFFI_DLL@ ++#if @LIBFFI_DLL@ && !defined(LIBFFI_NOT_DLL) +#ifdef DLL_EXPORT +#define __FFI_DECLSPEC __declspec(__dllexport__) +#else diff -ruN ghc-6.12.1/libraries/array/.darcs-boring ghc-6.13.20091231/libraries/array/.darcs-boring --- ghc-6.12.1/libraries/array/.darcs-boring 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/array/.darcs-boring 2009-12-31 10:22:57.000000000 -0800 @@ -0,0 +1,5 @@ +^dist(/|$) +^setup(/|$) +^GNUmakefile$ +^Makefile.local$ +^.depend(.bak)?$ diff -ruN ghc-6.12.1/libraries/array/Data/Array/Base.hs ghc-6.13.20091231/libraries/array/Data/Array/Base.hs --- ghc-6.12.1/libraries/array/Data/Array/Base.hs 2009-11-12 05:36:33.000000000 -0800 +++ ghc-6.13.20091231/libraries/array/Data/Array/Base.hs 2009-12-31 10:22:57.000000000 -0800 @@ -125,20 +125,18 @@ unsafeAccumST :: (IArray a e, Ix i) => (e -> e' -> e) -> a i e -> [(Int, e')] -> ST s (STArray s i e) unsafeAccumST f arr ies = do marr <- thaw arr - sequence_ [do - old <- unsafeRead marr i - unsafeWrite marr i (f old new) - | (i, new) <- ies] + sequence_ [do old <- unsafeRead marr i + unsafeWrite marr i (f old new) + | (i, new) <- ies] return marr {-# INLINE unsafeAccumArrayST #-} unsafeAccumArrayST :: Ix i => (e -> e' -> e) -> e -> (i,i) -> [(Int, e')] -> ST s (STArray s i e) unsafeAccumArrayST f e (l,u) ies = do marr <- newArray (l,u) e - sequence_ [do - old <- unsafeRead marr i - unsafeWrite marr i (f old new) - | (i, new) <- ies] + sequence_ [do old <- unsafeRead marr i + unsafeWrite marr i (f old new) + | (i, new) <- ies] return marr @@ -476,10 +474,9 @@ => (e -> e' -> e) -> UArray i e -> [(Int, e')] -> ST s (UArray i e) unsafeAccumUArray f arr ies = do marr <- thawSTUArray arr - sequence_ [do - old <- unsafeRead marr i - unsafeWrite marr i (f old new) - | (i, new) <- ies] + sequence_ [do old <- unsafeRead marr i + unsafeWrite marr i (f old new) + | (i, new) <- ies] unsafeFreezeSTUArray marr {-# INLINE unsafeAccumArrayUArray #-} @@ -487,10 +484,9 @@ => (e -> e' -> e) -> e -> (i,i) -> [(Int, e')] -> ST s (UArray i e) unsafeAccumArrayUArray f initialValue (l,u) ies = do marr <- newArray (l,u) initialValue - sequence_ [do - old <- unsafeRead marr i - unsafeWrite marr i (f old new) - | (i, new) <- ies] + sequence_ [do old <- unsafeRead marr i + unsafeWrite marr i (f old new) + | (i, new) <- ies] unsafeFreezeSTUArray marr {-# INLINE eqUArray #-} @@ -963,11 +959,15 @@ unsafeRead :: Ix i => a i e -> Int -> m e unsafeWrite :: Ix i => a i e -> Int -> e -> m () - {- INLINE newArray #-} + {-# INLINE newArray #-} -- The INLINE is crucial, because until we know at least which monad -- we are in, the code below allocates like crazy. So inline it, -- in the hope that the context will know the monad. - newArray = newArrayImpl + newArray (l,u) initialValue = do + let n = safeRangeSize (l,u) + marr <- unsafeNewArray_ (l,u) + sequence_ [unsafeWrite marr i initialValue | i <- [0 .. n - 1]] + return marr {-# INLINE unsafeNewArray_ #-} unsafeNewArray_ (l,u) = newArray (l,u) arrEleBottom @@ -990,17 +990,6 @@ -- default initialisation with undefined values if we *do* know the -- initial value and it is constant for all elements. --- Workaround for performance bug #3586, GHC 6.12 only (not 6.13 and --- later, which fixed the underlying problem). -{-# INLINE newArrayImpl #-} -newArrayImpl :: (Ix i, MArray a e m) => (i, i) -> e -> m (a i e) -newArrayImpl (l,u) initialValue = do - let n = safeRangeSize (l,u) - marr <- unsafeNewArray_ (l,u) - sequence_ [unsafeWrite marr i initialValue | i <- [0 .. n - 1]] - return marr - - instance MArray IOArray e IO where #if defined(__HUGS__) getBounds = return . boundsIOArray @@ -1072,10 +1061,9 @@ (l,u) <- getBounds marr n <- getNumElements marr marr' <- newArray_ (l,u) - sequence_ [do - e <- unsafeRead marr i - unsafeWrite marr' i (f e) - | i <- [0 .. n - 1]] + sequence_ [do e <- unsafeRead marr i + unsafeWrite marr' i (f e) + | i <- [0 .. n - 1]] return marr' {-# INLINE mapIndices #-} @@ -1085,10 +1073,9 @@ mapIndices (l',u') f marr = do marr' <- newArray_ (l',u') n' <- getNumElements marr' - sequence_ [do - e <- readArray marr (f i') - unsafeWrite marr' (safeIndex (l',u') n' i') e - | i' <- range (l',u')] + sequence_ [do e <- readArray marr (f i') + unsafeWrite marr' (safeIndex (l',u') n' i') e + | i' <- range (l',u')] return marr' ----------------------------------------------------------------------------- diff -ruN ghc-6.12.1/libraries/array/prologue.txt ghc-6.13.20091231/libraries/array/prologue.txt --- ghc-6.12.1/libraries/array/prologue.txt 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/array/prologue.txt 2009-12-31 10:22:57.000000000 -0800 @@ -0,0 +1 @@ +This package contains arrays. diff -ruN ghc-6.12.1/libraries/array/tests/all.T ghc-6.13.20091231/libraries/array/tests/all.T --- ghc-6.12.1/libraries/array/tests/all.T 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/array/tests/all.T 2009-12-31 10:22:57.000000000 -0800 @@ -0,0 +1,3 @@ + +test('T2120', normal, compile_and_run, ['']) + diff -ruN ghc-6.12.1/libraries/array/tests/Makefile ghc-6.13.20091231/libraries/array/tests/Makefile --- ghc-6.12.1/libraries/array/tests/Makefile 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/array/tests/Makefile 2009-12-31 10:22:57.000000000 -0800 @@ -0,0 +1,7 @@ +# This Makefile runs the tests using GHC's testsuite framework. It +# assumes the package is part of a GHC build tree with the testsuite +# installed in ../../../testsuite. + +TOP=../../../testsuite +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff -ruN ghc-6.12.1/libraries/array/tests/T2120.hs ghc-6.13.20091231/libraries/array/tests/T2120.hs --- ghc-6.12.1/libraries/array/tests/T2120.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/array/tests/T2120.hs 2009-12-31 10:22:57.000000000 -0800 @@ -0,0 +1,17 @@ + +module Main (main) where + +import Control.Exception +import Data.Array.IArray +import Prelude hiding (catch) + +a :: Array Int Int +a = listArray (1,4) [1..4] + +b :: Array (Int,Int) Int +b = listArray ((0,0), (3,3)) (repeat 0) + +main :: IO () +main = do print (a ! 5) `catch` \e -> print (e :: SomeException) + print (b ! (0,5)) `catch` \e -> print (e :: SomeException) + diff -ruN ghc-6.12.1/libraries/array/tests/T2120.stdout ghc-6.13.20091231/libraries/array/tests/T2120.stdout --- ghc-6.12.1/libraries/array/tests/T2120.stdout 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/array/tests/T2120.stdout 2009-12-31 10:22:57.000000000 -0800 @@ -0,0 +1,2 @@ +Ix{Int}.index: Index (5) out of range ((1,4)) +Error in array index diff -ruN ghc-6.12.1/libraries/base/Control/Exception/Base.hs ghc-6.13.20091231/libraries/base/Control/Exception/Base.hs --- ghc-6.12.1/libraries/base/Control/Exception/Base.hs 2009-12-10 10:23:42.000000000 -0800 +++ ghc-6.13.20091231/libraries/base/Control/Exception/Base.hs 2009-12-31 10:23:43.000000000 -0800 @@ -1,5 +1,4 @@ {-# OPTIONS_GHC -XNoImplicitPrelude #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} #include "Typeable.h" @@ -176,8 +175,8 @@ data PatternMatchFail data NoMethodError data Deadlock -data BlockedOnDeadMVar -data BlockedIndefinitely +data BlockedIndefinitelyOnMVar +data BlockedIndefinitelyOnSTM data ErrorCall data RecConError data RecSelError diff -ruN ghc-6.12.1/libraries/base/Control/Monad/Fix.hs ghc-6.13.20091231/libraries/base/Control/Monad/Fix.hs --- ghc-6.12.1/libraries/base/Control/Monad/Fix.hs 2009-12-10 10:23:42.000000000 -0800 +++ ghc-6.13.20091231/libraries/base/Control/Monad/Fix.hs 2009-12-31 10:23:43.000000000 -0800 @@ -29,6 +29,9 @@ #ifdef __HUGS__ import Hugs.Prelude (MonadFix(mfix)) #endif +#if defined(__GLASGOW_HASKELL__) +import GHC.ST +#endif #ifndef __HUGS__ -- | Monads having fixed points with a \'knot-tying\' semantics. @@ -77,3 +80,9 @@ instance MonadFix ((->) r) where mfix f = \ r -> let a = f a r in a + +#if defined(__GLASGOW_HASKELL__) +instance MonadFix (ST s) where + mfix = fixST +#endif + diff -ruN ghc-6.12.1/libraries/base/Control/Monad/Instances.hs ghc-6.13.20091231/libraries/base/Control/Monad/Instances.hs --- ghc-6.12.1/libraries/base/Control/Monad/Instances.hs 2009-12-10 10:23:42.000000000 -0800 +++ ghc-6.13.20091231/libraries/base/Control/Monad/Instances.hs 2009-12-31 10:23:43.000000000 -0800 @@ -1,4 +1,5 @@ {-# OPTIONS_NHC98 --prelude #-} +-- This module deliberately declares orphan instances: {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | diff -ruN ghc-6.12.1/libraries/base/Control/Monad/ST.hs ghc-6.13.20091231/libraries/base/Control/Monad/ST.hs --- ghc-6.12.1/libraries/base/Control/Monad/ST.hs 2009-12-10 10:23:42.000000000 -0800 +++ ghc-6.13.20091231/libraries/base/Control/Monad/ST.hs 2009-12-31 10:23:43.000000000 -0800 @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.ST @@ -32,15 +31,25 @@ unsafeSTToIO -- :: ST s a -> IO a ) where +#if defined(__GLASGOW_HASKELL__) +import Control.Monad.Fix () +#else import Control.Monad.Fix +#endif #include "Typeable.h" -#ifdef __HUGS__ +#if defined(__GLASGOW_HASKELL__) +import GHC.ST ( ST, runST, fixST, unsafeInterleaveST ) +import GHC.Base ( RealWorld ) +import GHC.IO ( stToIO, unsafeIOToST, unsafeSTToIO ) +#elif defined(__HUGS__) import Data.Typeable import Hugs.ST import qualified Hugs.LazyST as LazyST +#endif +#if defined(__HUGS__) INSTANCE_TYPEABLE2(ST,sTTc,"ST") INSTANCE_TYPEABLE0(RealWorld,realWorldTc,"RealWorld") @@ -52,12 +61,8 @@ LazyST.lazyToStrictST . LazyST.unsafeInterleaveST . LazyST.strictToLazyST #endif -#ifdef __GLASGOW_HASKELL__ -import GHC.ST ( ST, runST, fixST, unsafeInterleaveST ) -import GHC.Base ( RealWorld ) -import GHC.IO ( stToIO, unsafeIOToST, unsafeSTToIO ) -#endif - +#if !defined(__GLASGOW_HASKELL__) instance MonadFix (ST s) where mfix = fixST +#endif diff -ruN ghc-6.12.1/libraries/base/Data/Bits.hs ghc-6.13.20091231/libraries/base/Data/Bits.hs --- ghc-6.12.1/libraries/base/Data/Bits.hs 2009-12-10 10:23:42.000000000 -0800 +++ ghc-6.13.20091231/libraries/base/Data/Bits.hs 2009-12-31 10:23:43.000000000 -0800 @@ -151,6 +151,11 @@ value of the argument is ignored -} isSigned :: a -> Bool + {-# INLINE bit #-} + {-# INLINE setBit #-} + {-# INLINE clearBit #-} + {-# INLINE complementBit #-} + {-# INLINE testBit #-} bit i = 1 `shiftL` i x `setBit` i = x .|. bit i x `clearBit` i = x .&. complement (bit i) @@ -164,6 +169,7 @@ 'shift', depending on which is more convenient for the type in question. -} shiftL :: a -> Int -> a + {-# INLINE shiftL #-} x `shiftL` i = x `shift` i {-| Shift the first argument right by the specified number of bits @@ -176,6 +182,7 @@ 'shift', depending on which is more convenient for the type in question. -} shiftR :: a -> Int -> a + {-# INLINE shiftR #-} x `shiftR` i = x `shift` (-i) {-| Rotate the argument left by the specified number of bits @@ -185,6 +192,7 @@ 'rotate', depending on which is more convenient for the type in question. -} rotateL :: a -> Int -> a + {-# INLINE rotateL #-} x `rotateL` i = x `rotate` i {-| Rotate the argument right by the specified number of bits @@ -194,6 +202,7 @@ 'rotate', depending on which is more convenient for the type in question. -} rotateR :: a -> Int -> a + {-# INLINE rotateR #-} x `rotateR` i = x `rotate` (-i) instance Bits Int where @@ -222,9 +231,6 @@ !wsib = WORD_SIZE_IN_BITS# {- work around preprocessor problem (??) -} bitSize _ = WORD_SIZE_IN_BITS - {-# INLINE shiftR #-} - -- same as the default definition, but we want it inlined (#2376) - x `shiftR` i = x `shift` (-i) #else /* !__GLASGOW_HASKELL__ */ #ifdef __HUGS__ @@ -273,6 +279,8 @@ (.|.) = orInteger xor = xorInteger complement = complementInteger + shift x i@(I# i#) | i >= 0 = shiftLInteger x i# + | otherwise = shiftRInteger x (negateInt# i#) #else -- reduce bitwise binary operations to special cases we can handle @@ -289,11 +297,10 @@ -- assuming infinite 2's-complement arithmetic complement a = -1 - a + shift x i | i >= 0 = x * 2^i + | otherwise = x `div` 2^(-i) #endif - shift x i@(I# i#) | i >= 0 = shiftLInteger x i# - | otherwise = shiftRInteger x (negateInt# i#) - rotate x i = shift x i -- since an Integer never wraps around bitSize _ = error "Data.Bits.bitSize(Integer)" diff -ruN ghc-6.12.1/libraries/base/Data/Either.hs ghc-6.13.20091231/libraries/base/Data/Either.hs --- ghc-6.12.1/libraries/base/Data/Either.hs 2009-12-10 10:23:42.000000000 -0800 +++ ghc-6.13.20091231/libraries/base/Data/Either.hs 2009-12-31 10:23:43.000000000 -0800 @@ -79,8 +79,8 @@ partitionEithers :: [Either a b] -> ([a],[b]) partitionEithers = foldr (either left right) ([],[]) where - left a (l, r) = (a:l, r) - right a (l, r) = (l, a:r) + left a ~(l, r) = (a:l, r) + right a ~(l, r) = (l, a:r) {- {-------------------------------------------------------------------- diff -ruN ghc-6.12.1/libraries/base/Data/Fixed.hs ghc-6.13.20091231/libraries/base/Data/Fixed.hs --- ghc-6.12.1/libraries/base/Data/Fixed.hs 2009-12-10 10:23:42.000000000 -0800 +++ ghc-6.13.20091231/libraries/base/Data/Fixed.hs 2009-12-31 10:23:43.000000000 -0800 @@ -35,10 +35,14 @@ ) where import Prelude -- necessary to get dependencies right +#ifndef __NHC__ import Data.Typeable import Data.Data +#endif +#ifndef __NHC__ default () -- avoid any defaulting shenanigans +#endif -- | generalisation of 'div' to any instance of Real div' :: (Real a,Integral b) => a -> a -> b @@ -55,8 +59,14 @@ f = div' n d -- | The type parameter should be an instance of 'HasResolution'. -newtype Fixed a = MkFixed Integer deriving (Eq,Ord,Typeable) +newtype Fixed a = MkFixed Integer +#ifndef __NHC__ + deriving (Eq,Ord,Typeable) +#else + deriving (Eq,Ord) +#endif +#ifndef __NHC__ -- We do this because the automatically derived Data instance requires (Data a) context. -- Our manual instance has the more general (Typeable a) context. tyFixed :: DataType @@ -68,6 +78,7 @@ gunfold k z _ = k (z MkFixed) dataTypeOf _ = tyFixed toConstr _ = conMkFixed +#endif class HasResolution a where resolution :: p a -> Integer @@ -145,43 +156,64 @@ show = showFixed False -data E0 = E0 deriving (Typeable) +data E0 = E0 +#ifndef __NHC__ + deriving (Typeable) +#endif instance HasResolution E0 where resolution _ = 1 -- | resolution of 1, this works the same as Integer type Uni = Fixed E0 -data E1 = E1 deriving (Typeable) +data E1 = E1 +#ifndef __NHC__ + deriving (Typeable) +#endif instance HasResolution E1 where resolution _ = 10 -- | resolution of 10^-1 = .1 type Deci = Fixed E1 -data E2 = E2 deriving (Typeable) +data E2 = E2 +#ifndef __NHC__ + deriving (Typeable) +#endif instance HasResolution E2 where resolution _ = 100 -- | resolution of 10^-2 = .01, useful for many monetary currencies type Centi = Fixed E2 -data E3 = E3 deriving (Typeable) +data E3 = E3 +#ifndef __NHC__ + deriving (Typeable) +#endif instance HasResolution E3 where resolution _ = 1000 -- | resolution of 10^-3 = .001 type Milli = Fixed E3 -data E6 = E6 deriving (Typeable) +data E6 = E6 +#ifndef __NHC__ + deriving (Typeable) +#endif instance HasResolution E6 where resolution _ = 1000000 -- | resolution of 10^-6 = .000001 type Micro = Fixed E6 -data E9 = E9 deriving (Typeable) +data E9 = E9 +#ifndef __NHC__ + deriving (Typeable) +#endif instance HasResolution E9 where resolution _ = 1000000000 -- | resolution of 10^-9 = .000000001 type Nano = Fixed E9 -data E12 = E12 deriving (Typeable) +data E12 = E12 +#ifndef __NHC__ + deriving (Typeable) +#endif instance HasResolution E12 where resolution _ = 1000000000000 -- | resolution of 10^-12 = .000000000001 diff -ruN ghc-6.12.1/libraries/base/Data/Functor.hs ghc-6.13.20091231/libraries/base/Data/Functor.hs --- ghc-6.12.1/libraries/base/Data/Functor.hs 2009-12-10 10:23:42.000000000 -0800 +++ ghc-6.13.20091231/libraries/base/Data/Functor.hs 2009-12-31 10:23:43.000000000 -0800 @@ -13,12 +13,16 @@ module Data.Functor ( - Functor(fmap, (<$)), + Functor(fmap), + (<$), (<$>), ) where #ifdef __GLASGOW_HASKELL__ import GHC.Base (Functor(..)) +#else +(<$) :: Functor f => a -> f b -> f a +(<$) = fmap . const #endif infixl 4 <$> diff -ruN ghc-6.12.1/libraries/base/Data/List.hs ghc-6.13.20091231/libraries/base/Data/List.hs --- ghc-6.12.1/libraries/base/Data/List.hs 2009-12-10 10:23:42.000000000 -0800 +++ ghc-6.13.20091231/libraries/base/Data/List.hs 2009-12-31 10:23:43.000000000 -0800 @@ -793,10 +793,50 @@ sortBy cmp = foldr (insertBy cmp) [] #else +{- +GHC's mergesort replaced by a better implementation, 24/12/2009. +This code originally contributed to the nhc12 compiler by Thomas Nordin +in 2002. Rumoured to have been based on code by Lennart Augustsson, e.g. + http://www.mail-archive.com/haskell@haskell.org/msg01822.html +and possibly to bear similarities to a 1982 paper by Richard O'Keefe: +"A smooth applicative merge sort". + +Benchmarks show it to be often 2x the speed of the previous implementation. +Fixes ticket http://hackage.haskell.org/trac/ghc/ticket/2143 +-} + +sort = sortBy compare +sortBy cmp = mergeAll . sequences + where + sequences (a:b:xs) + | a `cmp` b == GT = descending b [a] xs + | otherwise = ascending b (a:) xs + sequences xs = [xs] + + descending a as (b:bs) + | a `cmp` b == GT = descending b (a:as) bs + descending a as bs = (a:as): sequences bs + + ascending a as (b:bs) + | a `cmp` b /= GT = ascending b (\ys -> as (a:ys)) bs + ascending a as bs = as [a]: sequences bs + + mergeAll [x] = x + mergeAll xs = mergeAll (mergePairs xs) + + mergePairs (a:b:xs) = merge a b: mergePairs xs + mergePairs xs = xs + + merge as@(a:as') bs@(b:bs') + | a `cmp` b == GT = b:merge as bs' + | otherwise = a:merge as' bs + merge [] bs = bs + merge as [] = as + +{- sortBy cmp l = mergesort cmp l sort l = mergesort compare l -{- Quicksort replaced by mergesort, 14/5/2002. From: Ian Lynagh @@ -837,7 +877,6 @@ func 100000 sorted mergesort 2.23 func 100000 revsorted sort 5872.34 func 100000 revsorted mergesort 2.24 --} mergesort :: (a -> a -> Ordering) -> [a] -> [a] mergesort cmp = mergesort' cmp . map wrap @@ -863,8 +902,9 @@ wrap :: a -> [a] wrap x = [x] -{- -OLD: qsort version + + +OLDER: qsort version -- qsort is stable and does not concatenate. qsort :: (a -> a -> Ordering) -> [a] -> [a] -> [a] diff -ruN ghc-6.12.1/libraries/base/Data/Tuple.hs ghc-6.13.20091231/libraries/base/Data/Tuple.hs --- ghc-6.12.1/libraries/base/Data/Tuple.hs 2009-12-10 10:23:42.000000000 -0800 +++ ghc-6.13.20091231/libraries/base/Data/Tuple.hs 2009-12-31 10:23:43.000000000 -0800 @@ -1,6 +1,5 @@ {-# OPTIONS_GHC -XNoImplicitPrelude #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- XXX -fno-warn-unused-imports needed for the GHC.Tuple import below. Sigh. ----------------------------------------------------------------------------- -- | @@ -41,15 +40,19 @@ where #ifdef __GLASGOW_HASKELL__ -import GHC.Bool -import GHC.Classes -import GHC.Ordering --- XXX The standalone deriving clauses fail with --- The data constructors of `(,)' are not all in scope --- so you cannot derive an instance for it --- In the stand-alone deriving instance for `Eq (a, b)' --- if we don't import GHC.Tuple + +import GHC.Base +-- We need to depend on GHC.Base so that +-- a) so that we get GHC.Bool, GHC.Classes, GHC.Ordering + +-- b) so that GHC.Base.inline is available, which is used +-- when expanding instance declarations + import GHC.Tuple +-- We must import GHC.Tuple, to ensure sure that the +-- data constructors of `(,)' are in scope when we do +-- the standalone deriving instance for Eq (a,b) etc + #endif /* __GLASGOW_HASKELL__ */ #ifdef __NHC__ @@ -81,89 +84,6 @@ default () -- Double isn't available yet -#ifdef __GLASGOW_HASKELL__ --- XXX Why aren't these derived? -instance Eq () where - () == () = True - () /= () = False - -instance Ord () where - () <= () = True - () < () = False - () >= () = True - () > () = False - max () () = () - min () () = () - compare () () = EQ - -#ifndef __HADDOCK__ -deriving instance (Eq a, Eq b) => Eq (a, b) -deriving instance (Ord a, Ord b) => Ord (a, b) -deriving instance (Eq a, Eq b, Eq c) => Eq (a, b, c) -deriving instance (Ord a, Ord b, Ord c) => Ord (a, b, c) -deriving instance (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d) -deriving instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d) -deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e) => Eq (a, b, c, d, e) -deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e) => Ord (a, b, c, d, e) -deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) - => Eq (a, b, c, d, e, f) -deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f) - => Ord (a, b, c, d, e, f) -deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g) - => Eq (a, b, c, d, e, f, g) -deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g) - => Ord (a, b, c, d, e, f, g) -deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, - Eq h) - => Eq (a, b, c, d, e, f, g, h) -deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, - Ord h) - => Ord (a, b, c, d, e, f, g, h) -deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, - Eq h, Eq i) - => Eq (a, b, c, d, e, f, g, h, i) -deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, - Ord h, Ord i) - => Ord (a, b, c, d, e, f, g, h, i) -deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, - Eq h, Eq i, Eq j) - => Eq (a, b, c, d, e, f, g, h, i, j) -deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, - Ord h, Ord i, Ord j) - => Ord (a, b, c, d, e, f, g, h, i, j) -deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, - Eq h, Eq i, Eq j, Eq k) - => Eq (a, b, c, d, e, f, g, h, i, j, k) -deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, - Ord h, Ord i, Ord j, Ord k) - => Ord (a, b, c, d, e, f, g, h, i, j, k) -deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, - Eq h, Eq i, Eq j, Eq k, Eq l) - => Eq (a, b, c, d, e, f, g, h, i, j, k, l) -deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, - Ord h, Ord i, Ord j, Ord k, Ord l) - => Ord (a, b, c, d, e, f, g, h, i, j, k, l) -deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, - Eq h, Eq i, Eq j, Eq k, Eq l, Eq m) - => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m) -deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, - Ord h, Ord i, Ord j, Ord k, Ord l, Ord m) - => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m) -deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, - Eq h, Eq i, Eq j, Eq k, Eq l, Eq m, Eq n) - => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n) -deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, - Ord h, Ord i, Ord j, Ord k, Ord l, Ord m, Ord n) - => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m, n) -deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, - Eq h, Eq i, Eq j, Eq k, Eq l, Eq m, Eq n, Eq o) - => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) -deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, - Ord h, Ord i, Ord j, Ord k, Ord l, Ord m, Ord n, Ord o) - => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) -#endif /* !__HADDOCK__ */ -#endif /* __GLASGOW_HASKELL__ */ - -- --------------------------------------------------------------------------- -- Standard functions over tuples diff -ruN ghc-6.12.1/libraries/base/Data/Typeable.hs ghc-6.13.20091231/libraries/base/Data/Typeable.hs --- ghc-6.12.1/libraries/base/Data/Typeable.hs 2009-12-10 10:23:42.000000000 -0800 +++ ghc-6.13.20091231/libraries/base/Data/Typeable.hs 2009-12-31 10:23:43.000000000 -0800 @@ -302,6 +302,22 @@ -- ------------------------------------------------------------- +{- Note [Memoising typeOf] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +IMPORTANT: we don't want to recalculate the type-rep once per +call to the dummy argument. This is what went wrong in Trac #3245 +So we help GHC by manually keeping the 'rep' *outside* the value +lambda, thus + + typeOfDefault :: forall t a. (Typeable1 t, Typeable a) => t a -> TypeRep + typeOfDefault = \_ -> rep + where + rep = typeOf1 (undefined :: t a) `mkAppTy` + typeOf (undefined :: a) + +Notice the crucial use of scoped type variables here! +-} + -- | The class 'Typeable' allows a concrete representation of a type to -- be calculated. class Typeable a where @@ -315,78 +331,148 @@ class Typeable1 t where typeOf1 :: t a -> TypeRep +#ifdef __GLASGOW_HASKELL__ +-- | For defining a 'Typeable' instance from any 'Typeable1' instance. +typeOfDefault :: forall t a. (Typeable1 t, Typeable a) => t a -> TypeRep +typeOfDefault = \_ -> rep + where + rep = typeOf1 (undefined :: t a) `mkAppTy` + typeOf (undefined :: a) + -- Note [Memoising typeOf] +#else -- | For defining a 'Typeable' instance from any 'Typeable1' instance. typeOfDefault :: (Typeable1 t, Typeable a) => t a -> TypeRep typeOfDefault x = typeOf1 x `mkAppTy` typeOf (argType x) where argType :: t a -> a - argType = undefined + argType = undefined +#endif -- | Variant for binary type constructors class Typeable2 t where typeOf2 :: t a b -> TypeRep +#ifdef __GLASGOW_HASKELL__ +-- | For defining a 'Typeable1' instance from any 'Typeable2' instance. +typeOf1Default :: forall t a b. (Typeable2 t, Typeable a) => t a b -> TypeRep +typeOf1Default = \_ -> rep + where + rep = typeOf2 (undefined :: t a b) `mkAppTy` + typeOf (undefined :: a) + -- Note [Memoising typeOf] +#else -- | For defining a 'Typeable1' instance from any 'Typeable2' instance. typeOf1Default :: (Typeable2 t, Typeable a) => t a b -> TypeRep typeOf1Default x = typeOf2 x `mkAppTy` typeOf (argType x) where argType :: t a b -> a - argType = undefined + argType = undefined +#endif -- | Variant for 3-ary type constructors class Typeable3 t where typeOf3 :: t a b c -> TypeRep +#ifdef __GLASGOW_HASKELL__ +-- | For defining a 'Typeable2' instance from any 'Typeable3' instance. +typeOf2Default :: forall t a b c. (Typeable3 t, Typeable a) => t a b c -> TypeRep +typeOf2Default = \_ -> rep + where + rep = typeOf3 (undefined :: t a b c) `mkAppTy` + typeOf (undefined :: a) + -- Note [Memoising typeOf] +#else -- | For defining a 'Typeable2' instance from any 'Typeable3' instance. typeOf2Default :: (Typeable3 t, Typeable a) => t a b c -> TypeRep typeOf2Default x = typeOf3 x `mkAppTy` typeOf (argType x) where argType :: t a b c -> a - argType = undefined + argType = undefined +#endif -- | Variant for 4-ary type constructors class Typeable4 t where typeOf4 :: t a b c d -> TypeRep +#ifdef __GLASGOW_HASKELL__ +-- | For defining a 'Typeable3' instance from any 'Typeable4' instance. +typeOf3Default :: forall t a b c d. (Typeable4 t, Typeable a) => t a b c d -> TypeRep +typeOf3Default = \_ -> rep + where + rep = typeOf4 (undefined :: t a b c d) `mkAppTy` + typeOf (undefined :: a) + -- Note [Memoising typeOf] +#else -- | For defining a 'Typeable3' instance from any 'Typeable4' instance. typeOf3Default :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep typeOf3Default x = typeOf4 x `mkAppTy` typeOf (argType x) where argType :: t a b c d -> a - argType = undefined - + argType = undefined +#endif + -- | Variant for 5-ary type constructors class Typeable5 t where typeOf5 :: t a b c d e -> TypeRep +#ifdef __GLASGOW_HASKELL__ +-- | For defining a 'Typeable4' instance from any 'Typeable5' instance. +typeOf4Default :: forall t a b c d e. (Typeable5 t, Typeable a) => t a b c d e -> TypeRep +typeOf4Default = \_ -> rep + where + rep = typeOf5 (undefined :: t a b c d e) `mkAppTy` + typeOf (undefined :: a) + -- Note [Memoising typeOf] +#else -- | For defining a 'Typeable4' instance from any 'Typeable5' instance. typeOf4Default :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep typeOf4Default x = typeOf5 x `mkAppTy` typeOf (argType x) where argType :: t a b c d e -> a - argType = undefined + argType = undefined +#endif -- | Variant for 6-ary type constructors class Typeable6 t where typeOf6 :: t a b c d e f -> TypeRep +#ifdef __GLASGOW_HASKELL__ +-- | For defining a 'Typeable5' instance from any 'Typeable6' instance. +typeOf5Default :: forall t a b c d e f. (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep +typeOf5Default = \_ -> rep + where + rep = typeOf6 (undefined :: t a b c d e f) `mkAppTy` + typeOf (undefined :: a) + -- Note [Memoising typeOf] +#else -- | For defining a 'Typeable5' instance from any 'Typeable6' instance. typeOf5Default :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep typeOf5Default x = typeOf6 x `mkAppTy` typeOf (argType x) where argType :: t a b c d e f -> a - argType = undefined + argType = undefined +#endif -- | Variant for 7-ary type constructors class Typeable7 t where typeOf7 :: t a b c d e f g -> TypeRep +#ifdef __GLASGOW_HASKELL__ +-- | For defining a 'Typeable6' instance from any 'Typeable7' instance. +typeOf6Default :: forall t a b c d e f g. (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep +typeOf6Default = \_ -> rep + where + rep = typeOf7 (undefined :: t a b c d e f g) `mkAppTy` + typeOf (undefined :: a) + -- Note [Memoising typeOf] +#else -- | For defining a 'Typeable6' instance from any 'Typeable7' instance. typeOf6Default :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep typeOf6Default x = typeOf7 x `mkAppTy` typeOf (argType x) where argType :: t a b c d e f g -> a - argType = undefined + argType = undefined +#endif #ifdef __GLASGOW_HASKELL__ -- Given a @Typeable@/n/ instance for an /n/-ary type constructor, diff -ruN ghc-6.12.1/libraries/base/GHC/Arr.lhs ghc-6.13.20091231/libraries/base/GHC/Arr.lhs --- ghc-6.12.1/libraries/base/GHC/Arr.lhs 2009-12-10 10:23:42.000000000 -0800 +++ ghc-6.13.20091231/libraries/base/GHC/Arr.lhs 2009-12-31 10:23:43.000000000 -0800 @@ -76,8 +76,14 @@ unsafeRangeSize :: (a,a) -> Int -- Must specify one of index, unsafeIndex + + -- 'index' is typically over-ridden in instances, with essentially + -- the same code, but using indexError instead of hopelessIndexError + -- Reason: we have 'Show' at the instances + {-# INLINE index #-} -- See Note [Inlining index] index b i | inRange b i = unsafeIndex b i - | otherwise = error "Error in array index" + | otherwise = hopelessIndexError + unsafeIndex b i = index b i rangeSize b@(_l,h) | inRange b h = unsafeIndex b h + 1 @@ -105,8 +111,54 @@ %* * %********************************************************* +Note [Inlining index] +~~~~~~~~~~~~~~~~~~~~~ +We inline the 'index' operation, + + * Partly because it generates much faster code + (although bigger); see Trac #1216 + + * Partly because it exposes the bounds checks to the simplifier which + might help a big. + +If you make a per-instance index method, you may consider inlining it. + +Note [Double bounds-checking of index values] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When you index an array, a!x, there are two possible bounds checks we might make: + + (A) Check that (inRange (bounds a) x) holds. + + (A) is checked in the method for 'index' + + (B) Check that (index (bounds a) x) lies in the range 0..n, + where n is the size of the underlying array + + (B) is checked in the top-level function (!), in safeIndex. + +Of course it *should* be the case that (A) holds iff (B) holds, but that +is a property of the particular instances of index, bounds, and inRange, +so GHC cannot guarantee it. + + * If you do (A) and not (B), then you might get a seg-fault, + by indexing at some bizarre location. Trac #1610 + + * If you do (B) but not (A), you may get no complaint when you index + an array out of its semantic bounds. Trac #2120 + +At various times we have had (A) and not (B), or (B) and not (A); both +led to complaints. So now we implement *both* checks (Trac #2669). + +For 1-d, 2-d, and 3-d arrays of Int we have specialised instances to avoid this. + +Note [Out-of-bounds error messages] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The default method for 'index' generates hoplelessIndexError, because +Ix doesn't have Show as a superclass. For particular base types we +can do better, so we override the default method for index. + \begin{code} --- abstract these errors from the relevant index functions so that +-- Abstract these errors from the relevant index functions so that -- the guts of the function will be small enough to inline. {-# NOINLINE indexError #-} @@ -117,6 +169,9 @@ showString " out of range " $ showParen True (showsPrec 0 rng) "") +hopelessIndexError :: Int -- Try to use 'indexError' instead! +hopelessIndexError = error "Error in array index" + ---------------------------------------------------------------------- instance Ix Char where {-# INLINE range #-} @@ -125,6 +180,8 @@ {-# INLINE unsafeIndex #-} unsafeIndex (m,_n) i = fromEnum i - fromEnum m + {-# INLINE index #-} -- See Note [Out-of-bounds error messages] + -- and Note [Inlining index] index b i | inRange b i = unsafeIndex b i | otherwise = indexError b i "Char" @@ -140,6 +197,8 @@ {-# INLINE unsafeIndex #-} unsafeIndex (m,_n) i = i - m + {-# INLINE index #-} -- See Note [Out-of-bounds error messages] + -- and Note [Inlining index] index b i | inRange b i = unsafeIndex b i | otherwise = indexError b i "Int" @@ -154,6 +213,8 @@ {-# INLINE unsafeIndex #-} unsafeIndex (m,_n) i = fromInteger (i - m) + {-# INLINE index #-} -- See Note [Out-of-bounds error messages] + -- and Note [Inlining index] index b i | inRange b i = unsafeIndex b i | otherwise = indexError b i "Integer" @@ -167,6 +228,8 @@ {-# INLINE unsafeIndex #-} unsafeIndex (l,_) i = fromEnum i - fromEnum l + {-# INLINE index #-} -- See Note [Out-of-bounds error messages] + -- and Note [Inlining index] index b i | inRange b i = unsafeIndex b i | otherwise = indexError b i "Bool" @@ -180,6 +243,8 @@ {-# INLINE unsafeIndex #-} unsafeIndex (l,_) i = fromEnum i - fromEnum l + {-# INLINE index #-} -- See Note [Out-of-bounds error messages] + -- and Note [Inlining index] index b i | inRange b i = unsafeIndex b i | otherwise = indexError b i "Ordering" @@ -193,7 +258,8 @@ unsafeIndex ((), ()) () = 0 {-# INLINE inRange #-} inRange ((), ()) () = True - {-# INLINE index #-} + + {-# INLINE index #-} -- See Note [Inlining index] index b i = unsafeIndex b i ---------------------------------------------------------------------- @@ -430,16 +496,38 @@ {-# INLINE safeRangeSize #-} safeRangeSize :: Ix i => (i, i) -> Int safeRangeSize (l,u) = let r = rangeSize (l, u) - in if r < 0 then error "Negative range size" + in if r < 0 then negRange else r -{-# INLINE safeIndex #-} +-- Don't inline this error message everywhere!! +negRange :: Int -- Uninformative, but Ix does not provide Show +negRange = error "Negative range size" + +{-# INLINE[1] safeIndex #-} +-- See Note [Double bounds-checking of index values] +-- Inline *after* (!) so the rules can fire safeIndex :: Ix i => (i, i) -> Int -> i -> Int safeIndex (l,u) n i = let i' = index (l,u) i in if (0 <= i') && (i' < n) then i' - else error ("Error in array index; " ++ show i' ++ - " not in range [0.." ++ show n ++ ")") + else badSafeIndex i' n + +-- See Note [Double bounds-checking of index values] +{-# RULES +"safeIndex/I" safeIndex = lessSafeIndex :: (Int,Int) -> Int -> Int -> Int +"safeIndex/(I,I)" safeIndex = lessSafeIndex :: ((Int,Int),(Int,Int)) -> Int -> (Int,Int) -> Int +"safeIndex/(I,I,I)" safeIndex = lessSafeIndex :: ((Int,Int,Int),(Int,Int,Int)) -> Int -> (Int,Int,Int) -> Int + #-} + +lessSafeIndex :: Ix i => (i, i) -> Int -> i -> Int +-- See Note [Double bounds-checking of index values] +-- Do only (A), the semantic check +lessSafeIndex (l,u) _ i = index (l,u) i + +-- Don't inline this long error message everywhere!! +badSafeIndex :: Int -> Int -> Int +badSafeIndex i' n = error ("Error in array index; " ++ show i' ++ + " not in range [0.." ++ show n ++ ")") {-# INLINE unsafeAt #-} unsafeAt :: Ix i => Array i e -> Int -> e diff -ruN ghc-6.12.1/libraries/base/GHC/Base.lhs ghc-6.13.20091231/libraries/base/GHC/Base.lhs --- ghc-6.12.1/libraries/base/GHC/Base.lhs 2009-12-10 10:23:42.000000000 -0800 +++ ghc-6.13.20091231/libraries/base/GHC/Base.lhs 2009-12-31 10:23:43.000000000 -0800 @@ -63,6 +63,8 @@ \begin{code} {-# OPTIONS_GHC -XNoImplicitPrelude #-} +-- -fno-warn-orphans is needed for things like: +-- Orphan rule: "x# -# x#" ALWAYS forall x# :: Int# -# x# x# = 0 {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -224,6 +226,7 @@ -- failure in a @do@ expression. fail :: String -> m a + {-# INLINE (>>) #-} m >> k = m >>= \_ -> k fail s = error s \end{code} @@ -236,24 +239,6 @@ %********************************************************* \begin{code} --- do explicitly: deriving (Eq, Ord) --- to avoid weird names like con2tag_[]# - -instance (Eq a) => Eq [a] where - {-# SPECIALISE instance Eq [Char] #-} - [] == [] = True - (x:xs) == (y:ys) = x == y && xs == ys - _xs == _ys = False - -instance (Ord a) => Ord [a] where - {-# SPECIALISE instance Ord [Char] #-} - compare [] [] = EQ - compare [] (_:_) = LT - compare (_:_) [] = GT - compare (x:xs) (y:ys) = case compare x y of - EQ -> compare xs ys - other -> other - instance Functor [] where fmap = map @@ -283,10 +268,12 @@ -- foldr f z (x:xs) = f x (foldr f z xs) {-# INLINE [0] foldr #-} -- Inline only in the final stage, after the foldr/cons rule has had a chance -foldr k z xs = go xs - where - go [] = z - go (y:ys) = y `k` go ys +-- Also note that we inline it when it has *two* parameters, which are the +-- ones we are keen about specialising! +foldr k z = go + where + go [] = z + go (y:ys) = y `k` go ys -- | A list producer that can be fused with 'foldr'. -- This function is merely @@ -374,7 +361,7 @@ -- Note eta expanded mapFB :: (elt -> lst -> lst) -> (a -> elt) -> a -> lst -> lst {-# INLINE [0] mapFB #-} -mapFB c f x ys = c (f x) ys +mapFB c f = \x ys -> c (f x) ys -- The rules for map work like this. -- @@ -431,30 +418,6 @@ %********************************************************* \begin{code} --- |The 'Bool' type is an enumeration. It is defined with 'False' --- first so that the corresponding 'Prelude.Enum' instance will give --- 'Prelude.fromEnum' 'False' the value zero, and --- 'Prelude.fromEnum' 'True' the value 1. --- The actual definition is in the ghc-prim package. - --- XXX These don't work: --- deriving instance Eq Bool --- deriving instance Ord Bool --- : --- Illegal binding of built-in syntax: con2tag_Bool# - -instance Eq Bool where - True == True = True - False == False = True - _ == _ = False - -instance Ord Bool where - compare False True = LT - compare True False = GT - compare _ _ = EQ - --- Read is in GHC.Read, Show in GHC.Show - -- |'otherwise' is defined as the value 'True'. It helps to make -- guards more readable. eg. -- @@ -466,36 +429,6 @@ %********************************************************* %* * -\subsection{Type @Ordering@} -%* * -%********************************************************* - -\begin{code} --- | Represents an ordering relationship between two values: less --- than, equal to, or greater than. An 'Ordering' is returned by --- 'compare'. --- XXX These don't work: --- deriving instance Eq Ordering --- deriving instance Ord Ordering --- Illegal binding of built-in syntax: con2tag_Ordering# -instance Eq Ordering where - EQ == EQ = True - LT == LT = True - GT == GT = True - _ == _ = False - -- Read in GHC.Read, Show in GHC.Show - -instance Ord Ordering where - LT <= _ = True - _ <= LT = False - EQ <= _ = True - _ <= EQ = False - GT <= GT = True -\end{code} - - -%********************************************************* -%* * \subsection{Type @Char@ and @String@} %* * %********************************************************* @@ -519,20 +452,6 @@ 'Prelude.Enum' class respectively (or equivalently 'ord' and 'chr'). -} --- We don't use deriving for Eq and Ord, because for Ord the derived --- instance defines only compare, which takes two primops. Then --- '>' uses compare, and therefore takes two primops instead of one. - -instance Eq Char where - (C# c1) == (C# c2) = c1 `eqChar#` c2 - (C# c1) /= (C# c2) = c1 `neChar#` c2 - -instance Ord Char where - (C# c1) > (C# c2) = c1 `gtChar#` c2 - (C# c1) >= (C# c2) = c1 `geChar#` c2 - (C# c1) <= (C# c2) = c1 `leChar#` c2 - (C# c1) < (C# c2) = c1 `ltChar#` c2 - {-# RULES "x# `eqChar#` x#" forall x#. x# `eqChar#` x# = True "x# `neChar#` x#" forall x#. x# `neChar#` x# = False @@ -639,16 +558,6 @@ -- sees it as lazy. Then the worker/wrapper phase inlines it. -- Result: happiness - --- | The call '(inline f)' reduces to 'f', but 'inline' has a BuiltInRule --- that tries to inline 'f' (if it has an unfolding) unconditionally --- The 'NOINLINE' pragma arranges that inline only gets inlined (and --- hence eliminated) late in compilation, after the rule has had --- a god chance to fire. -inline :: a -> a -{-# NOINLINE[0] inline #-} -inline x = x - -- Assertion function. This simply ignores its boolean argument. -- The compiler may rewrite it to @('assertError' line)@. @@ -684,8 +593,10 @@ -- | Function composition. {-# INLINE (.) #-} -(.) :: (b -> c) -> (a -> b) -> a -> c -(.) f g x = f (g x) +-- Make sure it has TWO args only on the left, so that it inlines +-- when applied to two functions, even if there is no final argument +(.) :: (b -> c) -> (a -> b) -> a -> c +(.) f g = \x -> f (g x) -- | @'flip' f@ takes its (first) two arguments in the reverse order of @f@. flip :: (a -> b -> c) -> b -> a -> c @@ -982,14 +893,21 @@ !ch = indexCharOffAddr# addr nh unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a -{-# NOINLINE [0] unpackFoldrCString# #-} --- Unlike unpackCString#, there *is* some point in inlining unpackFoldrCString#, --- because we get better code for the function call. --- However, don't inline till right at the end; --- usually the unpack-list rule turns it into unpackCStringList + +-- Usually the unpack-list rule turns unpackFoldrCString# into unpackCString# + -- It also has a BuiltInRule in PrelRules.lhs: -- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) -- = unpackFoldrCString# "foobaz" c n + +{-# NOINLINE unpackFoldrCString# #-} +-- At one stage I had NOINLINE [0] on the grounds that, unlike +-- unpackCString#, there *is* some point in inlining +-- unpackFoldrCString#, because we get better code for the +-- higher-order function call. BUT there may be a lot of +-- literal strings, and making a separate 'unpack' loop for +-- each is highly gratuitous. See nofib/real/anna/PrettyPrint. + unpackFoldrCString# addr f z = unpack 0# where diff -ruN ghc-6.12.1/libraries/base/GHC/Classes.hs ghc-6.13.20091231/libraries/base/GHC/Classes.hs --- ghc-6.12.1/libraries/base/GHC/Classes.hs 2009-12-10 10:23:42.000000000 -0800 +++ ghc-6.13.20091231/libraries/base/GHC/Classes.hs 2009-12-31 10:23:43.000000000 -0800 @@ -1,5 +1,7 @@ {-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +-- XXX -fno-warn-unused-imports needed for the GHC.Tuple import below. Sigh. {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | @@ -18,7 +20,14 @@ module GHC.Classes where import GHC.Bool +import GHC.Integer +-- GHC.Magic is used in some derived instances +import GHC.Magic () import GHC.Ordering +import GHC.Prim +import GHC.Tuple +import GHC.Types +import GHC.Unit infix 4 ==, /=, <, <=, >=, > infixr 3 && @@ -36,9 +45,68 @@ class Eq a where (==), (/=) :: a -> a -> Bool + {-# INLINE (/=) #-} + {-# INLINE (==) #-} x /= y = not (x == y) x == y = not (x /= y) +deriving instance Eq () +deriving instance (Eq a, Eq b) => Eq (a, b) +deriving instance (Eq a, Eq b, Eq c) => Eq (a, b, c) +deriving instance (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e) => Eq (a, b, c, d, e) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) + => Eq (a, b, c, d, e, f) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g) + => Eq (a, b, c, d, e, f, g) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, + Eq h) + => Eq (a, b, c, d, e, f, g, h) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, + Eq h, Eq i) + => Eq (a, b, c, d, e, f, g, h, i) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, + Eq h, Eq i, Eq j) + => Eq (a, b, c, d, e, f, g, h, i, j) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, + Eq h, Eq i, Eq j, Eq k) + => Eq (a, b, c, d, e, f, g, h, i, j, k) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, + Eq h, Eq i, Eq j, Eq k, Eq l) + => Eq (a, b, c, d, e, f, g, h, i, j, k, l) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, + Eq h, Eq i, Eq j, Eq k, Eq l, Eq m) + => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, + Eq h, Eq i, Eq j, Eq k, Eq l, Eq m, Eq n) + => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n) +deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, + Eq h, Eq i, Eq j, Eq k, Eq l, Eq m, Eq n, Eq o) + => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) + +instance (Eq a) => Eq [a] where + {-# SPECIALISE instance Eq [Char] #-} + [] == [] = True + (x:xs) == (y:ys) = x == y && xs == ys + _xs == _ys = False + +deriving instance Eq Bool +deriving instance Eq Ordering + +instance Eq Char where + (C# c1) == (C# c2) = c1 `eqChar#` c2 + (C# c1) /= (C# c2) = c1 `neChar#` c2 + +instance Eq Integer where + (==) = eqInteger + (/=) = neqInteger + +instance Eq Float where + (F# x) == (F# y) = x `eqFloat#` y + +instance Eq Double where + (D# x) == (D# y) = x ==## y + -- | The 'Ord' class is used for totally ordered datatypes. -- -- Instances of 'Ord' can be derived for any user-defined @@ -72,6 +140,90 @@ max x y = if x <= y then y else x min x y = if x <= y then x else y +deriving instance Ord () +deriving instance (Ord a, Ord b) => Ord (a, b) +deriving instance (Ord a, Ord b, Ord c) => Ord (a, b, c) +deriving instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e) => Ord (a, b, c, d, e) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f) + => Ord (a, b, c, d, e, f) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g) + => Ord (a, b, c, d, e, f, g) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, + Ord h) + => Ord (a, b, c, d, e, f, g, h) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, + Ord h, Ord i) + => Ord (a, b, c, d, e, f, g, h, i) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, + Ord h, Ord i, Ord j) + => Ord (a, b, c, d, e, f, g, h, i, j) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, + Ord h, Ord i, Ord j, Ord k) + => Ord (a, b, c, d, e, f, g, h, i, j, k) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, + Ord h, Ord i, Ord j, Ord k, Ord l) + => Ord (a, b, c, d, e, f, g, h, i, j, k, l) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, + Ord h, Ord i, Ord j, Ord k, Ord l, Ord m) + => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, + Ord h, Ord i, Ord j, Ord k, Ord l, Ord m, Ord n) + => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m, n) +deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, + Ord h, Ord i, Ord j, Ord k, Ord l, Ord m, Ord n, Ord o) + => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) + +instance (Ord a) => Ord [a] where + {-# SPECIALISE instance Ord [Char] #-} + compare [] [] = EQ + compare [] (_:_) = LT + compare (_:_) [] = GT + compare (x:xs) (y:ys) = case compare x y of + EQ -> compare xs ys + other -> other + +deriving instance Ord Bool +deriving instance Ord Ordering + +-- We don't use deriving for Ord Char, because for Ord the derived +-- instance defines only compare, which takes two primops. Then +-- '>' uses compare, and therefore takes two primops instead of one. +instance Ord Char where + (C# c1) > (C# c2) = c1 `gtChar#` c2 + (C# c1) >= (C# c2) = c1 `geChar#` c2 + (C# c1) <= (C# c2) = c1 `leChar#` c2 + (C# c1) < (C# c2) = c1 `ltChar#` c2 + +instance Ord Integer where + (<=) = leInteger + (>) = gtInteger + (<) = ltInteger + (>=) = geInteger + compare = compareInteger + +instance Ord Float where + (F# x) `compare` (F# y) + = if x `ltFloat#` y then LT + else if x `eqFloat#` y then EQ + else GT + + (F# x) < (F# y) = x `ltFloat#` y + (F# x) <= (F# y) = x `leFloat#` y + (F# x) >= (F# y) = x `geFloat#` y + (F# x) > (F# y) = x `gtFloat#` y + +instance Ord Double where + (D# x) `compare` (D# y) + = if x <## y then LT + else if x ==## y then EQ + else GT + + (D# x) < (D# y) = x <## y + (D# x) <= (D# y) = x <=## y + (D# x) >= (D# y) = x >=## y + (D# x) > (D# y) = x >## y + -- OK, so they're technically not part of a class...: -- Boolean functions diff -ruN ghc-6.12.1/libraries/base/GHC/Exts.hs ghc-6.13.20091231/libraries/base/GHC/Exts.hs --- ghc-6.12.1/libraries/base/GHC/Exts.hs 2009-12-10 10:23:43.000000000 -0800 +++ ghc-6.13.20091231/libraries/base/GHC/Exts.hs 2009-12-31 10:23:43.000000000 -0800 @@ -52,6 +52,7 @@ import GHC.Prim import GHC.Base +import GHC.Magic import GHC.Word import GHC.Int -- import GHC.Float diff -ruN ghc-6.12.1/libraries/base/GHC/Float.lhs ghc-6.13.20091231/libraries/base/GHC/Float.lhs --- ghc-6.12.1/libraries/base/GHC/Float.lhs 2009-12-10 10:23:42.000000000 -0800 +++ ghc-6.13.20091231/libraries/base/GHC/Float.lhs 2009-12-31 10:23:43.000000000 -0800 @@ -1,5 +1,7 @@ \begin{code} {-# OPTIONS_GHC -XNoImplicitPrelude #-} +-- We believe we could deorphan this module, by moving lots of things +-- around, but we haven't got there yet: {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -57,6 +59,11 @@ sinh, cosh, tanh :: a -> a asinh, acosh, atanh :: a -> a + {-# INLINE (**) #-} + {-# INLINE logBase #-} + {-# INLINE sqrt #-} + {-# INLINE tan #-} + {-# INLINE tanh #-} x ** y = exp (log x * y) logBase x y = log y / log x sqrt x = x ** 0.5 @@ -149,19 +156,6 @@ %********************************************************* \begin{code} -instance Eq Float where - (F# x) == (F# y) = x `eqFloat#` y - -instance Ord Float where - (F# x) `compare` (F# y) | x `ltFloat#` y = LT - | x `eqFloat#` y = EQ - | otherwise = GT - - (F# x) < (F# y) = x `ltFloat#` y - (F# x) <= (F# y) = x `leFloat#` y - (F# x) >= (F# y) = x `geFloat#` y - (F# x) > (F# y) = x `gtFloat#` y - instance Num Float where (+) x y = plusFloat x y (-) x y = minusFloat x y @@ -293,19 +287,6 @@ %********************************************************* \begin{code} -instance Eq Double where - (D# x) == (D# y) = x ==## y - -instance Ord Double where - (D# x) `compare` (D# y) | x <## y = LT - | x ==## y = EQ - | otherwise = GT - - (D# x) < (D# y) = x <## y - (D# x) <= (D# y) = x <=## y - (D# x) >= (D# y) = x >=## y - (D# x) > (D# y) = x >## y - instance Num Double where (+) x y = plusDouble x y (-) x y = minusDouble x y diff -ruN ghc-6.12.1/libraries/base/GHC/ForeignPtr.hs ghc-6.13.20091231/libraries/base/GHC/ForeignPtr.hs --- ghc-6.12.1/libraries/base/GHC/ForeignPtr.hs 2009-12-10 10:23:42.000000000 -0800 +++ ghc-6.13.20091231/libraries/base/GHC/ForeignPtr.hs 2009-12-31 10:23:43.000000000 -0800 @@ -42,11 +42,11 @@ import GHC.Show import GHC.List ( null ) import GHC.Base --- import GHC.IO import GHC.IORef import GHC.STRef ( STRef(..) ) import GHC.Ptr ( Ptr(..), FunPtr(..) ) import GHC.Err +import GHC.Num ( fromInteger ) #include "Typeable.h" @@ -150,7 +150,9 @@ -- mallocForeignPtr = doMalloc undefined where doMalloc :: Storable b => b -> IO (ForeignPtr b) - doMalloc a = do + doMalloc a + | I# size < 0 = error "mallocForeignPtr: size must be >= 0" + | otherwise = do r <- newIORef (NoFinalizers, []) IO $ \s -> case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) -> @@ -163,6 +165,8 @@ -- | This function is similar to 'mallocForeignPtr', except that the -- size of the memory required is given explicitly as a number of bytes. mallocForeignPtrBytes :: Int -> IO (ForeignPtr a) +mallocForeignPtrBytes size | size < 0 = + error "mallocForeignPtrBytes: size must be >= 0" mallocForeignPtrBytes (I# size) = do r <- newIORef (NoFinalizers, []) IO $ \s -> @@ -187,7 +191,9 @@ mallocPlainForeignPtr :: Storable a => IO (ForeignPtr a) mallocPlainForeignPtr = doMalloc undefined where doMalloc :: Storable b => b -> IO (ForeignPtr b) - doMalloc a = IO $ \s -> + doMalloc a + | I# size < 0 = error "mallocForeignPtr: size must be >= 0" + | otherwise = IO $ \s -> case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) -> (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#)) (PlainPtr mbarr#) #) @@ -200,6 +206,8 @@ -- finalizer is used. Attempts to add a finalizer will cause an -- exception to be thrown. mallocPlainForeignPtrBytes :: Int -> IO (ForeignPtr a) +mallocPlainForeignPtrBytes size | size < 0 = + error "mallocPlainForeignPtrBytes: size must be >= 0" mallocPlainForeignPtrBytes (I# size) = IO $ \s -> case newPinnedByteArray# size s of { (# s', mbarr# #) -> (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#)) @@ -214,7 +222,7 @@ PlainForeignPtr r -> f r >> return () MallocPtr _ r -> f r >> return () _ -> error "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer" - where + where f r = noMixing CFinalizers r $ IO $ \s -> @@ -232,7 +240,7 @@ PlainForeignPtr r -> f r >> return () MallocPtr _ r -> f r >> return () _ -> error "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer" - where + where f r = noMixing CFinalizers r $ IO $ \s -> diff -ruN ghc-6.12.1/libraries/base/GHC/Int.hs ghc-6.13.20091231/libraries/base/GHC/Int.hs --- ghc-6.12.1/libraries/base/GHC/Int.hs 2009-12-10 10:23:42.000000000 -0800 +++ ghc-6.13.20091231/libraries/base/GHC/Int.hs 2009-12-31 10:23:43.000000000 -0800 @@ -147,10 +147,6 @@ bitSize _ = 8 isSigned _ = True - {-# INLINE shiftR #-} - -- same as the default definition, but we want it inlined (#2376) - x `shiftR` i = x `shift` (-i) - {-# RULES "fromIntegral/Int8->Int8" fromIntegral = id :: Int8 -> Int8 "fromIntegral/a->Int8" fromIntegral = \x -> case fromIntegral x of I# x# -> I8# (narrow8Int# x#) @@ -263,9 +259,6 @@ bitSize _ = 16 isSigned _ = True - {-# INLINE shiftR #-} - -- same as the default definition, but we want it inlined (#2376) - x `shiftR` i = x `shift` (-i) {-# RULES "fromIntegral/Word8->Int16" fromIntegral = \(W8# x#) -> I16# (word2Int# x#) @@ -399,9 +392,6 @@ bitSize _ = 32 isSigned _ = True - {-# INLINE shiftR #-} - -- same as the default definition, but we want it inlined (#2376) - x `shiftR` i = x `shift` (-i) {-# RULES "fromIntegral/Int->Int32" fromIntegral = \(I# x#) -> I32# (intToInt32# x#) @@ -512,10 +502,6 @@ bitSize _ = 32 isSigned _ = True - {-# INLINE shiftR #-} - -- same as the default definition, but we want it inlined (#2376) - x `shiftR` i = x `shift` (-i) - {-# RULES "fromIntegral/Word8->Int32" fromIntegral = \(W8# x#) -> I32# (word2Int# x#) "fromIntegral/Word16->Int32" fromIntegral = \(W16# x#) -> I32# (word2Int# x#) @@ -661,11 +647,6 @@ bitSize _ = 64 isSigned _ = True - {-# INLINE shiftR #-} - -- same as the default definition, but we want it inlined (#2376) - x `shiftR` i = x `shift` (-i) - - -- give the 64-bit shift operations the same treatment as the 32-bit -- ones (see GHC.Base), namely we wrap them in tests to catch the -- cases when we're shifting more than 64 bits to avoid unspecified @@ -779,10 +760,6 @@ bitSize _ = 64 isSigned _ = True - {-# INLINE shiftR #-} - -- same as the default definition, but we want it inlined (#2376) - x `shiftR` i = x `shift` (-i) - {-# RULES "fromIntegral/a->Int64" fromIntegral = \x -> case fromIntegral x of I# x# -> I64# x# "fromIntegral/Int64->a" fromIntegral = \(I64# x#) -> fromIntegral (I# x#) diff -ruN ghc-6.12.1/libraries/base/GHC/IO.hs ghc-6.13.20091231/libraries/base/GHC/IO.hs --- ghc-6.12.1/libraries/base/GHC/IO.hs 2009-12-10 10:23:42.000000000 -0800 +++ ghc-6.13.20091231/libraries/base/GHC/IO.hs 2009-12-31 10:23:43.000000000 -0800 @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields -XBangPatterns #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- diff -ruN ghc-6.12.1/libraries/base/GHC/List.lhs ghc-6.13.20091231/libraries/base/GHC/List.lhs --- ghc-6.12.1/libraries/base/GHC/List.lhs 2009-12-10 10:23:42.000000000 -0800 +++ ghc-6.13.20091231/libraries/base/GHC/List.lhs 2009-12-31 10:23:43.000000000 -0800 @@ -647,7 +647,7 @@ {-# INLINE [0] zipFB #-} zipFB :: ((a, b) -> c -> d) -> a -> b -> c -> d -zipFB c x y r = (x,y) `c` r +zipFB c = \x y r -> (x,y) `c` r {-# RULES "zip" [~1] forall xs ys. zip xs ys = build (\c n -> foldr2 (zipFB c) n xs ys) @@ -680,9 +680,11 @@ zipWith f (a:as) (b:bs) = f a b : zipWith f as bs zipWith _ _ _ = [] +-- zipWithFB must have arity 2 since it gets two arguments in the "zipWith" +-- rule; it might not get inlined otherwise {-# INLINE [0] zipWithFB #-} zipWithFB :: (a -> b -> c) -> (d -> e -> a) -> d -> e -> b -> c -zipWithFB c f x y r = (x `f` y) `c` r +zipWithFB c f = \x y r -> (x `f` y) `c` r {-# RULES "zipWith" [~1] forall f xs ys. zipWith f xs ys = build (\c n -> foldr2 (zipWithFB c f) n xs ys) diff -ruN ghc-6.12.1/libraries/base/GHC/Num.lhs ghc-6.13.20091231/libraries/base/GHC/Num.lhs --- ghc-6.12.1/libraries/base/GHC/Num.lhs 2009-12-10 10:23:42.000000000 -0800 +++ ghc-6.13.20091231/libraries/base/GHC/Num.lhs 2009-12-31 10:23:43.000000000 -0800 @@ -1,5 +1,7 @@ \begin{code} {-# OPTIONS_GHC -XNoImplicitPrelude #-} +-- We believe we could deorphan this module, by moving lots of things +-- around, but we haven't got there yet: {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -7,7 +9,7 @@ -- Module : GHC.Num -- Copyright : (c) The University of Glasgow 1994-2002 -- License : see libraries/base/LICENSE --- +-- -- Maintainer : cvs-ghc@haskell.org -- Stability : internal -- Portability : non-portable (GHC Extensions) @@ -41,7 +43,7 @@ infixl 7 * infixl 6 +, - -default () -- Double isn't available yet, +default () -- Double isn't available yet, -- and we shouldn't be using defaults anyway \end{code} @@ -62,7 +64,7 @@ -- | Absolute value. abs :: a -> a -- | Sign of a number. - -- The functions 'abs' and 'signum' should satisfy the law: + -- The functions 'abs' and 'signum' should satisfy the law: -- -- > abs x * signum x == x -- @@ -75,6 +77,8 @@ -- so such literals have type @('Num' a) => a@. fromInteger :: Integer -> a + {-# INLINE (-) #-} + {-# INLINE negate #-} x - y = x + negate y negate x = 0 - x @@ -120,27 +124,6 @@ %********************************************************* %* * -\subsection{The @Integer@ instances for @Eq@, @Ord@} -%* * -%********************************************************* - -\begin{code} -instance Eq Integer where - (==) = eqInteger - (/=) = neqInteger - ------------------------------------------------------------------------- -instance Ord Integer where - (<=) = leInteger - (>) = gtInteger - (<) = ltInteger - (>=) = geInteger - compare = compareInteger -\end{code} - - -%********************************************************* -%* * \subsection{The @Integer@ instances for @Show@} %* * %********************************************************* diff -ruN ghc-6.12.1/libraries/base/GHC/Real.lhs ghc-6.13.20091231/libraries/base/GHC/Real.lhs --- ghc-6.12.1/libraries/base/GHC/Real.lhs 2009-12-10 10:23:42.000000000 -0800 +++ ghc-6.13.20091231/libraries/base/GHC/Real.lhs 2009-12-31 10:23:43.000000000 -0800 @@ -133,10 +133,15 @@ -- | conversion to 'Integer' toInteger :: a -> Integer + {-# INLINE quot #-} + {-# INLINE rem #-} + {-# INLINE div #-} + {-# INLINE mod #-} n `quot` d = q where (q,_) = quotRem n d n `rem` d = r where (_,r) = quotRem n d n `div` d = q where (q,_) = divMod n d n `mod` d = r where (_,r) = divMod n d + divMod n d = if signum r == negate (signum d) then (q-1, r+d) else qr where qr@(q,r) = quotRem n d @@ -154,6 +159,8 @@ -- @('Fractional' a) => a@. fromRational :: Rational -> a + {-# INLINE recip #-} + {-# INLINE (/) #-} recip x = 1 / x x / y = x * recip y @@ -182,6 +189,7 @@ -- | @'floor' x@ returns the greatest integer not greater than @x@ floor :: (Integral b) => a -> b + {-# INLINE truncate #-} truncate x = m where (m,_) = properFraction x round x = let (n,r) = properFraction x @@ -456,9 +464,6 @@ "lcm/Integer->Integer->Integer" lcm = lcmInteger #-} --- XXX to use another Integer implementation, you might need to disable --- the gcd/Integer and lcm/Integer RULES above --- gcdInteger' :: Integer -> Integer -> Integer gcdInteger' 0 0 = error "GHC.Real.gcdInteger': gcd 0 0 is undefined" gcdInteger' a b = gcdInteger a b diff -ruN ghc-6.12.1/libraries/base/GHC/Word.hs ghc-6.13.20091231/libraries/base/GHC/Word.hs --- ghc-6.12.1/libraries/base/GHC/Word.hs 2009-12-10 10:23:42.000000000 -0800 +++ ghc-6.13.20091231/libraries/base/GHC/Word.hs 2009-12-31 10:23:43.000000000 -0800 @@ -181,10 +181,6 @@ bitSize _ = WORD_SIZE_IN_BITS isSigned _ = False - {-# INLINE shiftR #-} - -- same as the default definition, but we want it inlined (#2376) - x `shiftR` i = x `shift` (-i) - {-# RULES "fromIntegral/Int->Word" fromIntegral = \(I# x#) -> W# (int2Word# x#) "fromIntegral/Word->Int" fromIntegral = \(W# x#) -> I# (word2Int# x#) @@ -285,10 +281,6 @@ bitSize _ = 8 isSigned _ = False - {-# INLINE shiftR #-} - -- same as the default definition, but we want it inlined (#2376) - x `shiftR` i = x `shift` (-i) - {-# RULES "fromIntegral/Word8->Word8" fromIntegral = id :: Word8 -> Word8 "fromIntegral/Word8->Integer" fromIntegral = toInteger :: Word8 -> Integer @@ -390,10 +382,6 @@ bitSize _ = 16 isSigned _ = False - {-# INLINE shiftR #-} - -- same as the default definition, but we want it inlined (#2376) - x `shiftR` i = x `shift` (-i) - {-# RULES "fromIntegral/Word8->Word16" fromIntegral = \(W8# x#) -> W16# x# "fromIntegral/Word16->Word16" fromIntegral = id :: Word16 -> Word16 @@ -493,10 +481,6 @@ bitSize _ = 32 isSigned _ = False - {-# INLINE shiftR #-} - -- same as the default definition, but we want it inlined (#2376) - x `shiftR` i = x `shift` (-i) - {-# RULES "fromIntegral/Int->Word32" fromIntegral = \(I# x#) -> W32# (int32ToWord32# (intToInt32# x#)) "fromIntegral/Word->Word32" fromIntegral = \(W# x#) -> W32# (wordToWord32# x#) @@ -604,10 +588,6 @@ bitSize _ = 32 isSigned _ = False - {-# INLINE shiftR #-} - -- same as the default definition, but we want it inlined (#2376) - x `shiftR` i = x `shift` (-i) - {-# RULES "fromIntegral/Word8->Word32" fromIntegral = \(W8# x#) -> W32# x# "fromIntegral/Word16->Word32" fromIntegral = \(W16# x#) -> W32# x# @@ -734,10 +714,6 @@ bitSize _ = 64 isSigned _ = False - {-# INLINE shiftR #-} - -- same as the default definition, but we want it inlined (#2376) - x `shiftR` i = x `shift` (-i) - -- give the 64-bit shift operations the same treatment as the 32-bit -- ones (see GHC.Base), namely we wrap them in tests to catch the -- cases when we're shifting more than 64 bits to avoid unspecified @@ -842,10 +818,6 @@ bitSize _ = 64 isSigned _ = False - {-# INLINE shiftR #-} - -- same as the default definition, but we want it inlined (#2376) - x `shiftR` i = x `shift` (-i) - {-# RULES "fromIntegral/a->Word64" fromIntegral = \x -> case fromIntegral x of W# x# -> W64# x# "fromIntegral/Word64->a" fromIntegral = \(W64# x#) -> fromIntegral (W# x#) diff -ruN ghc-6.12.1/libraries/base/Makefile.nhc98 ghc-6.13.20091231/libraries/base/Makefile.nhc98 --- ghc-6.12.1/libraries/base/Makefile.nhc98 2009-12-10 10:23:42.000000000 -0800 +++ ghc-6.13.20091231/libraries/base/Makefile.nhc98 2009-12-31 10:23:43.000000000 -0800 @@ -1,7 +1,7 @@ THISPKG = base SEARCH = -I$(TOPDIR)/targets/$(MACHINE) -Iinclude \ -I../../prelude/PreludeIO -I../../prelude/`$(LOCAL)harch` -EXTRA_H_FLAGS = -H4M -K3M +EXTRA_H_FLAGS = -H4M -K6M EXTRA_C_FLAGS = -D__NHC__ EXTRA_HBC_FLAGS = -H16M -A1M @@ -40,9 +40,10 @@ Text/Read.hs Text/Show.hs Text/Show/Functions.hs \ Text/ParserCombinators/ReadP.hs Data/Version.hs \ Unsafe/Coerce.hs \ - WCsubst.c dirUtils.c \ + WCsubst.c \ GHC/IO/Device.hs \ System/Posix/Types.hs System/Posix/Internals.hs \ + System/Console/GetOpt.hs \ # Data/String.hs # Text/ParserCombinators/ReadPrec.hs @@ -55,13 +56,13 @@ # System/Random.hs System/Locale.hs System/Time.hsc \ # System/Cmd.hs \ # System/Timeout.hs \ -# System/Console/GetOpt.hs \ # Text/Regex/Posix.hsc Text/Regex.hs \ # [Data/Dynamic.hs] Data/Generics.hs Data/STRef.hs Data/Unique.hs # System/Mem.hs System/Mem/StableName.hs System/Mem/Weak.hs # System/Posix/Types.hs System/Posix/Signals.hsc # System/FilePath.hs +# dirUtils.c # Here are the main rules. diff -ruN ghc-6.12.1/libraries/base/System/IO.hs ghc-6.13.20091231/libraries/base/System/IO.hs --- ghc-6.12.1/libraries/base/System/IO.hs 2009-12-10 10:23:43.000000000 -0800 +++ ghc-6.13.20091231/libraries/base/System/IO.hs 2009-12-31 10:23:43.000000000 -0800 @@ -468,6 +468,8 @@ -- Assume a unix platform, where text and binary I/O are identical. openBinaryFile = openFile hSetBinaryMode _ _ = return () + +type CMode = Int #endif -- | The function creates a temporary file in ReadWrite mode. diff -ruN ghc-6.12.1/libraries/base/System/Posix/Internals.hs ghc-6.13.20091231/libraries/base/System/Posix/Internals.hs --- ghc-6.12.1/libraries/base/System/Posix/Internals.hs 2009-12-10 10:23:43.000000000 -0800 +++ ghc-6.13.20091231/libraries/base/System/Posix/Internals.hs 2009-12-31 10:23:43.000000000 -0800 @@ -390,16 +390,16 @@ foreign import ccall unsafe "HsBase.h __hscore_lstat" lstat :: CFilePath -> Ptr CStat -> IO CInt -foreign import ccall unsafe "__hscore_open" +foreign import ccall unsafe "HsBase.h __hscore_open" c_open :: CFilePath -> CInt -> CMode -> IO CInt foreign import ccall unsafe "HsBase.h read" c_read :: CInt -> Ptr Word8 -> CSize -> IO CSsize -foreign import ccall safe "read" +foreign import ccall safe "HsBase.h read" c_safe_read :: CInt -> Ptr Word8 -> CSize -> IO CSsize -foreign import ccall unsafe "__hscore_stat" +foreign import ccall unsafe "HsBase.h __hscore_stat" c_stat :: CFilePath -> Ptr CStat -> IO CInt foreign import ccall unsafe "HsBase.h umask" @@ -408,7 +408,7 @@ foreign import ccall unsafe "HsBase.h write" c_write :: CInt -> Ptr Word8 -> CSize -> IO CSsize -foreign import ccall safe "write" +foreign import ccall safe "HsBase.h write" c_safe_write :: CInt -> Ptr Word8 -> CSize -> IO CSsize foreign import ccall unsafe "HsBase.h __hscore_ftruncate" diff -ruN ghc-6.12.1/libraries/base/Text/ParserCombinators/ReadP.hs ghc-6.13.20091231/libraries/base/Text/ParserCombinators/ReadP.hs --- ghc-6.12.1/libraries/base/Text/ParserCombinators/ReadP.hs 2009-12-10 10:23:43.000000000 -0800 +++ ghc-6.13.20091231/libraries/base/Text/ParserCombinators/ReadP.hs 2009-12-31 10:23:43.000000000 -0800 @@ -307,7 +307,8 @@ -- Hence NOT the same as (many1 (satisfy p)) munch1 p = do c <- get - if p c then do s <- munch p; return (c:s) else pfail + if p c then do s <- munch p; return (c:s) + else pfail choice :: [ReadP a] -> ReadP a -- ^ Combines all parsers in the specified list. diff -ruN ghc-6.12.1/libraries/base/Text/Show/Functions.hs ghc-6.13.20091231/libraries/base/Text/Show/Functions.hs --- ghc-6.12.1/libraries/base/Text/Show/Functions.hs 2009-12-10 10:23:43.000000000 -0800 +++ ghc-6.13.20091231/libraries/base/Text/Show/Functions.hs 2009-12-31 10:23:43.000000000 -0800 @@ -1,3 +1,4 @@ +-- This module deliberately declares orphan instances: {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | diff -ruN ghc-6.12.1/libraries/base3-compat/base.cabal ghc-6.13.20091231/libraries/base3-compat/base.cabal --- ghc-6.12.1/libraries/base3-compat/base.cabal 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/base.cabal 1969-12-31 16:00:00.000000000 -0800 @@ -1,160 +0,0 @@ -name: base -version: 3.0.3.2 -license: BSD3 -license-file: LICENSE -maintainer: libraries@haskell.org -bug-reports: http://hackage.haskell.org/trac/ghc/newticket?component=libraries/base -synopsis: Basic libraries (backwards-compatibility version) -description: - This is a backwards-compatible version of the base package. - It depends on a later version of base, and was probably supplied - with your compiler when it was installed. - -cabal-version: >=1.6 -build-type: Simple - -source-repository head - type: darcs - location: http://darcs.haskell.org/packages/base3-compat - -Library { - build-depends: base >= 4.0 && < 4.3, - syb >= 0.1 && < 0.2 - extensions: PackageImports,CPP - ghc-options: -fno-warn-deprecations - - if impl(ghc < 6.9) { - buildable: False - } - - if impl(ghc) { - exposed-modules: - Data.Generics, - Data.Generics.Aliases, - Data.Generics.Basics, - Data.Generics.Instances, - Data.Generics.Schemes, - Data.Generics.Text, - Data.Generics.Twins, - Foreign.Concurrent, - GHC.Arr, - GHC.Base, - GHC.Conc, - GHC.ConsoleHandler, - GHC.Desugar, - GHC.Dotnet, - GHC.Enum, - GHC.Environment, - GHC.Err, - GHC.Exception, - GHC.Exts, - GHC.Float, - GHC.ForeignPtr, - GHC.Handle, - GHC.IO, - GHC.IOBase, - GHC.Int, - GHC.List, - GHC.Num, - GHC.PArr, - GHC.Pack, - GHC.Ptr, - GHC.Read, - GHC.Real, - GHC.ST, - GHC.STRef, - GHC.Show, - GHC.Stable, - GHC.Storable, - GHC.TopHandler, - GHC.Unicode, - GHC.Weak, - GHC.Word, - System.Timeout - } - exposed-modules: - Control.Applicative, - Control.Arrow, - Control.Category, - Control.Concurrent, - Control.Concurrent.Chan, - Control.Concurrent.MVar, - Control.Concurrent.QSem, - Control.Concurrent.QSemN, - Control.Concurrent.SampleVar, - Control.Exception, - Control.Monad, - Control.Monad.Fix, - Control.Monad.Instances, - Control.Monad.ST, - Control.Monad.ST.Lazy, - Control.Monad.ST.Strict, - Data.Bits, - Data.Bool, - Data.Char, - Data.Complex, - Data.Dynamic, - Data.Either, - Data.Eq, - Data.Fixed, - Data.Foldable - Data.Function, - Data.HashTable, - Data.IORef, - Data.Int, - Data.Ix, - Data.List, - Data.Maybe, - Data.Monoid, - Data.Ord, - Data.Ratio, - Data.STRef, - Data.STRef.Lazy, - Data.STRef.Strict, - Data.String, - Data.Traversable - Data.Tuple, - Data.Typeable, - Data.Unique, - Data.Version, - Data.Word, - Debug.Trace, - Foreign, - Foreign.C, - Foreign.C.Error, - Foreign.C.String, - Foreign.C.Types, - Foreign.ForeignPtr, - Foreign.Marshal, - Foreign.Marshal.Alloc, - Foreign.Marshal.Array, - Foreign.Marshal.Error, - Foreign.Marshal.Pool, - Foreign.Marshal.Utils, - Foreign.Ptr, - Foreign.StablePtr, - Foreign.Storable, - Numeric, - Prelude, - System.Console.GetOpt, - System.CPUTime, - System.Environment, - System.Exit, - System.IO, - System.IO.Error, - System.IO.Unsafe, - System.Info, - System.Mem, - System.Mem.StableName, - System.Mem.Weak, - System.Posix.Internals, - System.Posix.Types, - Text.ParserCombinators.ReadP, - Text.ParserCombinators.ReadPrec, - Text.Printf, - Text.Read, - Text.Read.Lex, - Text.Show, - Text.Show.Functions - Unsafe.Coerce -} diff -ruN ghc-6.12.1/libraries/base3-compat/Control/Applicative.hs ghc-6.13.20091231/libraries/base3-compat/Control/Applicative.hs --- ghc-6.12.1/libraries/base3-compat/Control/Applicative.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Control/Applicative.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Control.Applicative (module X___) where -import "base" Control.Applicative as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Control/Arrow.hs ghc-6.13.20091231/libraries/base3-compat/Control/Arrow.hs --- ghc-6.12.1/libraries/base3-compat/Control/Arrow.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Control/Arrow.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Control.Arrow (module X___) where -import "base" Control.Arrow as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Control/Category.hs ghc-6.13.20091231/libraries/base3-compat/Control/Category.hs --- ghc-6.12.1/libraries/base3-compat/Control/Category.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Control/Category.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Control.Category (module X___) where -import "base" Control.Category as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Control/Concurrent/Chan.hs ghc-6.13.20091231/libraries/base3-compat/Control/Concurrent/Chan.hs --- ghc-6.12.1/libraries/base3-compat/Control/Concurrent/Chan.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Control/Concurrent/Chan.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Control.Concurrent.Chan (module X___) where -import "base" Control.Concurrent.Chan as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Control/Concurrent/MVar.hs ghc-6.13.20091231/libraries/base3-compat/Control/Concurrent/MVar.hs --- ghc-6.12.1/libraries/base3-compat/Control/Concurrent/MVar.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Control/Concurrent/MVar.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Control.Concurrent.MVar (module X___) where -import "base" Control.Concurrent.MVar as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Control/Concurrent/QSem.hs ghc-6.13.20091231/libraries/base3-compat/Control/Concurrent/QSem.hs --- ghc-6.12.1/libraries/base3-compat/Control/Concurrent/QSem.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Control/Concurrent/QSem.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Control.Concurrent.QSem (module X___) where -import "base" Control.Concurrent.QSem as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Control/Concurrent/QSemN.hs ghc-6.13.20091231/libraries/base3-compat/Control/Concurrent/QSemN.hs --- ghc-6.12.1/libraries/base3-compat/Control/Concurrent/QSemN.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Control/Concurrent/QSemN.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Control.Concurrent.QSemN (module X___) where -import "base" Control.Concurrent.QSemN as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Control/Concurrent/SampleVar.hs ghc-6.13.20091231/libraries/base3-compat/Control/Concurrent/SampleVar.hs --- ghc-6.12.1/libraries/base3-compat/Control/Concurrent/SampleVar.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Control/Concurrent/SampleVar.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Control.Concurrent.SampleVar (module X___) where -import "base" Control.Concurrent.SampleVar as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Control/Concurrent.hs ghc-6.13.20091231/libraries/base3-compat/Control/Concurrent.hs --- ghc-6.12.1/libraries/base3-compat/Control/Concurrent.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Control/Concurrent.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Control.Concurrent (module X___) where -import "base" Control.Concurrent as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Control/Exception.hs ghc-6.13.20091231/libraries/base3-compat/Control/Exception.hs --- ghc-6.12.1/libraries/base3-compat/Control/Exception.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Control/Exception.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Control.Exception (module Control.OldException) where -import Control.OldException diff -ruN ghc-6.12.1/libraries/base3-compat/Control/Monad/Fix.hs ghc-6.13.20091231/libraries/base3-compat/Control/Monad/Fix.hs --- ghc-6.12.1/libraries/base3-compat/Control/Monad/Fix.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Control/Monad/Fix.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Control.Monad.Fix (module X___) where -import "base" Control.Monad.Fix as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Control/Monad/Instances.hs ghc-6.13.20091231/libraries/base3-compat/Control/Monad/Instances.hs --- ghc-6.12.1/libraries/base3-compat/Control/Monad/Instances.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Control/Monad/Instances.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Control.Monad.Instances (module X___) where -import "base" Control.Monad.Instances as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Control/Monad/ST/Lazy.hs ghc-6.13.20091231/libraries/base3-compat/Control/Monad/ST/Lazy.hs --- ghc-6.12.1/libraries/base3-compat/Control/Monad/ST/Lazy.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Control/Monad/ST/Lazy.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Control.Monad.ST.Lazy (module X___) where -import "base" Control.Monad.ST.Lazy as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Control/Monad/ST/Strict.hs ghc-6.13.20091231/libraries/base3-compat/Control/Monad/ST/Strict.hs --- ghc-6.12.1/libraries/base3-compat/Control/Monad/ST/Strict.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Control/Monad/ST/Strict.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Control.Monad.ST.Strict (module X___) where -import "base" Control.Monad.ST.Strict as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Control/Monad/ST.hs ghc-6.13.20091231/libraries/base3-compat/Control/Monad/ST.hs --- ghc-6.12.1/libraries/base3-compat/Control/Monad/ST.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Control/Monad/ST.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Control.Monad.ST (module X___) where -import "base" Control.Monad.ST as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Control/Monad.hs ghc-6.13.20091231/libraries/base3-compat/Control/Monad.hs --- ghc-6.12.1/libraries/base3-compat/Control/Monad.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Control/Monad.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Control.Monad (module X___) where -import "base" Control.Monad as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/Bits.hs ghc-6.13.20091231/libraries/base3-compat/Data/Bits.hs --- ghc-6.12.1/libraries/base3-compat/Data/Bits.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/Bits.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.Bits (module X___) where -import "base" Data.Bits as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/Bool.hs ghc-6.13.20091231/libraries/base3-compat/Data/Bool.hs --- ghc-6.12.1/libraries/base3-compat/Data/Bool.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/Bool.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.Bool (module X___) where -import "base" Data.Bool as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/Char.hs ghc-6.13.20091231/libraries/base3-compat/Data/Char.hs --- ghc-6.12.1/libraries/base3-compat/Data/Char.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/Char.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.Char (module X___) where -import "base" Data.Char as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/Complex.hs ghc-6.13.20091231/libraries/base3-compat/Data/Complex.hs --- ghc-6.12.1/libraries/base3-compat/Data/Complex.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/Complex.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.Complex (module X___) where -import "base" Data.Complex as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/Dynamic.hs ghc-6.13.20091231/libraries/base3-compat/Data/Dynamic.hs --- ghc-6.12.1/libraries/base3-compat/Data/Dynamic.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/Dynamic.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.Dynamic (module X___) where -import "base" Data.Dynamic as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/Either.hs ghc-6.13.20091231/libraries/base3-compat/Data/Either.hs --- ghc-6.12.1/libraries/base3-compat/Data/Either.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/Either.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.Either (module X___) where -import "base" Data.Either as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/Eq.hs ghc-6.13.20091231/libraries/base3-compat/Data/Eq.hs --- ghc-6.12.1/libraries/base3-compat/Data/Eq.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/Eq.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.Eq (module X___) where -import "base" Data.Eq as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/Fixed.hs ghc-6.13.20091231/libraries/base3-compat/Data/Fixed.hs --- ghc-6.12.1/libraries/base3-compat/Data/Fixed.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/Fixed.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.Fixed (module X___) where -import "base" Data.Fixed as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/Foldable.hs ghc-6.13.20091231/libraries/base3-compat/Data/Foldable.hs --- ghc-6.12.1/libraries/base3-compat/Data/Foldable.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/Foldable.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.Foldable (module X___) where -import "base" Data.Foldable as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/Function.hs ghc-6.13.20091231/libraries/base3-compat/Data/Function.hs --- ghc-6.12.1/libraries/base3-compat/Data/Function.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/Function.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.Function (module X___) where -import "base" Data.Function as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/Generics/Aliases.hs ghc-6.13.20091231/libraries/base3-compat/Data/Generics/Aliases.hs --- ghc-6.12.1/libraries/base3-compat/Data/Generics/Aliases.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/Generics/Aliases.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.Generics.Aliases (module X___) where -import "syb" Data.Generics.Aliases as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/Generics/Basics.hs ghc-6.13.20091231/libraries/base3-compat/Data/Generics/Basics.hs --- ghc-6.12.1/libraries/base3-compat/Data/Generics/Basics.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/Generics/Basics.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.Generics.Basics (module X___) where -import "syb" Data.Generics.Basics as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/Generics/Instances.hs ghc-6.13.20091231/libraries/base3-compat/Data/Generics/Instances.hs --- ghc-6.12.1/libraries/base3-compat/Data/Generics/Instances.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/Generics/Instances.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.Generics.Instances () where -import "syb" Data.Generics.Instances as X___ () diff -ruN ghc-6.12.1/libraries/base3-compat/Data/Generics/Schemes.hs ghc-6.13.20091231/libraries/base3-compat/Data/Generics/Schemes.hs --- ghc-6.12.1/libraries/base3-compat/Data/Generics/Schemes.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/Generics/Schemes.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.Generics.Schemes (module X___) where -import "syb" Data.Generics.Schemes as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/Generics/Text.hs ghc-6.13.20091231/libraries/base3-compat/Data/Generics/Text.hs --- ghc-6.12.1/libraries/base3-compat/Data/Generics/Text.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/Generics/Text.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.Generics.Text (module X___) where -import "syb" Data.Generics.Text as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/Generics/Twins.hs ghc-6.13.20091231/libraries/base3-compat/Data/Generics/Twins.hs --- ghc-6.12.1/libraries/base3-compat/Data/Generics/Twins.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/Generics/Twins.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.Generics.Twins (module X___) where -import "syb" Data.Generics.Twins as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/Generics.hs ghc-6.13.20091231/libraries/base3-compat/Data/Generics.hs --- ghc-6.12.1/libraries/base3-compat/Data/Generics.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/Generics.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.Generics (module X___) where -import "syb" Data.Generics as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/HashTable.hs ghc-6.13.20091231/libraries/base3-compat/Data/HashTable.hs --- ghc-6.12.1/libraries/base3-compat/Data/HashTable.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/HashTable.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.HashTable (module X___) where -import "base" Data.HashTable as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/Int.hs ghc-6.13.20091231/libraries/base3-compat/Data/Int.hs --- ghc-6.12.1/libraries/base3-compat/Data/Int.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/Int.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.Int (module X___) where -import "base" Data.Int as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/IORef.hs ghc-6.13.20091231/libraries/base3-compat/Data/IORef.hs --- ghc-6.12.1/libraries/base3-compat/Data/IORef.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/IORef.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.IORef (module X___) where -import "base" Data.IORef as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/Ix.hs ghc-6.13.20091231/libraries/base3-compat/Data/Ix.hs --- ghc-6.12.1/libraries/base3-compat/Data/Ix.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/Ix.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.Ix (module X___) where -import "base" Data.Ix as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/List.hs ghc-6.13.20091231/libraries/base3-compat/Data/List.hs --- ghc-6.12.1/libraries/base3-compat/Data/List.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/List.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.List (module X___) where -import "base" Data.List as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/Maybe.hs ghc-6.13.20091231/libraries/base3-compat/Data/Maybe.hs --- ghc-6.12.1/libraries/base3-compat/Data/Maybe.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/Maybe.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.Maybe (module X___) where -import "base" Data.Maybe as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/Monoid.hs ghc-6.13.20091231/libraries/base3-compat/Data/Monoid.hs --- ghc-6.12.1/libraries/base3-compat/Data/Monoid.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/Monoid.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.Monoid (module X___) where -import "base" Data.Monoid as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/Ord.hs ghc-6.13.20091231/libraries/base3-compat/Data/Ord.hs --- ghc-6.12.1/libraries/base3-compat/Data/Ord.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/Ord.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.Ord (module X___) where -import "base" Data.Ord as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/Ratio.hs ghc-6.13.20091231/libraries/base3-compat/Data/Ratio.hs --- ghc-6.12.1/libraries/base3-compat/Data/Ratio.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/Ratio.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.Ratio (module X___) where -import "base" Data.Ratio as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/STRef/Lazy.hs ghc-6.13.20091231/libraries/base3-compat/Data/STRef/Lazy.hs --- ghc-6.12.1/libraries/base3-compat/Data/STRef/Lazy.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/STRef/Lazy.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.STRef.Lazy (module X___) where -import "base" Data.STRef.Lazy as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/STRef/Strict.hs ghc-6.13.20091231/libraries/base3-compat/Data/STRef/Strict.hs --- ghc-6.12.1/libraries/base3-compat/Data/STRef/Strict.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/STRef/Strict.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.STRef.Strict (module X___) where -import "base" Data.STRef.Strict as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/STRef.hs ghc-6.13.20091231/libraries/base3-compat/Data/STRef.hs --- ghc-6.12.1/libraries/base3-compat/Data/STRef.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/STRef.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.STRef (module X___) where -import "base" Data.STRef as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/String.hs ghc-6.13.20091231/libraries/base3-compat/Data/String.hs --- ghc-6.12.1/libraries/base3-compat/Data/String.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/String.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.String (module X___) where -import "base" Data.String as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/Traversable.hs ghc-6.13.20091231/libraries/base3-compat/Data/Traversable.hs --- ghc-6.12.1/libraries/base3-compat/Data/Traversable.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/Traversable.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.Traversable (module X___) where -import "base" Data.Traversable as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/Tuple.hs ghc-6.13.20091231/libraries/base3-compat/Data/Tuple.hs --- ghc-6.12.1/libraries/base3-compat/Data/Tuple.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/Tuple.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.Tuple (module X___) where -import "base" Data.Tuple as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/Typeable.hs ghc-6.13.20091231/libraries/base3-compat/Data/Typeable.hs --- ghc-6.12.1/libraries/base3-compat/Data/Typeable.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/Typeable.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.Typeable (module X___) where -import "base" Data.Typeable as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/Unique.hs ghc-6.13.20091231/libraries/base3-compat/Data/Unique.hs --- ghc-6.12.1/libraries/base3-compat/Data/Unique.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/Unique.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.Unique (module X___) where -import "base" Data.Unique as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/Version.hs ghc-6.13.20091231/libraries/base3-compat/Data/Version.hs --- ghc-6.12.1/libraries/base3-compat/Data/Version.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/Version.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.Version (module X___) where -import "base" Data.Version as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Data/Word.hs ghc-6.13.20091231/libraries/base3-compat/Data/Word.hs --- ghc-6.12.1/libraries/base3-compat/Data/Word.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Data/Word.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Data.Word (module X___) where -import "base" Data.Word as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Debug/Trace.hs ghc-6.13.20091231/libraries/base3-compat/Debug/Trace.hs --- ghc-6.12.1/libraries/base3-compat/Debug/Trace.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Debug/Trace.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Debug.Trace (module X___) where -import "base" Debug.Trace as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Foreign/C/Error.hs ghc-6.13.20091231/libraries/base3-compat/Foreign/C/Error.hs --- ghc-6.12.1/libraries/base3-compat/Foreign/C/Error.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Foreign/C/Error.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Foreign.C.Error (module X___) where -import "base" Foreign.C.Error as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Foreign/C/String.hs ghc-6.13.20091231/libraries/base3-compat/Foreign/C/String.hs --- ghc-6.12.1/libraries/base3-compat/Foreign/C/String.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Foreign/C/String.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Foreign.C.String (module X___) where -import "base" Foreign.C.String as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Foreign/C/Types.hs ghc-6.13.20091231/libraries/base3-compat/Foreign/C/Types.hs --- ghc-6.12.1/libraries/base3-compat/Foreign/C/Types.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Foreign/C/Types.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Foreign.C.Types (module X___) where -import "base" Foreign.C.Types as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Foreign/C.hs ghc-6.13.20091231/libraries/base3-compat/Foreign/C.hs --- ghc-6.12.1/libraries/base3-compat/Foreign/C.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Foreign/C.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Foreign.C (module X___) where -import "base" Foreign.C as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Foreign/Concurrent.hs ghc-6.13.20091231/libraries/base3-compat/Foreign/Concurrent.hs --- ghc-6.12.1/libraries/base3-compat/Foreign/Concurrent.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Foreign/Concurrent.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Foreign.Concurrent (module X___) where -import "base" Foreign.Concurrent as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Foreign/ForeignPtr.hs ghc-6.13.20091231/libraries/base3-compat/Foreign/ForeignPtr.hs --- ghc-6.12.1/libraries/base3-compat/Foreign/ForeignPtr.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Foreign/ForeignPtr.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Foreign.ForeignPtr (module X___) where -import "base" Foreign.ForeignPtr as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Foreign/Marshal/Alloc.hs ghc-6.13.20091231/libraries/base3-compat/Foreign/Marshal/Alloc.hs --- ghc-6.12.1/libraries/base3-compat/Foreign/Marshal/Alloc.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Foreign/Marshal/Alloc.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Foreign.Marshal.Alloc (module X___) where -import "base" Foreign.Marshal.Alloc as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Foreign/Marshal/Array.hs ghc-6.13.20091231/libraries/base3-compat/Foreign/Marshal/Array.hs --- ghc-6.12.1/libraries/base3-compat/Foreign/Marshal/Array.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Foreign/Marshal/Array.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Foreign.Marshal.Array (module X___) where -import "base" Foreign.Marshal.Array as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Foreign/Marshal/Error.hs ghc-6.13.20091231/libraries/base3-compat/Foreign/Marshal/Error.hs --- ghc-6.12.1/libraries/base3-compat/Foreign/Marshal/Error.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Foreign/Marshal/Error.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Foreign.Marshal.Error (module X___) where -import "base" Foreign.Marshal.Error as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Foreign/Marshal/Pool.hs ghc-6.13.20091231/libraries/base3-compat/Foreign/Marshal/Pool.hs --- ghc-6.12.1/libraries/base3-compat/Foreign/Marshal/Pool.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Foreign/Marshal/Pool.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Foreign.Marshal.Pool (module X___) where -import "base" Foreign.Marshal.Pool as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Foreign/Marshal/Utils.hs ghc-6.13.20091231/libraries/base3-compat/Foreign/Marshal/Utils.hs --- ghc-6.12.1/libraries/base3-compat/Foreign/Marshal/Utils.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Foreign/Marshal/Utils.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Foreign.Marshal.Utils (module X___) where -import "base" Foreign.Marshal.Utils as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Foreign/Marshal.hs ghc-6.13.20091231/libraries/base3-compat/Foreign/Marshal.hs --- ghc-6.12.1/libraries/base3-compat/Foreign/Marshal.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Foreign/Marshal.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Foreign.Marshal (module X___) where -import "base" Foreign.Marshal as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Foreign/Ptr.hs ghc-6.13.20091231/libraries/base3-compat/Foreign/Ptr.hs --- ghc-6.12.1/libraries/base3-compat/Foreign/Ptr.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Foreign/Ptr.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Foreign.Ptr (module X___) where -import "base" Foreign.Ptr as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Foreign/StablePtr.hs ghc-6.13.20091231/libraries/base3-compat/Foreign/StablePtr.hs --- ghc-6.12.1/libraries/base3-compat/Foreign/StablePtr.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Foreign/StablePtr.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Foreign.StablePtr (module X___) where -import "base" Foreign.StablePtr as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Foreign/Storable.hs ghc-6.13.20091231/libraries/base3-compat/Foreign/Storable.hs --- ghc-6.12.1/libraries/base3-compat/Foreign/Storable.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Foreign/Storable.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Foreign.Storable (module X___) where -import "base" Foreign.Storable as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Foreign.hs ghc-6.13.20091231/libraries/base3-compat/Foreign.hs --- ghc-6.12.1/libraries/base3-compat/Foreign.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Foreign.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Foreign (module X___) where -import "base" Foreign as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/Arr.hs ghc-6.13.20091231/libraries/base3-compat/GHC/Arr.hs --- ghc-6.12.1/libraries/base3-compat/GHC/Arr.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/Arr.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module GHC.Arr (module X___) where -import "base" GHC.Arr as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/Base.hs ghc-6.13.20091231/libraries/base3-compat/GHC/Base.hs --- ghc-6.12.1/libraries/base3-compat/GHC/Base.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/Base.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module GHC.Base (module X___) where -import "base" GHC.Base as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/Conc.hs ghc-6.13.20091231/libraries/base3-compat/GHC/Conc.hs --- ghc-6.12.1/libraries/base3-compat/GHC/Conc.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/Conc.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module GHC.Conc (module X___) where -import "base" GHC.Conc as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/ConsoleHandler.hs ghc-6.13.20091231/libraries/base3-compat/GHC/ConsoleHandler.hs --- ghc-6.12.1/libraries/base3-compat/GHC/ConsoleHandler.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/ConsoleHandler.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module GHC.ConsoleHandler ({- empty: module X___ -}) where -import "base" GHC.ConsoleHandler as X___ () diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/Desugar.hs ghc-6.13.20091231/libraries/base3-compat/GHC/Desugar.hs --- ghc-6.12.1/libraries/base3-compat/GHC/Desugar.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/Desugar.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module GHC.Desugar (module X___) where -import "base" GHC.Desugar as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/Dotnet.hs ghc-6.13.20091231/libraries/base3-compat/GHC/Dotnet.hs --- ghc-6.12.1/libraries/base3-compat/GHC/Dotnet.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/Dotnet.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1 +0,0 @@ -module GHC.Dotnet () where diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/Enum.hs ghc-6.13.20091231/libraries/base3-compat/GHC/Enum.hs --- ghc-6.12.1/libraries/base3-compat/GHC/Enum.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/Enum.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module GHC.Enum (module X___) where -import "base" GHC.Enum as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/Environment.hs ghc-6.13.20091231/libraries/base3-compat/GHC/Environment.hs --- ghc-6.12.1/libraries/base3-compat/GHC/Environment.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/Environment.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module GHC.Environment (module X___) where -import "base" GHC.Environment as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/Err.hs ghc-6.13.20091231/libraries/base3-compat/GHC/Err.hs --- ghc-6.12.1/libraries/base3-compat/GHC/Err.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/Err.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module GHC.Err (module X___) where -import "base" GHC.Err as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/Exception.hs ghc-6.13.20091231/libraries/base3-compat/GHC/Exception.hs --- ghc-6.12.1/libraries/base3-compat/GHC/Exception.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/Exception.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module GHC.Exception (module X___) where -import "base" GHC.Exception as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/Exts.hs ghc-6.13.20091231/libraries/base3-compat/GHC/Exts.hs --- ghc-6.12.1/libraries/base3-compat/GHC/Exts.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/Exts.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module GHC.Exts (module X___) where -import "base" GHC.Exts as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/Float.hs ghc-6.13.20091231/libraries/base3-compat/GHC/Float.hs --- ghc-6.12.1/libraries/base3-compat/GHC/Float.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/Float.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module GHC.Float (module X___) where -import "base" GHC.Float as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/ForeignPtr.hs ghc-6.13.20091231/libraries/base3-compat/GHC/ForeignPtr.hs --- ghc-6.12.1/libraries/base3-compat/GHC/ForeignPtr.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/ForeignPtr.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module GHC.ForeignPtr (module X___) where -import "base" GHC.ForeignPtr as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/Handle.hs ghc-6.13.20091231/libraries/base3-compat/GHC/Handle.hs --- ghc-6.12.1/libraries/base3-compat/GHC/Handle.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/Handle.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,52 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -module GHC.Handle ( - withHandle, withHandle', withHandle_, - wantWritableHandle, wantReadableHandle, wantSeekableHandle, - - --newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer, - --flushWriteBufferOnly, - flushWriteBuffer, --flushReadBuffer, - --fillReadBuffer, fillReadBufferWithoutBlocking, - --readRawBuffer, readRawBufferPtr, - --readRawBufferNoBlock, readRawBufferPtrNoBlock, - --writeRawBuffer, writeRawBufferPtr, - -#ifndef mingw32_HOST_OS - unlockFile, -#endif - - ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable, - - stdin, stdout, stderr, - IOMode(..), openFile, openBinaryFile, - --fdToHandle_stat, - fdToHandle, fdToHandle', - hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode, - -- hLookAhead', - hFlush, hDuplicate, hDuplicateTo, - - hClose, hClose_help, - - HandlePosition, HandlePosn(..), hGetPosn, hSetPosn, - SeekMode(..), hSeek, hTell, - - hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable, - hSetEcho, hGetEcho, hIsTerminalDevice, - - hShow, - - ) where - -import "base" GHC.IO.IOMode -import "base" GHC.IO.Handle -import "base" GHC.IO.Handle.Internals -import "base" GHC.IO.Handle.FD -#ifndef mingw32_HOST_OS -import "base" Foreign.C -#endif - -#ifndef mingw32_HOST_OS -foreign import ccall unsafe "unlockFile" - unlockFile :: CInt -> IO CInt -#endif - diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/Int.hs ghc-6.13.20091231/libraries/base3-compat/GHC/Int.hs --- ghc-6.12.1/libraries/base3-compat/GHC/Int.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/Int.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module GHC.Int (module X___) where -import "base" GHC.Int as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/IOBase.hs ghc-6.13.20091231/libraries/base3-compat/GHC/IOBase.hs --- ghc-6.12.1/libraries/base3-compat/GHC/IOBase.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/IOBase.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,40 +0,0 @@ -module GHC.IOBase( - IO(..), unIO, failIO, liftIO, bindIO, thenIO, returnIO, - unsafePerformIO, unsafeInterleaveIO, - unsafeDupablePerformIO, unsafeDupableInterleaveIO, - noDuplicate, - - -- To and from from ST - stToIO, ioToST, unsafeIOToST, unsafeSTToIO, - - -- References - IORef(..), newIORef, readIORef, writeIORef, - IOArray(..), newIOArray, readIOArray, writeIOArray, unsafeReadIOArray, unsafeWriteIOArray, - MVar(..), - - -- Handles, file descriptors, - FilePath, - Handle(..), Handle__(..), HandleType(..), IOMode(..), FD, - isReadableHandleType, isWritableHandleType, isReadWriteHandleType, showHandle, - - -- Buffers - -- Buffer(..), RawBuffer, BufferState(..), - BufferList(..), BufferMode(..), - --bufferIsWritable, bufferEmpty, bufferFull, - - -- Exceptions - Exception(..), ArithException(..), AsyncException(..), ArrayException(..), - stackOverflow, heapOverflow, ioException, - IOError, IOException(..), IOErrorType(..), ioError, userError, - ExitCode(..), - throwIO, block, unblock, blocked, catchAny, catchException, - evaluate, - ErrorCall(..), AssertionFailed(..), assertError, untangle, - BlockedOnDeadMVar(..), BlockedIndefinitely(..), Deadlock(..), - blockedOnDeadMVar, blockedIndefinitely - ) where - -import "base" GHC.Base -import "base" GHC.Exception -import "base" GHC.IO -import "base" GHC.IOBase diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/IO.hs ghc-6.13.20091231/libraries/base3-compat/GHC/IO.hs --- ghc-6.12.1/libraries/base3-compat/GHC/IO.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/IO.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module GHC.IO (module X___) where -import "base" GHC.IO as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/List.hs ghc-6.13.20091231/libraries/base3-compat/GHC/List.hs --- ghc-6.12.1/libraries/base3-compat/GHC/List.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/List.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module GHC.List (module X___) where -import "base" GHC.List as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/Num.hs ghc-6.13.20091231/libraries/base3-compat/GHC/Num.hs --- ghc-6.12.1/libraries/base3-compat/GHC/Num.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/Num.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module GHC.Num (module X___) where -import "base" GHC.Num as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/Pack.hs ghc-6.13.20091231/libraries/base3-compat/GHC/Pack.hs --- ghc-6.12.1/libraries/base3-compat/GHC/Pack.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/Pack.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module GHC.Pack (module X___) where -import "base" GHC.Pack as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/PArr.hs ghc-6.13.20091231/libraries/base3-compat/GHC/PArr.hs --- ghc-6.12.1/libraries/base3-compat/GHC/PArr.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/PArr.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module GHC.PArr (module X___) where -import "base" GHC.PArr as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/Ptr.hs ghc-6.13.20091231/libraries/base3-compat/GHC/Ptr.hs --- ghc-6.12.1/libraries/base3-compat/GHC/Ptr.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/Ptr.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module GHC.Ptr (module X___) where -import "base" GHC.Ptr as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/Read.hs ghc-6.13.20091231/libraries/base3-compat/GHC/Read.hs --- ghc-6.12.1/libraries/base3-compat/GHC/Read.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/Read.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module GHC.Read (module X___) where -import "base" GHC.Read as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/Real.hs ghc-6.13.20091231/libraries/base3-compat/GHC/Real.hs --- ghc-6.12.1/libraries/base3-compat/GHC/Real.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/Real.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module GHC.Real (module X___) where -import "base" GHC.Real as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/Show.hs ghc-6.13.20091231/libraries/base3-compat/GHC/Show.hs --- ghc-6.12.1/libraries/base3-compat/GHC/Show.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/Show.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module GHC.Show (module X___) where -import "base" GHC.Show as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/Stable.hs ghc-6.13.20091231/libraries/base3-compat/GHC/Stable.hs --- ghc-6.12.1/libraries/base3-compat/GHC/Stable.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/Stable.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module GHC.Stable (module X___) where -import "base" GHC.Stable as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/ST.hs ghc-6.13.20091231/libraries/base3-compat/GHC/ST.hs --- ghc-6.12.1/libraries/base3-compat/GHC/ST.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/ST.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module GHC.ST (module X___) where -import "base" GHC.ST as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/Storable.hs ghc-6.13.20091231/libraries/base3-compat/GHC/Storable.hs --- ghc-6.12.1/libraries/base3-compat/GHC/Storable.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/Storable.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module GHC.Storable (module X___) where -import "base" GHC.Storable as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/STRef.hs ghc-6.13.20091231/libraries/base3-compat/GHC/STRef.hs --- ghc-6.12.1/libraries/base3-compat/GHC/STRef.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/STRef.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module GHC.STRef (module X___) where -import "base" GHC.STRef as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/TopHandler.hs ghc-6.13.20091231/libraries/base3-compat/GHC/TopHandler.hs --- ghc-6.12.1/libraries/base3-compat/GHC/TopHandler.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/TopHandler.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module GHC.TopHandler (module X___) where -import "base" GHC.TopHandler as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/Unicode.hs ghc-6.13.20091231/libraries/base3-compat/GHC/Unicode.hs --- ghc-6.12.1/libraries/base3-compat/GHC/Unicode.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/Unicode.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module GHC.Unicode (module X___) where -import "base" GHC.Unicode as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/Weak.hs ghc-6.13.20091231/libraries/base3-compat/GHC/Weak.hs --- ghc-6.12.1/libraries/base3-compat/GHC/Weak.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/Weak.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module GHC.Weak (module X___) where -import "base" GHC.Weak as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/GHC/Word.hs ghc-6.13.20091231/libraries/base3-compat/GHC/Word.hs --- ghc-6.12.1/libraries/base3-compat/GHC/Word.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GHC/Word.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module GHC.Word (module X___) where -import "base" GHC.Word as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/ghc.mk ghc-6.13.20091231/libraries/base3-compat/ghc.mk --- ghc-6.12.1/libraries/base3-compat/ghc.mk 2009-12-10 10:31:37.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/ghc.mk 1969-12-31 16:00:00.000000000 -0800 @@ -1,3 +0,0 @@ -libraries/base3-compat_PACKAGE = base -libraries/base3-compat_dist-install_GROUP = libraries -$(eval $(call build-package,libraries/base3-compat,dist-install,1)) diff -ruN ghc-6.12.1/libraries/base3-compat/GNUmakefile ghc-6.13.20091231/libraries/base3-compat/GNUmakefile --- ghc-6.12.1/libraries/base3-compat/GNUmakefile 2009-12-10 10:31:37.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/GNUmakefile 1969-12-31 16:00:00.000000000 -0800 @@ -1,3 +0,0 @@ -dir = libraries/base3-compat -TOP = ../.. -include $(TOP)/mk/sub-makefile.mk diff -ruN ghc-6.12.1/libraries/base3-compat/LICENSE ghc-6.13.20091231/libraries/base3-compat/LICENSE --- ghc-6.12.1/libraries/base3-compat/LICENSE 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/LICENSE 1969-12-31 16:00:00.000000000 -0800 @@ -1,83 +0,0 @@ -This library (libraries/base) is derived from code from several -sources: - - * Code from the GHC project which is largely (c) The University of - Glasgow, and distributable under a BSD-style license (see below), - - * Code from the Haskell 98 Report which is (c) Simon Peyton Jones - and freely redistributable (but see the full license for - restrictions). - - * Code from the Haskell Foreign Function Interface specification, - which is (c) Manuel M. T. Chakravarty and freely redistributable - (but see the full license for restrictions). - -The full text of these licenses is reproduced below. All of the -licenses are BSD-style or compatible. - ------------------------------------------------------------------------------ - -The Glasgow Haskell Compiler License - -Copyright 2004, The University Court of the University of Glasgow. -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -- Redistributions of source code must retain the above copyright notice, -this list of conditions and the following disclaimer. - -- Redistributions in binary form must reproduce the above copyright notice, -this list of conditions and the following disclaimer in the documentation -and/or other materials provided with the distribution. - -- Neither name of the University nor the names of its contributors may be -used to endorse or promote products derived from this software without -specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF -GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, -INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH -DAMAGE. - ------------------------------------------------------------------------------ - -Code derived from the document "Report on the Programming Language -Haskell 98", is distributed under the following license: - - Copyright (c) 2002 Simon Peyton Jones - - The authors intend this Report to belong to the entire Haskell - community, and so we grant permission to copy and distribute it for - any purpose, provided that it is reproduced in its entirety, - including this Notice. Modified versions of this Report may also be - copied and distributed for any purpose, provided that the modified - version is clearly presented as such, and that it does not claim to - be a definition of the Haskell 98 Language. - ------------------------------------------------------------------------------ - -Code derived from the document "The Haskell 98 Foreign Function -Interface, An Addendum to the Haskell 98 Report" is distributed under -the following license: - - Copyright (c) 2002 Manuel M. T. Chakravarty - - The authors intend this Report to belong to the entire Haskell - community, and so we grant permission to copy and distribute it for - any purpose, provided that it is reproduced in its entirety, - including this Notice. Modified versions of this Report may also be - copied and distributed for any purpose, provided that the modified - version is clearly presented as such, and that it does not claim to - be a definition of the Haskell 98 Foreign Function Interface. - ------------------------------------------------------------------------------ diff -ruN ghc-6.12.1/libraries/base3-compat/Numeric.hs ghc-6.13.20091231/libraries/base3-compat/Numeric.hs --- ghc-6.12.1/libraries/base3-compat/Numeric.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Numeric.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Numeric (module X___) where -import "base" Numeric as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Prelude.hs ghc-6.13.20091231/libraries/base3-compat/Prelude.hs --- ghc-6.12.1/libraries/base3-compat/Prelude.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Prelude.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,9 +0,0 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} -module Prelude -{-# DEPRECATED - ["You are using the old package `base' version 3.x." - ,"Future GHC versions will not support base version 3.x. You" - ,"should update your code to use the new base version 4.x."] - #-} - (module X___) where -import "base" Prelude as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/System/Console/GetOpt.hs ghc-6.13.20091231/libraries/base3-compat/System/Console/GetOpt.hs --- ghc-6.12.1/libraries/base3-compat/System/Console/GetOpt.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/System/Console/GetOpt.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module System.Console.GetOpt (module X___) where -import "base" System.Console.GetOpt as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/System/CPUTime.hs ghc-6.13.20091231/libraries/base3-compat/System/CPUTime.hs --- ghc-6.12.1/libraries/base3-compat/System/CPUTime.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/System/CPUTime.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module System.CPUTime (module X___) where -import "base" System.CPUTime as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/System/Environment.hs ghc-6.13.20091231/libraries/base3-compat/System/Environment.hs --- ghc-6.12.1/libraries/base3-compat/System/Environment.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/System/Environment.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module System.Environment (module X___) where -import "base" System.Environment as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/System/Exit.hs ghc-6.13.20091231/libraries/base3-compat/System/Exit.hs --- ghc-6.12.1/libraries/base3-compat/System/Exit.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/System/Exit.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module System.Exit (module X___) where -import "base" System.Exit as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/System/Info.hs ghc-6.13.20091231/libraries/base3-compat/System/Info.hs --- ghc-6.12.1/libraries/base3-compat/System/Info.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/System/Info.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module System.Info (module X___) where -import "base" System.Info as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/System/IO/Error.hs ghc-6.13.20091231/libraries/base3-compat/System/IO/Error.hs --- ghc-6.12.1/libraries/base3-compat/System/IO/Error.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/System/IO/Error.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module System.IO.Error (module X___) where -import "base" System.IO.Error as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/System/IO/Unsafe.hs ghc-6.13.20091231/libraries/base3-compat/System/IO/Unsafe.hs --- ghc-6.12.1/libraries/base3-compat/System/IO/Unsafe.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/System/IO/Unsafe.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module System.IO.Unsafe (module X___) where -import "base" System.IO.Unsafe as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/System/IO.hs ghc-6.13.20091231/libraries/base3-compat/System/IO.hs --- ghc-6.12.1/libraries/base3-compat/System/IO.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/System/IO.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module System.IO (module X___) where -import "base" System.IO as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/System/Mem/StableName.hs ghc-6.13.20091231/libraries/base3-compat/System/Mem/StableName.hs --- ghc-6.12.1/libraries/base3-compat/System/Mem/StableName.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/System/Mem/StableName.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module System.Mem.StableName (module X___) where -import "base" System.Mem.StableName as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/System/Mem/Weak.hs ghc-6.13.20091231/libraries/base3-compat/System/Mem/Weak.hs --- ghc-6.12.1/libraries/base3-compat/System/Mem/Weak.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/System/Mem/Weak.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module System.Mem.Weak (module X___) where -import "base" System.Mem.Weak as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/System/Mem.hs ghc-6.13.20091231/libraries/base3-compat/System/Mem.hs --- ghc-6.12.1/libraries/base3-compat/System/Mem.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/System/Mem.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module System.Mem (module X___) where -import "base" System.Mem as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/System/Posix/Internals.hs ghc-6.13.20091231/libraries/base3-compat/System/Posix/Internals.hs --- ghc-6.12.1/libraries/base3-compat/System/Posix/Internals.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/System/Posix/Internals.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module System.Posix.Internals (module X___) where -import "base" System.Posix.Internals as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/System/Posix/Types.hs ghc-6.13.20091231/libraries/base3-compat/System/Posix/Types.hs --- ghc-6.12.1/libraries/base3-compat/System/Posix/Types.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/System/Posix/Types.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module System.Posix.Types (module X___) where -import "base" System.Posix.Types as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/System/Timeout.hs ghc-6.13.20091231/libraries/base3-compat/System/Timeout.hs --- ghc-6.12.1/libraries/base3-compat/System/Timeout.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/System/Timeout.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module System.Timeout (module X___) where -import "base" System.Timeout as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Text/ParserCombinators/ReadP.hs ghc-6.13.20091231/libraries/base3-compat/Text/ParserCombinators/ReadP.hs --- ghc-6.12.1/libraries/base3-compat/Text/ParserCombinators/ReadP.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Text/ParserCombinators/ReadP.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Text.ParserCombinators.ReadP (module X___) where -import "base" Text.ParserCombinators.ReadP as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Text/ParserCombinators/ReadPrec.hs ghc-6.13.20091231/libraries/base3-compat/Text/ParserCombinators/ReadPrec.hs --- ghc-6.12.1/libraries/base3-compat/Text/ParserCombinators/ReadPrec.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Text/ParserCombinators/ReadPrec.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Text.ParserCombinators.ReadPrec (module X___) where -import "base" Text.ParserCombinators.ReadPrec as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Text/Printf.hs ghc-6.13.20091231/libraries/base3-compat/Text/Printf.hs --- ghc-6.12.1/libraries/base3-compat/Text/Printf.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Text/Printf.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Text.Printf (module X___) where -import "base" Text.Printf as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Text/Read/Lex.hs ghc-6.13.20091231/libraries/base3-compat/Text/Read/Lex.hs --- ghc-6.12.1/libraries/base3-compat/Text/Read/Lex.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Text/Read/Lex.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Text.Read.Lex (module X___) where -import "base" Text.Read.Lex as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Text/Read.hs ghc-6.13.20091231/libraries/base3-compat/Text/Read.hs --- ghc-6.12.1/libraries/base3-compat/Text/Read.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Text/Read.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Text.Read (module X___) where -import "base" Text.Read as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Text/Show/Functions.hs ghc-6.13.20091231/libraries/base3-compat/Text/Show/Functions.hs --- ghc-6.12.1/libraries/base3-compat/Text/Show/Functions.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Text/Show/Functions.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Text.Show.Functions ({- empty: module X___ -}) where -import "base" Text.Show.Functions as X___ () diff -ruN ghc-6.12.1/libraries/base3-compat/Text/Show.hs ghc-6.13.20091231/libraries/base3-compat/Text/Show.hs --- ghc-6.12.1/libraries/base3-compat/Text/Show.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Text/Show.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Text.Show (module X___) where -import "base" Text.Show as X___ diff -ruN ghc-6.12.1/libraries/base3-compat/Unsafe/Coerce.hs ghc-6.13.20091231/libraries/base3-compat/Unsafe/Coerce.hs --- ghc-6.12.1/libraries/base3-compat/Unsafe/Coerce.hs 2009-12-10 10:23:48.000000000 -0800 +++ ghc-6.13.20091231/libraries/base3-compat/Unsafe/Coerce.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,2 +0,0 @@ -module Unsafe.Coerce (module X___) where -import "base" Unsafe.Coerce as X___ diff -ruN ghc-6.12.1/libraries/binary/binary.cabal ghc-6.13.20091231/libraries/binary/binary.cabal --- ghc-6.12.1/libraries/binary/binary.cabal 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/binary/binary.cabal 2009-12-31 10:24:49.000000000 -0800 @@ -0,0 +1,58 @@ +name: binary +version: 0.5.0.2 +license: BSD3 +license-file: LICENSE +author: Lennart Kolmodin +maintainer: Lennart Kolmodin, Don Stewart +homepage: http://code.haskell.org/binary/ +description: Efficient, pure binary serialisation using lazy ByteStrings. + Haskell values may be encoded to and from binary formats, + written to disk as binary, or sent over the network. + Serialisation speeds of over 1 G\/sec have been observed, + so this library should be suitable for high performance + scenarios. +synopsis: Binary serialisation for Haskell values using lazy ByteStrings +category: Data, Parsing +stability: provisional +build-type: Simple +cabal-version: >= 1.2 +tested-with: GHC ==6.4.2, GHC ==6.6.1, GHC ==6.8.0, GHC ==6.10.1 +extra-source-files: README index.html + +flag bytestring-in-base +flag split-base +flag applicative-in-base + +library + if flag(bytestring-in-base) + -- bytestring was in base-2.0 and 2.1.1 + build-depends: base >= 2.0 && < 2.2 + cpp-options: -DBYTESTRING_IN_BASE + else + -- in base 1.0 and 3.0 bytestring is a separate package + build-depends: base < 2.0 || >= 3, bytestring >= 0.9 + + if flag(split-base) + build-depends: base >= 3.0, containers, array + else + build-depends: base < 3.0 + + if flag(applicative-in-base) + build-depends: base >= 2.0 + cpp-options: -DAPPLICATIVE_IN_BASE + else + build-depends: base < 2.0 + hs-source-dirs: src + + exposed-modules: Data.Binary, + Data.Binary.Put, + Data.Binary.Get, + Data.Binary.Builder + + extensions: CPP, + FlexibleContexts + + ghc-options: -O2 -Wall -fliberate-case-threshold=1000 + +-- if impl(ghc < 6.5) +-- ghc-options: -fallow-undecidable-instances diff -ruN ghc-6.12.1/libraries/binary/docs/hcar/binary-Lb.tex ghc-6.13.20091231/libraries/binary/docs/hcar/binary-Lb.tex --- ghc-6.12.1/libraries/binary/docs/hcar/binary-Lb.tex 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/binary/docs/hcar/binary-Lb.tex 2009-12-31 10:24:49.000000000 -0800 @@ -0,0 +1,48 @@ +\begin{hcarentry}{binary} +\label{binary} +\report{Lennart Kolmodin} +\status{active} +\participants{Duncan Coutts, Don Stewart, Binary Strike Team} +\makeheader + +The Binary Strike Team is pleased to announce yet a release of a new, +pure, efficient binary serialisation library. + +The `binary' package provides efficient serialisation of Haskell values +to and from lazy ByteStrings. ByteStrings constructed this way may then +be written to disk, written to the network, or further processed (e.g. +stored in memory directly, or compressed in memory with zlib or bzlib). + +The binary library has been heavily tuned for performance, particularly for +writing speed. Throughput of up to 160M/s has been achieved in practice, and +in general speed is on par or better than NewBinary, with the advantage of a +pure interface. Efforts are underway to improve performance still further. +Plans are also taking shape for a parser combinator library on top of +binary, for bit parsing and foreign structure parsing (e.g. network +protocols). + +Data.Derive~\cref{derive} has support for automatically generating Binary +instances, allowing to read and write your data structures with little fuzz. + +Binary was developed by a team of 8 during the Haskell Hackathon in Oxford +2007, and since then has about 15 people contributed code and many more +given feedback and cheerleading on \verb|#haskell|. + +The package is cabalized and available through Hackage~\cref{hackagedb}. +% to editors: ref. to cabal? + +\FurtherReading +\begin{compactitem} +\item Homepage + + \url{http://code.haskell.org/binary/} +\item Hackage + + \url{http://hackage.haskell.org/cgi-bin/hackage-scripts/package/binary} +\item Development version + + \texttt{darcs get --partial} + + \url{http://code.haskell.org/binary} +\end{compactitem} +\end{hcarentry} diff -ruN ghc-6.12.1/libraries/binary/ghc.mk ghc-6.13.20091231/libraries/binary/ghc.mk --- ghc-6.12.1/libraries/binary/ghc.mk 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/binary/ghc.mk 2009-12-31 10:32:42.000000000 -0800 @@ -0,0 +1,3 @@ +libraries/binary_PACKAGE = binary +libraries/binary_dist-install_GROUP = libraries +$(eval $(call build-package,libraries/binary,dist-install,1)) diff -ruN ghc-6.12.1/libraries/binary/GNUmakefile ghc-6.13.20091231/libraries/binary/GNUmakefile --- ghc-6.12.1/libraries/binary/GNUmakefile 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/binary/GNUmakefile 2009-12-31 10:32:42.000000000 -0800 @@ -0,0 +1,3 @@ +dir = libraries/binary +TOP = ../.. +include $(TOP)/mk/sub-makefile.mk diff -ruN ghc-6.12.1/libraries/binary/index.html ghc-6.13.20091231/libraries/binary/index.html --- ghc-6.12.1/libraries/binary/index.html 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/binary/index.html 2009-12-31 10:24:49.000000000 -0800 @@ -0,0 +1,161 @@ + + + + + + Data.Binary - efficient, pure binary serialisation for Haskell + + + + + +
+ +

Data.Binary

+ +
+ +

About

+

+ Data.Binary is a library for high performance binary serialisation + of Haskell data. It uses the + ByteString library to achieve efficient, lazy reading and + writing of structures in binary format. +

+ +

+ Chris Eidhof writes on his use of Data.Binary implementing a + full-text search engine: +

+ 
+   "The communication with Sphinx is done using a quite low-level binary
+    protocol, but Data.Binary saved the day: it made it very easy for us
+    to parse all the binary things. Especially the use of the Get and
+    Put monads are a big improvement over the manual reading and keeping
+    track of positions, as is done in the PHP/Python clients."
+
+ +

Example

+ For example, to serialise an interpreter's abstract syntax tree to + binary format: +
import Data.Binary
+import Control.Monad
+import Codec.Compression.GZip
+
+-- A Haskell AST structure
+data Exp = IntE Int
+         | OpE  String Exp Exp
+   deriving Eq
+
+-- An instance of Binary to encode and decode an Exp in binary
+instance Binary Exp where
+     put (IntE i)          = put (0 :: Word8) >> put i
+     put (OpE s e1 e2)     = put (1 :: Word8) >> put s >> put e1 >> put e2
+     get = do tag <- getWord8
+              case tag of
+                  0 -> liftM  IntE get
+                  1 -> liftM3 OpE  get get get
+
+-- A test expression
+e = OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2))
+
+-- Serialise and compress with gzip, then decompress and deserialise
+main = do
+    let t  = compress (encode e)
+    print t
+    let e' = decode (decompress t)
+    print (e == e')
+
+ +

Download

+ + + +

stable release

+ + + + + + + + + + + +
+ binary 0.4.2 + (Apr 2008)
+ binary 0.4.1 + (Oct 2007)
+ binary 0.4 + (Oct 2007)
+ binary 0.3 + (Mar 2007)
+ binary 0.2 + (Jan 2007)
+

development branch

+ + +
+ darcs get http://code.haskell.org/binary +
+
+ +

Download

+ + +

Project Activity

+ +
+ binary commit statistics +
+ +

Starring...

+ + The Binary Strike Force +
    +
  • Lennart Kolmodin
    • +
  • Duncan Coutts
    • +
  • Don Stewart
    • +
  • Spencer Janssen
    • +
  • David Himmelstrup
    • +
  • Björn Bringert
    • +
  • Ross Paterson
    • +
  • Einar Karttunen
    • +
  • John Meacham
    • +
  • Ulf Norell
    • +
  • Bryan O'Sullivan
    • +
  • Tomasz Zielonka
    • +
  • Florian Weimer
    • +
  • Judah Jacobson
    • +
+ +
+ +covered by HPC +built with Cabal +tested with QuickCheck + +
+ + + + + + diff -ruN ghc-6.12.1/libraries/binary/LICENSE ghc-6.13.20091231/libraries/binary/LICENSE --- ghc-6.12.1/libraries/binary/LICENSE 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/binary/LICENSE 2009-12-31 10:24:49.000000000 -0800 @@ -0,0 +1,30 @@ +Copyright (c) Lennart Kolmodin + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS +OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff -ruN ghc-6.12.1/libraries/binary/README ghc-6.13.20091231/libraries/binary/README --- ghc-6.12.1/libraries/binary/README 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/binary/README 2009-12-31 10:24:49.000000000 -0800 @@ -0,0 +1,74 @@ + + binary: efficient, pure binary serialisation using lazy ByteStrings +------------------------------------------------------------------------ + +The 'binary' package provides Data.Binary, containing the Binary class, +and associated methods, for serialising values to and from lazy +ByteStrings. + +A key feature of 'binary' is that the interface is both pure, and efficient. + +The 'binary' package is portable to GHC and Hugs. + +Building: + + runhaskell Setup.lhs configure + runhaskell Setup.lhs build + runhaskell Setup.lhs install + +First: + import Data.Binary + +and then write an instance of Binary for the type you wish to serialise. +More information in the haddock documentation. + +Deriving: + +It is possible to mechanically derive new instances of Binary for your +types, if they support the Data and Typeable classes. A script is +provided in tools/derive. Here's an example of its use. + + $ cd binary + $ cd tools/derive + + $ ghci -fglasgow-exts BinaryDerive.hs + + *BinaryDerive> :l Example.hs + + *Main> deriveM (undefined :: Drinks) + + instance Binary Main.Drinks where + put (Beer a) = putWord8 0 >> put a + put Coffee = putWord8 1 + put Tea = putWord8 2 + put EnergyDrink = putWord8 3 + put Water = putWord8 4 + put Wine = putWord8 5 + put Whisky = putWord8 6 + get = do + tag_ <- getWord8 + case tag_ of + 0 -> get >>= \a -> return (Beer a) + 1 -> return Coffee + 2 -> return Tea + 3 -> return EnergyDrink + 4 -> return Water + 5 -> return Wine + 6 -> return Whisky + +Contributors: + + Lennart Kolmodin + Duncan Coutts + Don Stewart + Spencer Janssen + David Himmelstrup + Björn Bringert + Ross Paterson + Einar Karttunen + John Meacham + Ulf Norell + Tomasz Zielonka + Stefan Karrmann + Bryan O'Sullivan + Florian Weimer diff -ruN ghc-6.12.1/libraries/binary/Setup.lhs ghc-6.13.20091231/libraries/binary/Setup.lhs --- ghc-6.12.1/libraries/binary/Setup.lhs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/binary/Setup.lhs 2009-12-31 10:24:49.000000000 -0800 @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff -ruN ghc-6.12.1/libraries/binary/src/Data/Binary/Builder.hs ghc-6.13.20091231/libraries/binary/src/Data/Binary/Builder.hs --- ghc-6.12.1/libraries/binary/src/Data/Binary/Builder.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/binary/src/Data/Binary/Builder.hs 2009-12-31 10:24:49.000000000 -0800 @@ -0,0 +1,426 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fglasgow-exts #-} +-- for unboxed shifts + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Binary.Builder +-- Copyright : Lennart Kolmodin, Ross Paterson +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Lennart Kolmodin +-- Stability : experimental +-- Portability : portable to Hugs and GHC +-- +-- Efficient construction of lazy bytestrings. +-- +----------------------------------------------------------------------------- + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +#include "MachDeps.h" +#endif + +module Data.Binary.Builder ( + + -- * The Builder type + Builder + , toLazyByteString + + -- * Constructing Builders + , empty + , singleton + , append + , fromByteString -- :: S.ByteString -> Builder + , fromLazyByteString -- :: L.ByteString -> Builder + + -- * Flushing the buffer state + , flush + + -- * Derived Builders + -- ** Big-endian writes + , putWord16be -- :: Word16 -> Builder + , putWord32be -- :: Word32 -> Builder + , putWord64be -- :: Word64 -> Builder + + -- ** Little-endian writes + , putWord16le -- :: Word16 -> Builder + , putWord32le -- :: Word32 -> Builder + , putWord64le -- :: Word64 -> Builder + + -- ** Host-endian, unaligned writes + , putWordhost -- :: Word -> Builder + , putWord16host -- :: Word16 -> Builder + , putWord32host -- :: Word32 -> Builder + , putWord64host -- :: Word64 -> Builder + + ) where + +import Foreign +import Data.Monoid +import Data.Word +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + +#ifdef BYTESTRING_IN_BASE +import Data.ByteString.Base (inlinePerformIO) +import qualified Data.ByteString.Base as S +#else +import Data.ByteString.Internal (inlinePerformIO) +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Lazy.Internal as L +#endif + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +import GHC.Base +import GHC.Word (Word32(..),Word16(..),Word64(..)) + +#if WORD_SIZE_IN_BITS < 64 && __GLASGOW_HASKELL__ >= 608 +import GHC.Word (uncheckedShiftRL64#) +#endif +#endif + +------------------------------------------------------------------------ + +-- | A 'Builder' is an efficient way to build lazy 'L.ByteString's. +-- There are several functions for constructing 'Builder's, but only one +-- to inspect them: to extract any data, you have to turn them into lazy +-- 'L.ByteString's using 'toLazyByteString'. +-- +-- Internally, a 'Builder' constructs a lazy 'L.Bytestring' by filling byte +-- arrays piece by piece. As each buffer is filled, it is \'popped\' +-- off, to become a new chunk of the resulting lazy 'L.ByteString'. +-- All this is hidden from the user of the 'Builder'. + +newtype Builder = Builder { + -- Invariant (from Data.ByteString.Lazy): + -- The lists include no null ByteStrings. + runBuilder :: (Buffer -> [S.ByteString]) -> Buffer -> [S.ByteString] + } + +instance Monoid Builder where + mempty = empty + {-# INLINE mempty #-} + mappend = append + {-# INLINE mappend #-} + +------------------------------------------------------------------------ + +-- | /O(1)./ The empty Builder, satisfying +-- +-- * @'toLazyByteString' 'empty' = 'L.empty'@ +-- +empty :: Builder +empty = Builder id +{-# INLINE empty #-} + +-- | /O(1)./ A Builder taking a single byte, satisfying +-- +-- * @'toLazyByteString' ('singleton' b) = 'L.singleton' b@ +-- +singleton :: Word8 -> Builder +singleton = writeN 1 . flip poke +{-# INLINE singleton #-} + +------------------------------------------------------------------------ + +-- | /O(1)./ The concatenation of two Builders, an associative operation +-- with identity 'empty', satisfying +-- +-- * @'toLazyByteString' ('append' x y) = 'L.append' ('toLazyByteString' x) ('toLazyByteString' y)@ +-- +append :: Builder -> Builder -> Builder +append (Builder f) (Builder g) = Builder (f . g) +{-# INLINE append #-} + +-- | /O(1)./ A Builder taking a 'S.ByteString', satisfying +-- +-- * @'toLazyByteString' ('fromByteString' bs) = 'L.fromChunks' [bs]@ +-- +fromByteString :: S.ByteString -> Builder +fromByteString bs + | S.null bs = empty + | otherwise = flush `append` mapBuilder (bs :) +{-# INLINE fromByteString #-} + +-- | /O(1)./ A Builder taking a lazy 'L.ByteString', satisfying +-- +-- * @'toLazyByteString' ('fromLazyByteString' bs) = bs@ +-- +fromLazyByteString :: L.ByteString -> Builder +fromLazyByteString bss = flush `append` mapBuilder (L.toChunks bss ++) +{-# INLINE fromLazyByteString #-} + +------------------------------------------------------------------------ + +-- Our internal buffer type +data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8) + {-# UNPACK #-} !Int -- offset + {-# UNPACK #-} !Int -- used bytes + {-# UNPACK #-} !Int -- length left + +------------------------------------------------------------------------ + +-- | /O(n)./ Extract a lazy 'L.ByteString' from a 'Builder'. +-- The construction work takes place if and when the relevant part of +-- the lazy 'L.ByteString' is demanded. +-- +toLazyByteString :: Builder -> L.ByteString +toLazyByteString m = L.fromChunks $ unsafePerformIO $ do + buf <- newBuffer defaultSize + return (runBuilder (m `append` flush) (const []) buf) + +-- | /O(1)./ Pop the 'S.ByteString' we have constructed so far, if any, +-- yielding a new chunk in the result lazy 'L.ByteString'. +flush :: Builder +flush = Builder $ \ k buf@(Buffer p o u l) -> + if u == 0 + then k buf + else S.PS p o u : k (Buffer p (o+u) 0 l) + +------------------------------------------------------------------------ + +-- +-- copied from Data.ByteString.Lazy +-- +defaultSize :: Int +defaultSize = 32 * k - overhead + where k = 1024 + overhead = 2 * sizeOf (undefined :: Int) + +------------------------------------------------------------------------ + +-- | Sequence an IO operation on the buffer +unsafeLiftIO :: (Buffer -> IO Buffer) -> Builder +unsafeLiftIO f = Builder $ \ k buf -> inlinePerformIO $ do + buf' <- f buf + return (k buf') +{-# INLINE unsafeLiftIO #-} + +-- | Get the size of the buffer +withSize :: (Int -> Builder) -> Builder +withSize f = Builder $ \ k buf@(Buffer _ _ _ l) -> + runBuilder (f l) k buf + +-- | Map the resulting list of bytestrings. +mapBuilder :: ([S.ByteString] -> [S.ByteString]) -> Builder +mapBuilder f = Builder (f .) + +------------------------------------------------------------------------ + +-- | Ensure that there are at least @n@ many bytes available. +ensureFree :: Int -> Builder +ensureFree n = n `seq` withSize $ \ l -> + if n <= l then empty else + flush `append` unsafeLiftIO (const (newBuffer (max n defaultSize))) +{-# INLINE ensureFree #-} + +-- | Ensure that @n@ many bytes are available, and then use @f@ to write some +-- bytes into the memory. +writeN :: Int -> (Ptr Word8 -> IO ()) -> Builder +writeN n f = ensureFree n `append` unsafeLiftIO (writeNBuffer n f) +{-# INLINE writeN #-} + +writeNBuffer :: Int -> (Ptr Word8 -> IO ()) -> Buffer -> IO Buffer +writeNBuffer n f (Buffer fp o u l) = do + withForeignPtr fp (\p -> f (p `plusPtr` (o+u))) + return (Buffer fp o (u+n) (l-n)) +{-# INLINE writeNBuffer #-} + +newBuffer :: Int -> IO Buffer +newBuffer size = do + fp <- S.mallocByteString size + return $! Buffer fp 0 0 size +{-# INLINE newBuffer #-} + +------------------------------------------------------------------------ +-- Aligned, host order writes of storable values + +-- | Ensure that @n@ many bytes are available, and then use @f@ to write some +-- storable values into the memory. +writeNbytes :: Storable a => Int -> (Ptr a -> IO ()) -> Builder +writeNbytes n f = ensureFree n `append` unsafeLiftIO (writeNBufferBytes n f) +{-# INLINE writeNbytes #-} + +writeNBufferBytes :: Storable a => Int -> (Ptr a -> IO ()) -> Buffer -> IO Buffer +writeNBufferBytes n f (Buffer fp o u l) = do + withForeignPtr fp (\p -> f (p `plusPtr` (o+u))) + return (Buffer fp o (u+n) (l-n)) +{-# INLINE writeNBufferBytes #-} + +------------------------------------------------------------------------ + +-- +-- We rely on the fromIntegral to do the right masking for us. +-- The inlining here is critical, and can be worth 4x performance +-- + +-- | Write a Word16 in big endian format +putWord16be :: Word16 -> Builder +putWord16be w = writeN 2 $ \p -> do + poke p (fromIntegral (shiftr_w16 w 8) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (w) :: Word8) +{-# INLINE putWord16be #-} + +-- | Write a Word16 in little endian format +putWord16le :: Word16 -> Builder +putWord16le w = writeN 2 $ \p -> do + poke p (fromIntegral (w) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w16 w 8) :: Word8) +{-# INLINE putWord16le #-} + +-- putWord16le w16 = writeN 2 (\p -> poke (castPtr p) w16) + +-- | Write a Word32 in big endian format +putWord32be :: Word32 -> Builder +putWord32be w = writeN 4 $ \p -> do + poke p (fromIntegral (shiftr_w32 w 24) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 16) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 8) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (w) :: Word8) +{-# INLINE putWord32be #-} + +-- +-- a data type to tag Put/Check. writes construct these which are then +-- inlined and flattened. matching Checks will be more robust with rules. +-- + +-- | Write a Word32 in little endian format +putWord32le :: Word32 -> Builder +putWord32le w = writeN 4 $ \p -> do + poke p (fromIntegral (w) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 8) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 16) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 w 24) :: Word8) +{-# INLINE putWord32le #-} + +-- on a little endian machine: +-- putWord32le w32 = writeN 4 (\p -> poke (castPtr p) w32) + +-- | Write a Word64 in big endian format +putWord64be :: Word64 -> Builder +#if WORD_SIZE_IN_BITS < 64 +-- +-- To avoid expensive 64 bit shifts on 32 bit machines, we cast to +-- Word32, and write that +-- +putWord64be w = + let a = fromIntegral (shiftr_w64 w 32) :: Word32 + b = fromIntegral w :: Word32 + in writeN 8 $ \p -> do + poke p (fromIntegral (shiftr_w32 a 24) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 16) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 8) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (a) :: Word8) + poke (p `plusPtr` 4) (fromIntegral (shiftr_w32 b 24) :: Word8) + poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 16) :: Word8) + poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 8) :: Word8) + poke (p `plusPtr` 7) (fromIntegral (b) :: Word8) +#else +putWord64be w = writeN 8 $ \p -> do + poke p (fromIntegral (shiftr_w64 w 56) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 48) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 40) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 32) :: Word8) + poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 24) :: Word8) + poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 16) :: Word8) + poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 8) :: Word8) + poke (p `plusPtr` 7) (fromIntegral (w) :: Word8) +#endif +{-# INLINE putWord64be #-} + +-- | Write a Word64 in little endian format +putWord64le :: Word64 -> Builder + +#if WORD_SIZE_IN_BITS < 64 +putWord64le w = + let b = fromIntegral (shiftr_w64 w 32) :: Word32 + a = fromIntegral w :: Word32 + in writeN 8 $ \p -> do + poke (p) (fromIntegral (a) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 8) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 16) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 a 24) :: Word8) + poke (p `plusPtr` 4) (fromIntegral (b) :: Word8) + poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 8) :: Word8) + poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 16) :: Word8) + poke (p `plusPtr` 7) (fromIntegral (shiftr_w32 b 24) :: Word8) +#else +putWord64le w = writeN 8 $ \p -> do + poke p (fromIntegral (w) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 8) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 16) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 24) :: Word8) + poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 32) :: Word8) + poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 40) :: Word8) + poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 48) :: Word8) + poke (p `plusPtr` 7) (fromIntegral (shiftr_w64 w 56) :: Word8) +#endif +{-# INLINE putWord64le #-} + +-- on a little endian machine: +-- putWord64le w64 = writeN 8 (\p -> poke (castPtr p) w64) + +------------------------------------------------------------------------ +-- Unaligned, word size ops + +-- | /O(1)./ A Builder taking a single native machine word. The word is +-- written in host order, host endian form, for the machine you're on. +-- On a 64 bit machine the Word is an 8 byte value, on a 32 bit machine, +-- 4 bytes. Values written this way are not portable to +-- different endian or word sized machines, without conversion. +-- +putWordhost :: Word -> Builder +putWordhost w = writeNbytes (sizeOf (undefined :: Word)) (\p -> poke p w) +{-# INLINE putWordhost #-} + +-- | Write a Word16 in native host order and host endianness. +-- 2 bytes will be written, unaligned. +putWord16host :: Word16 -> Builder +putWord16host w16 = writeNbytes (sizeOf (undefined :: Word16)) (\p -> poke p w16) +{-# INLINE putWord16host #-} + +-- | Write a Word32 in native host order and host endianness. +-- 4 bytes will be written, unaligned. +putWord32host :: Word32 -> Builder +putWord32host w32 = writeNbytes (sizeOf (undefined :: Word32)) (\p -> poke p w32) +{-# INLINE putWord32host #-} + +-- | Write a Word64 in native host order. +-- On a 32 bit machine we write two host order Word32s, in big endian form. +-- 8 bytes will be written, unaligned. +putWord64host :: Word64 -> Builder +putWord64host w = writeNbytes (sizeOf (undefined :: Word64)) (\p -> poke p w) +{-# INLINE putWord64host #-} + +------------------------------------------------------------------------ +-- Unchecked shifts + +{-# INLINE shiftr_w16 #-} +shiftr_w16 :: Word16 -> Int -> Word16 +{-# INLINE shiftr_w32 #-} +shiftr_w32 :: Word32 -> Int -> Word32 +{-# INLINE shiftr_w64 #-} +shiftr_w64 :: Word64 -> Int -> Word64 + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i) +shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i) + +#if WORD_SIZE_IN_BITS < 64 +shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i) + +#if __GLASGOW_HASKELL__ <= 606 +-- Exported by GHC.Word in GHC 6.8 and higher +foreign import ccall unsafe "stg_uncheckedShiftRL64" + uncheckedShiftRL64# :: Word64# -> Int# -> Word64# +#endif + +#else +shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i) +#endif + +#else +shiftr_w16 = shiftR +shiftr_w32 = shiftR +shiftr_w64 = shiftR +#endif diff -ruN ghc-6.12.1/libraries/binary/src/Data/Binary/Get.hs ghc-6.13.20091231/libraries/binary/src/Data/Binary/Get.hs --- ghc-6.12.1/libraries/binary/src/Data/Binary/Get.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/binary/src/Data/Binary/Get.hs 2009-12-31 10:24:49.000000000 -0800 @@ -0,0 +1,547 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fglasgow-exts #-} +-- for unboxed shifts + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Binary.Get +-- Copyright : Lennart Kolmodin +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Lennart Kolmodin +-- Stability : experimental +-- Portability : portable to Hugs and GHC. +-- +-- The Get monad. A monad for efficiently building structures from +-- encoded lazy ByteStrings +-- +----------------------------------------------------------------------------- + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +#include "MachDeps.h" +#endif + +module Data.Binary.Get ( + + -- * The Get type + Get + , runGet + , runGetState + + -- * Parsing + , skip + , uncheckedSkip + , lookAhead + , lookAheadM + , lookAheadE + , uncheckedLookAhead + + -- * Utility + , bytesRead + , getBytes + , remaining + , isEmpty + + -- * Parsing particular types + , getWord8 + + -- ** ByteStrings + , getByteString + , getLazyByteString + , getLazyByteStringNul + , getRemainingLazyByteString + + -- ** Big-endian reads + , getWord16be + , getWord32be + , getWord64be + + -- ** Little-endian reads + , getWord16le + , getWord32le + , getWord64le + + -- ** Host-endian, unaligned reads + , getWordhost + , getWord16host + , getWord32host + , getWord64host + + ) where + +import Control.Monad (when,liftM,ap) +import Control.Monad.Fix +import Data.Maybe (isNothing) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L + +#ifdef BYTESTRING_IN_BASE +import qualified Data.ByteString.Base as B +#else +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Lazy.Internal as L +#endif + +#ifdef APPLICATIVE_IN_BASE +import Control.Applicative (Applicative(..)) +#endif + +import Foreign + +-- used by splitAtST +import Control.Monad.ST +import Data.STRef + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +import GHC.Base +import GHC.Word +import GHC.Int +#endif + +-- | The parse state +data S = S {-# UNPACK #-} !B.ByteString -- current chunk + L.ByteString -- the rest of the input + {-# UNPACK #-} !Int64 -- bytes read + +-- | The Get monad is just a State monad carrying around the input ByteString +-- We treat it as a strict state monad. +newtype Get a = Get { unGet :: S -> (# a, S #) } + +instance Functor Get where + fmap f m = Get (\s -> case unGet m s of + (# a, s' #) -> (# f a, s' #)) + {-# INLINE fmap #-} + +#ifdef APPLICATIVE_IN_BASE +instance Applicative Get where + pure = return + (<*>) = ap +#endif + +-- Definition directly from Control.Monad.State.Strict +instance Monad Get where + return a = Get $ \s -> (# a, s #) + {-# INLINE return #-} + + m >>= k = Get $ \s -> case unGet m s of + (# a, s' #) -> unGet (k a) s' + {-# INLINE (>>=) #-} + + fail = failDesc + +instance MonadFix Get where + mfix f = Get $ \s -> let (a,s') = case unGet (f a) s of + (# a', s'' #) -> (a',s'') + in (# a,s' #) + +------------------------------------------------------------------------ + +get :: Get S +get = Get $ \s -> (# s, s #) + +put :: S -> Get () +put s = Get $ \_ -> (# (), s #) + +------------------------------------------------------------------------ +-- +-- dons, GHC 6.10: explicit inlining disabled, was killing performance. +-- Without it, GHC seems to do just fine. And we get similar +-- performance with 6.8.2 anyway. +-- + +initState :: L.ByteString -> S +initState xs = mkState xs 0 +{- INLINE initState -} + +{- +initState (B.LPS xs) = + case xs of + [] -> S B.empty L.empty 0 + (x:xs') -> S x (B.LPS xs') 0 +-} + +#ifndef BYTESTRING_IN_BASE +mkState :: L.ByteString -> Int64 -> S +mkState l = case l of + L.Empty -> S B.empty L.empty + L.Chunk x xs -> S x xs +{- INLINE mkState -} + +#else +mkState :: L.ByteString -> Int64 -> S +mkState (B.LPS xs) = + case xs of + [] -> S B.empty L.empty + (x:xs') -> S x (B.LPS xs') +#endif + +-- | Run the Get monad applies a 'get'-based parser on the input ByteString +runGet :: Get a -> L.ByteString -> a +runGet m str = case unGet m (initState str) of (# a, _ #) -> a + +-- | Run the Get monad applies a 'get'-based parser on the input +-- ByteString. Additional to the result of get it returns the number of +-- consumed bytes and the rest of the input. +runGetState :: Get a -> L.ByteString -> Int64 -> (a, L.ByteString, Int64) +runGetState m str off = + case unGet m (mkState str off) of + (# a, ~(S s ss newOff) #) -> (a, s `join` ss, newOff) + +------------------------------------------------------------------------ + +failDesc :: String -> Get a +failDesc err = do + S _ _ bytes <- get + Get (error (err ++ ". Failed reading at byte position " ++ show bytes)) + +-- | Skip ahead @n@ bytes. Fails if fewer than @n@ bytes are available. +skip :: Int -> Get () +skip n = readN (fromIntegral n) (const ()) + +-- | Skip ahead @n@ bytes. No error if there isn't enough bytes. +uncheckedSkip :: Int64 -> Get () +uncheckedSkip n = do + S s ss bytes <- get + if fromIntegral (B.length s) >= n + then put (S (B.drop (fromIntegral n) s) ss (bytes + n)) + else do + let rest = L.drop (n - fromIntegral (B.length s)) ss + put $! mkState rest (bytes + n) + +-- | Run @ga@, but return without consuming its input. +-- Fails if @ga@ fails. +lookAhead :: Get a -> Get a +lookAhead ga = do + s <- get + a <- ga + put s + return a + +-- | Like 'lookAhead', but consume the input if @gma@ returns 'Just _'. +-- Fails if @gma@ fails. +lookAheadM :: Get (Maybe a) -> Get (Maybe a) +lookAheadM gma = do + s <- get + ma <- gma + when (isNothing ma) $ + put s + return ma + +-- | Like 'lookAhead', but consume the input if @gea@ returns 'Right _'. +-- Fails if @gea@ fails. +lookAheadE :: Get (Either a b) -> Get (Either a b) +lookAheadE gea = do + s <- get + ea <- gea + case ea of + Left _ -> put s + _ -> return () + return ea + +-- | Get the next up to @n@ bytes as a lazy ByteString, without consuming them. +uncheckedLookAhead :: Int64 -> Get L.ByteString +uncheckedLookAhead n = do + S s ss _ <- get + if n <= fromIntegral (B.length s) + then return (L.fromChunks [B.take (fromIntegral n) s]) + else return $ L.take n (s `join` ss) + +------------------------------------------------------------------------ +-- Utility + +-- | Get the total number of bytes read to this point. +bytesRead :: Get Int64 +bytesRead = do + S _ _ b <- get + return b + +-- | Get the number of remaining unparsed bytes. +-- Useful for checking whether all input has been consumed. +-- Note that this forces the rest of the input. +remaining :: Get Int64 +remaining = do + S s ss _ <- get + return (fromIntegral (B.length s) + L.length ss) + +-- | Test whether all input has been consumed, +-- i.e. there are no remaining unparsed bytes. +isEmpty :: Get Bool +isEmpty = do + S s ss _ <- get + return (B.null s && L.null ss) + +------------------------------------------------------------------------ +-- Utility with ByteStrings + +-- | An efficient 'get' method for strict ByteStrings. Fails if fewer +-- than @n@ bytes are left in the input. +getByteString :: Int -> Get B.ByteString +getByteString n = readN n id +{-# INLINE getByteString #-} + +-- | An efficient 'get' method for lazy ByteStrings. Does not fail if fewer than +-- @n@ bytes are left in the input. +getLazyByteString :: Int64 -> Get L.ByteString +getLazyByteString n = do + S s ss bytes <- get + let big = s `join` ss + case splitAtST n big of + (consume, rest) -> do put $ mkState rest (bytes + n) + return consume +{-# INLINE getLazyByteString #-} + +-- | Get a lazy ByteString that is terminated with a NUL byte. Fails +-- if it reaches the end of input without hitting a NUL. +getLazyByteStringNul :: Get L.ByteString +getLazyByteStringNul = do + S s ss bytes <- get + let big = s `join` ss + (consume, t) = L.break (== 0) big + (h, rest) = L.splitAt 1 t + if L.null h + then fail "too few bytes" + else do + put $ mkState rest (bytes + L.length consume + 1) + return consume +{-# INLINE getLazyByteStringNul #-} + +-- | Get the remaining bytes as a lazy ByteString +getRemainingLazyByteString :: Get L.ByteString +getRemainingLazyByteString = do + S s ss _ <- get + return (s `join` ss) + +------------------------------------------------------------------------ +-- Helpers + +-- | Pull @n@ bytes from the input, as a strict ByteString. +getBytes :: Int -> Get B.ByteString +getBytes n = do + S s ss bytes <- get + if n <= B.length s + then do let (consume,rest) = B.splitAt n s + put $! S rest ss (bytes + fromIntegral n) + return $! consume + else + case L.splitAt (fromIntegral n) (s `join` ss) of + (consuming, rest) -> + do let now = B.concat . L.toChunks $ consuming + put $! mkState rest (bytes + fromIntegral n) + -- forces the next chunk before this one is returned + if (B.length now < n) + then + fail "too few bytes" + else + return now +{- INLINE getBytes -} +-- ^ important + +#ifndef BYTESTRING_IN_BASE +join :: B.ByteString -> L.ByteString -> L.ByteString +join bb lb + | B.null bb = lb + | otherwise = L.Chunk bb lb + +#else +join :: B.ByteString -> L.ByteString -> L.ByteString +join bb (B.LPS lb) + | B.null bb = B.LPS lb + | otherwise = B.LPS (bb:lb) +#endif + -- don't use L.append, it's strict in it's second argument :/ +{- INLINE join -} + +-- | Split a ByteString. If the first result is consumed before the -- +-- second, this runs in constant heap space. +-- +-- You must force the returned tuple for that to work, e.g. +-- +-- > case splitAtST n xs of +-- > (ys,zs) -> consume ys ... consume zs +-- +splitAtST :: Int64 -> L.ByteString -> (L.ByteString, L.ByteString) +splitAtST i ps | i <= 0 = (L.empty, ps) +#ifndef BYTESTRING_IN_BASE +splitAtST i ps = runST ( + do r <- newSTRef undefined + xs <- first r i ps + ys <- unsafeInterleaveST (readSTRef r) + return (xs, ys)) + + where + first r 0 xs@(L.Chunk _ _) = writeSTRef r xs >> return L.Empty + first r _ L.Empty = writeSTRef r L.Empty >> return L.Empty + + first r n (L.Chunk x xs) + | n < l = do writeSTRef r (L.Chunk (B.drop (fromIntegral n) x) xs) + return $ L.Chunk (B.take (fromIntegral n) x) L.Empty + | otherwise = do writeSTRef r (L.drop (n - l) xs) + liftM (L.Chunk x) $ unsafeInterleaveST (first r (n - l) xs) + + where l = fromIntegral (B.length x) +#else +splitAtST i (B.LPS ps) = runST ( + do r <- newSTRef undefined + xs <- first r i ps + ys <- unsafeInterleaveST (readSTRef r) + return (B.LPS xs, B.LPS ys)) + + where first r 0 xs = writeSTRef r xs >> return [] + first r _ [] = writeSTRef r [] >> return [] + first r n (x:xs) + | n < l = do writeSTRef r (B.drop (fromIntegral n) x : xs) + return [B.take (fromIntegral n) x] + | otherwise = do writeSTRef r (L.toChunks (L.drop (n - l) (B.LPS xs))) + fmap (x:) $ unsafeInterleaveST (first r (n - l) xs) + + where l = fromIntegral (B.length x) +#endif +{- INLINE splitAtST -} + +-- Pull n bytes from the input, and apply a parser to those bytes, +-- yielding a value. If less than @n@ bytes are available, fail with an +-- error. This wraps @getBytes@. +readN :: Int -> (B.ByteString -> a) -> Get a +readN n f = fmap f $ getBytes n +{- INLINE readN -} +-- ^ important + +------------------------------------------------------------------------ +-- Primtives + +-- helper, get a raw Ptr onto a strict ByteString copied out of the +-- underlying lazy byteString. So many indirections from the raw parser +-- state that my head hurts... + +getPtr :: Storable a => Int -> Get a +getPtr n = do + (fp,o,_) <- readN n B.toForeignPtr + return . B.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o) +{- INLINE getPtr -} + +------------------------------------------------------------------------ + +-- | Read a Word8 from the monad state +getWord8 :: Get Word8 +getWord8 = getPtr (sizeOf (undefined :: Word8)) +{- INLINE getWord8 -} + +-- | Read a Word16 in big endian format +getWord16be :: Get Word16 +getWord16be = do + s <- readN 2 id + return $! (fromIntegral (s `B.index` 0) `shiftl_w16` 8) .|. + (fromIntegral (s `B.index` 1)) +{- INLINE getWord16be -} + +-- | Read a Word16 in little endian format +getWord16le :: Get Word16 +getWord16le = do + s <- readN 2 id + return $! (fromIntegral (s `B.index` 1) `shiftl_w16` 8) .|. + (fromIntegral (s `B.index` 0) ) +{- INLINE getWord16le -} + +-- | Read a Word32 in big endian format +getWord32be :: Get Word32 +getWord32be = do + s <- readN 4 id + return $! (fromIntegral (s `B.index` 0) `shiftl_w32` 24) .|. + (fromIntegral (s `B.index` 1) `shiftl_w32` 16) .|. + (fromIntegral (s `B.index` 2) `shiftl_w32` 8) .|. + (fromIntegral (s `B.index` 3) ) +{- INLINE getWord32be -} + +-- | Read a Word32 in little endian format +getWord32le :: Get Word32 +getWord32le = do + s <- readN 4 id + return $! (fromIntegral (s `B.index` 3) `shiftl_w32` 24) .|. + (fromIntegral (s `B.index` 2) `shiftl_w32` 16) .|. + (fromIntegral (s `B.index` 1) `shiftl_w32` 8) .|. + (fromIntegral (s `B.index` 0) ) +{- INLINE getWord32le -} + +-- | Read a Word64 in big endian format +getWord64be :: Get Word64 +getWord64be = do + s <- readN 8 id + return $! (fromIntegral (s `B.index` 0) `shiftl_w64` 56) .|. + (fromIntegral (s `B.index` 1) `shiftl_w64` 48) .|. + (fromIntegral (s `B.index` 2) `shiftl_w64` 40) .|. + (fromIntegral (s `B.index` 3) `shiftl_w64` 32) .|. + (fromIntegral (s `B.index` 4) `shiftl_w64` 24) .|. + (fromIntegral (s `B.index` 5) `shiftl_w64` 16) .|. + (fromIntegral (s `B.index` 6) `shiftl_w64` 8) .|. + (fromIntegral (s `B.index` 7) ) +{- INLINE getWord64be -} + +-- | Read a Word64 in little endian format +getWord64le :: Get Word64 +getWord64le = do + s <- readN 8 id + return $! (fromIntegral (s `B.index` 7) `shiftl_w64` 56) .|. + (fromIntegral (s `B.index` 6) `shiftl_w64` 48) .|. + (fromIntegral (s `B.index` 5) `shiftl_w64` 40) .|. + (fromIntegral (s `B.index` 4) `shiftl_w64` 32) .|. + (fromIntegral (s `B.index` 3) `shiftl_w64` 24) .|. + (fromIntegral (s `B.index` 2) `shiftl_w64` 16) .|. + (fromIntegral (s `B.index` 1) `shiftl_w64` 8) .|. + (fromIntegral (s `B.index` 0) ) +{- INLINE getWord64le -} + +------------------------------------------------------------------------ +-- Host-endian reads + +-- | /O(1)./ Read a single native machine word. The word is read in +-- host order, host endian form, for the machine you're on. On a 64 bit +-- machine the Word is an 8 byte value, on a 32 bit machine, 4 bytes. +getWordhost :: Get Word +getWordhost = getPtr (sizeOf (undefined :: Word)) +{- INLINE getWordhost -} + +-- | /O(1)./ Read a 2 byte Word16 in native host order and host endianness. +getWord16host :: Get Word16 +getWord16host = getPtr (sizeOf (undefined :: Word16)) +{- INLINE getWord16host -} + +-- | /O(1)./ Read a Word32 in native host order and host endianness. +getWord32host :: Get Word32 +getWord32host = getPtr (sizeOf (undefined :: Word32)) +{- INLINE getWord32host -} + +-- | /O(1)./ Read a Word64 in native host order and host endianess. +getWord64host :: Get Word64 +getWord64host = getPtr (sizeOf (undefined :: Word64)) +{- INLINE getWord64host -} + +------------------------------------------------------------------------ +-- Unchecked shifts + +shiftl_w16 :: Word16 -> Int -> Word16 +shiftl_w32 :: Word32 -> Int -> Word32 +shiftl_w64 :: Word64 -> Int -> Word64 + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i) +shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i) + +#if WORD_SIZE_IN_BITS < 64 +shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i) + +#if __GLASGOW_HASKELL__ <= 606 +-- Exported by GHC.Word in GHC 6.8 and higher +foreign import ccall unsafe "stg_uncheckedShiftL64" + uncheckedShiftL64# :: Word64# -> Int# -> Word64# +#endif + +#else +shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i) +#endif + +#else +shiftl_w16 = shiftL +shiftl_w32 = shiftL +shiftl_w64 = shiftL +#endif diff -ruN ghc-6.12.1/libraries/binary/src/Data/Binary/Put.hs ghc-6.13.20091231/libraries/binary/src/Data/Binary/Put.hs --- ghc-6.12.1/libraries/binary/src/Data/Binary/Put.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/binary/src/Data/Binary/Put.hs 2009-12-31 10:24:49.000000000 -0800 @@ -0,0 +1,215 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Binary.Put +-- Copyright : Lennart Kolmodin +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Lennart Kolmodin +-- Stability : stable +-- Portability : Portable to Hugs and GHC. Requires MPTCs +-- +-- The Put monad. A monad for efficiently constructing lazy bytestrings. +-- +----------------------------------------------------------------------------- + +module Data.Binary.Put ( + + -- * The Put type + Put + , PutM(..) + , runPut + , runPutM + , putBuilder + , execPut + + -- * Flushing the implicit parse state + , flush + + -- * Primitives + , putWord8 + , putByteString + , putLazyByteString + + -- * Big-endian primitives + , putWord16be + , putWord32be + , putWord64be + + -- * Little-endian primitives + , putWord16le + , putWord32le + , putWord64le + + -- * Host-endian, unaligned writes + , putWordhost -- :: Word -> Put + , putWord16host -- :: Word16 -> Put + , putWord32host -- :: Word32 -> Put + , putWord64host -- :: Word64 -> Put + + ) where + +import Data.Monoid +import Data.Binary.Builder (Builder, toLazyByteString) +import qualified Data.Binary.Builder as B + +import Data.Word +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + +#ifdef APPLICATIVE_IN_BASE +import Control.Applicative +#endif + + +------------------------------------------------------------------------ + +-- XXX Strict in buffer only. +data PairS a = PairS a {-# UNPACK #-}!Builder + +sndS :: PairS a -> Builder +sndS (PairS _ b) = b + +-- | The PutM type. A Writer monad over the efficient Builder monoid. +newtype PutM a = Put { unPut :: PairS a } + +-- | Put merely lifts Builder into a Writer monad, applied to (). +type Put = PutM () + +instance Functor PutM where + fmap f m = Put $ let PairS a w = unPut m in PairS (f a) w + {-# INLINE fmap #-} + +#ifdef APPLICATIVE_IN_BASE +instance Applicative PutM where + pure = return + m <*> k = Put $ + let PairS f w = unPut m + PairS x w' = unPut k + in PairS (f x) (w `mappend` w') +#endif + +-- Standard Writer monad, with aggressive inlining +instance Monad PutM where + return a = Put $ PairS a mempty + {-# INLINE return #-} + + m >>= k = Put $ + let PairS a w = unPut m + PairS b w' = unPut (k a) + in PairS b (w `mappend` w') + {-# INLINE (>>=) #-} + + m >> k = Put $ + let PairS _ w = unPut m + PairS b w' = unPut k + in PairS b (w `mappend` w') + {-# INLINE (>>) #-} + +tell :: Builder -> Put +tell b = Put $ PairS () b +{-# INLINE tell #-} + +putBuilder :: Builder -> Put +putBuilder = tell +{-# INLINE putBuilder #-} + +-- | Run the 'Put' monad +execPut :: PutM a -> Builder +execPut = sndS . unPut +{-# INLINE execPut #-} + +-- | Run the 'Put' monad with a serialiser +runPut :: Put -> L.ByteString +runPut = toLazyByteString . sndS . unPut +{-# INLINE runPut #-} + +-- | Run the 'Put' monad with a serialiser and get its result +runPutM :: PutM a -> (a, L.ByteString) +runPutM (Put (PairS f s)) = (f, toLazyByteString s) +{-# INLINE runPutM #-} + +------------------------------------------------------------------------ + +-- | Pop the ByteString we have constructed so far, if any, yielding a +-- new chunk in the result ByteString. +flush :: Put +flush = tell B.flush +{-# INLINE flush #-} + +-- | Efficiently write a byte into the output buffer +putWord8 :: Word8 -> Put +putWord8 = tell . B.singleton +{-# INLINE putWord8 #-} + +-- | An efficient primitive to write a strict ByteString into the output buffer. +-- It flushes the current buffer, and writes the argument into a new chunk. +putByteString :: S.ByteString -> Put +putByteString = tell . B.fromByteString +{-# INLINE putByteString #-} + +-- | Write a lazy ByteString efficiently, simply appending the lazy +-- ByteString chunks to the output buffer +putLazyByteString :: L.ByteString -> Put +putLazyByteString = tell . B.fromLazyByteString +{-# INLINE putLazyByteString #-} + +-- | Write a Word16 in big endian format +putWord16be :: Word16 -> Put +putWord16be = tell . B.putWord16be +{-# INLINE putWord16be #-} + +-- | Write a Word16 in little endian format +putWord16le :: Word16 -> Put +putWord16le = tell . B.putWord16le +{-# INLINE putWord16le #-} + +-- | Write a Word32 in big endian format +putWord32be :: Word32 -> Put +putWord32be = tell . B.putWord32be +{-# INLINE putWord32be #-} + +-- | Write a Word32 in little endian format +putWord32le :: Word32 -> Put +putWord32le = tell . B.putWord32le +{-# INLINE putWord32le #-} + +-- | Write a Word64 in big endian format +putWord64be :: Word64 -> Put +putWord64be = tell . B.putWord64be +{-# INLINE putWord64be #-} + +-- | Write a Word64 in little endian format +putWord64le :: Word64 -> Put +putWord64le = tell . B.putWord64le +{-# INLINE putWord64le #-} + +------------------------------------------------------------------------ + +-- | /O(1)./ Write a single native machine word. The word is +-- written in host order, host endian form, for the machine you're on. +-- On a 64 bit machine the Word is an 8 byte value, on a 32 bit machine, +-- 4 bytes. Values written this way are not portable to +-- different endian or word sized machines, without conversion. +-- +putWordhost :: Word -> Put +putWordhost = tell . B.putWordhost +{-# INLINE putWordhost #-} + +-- | /O(1)./ Write a Word16 in native host order and host endianness. +-- For portability issues see @putWordhost@. +putWord16host :: Word16 -> Put +putWord16host = tell . B.putWord16host +{-# INLINE putWord16host #-} + +-- | /O(1)./ Write a Word32 in native host order and host endianness. +-- For portability issues see @putWordhost@. +putWord32host :: Word32 -> Put +putWord32host = tell . B.putWord32host +{-# INLINE putWord32host #-} + +-- | /O(1)./ Write a Word64 in native host order +-- On a 32 bit machine we write two host order Word32s, in big endian form. +-- For portability issues see @putWordhost@. +putWord64host :: Word64 -> Put +putWord64host = tell . B.putWord64host +{-# INLINE putWord64host #-} diff -ruN ghc-6.12.1/libraries/binary/src/Data/Binary.hs ghc-6.13.20091231/libraries/binary/src/Data/Binary.hs --- ghc-6.12.1/libraries/binary/src/Data/Binary.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/binary/src/Data/Binary.hs 2009-12-31 10:24:49.000000000 -0800 @@ -0,0 +1,719 @@ +{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Binary +-- Copyright : Lennart Kolmodin +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Lennart Kolmodin +-- Stability : unstable +-- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances +-- +-- Binary serialisation of Haskell values to and from lazy ByteStrings. +-- The Binary library provides methods for encoding Haskell values as +-- streams of bytes directly in memory. The resulting @ByteString@ can +-- then be written to disk, sent over the network, or futher processed +-- (for example, compressed with gzip). +-- +-- The 'Binary' package is notable in that it provides both pure, and +-- high performance serialisation. +-- +-- Values are always encoded in network order (big endian) form, and +-- encoded data should be portable across machine endianess, word size, +-- or compiler version. For example, data encoded using the Binary class +-- could be written from GHC, and read back in Hugs. +-- +----------------------------------------------------------------------------- + +module Data.Binary ( + + -- * The Binary class + Binary(..) + + -- $example + + -- * The Get and Put monads + , Get + , Put + + -- * Useful helpers for writing instances + , putWord8 + , getWord8 + + -- * Binary serialisation + , encode -- :: Binary a => a -> ByteString + , decode -- :: Binary a => ByteString -> a + + -- * IO functions for serialisation + , encodeFile -- :: Binary a => FilePath -> a -> IO () + , decodeFile -- :: Binary a => FilePath -> IO a + +-- Lazy put and get +-- , lazyPut +-- , lazyGet + + , module Data.Word -- useful + + ) where + +import Data.Word + +import Data.Binary.Put +import Data.Binary.Get + +import Control.Monad +import Foreign +import System.IO + +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as L + +import Data.Char (chr,ord) +import Data.List (unfoldr) + +-- And needed for the instances: +import qualified Data.ByteString as B +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.Ratio as R + +import qualified Data.Tree as T + +import Data.Array.Unboxed + +-- +-- This isn't available in older Hugs or older GHC +-- +#if __GLASGOW_HASKELL__ >= 606 +import qualified Data.Sequence as Seq +import qualified Data.Foldable as Fold +#endif + +------------------------------------------------------------------------ + +-- | The @Binary@ class provides 'put' and 'get', methods to encode and +-- decode a Haskell value to a lazy ByteString. It mirrors the Read and +-- Show classes for textual representation of Haskell types, and is +-- suitable for serialising Haskell values to disk, over the network. +-- +-- For parsing and generating simple external binary formats (e.g. C +-- structures), Binary may be used, but in general is not suitable +-- for complex protocols. Instead use the Put and Get primitives +-- directly. +-- +-- Instances of Binary should satisfy the following property: +-- +-- > decode . encode == id +-- +-- That is, the 'get' and 'put' methods should be the inverse of each +-- other. A range of instances are provided for basic Haskell types. +-- +class Binary t where + -- | Encode a value in the Put monad. + put :: t -> Put + -- | Decode a value in the Get monad + get :: Get t + +-- $example +-- To serialise a custom type, an instance of Binary for that type is +-- required. For example, suppose we have a data structure: +-- +-- > data Exp = IntE Int +-- > | OpE String Exp Exp +-- > deriving Show +-- +-- We can encode values of this type into bytestrings using the +-- following instance, which proceeds by recursively breaking down the +-- structure to serialise: +-- +-- > instance Binary Exp where +-- > put (IntE i) = do put (0 :: Word8) +-- > put i +-- > put (OpE s e1 e2) = do put (1 :: Word8) +-- > put s +-- > put e1 +-- > put e2 +-- > +-- > get = do t <- get :: Get Word8 +-- > case t of +-- > 0 -> do i <- get +-- > return (IntE i) +-- > 1 -> do s <- get +-- > e1 <- get +-- > e2 <- get +-- > return (OpE s e1 e2) +-- +-- Note how we write an initial tag byte to indicate each variant of the +-- data type. +-- +-- We can simplify the writing of 'get' instances using monadic +-- combinators: +-- +-- > get = do tag <- getWord8 +-- > case tag of +-- > 0 -> liftM IntE get +-- > 1 -> liftM3 OpE get get get +-- +-- The generation of Binary instances has been automated by a script +-- using Scrap Your Boilerplate generics. Use the script here: +-- . +-- +-- To derive the instance for a type, load this script into GHCi, and +-- bring your type into scope. Your type can then have its Binary +-- instances derived as follows: +-- +-- > $ ghci -fglasgow-exts BinaryDerive.hs +-- > *BinaryDerive> :l Example.hs +-- > *Main> deriveM (undefined :: Drinks) +-- > +-- > instance Binary Main.Drinks where +-- > put (Beer a) = putWord8 0 >> put a +-- > put Coffee = putWord8 1 +-- > put Tea = putWord8 2 +-- > put EnergyDrink = putWord8 3 +-- > put Water = putWord8 4 +-- > put Wine = putWord8 5 +-- > put Whisky = putWord8 6 +-- > get = do +-- > tag_ <- getWord8 +-- > case tag_ of +-- > 0 -> get >>= \a -> return (Beer a) +-- > 1 -> return Coffee +-- > 2 -> return Tea +-- > 3 -> return EnergyDrink +-- > 4 -> return Water +-- > 5 -> return Wine +-- > 6 -> return Whisky +-- > +-- +-- To serialise this to a bytestring, we use 'encode', which packs the +-- data structure into a binary format, in a lazy bytestring +-- +-- > > let e = OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2)) +-- > > let v = encode e +-- +-- Where 'v' is a binary encoded data structure. To reconstruct the +-- original data, we use 'decode' +-- +-- > > decode v :: Exp +-- > OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2)) +-- +-- The lazy ByteString that results from 'encode' can be written to +-- disk, and read from disk using Data.ByteString.Lazy IO functions, +-- such as hPutStr or writeFile: +-- +-- > > writeFile "/tmp/exp.txt" (encode e) +-- +-- And read back with: +-- +-- > > readFile "/tmp/exp.txt" >>= return . decode :: IO Exp +-- > OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2)) +-- +-- We can also directly serialise a value to and from a Handle, or a file: +-- +-- > > v <- decodeFile "/tmp/exp.txt" :: IO Exp +-- > OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2)) +-- +-- And write a value to disk +-- +-- > > encodeFile "/tmp/a.txt" v +-- + +------------------------------------------------------------------------ +-- Wrappers to run the underlying monad + +-- | Encode a value using binary serialisation to a lazy ByteString. +-- +encode :: Binary a => a -> ByteString +encode = runPut . put +{-# INLINE encode #-} + +-- | Decode a value from a lazy ByteString, reconstructing the original structure. +-- +decode :: Binary a => ByteString -> a +decode = runGet get + +------------------------------------------------------------------------ +-- Convenience IO operations + +-- | Lazily serialise a value to a file +-- +-- This is just a convenience function, it's defined simply as: +-- +-- > encodeFile f = B.writeFile f . encode +-- +-- So for example if you wanted to compress as well, you could use: +-- +-- > B.writeFile f . compress . encode +-- +encodeFile :: Binary a => FilePath -> a -> IO () +encodeFile f v = L.writeFile f (encode v) + +-- | Lazily reconstruct a value previously written to a file. +-- +-- This is just a convenience function, it's defined simply as: +-- +-- > decodeFile f = return . decode =<< B.readFile f +-- +-- So for example if you wanted to decompress as well, you could use: +-- +-- > return . decode . decompress =<< B.readFile f +-- +-- After contructing the data from the input file, 'decodeFile' checks +-- if the file is empty, and in doing so will force the associated file +-- handle closed, if it is indeed empty. If the file is not empty, +-- it is up to the decoding instance to consume the rest of the data, +-- or otherwise finalise the resource. +-- +decodeFile :: Binary a => FilePath -> IO a +decodeFile f = do + s <- L.readFile f + return $ runGet (do v <- get + m <- isEmpty + m `seq` return v) s + +-- needs bytestring 0.9.1.x to work + +------------------------------------------------------------------------ +-- Lazy put and get + +-- lazyPut :: (Binary a) => a -> Put +-- lazyPut a = put (encode a) + +-- lazyGet :: (Binary a) => Get a +-- lazyGet = fmap decode get + +------------------------------------------------------------------------ +-- Simple instances + +-- The () type need never be written to disk: values of singleton type +-- can be reconstructed from the type alone +instance Binary () where + put () = return () + get = return () + +-- Bools are encoded as a byte in the range 0 .. 1 +instance Binary Bool where + put = putWord8 . fromIntegral . fromEnum + get = liftM (toEnum . fromIntegral) getWord8 + +-- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2 +instance Binary Ordering where + put = putWord8 . fromIntegral . fromEnum + get = liftM (toEnum . fromIntegral) getWord8 + +------------------------------------------------------------------------ +-- Words and Ints + +-- Words8s are written as bytes +instance Binary Word8 where + put = putWord8 + get = getWord8 + +-- Words16s are written as 2 bytes in big-endian (network) order +instance Binary Word16 where + put = putWord16be + get = getWord16be + +-- Words32s are written as 4 bytes in big-endian (network) order +instance Binary Word32 where + put = putWord32be + get = getWord32be + +-- Words64s are written as 8 bytes in big-endian (network) order +instance Binary Word64 where + put = putWord64be + get = getWord64be + +-- Int8s are written as a single byte. +instance Binary Int8 where + put i = put (fromIntegral i :: Word8) + get = liftM fromIntegral (get :: Get Word8) + +-- Int16s are written as a 2 bytes in big endian format +instance Binary Int16 where + put i = put (fromIntegral i :: Word16) + get = liftM fromIntegral (get :: Get Word16) + +-- Int32s are written as a 4 bytes in big endian format +instance Binary Int32 where + put i = put (fromIntegral i :: Word32) + get = liftM fromIntegral (get :: Get Word32) + +-- Int64s are written as a 4 bytes in big endian format +instance Binary Int64 where + put i = put (fromIntegral i :: Word64) + get = liftM fromIntegral (get :: Get Word64) + +------------------------------------------------------------------------ + +-- Words are are written as Word64s, that is, 8 bytes in big endian format +instance Binary Word where + put i = put (fromIntegral i :: Word64) + get = liftM fromIntegral (get :: Get Word64) + +-- Ints are are written as Int64s, that is, 8 bytes in big endian format +instance Binary Int where + put i = put (fromIntegral i :: Int64) + get = liftM fromIntegral (get :: Get Int64) + +------------------------------------------------------------------------ +-- +-- Portable, and pretty efficient, serialisation of Integer +-- + +-- Fixed-size type for a subset of Integer +type SmallInt = Int32 + +-- Integers are encoded in two ways: if they fit inside a SmallInt, +-- they're written as a byte tag, and that value. If the Integer value +-- is too large to fit in a SmallInt, it is written as a byte array, +-- along with a sign and length field. + +instance Binary Integer where + + {-# INLINE put #-} + put n | n >= lo && n <= hi = do + putWord8 0 + put (fromIntegral n :: SmallInt) -- fast path + where + lo = fromIntegral (minBound :: SmallInt) :: Integer + hi = fromIntegral (maxBound :: SmallInt) :: Integer + + put n = do + putWord8 1 + put sign + put (unroll (abs n)) -- unroll the bytes + where + sign = fromIntegral (signum n) :: Word8 + + {-# INLINE get #-} + get = do + tag <- get :: Get Word8 + case tag of + 0 -> liftM fromIntegral (get :: Get SmallInt) + _ -> do sign <- get + bytes <- get + let v = roll bytes + return $! if sign == (1 :: Word8) then v else - v + +-- +-- Fold and unfold an Integer to and from a list of its bytes +-- +unroll :: Integer -> [Word8] +unroll = unfoldr step + where + step 0 = Nothing + step i = Just (fromIntegral i, i `shiftR` 8) + +roll :: [Word8] -> Integer +roll = foldr unstep 0 + where + unstep b a = a `shiftL` 8 .|. fromIntegral b + +{- + +-- +-- An efficient, raw serialisation for Integer (GHC only) +-- + +-- TODO This instance is not architecture portable. GMP stores numbers as +-- arrays of machine sized words, so the byte format is not portable across +-- architectures with different endianess and word size. + +import Data.ByteString.Base (toForeignPtr,unsafePackAddress, memcpy) +import GHC.Base hiding (ord, chr) +import GHC.Prim +import GHC.Ptr (Ptr(..)) +import GHC.IOBase (IO(..)) + +instance Binary Integer where + put (S# i) = putWord8 0 >> put (I# i) + put (J# s ba) = do + putWord8 1 + put (I# s) + put (BA ba) + + get = do + b <- getWord8 + case b of + 0 -> do (I# i#) <- get + return (S# i#) + _ -> do (I# s#) <- get + (BA a#) <- get + return (J# s# a#) + +instance Binary ByteArray where + + -- Pretty safe. + put (BA ba) = + let sz = sizeofByteArray# ba -- (primitive) in *bytes* + addr = byteArrayContents# ba + bs = unsafePackAddress (I# sz) addr + in put bs -- write as a ByteString. easy, yay! + + -- Pretty scary. Should be quick though + get = do + (fp, off, n@(I# sz)) <- liftM toForeignPtr get -- so decode a ByteString + assert (off == 0) $ return $ unsafePerformIO $ do + (MBA arr) <- newByteArray sz -- and copy it into a ByteArray# + let to = byteArrayContents# (unsafeCoerce# arr) -- urk, is this safe? + withForeignPtr fp $ \from -> memcpy (Ptr to) from (fromIntegral n) + freezeByteArray arr + +-- wrapper for ByteArray# +data ByteArray = BA {-# UNPACK #-} !ByteArray# +data MBA = MBA {-# UNPACK #-} !(MutableByteArray# RealWorld) + +newByteArray :: Int# -> IO MBA +newByteArray sz = IO $ \s -> + case newPinnedByteArray# sz s of { (# s', arr #) -> + (# s', MBA arr #) } + +freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray +freezeByteArray arr = IO $ \s -> + case unsafeFreezeByteArray# arr s of { (# s', arr' #) -> + (# s', BA arr' #) } + +-} + +instance (Binary a,Integral a) => Binary (R.Ratio a) where + put r = put (R.numerator r) >> put (R.denominator r) + get = liftM2 (R.%) get get + +------------------------------------------------------------------------ + +-- Char is serialised as UTF-8 +instance Binary Char where + put a | c <= 0x7f = put (fromIntegral c :: Word8) + | c <= 0x7ff = do put (0xc0 .|. y) + put (0x80 .|. z) + | c <= 0xffff = do put (0xe0 .|. x) + put (0x80 .|. y) + put (0x80 .|. z) + | c <= 0x10ffff = do put (0xf0 .|. w) + put (0x80 .|. x) + put (0x80 .|. y) + put (0x80 .|. z) + | otherwise = error "Not a valid Unicode code point" + where + c = ord a + z, y, x, w :: Word8 + z = fromIntegral (c .&. 0x3f) + y = fromIntegral (shiftR c 6 .&. 0x3f) + x = fromIntegral (shiftR c 12 .&. 0x3f) + w = fromIntegral (shiftR c 18 .&. 0x7) + + get = do + let getByte = liftM (fromIntegral :: Word8 -> Int) get + shiftL6 = flip shiftL 6 :: Int -> Int + w <- getByte + r <- case () of + _ | w < 0x80 -> return w + | w < 0xe0 -> do + x <- liftM (xor 0x80) getByte + return (x .|. shiftL6 (xor 0xc0 w)) + | w < 0xf0 -> do + x <- liftM (xor 0x80) getByte + y <- liftM (xor 0x80) getByte + return (y .|. shiftL6 (x .|. shiftL6 + (xor 0xe0 w))) + | otherwise -> do + x <- liftM (xor 0x80) getByte + y <- liftM (xor 0x80) getByte + z <- liftM (xor 0x80) getByte + return (z .|. shiftL6 (y .|. shiftL6 + (x .|. shiftL6 (xor 0xf0 w)))) + return $! chr r + +------------------------------------------------------------------------ +-- Instances for the first few tuples + +instance (Binary a, Binary b) => Binary (a,b) where + put (a,b) = put a >> put b + get = liftM2 (,) get get + +instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where + put (a,b,c) = put a >> put b >> put c + get = liftM3 (,,) get get get + +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where + put (a,b,c,d) = put a >> put b >> put c >> put d + get = liftM4 (,,,) get get get get + +instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where + put (a,b,c,d,e) = put a >> put b >> put c >> put d >> put e + get = liftM5 (,,,,) get get get get get + +-- +-- and now just recurse: +-- + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) + => Binary (a,b,c,d,e,f) where + put (a,b,c,d,e,f) = put (a,(b,c,d,e,f)) + get = do (a,(b,c,d,e,f)) <- get ; return (a,b,c,d,e,f) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g) + => Binary (a,b,c,d,e,f,g) where + put (a,b,c,d,e,f,g) = put (a,(b,c,d,e,f,g)) + get = do (a,(b,c,d,e,f,g)) <- get ; return (a,b,c,d,e,f,g) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, + Binary f, Binary g, Binary h) + => Binary (a,b,c,d,e,f,g,h) where + put (a,b,c,d,e,f,g,h) = put (a,(b,c,d,e,f,g,h)) + get = do (a,(b,c,d,e,f,g,h)) <- get ; return (a,b,c,d,e,f,g,h) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, + Binary f, Binary g, Binary h, Binary i) + => Binary (a,b,c,d,e,f,g,h,i) where + put (a,b,c,d,e,f,g,h,i) = put (a,(b,c,d,e,f,g,h,i)) + get = do (a,(b,c,d,e,f,g,h,i)) <- get ; return (a,b,c,d,e,f,g,h,i) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, + Binary f, Binary g, Binary h, Binary i, Binary j) + => Binary (a,b,c,d,e,f,g,h,i,j) where + put (a,b,c,d,e,f,g,h,i,j) = put (a,(b,c,d,e,f,g,h,i,j)) + get = do (a,(b,c,d,e,f,g,h,i,j)) <- get ; return (a,b,c,d,e,f,g,h,i,j) + +------------------------------------------------------------------------ +-- Container types + +instance Binary a => Binary [a] where + put l = put (length l) >> mapM_ put l + get = do n <- get :: Get Int + getMany n + +-- | 'getMany n' get 'n' elements in order, without blowing the stack. +getMany :: Binary a => Int -> Get [a] +getMany n = go [] n + where + go xs 0 = return $! reverse xs + go xs i = do x <- get + -- we must seq x to avoid stack overflows due to laziness in + -- (>>=) + x `seq` go (x:xs) (i-1) +{-# INLINE getMany #-} + +instance (Binary a) => Binary (Maybe a) where + put Nothing = putWord8 0 + put (Just x) = putWord8 1 >> put x + get = do + w <- getWord8 + case w of + 0 -> return Nothing + _ -> liftM Just get + +instance (Binary a, Binary b) => Binary (Either a b) where + put (Left a) = putWord8 0 >> put a + put (Right b) = putWord8 1 >> put b + get = do + w <- getWord8 + case w of + 0 -> liftM Left get + _ -> liftM Right get + +------------------------------------------------------------------------ +-- ByteStrings (have specially efficient instances) + +instance Binary B.ByteString where + put bs = do put (B.length bs) + putByteString bs + get = get >>= getByteString + +-- +-- Using old versions of fps, this is a type synonym, and non portable +-- +-- Requires 'flexible instances' +-- +instance Binary ByteString where + put bs = do put (fromIntegral (L.length bs) :: Int) + putLazyByteString bs + get = get >>= getLazyByteString + +------------------------------------------------------------------------ +-- Maps and Sets + +instance (Ord a, Binary a) => Binary (Set.Set a) where + put s = put (Set.size s) >> mapM_ put (Set.toAscList s) + get = liftM Set.fromDistinctAscList get + +instance (Ord k, Binary k, Binary e) => Binary (Map.Map k e) where + put m = put (Map.size m) >> mapM_ put (Map.toAscList m) + get = liftM Map.fromDistinctAscList get + +instance Binary IntSet.IntSet where + put s = put (IntSet.size s) >> mapM_ put (IntSet.toAscList s) + get = liftM IntSet.fromDistinctAscList get + +instance (Binary e) => Binary (IntMap.IntMap e) where + put m = put (IntMap.size m) >> mapM_ put (IntMap.toAscList m) + get = liftM IntMap.fromDistinctAscList get + +------------------------------------------------------------------------ +-- Queues and Sequences + +#if __GLASGOW_HASKELL__ >= 606 +-- +-- This is valid Hugs, but you need the most recent Hugs +-- + +instance (Binary e) => Binary (Seq.Seq e) where + put s = put (Seq.length s) >> Fold.mapM_ put s + get = do n <- get :: Get Int + rep Seq.empty n get + where rep xs 0 _ = return $! xs + rep xs n g = xs `seq` n `seq` do + x <- g + rep (xs Seq.|> x) (n-1) g + +#endif + +------------------------------------------------------------------------ +-- Floating point + +instance Binary Double where + put d = put (decodeFloat d) + get = liftM2 encodeFloat get get + +instance Binary Float where + put f = put (decodeFloat f) + get = liftM2 encodeFloat get get + +------------------------------------------------------------------------ +-- Trees + +instance (Binary e) => Binary (T.Tree e) where + put (T.Node r s) = put r >> put s + get = liftM2 T.Node get get + +------------------------------------------------------------------------ +-- Arrays + +instance (Binary i, Ix i, Binary e) => Binary (Array i e) where + put a = do + put (bounds a) + put (rangeSize $ bounds a) -- write the length + mapM_ put (elems a) -- now the elems. + get = do + bs <- get + n <- get -- read the length + xs <- getMany n -- now the elems. + return (listArray bs xs) + +-- +-- The IArray UArray e constraint is non portable. Requires flexible instances +-- +instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where + put a = do + put (bounds a) + put (rangeSize $ bounds a) -- now write the length + mapM_ put (elems a) + get = do + bs <- get + n <- get + xs <- getMany n + return (listArray bs xs) diff -ruN ghc-6.12.1/libraries/binary/tests/Benchmark.hs ghc-6.13.20091231/libraries/binary/tests/Benchmark.hs --- ghc-6.12.1/libraries/binary/tests/Benchmark.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/binary/tests/Benchmark.hs 2009-12-31 10:24:49.000000000 -0800 @@ -0,0 +1,1461 @@ +{-# LANGUAGE BangPatterns #-} +module Main (main) where + +import qualified Data.ByteString.Lazy as L +import Data.Binary +import Data.Binary.Put +import Data.Binary.Get + +import Control.Exception +import System.CPUTime +import Numeric +import Text.Printf +import System.Environment + +import MemBench + +data Endian + = Big + | Little + | Host + deriving (Eq,Ord,Show) + +main :: IO () +main = do + mb <- getArgs >>= readIO . head + memBench (mb*10) + putStrLn "" + putStrLn "Binary (de)serialisation benchmarks:" + + -- do bytewise + sequence_ + [ test wordSize chunkSize Host mb + | wordSize <- [1] + , chunkSize <- [16] --1,2,4,8,16] + ] + + -- now Word16 .. Word64 + sequence_ + [ test wordSize chunkSize end mb + | wordSize <- [2,4,8] + , chunkSize <- [16] + , end <- [Host] -- ,Big,Little] + ] + +------------------------------------------------------------------------ + +time :: IO a -> IO Double +time action = do + start <- getCPUTime + action + end <- getCPUTime + return $! (fromIntegral (end - start)) / (10^12) + +------------------------------------------------------------------------ + +test :: Int -> Int -> Endian -> Int -> IO () +test wordSize chunkSize end mb = do + let bytes :: Int + bytes = mb * 2^20 + iterations = bytes `div` wordSize + bs = runPut (doPut wordSize chunkSize end iterations) + sum = runGet (doGet wordSize chunkSize end iterations) bs + + case (chunkSize,end) of (1,Host) -> putStrLn "" ; _ -> return () + + printf "%dMB of Word%-2d in chunks of %2d (%6s endian): " + (mb :: Int) (8 * wordSize :: Int) (chunkSize :: Int) (show end) + + putSeconds <- time $ evaluate (L.length bs) + getSeconds <- time $ evaluate sum +-- print (L.length bs, sum) + let putThroughput = fromIntegral mb / putSeconds + getThroughput = fromIntegral mb / getSeconds + + printf "%6.1f MB/s write, %6.1f MB/s read, %5.1f get/put-ratio\n" + putThroughput + getThroughput + (getThroughput/putThroughput) + +------------------------------------------------------------------------ + +doPut :: Int -> Int -> Endian -> Int -> Put +doPut wordSize chunkSize end = case (wordSize, chunkSize, end) of + (1, 1,_) -> putWord8N1 + (1, 2,_) -> putWord8N2 + (1, 4,_) -> putWord8N4 + (1, 8,_) -> putWord8N8 + (1, 16, _) -> putWord8N16 + + (2, 1, Big) -> putWord16N1Big + (2, 2, Big) -> putWord16N2Big + (2, 4, Big) -> putWord16N4Big + (2, 8, Big) -> putWord16N8Big + (2, 16, Big) -> putWord16N16Big + (2, 1, Little) -> putWord16N1Little + (2, 2, Little) -> putWord16N2Little + (2, 4, Little) -> putWord16N4Little + (2, 8, Little) -> putWord16N8Little + (2, 16, Little) -> putWord16N16Little + (2, 1, Host) -> putWord16N1Host + (2, 2, Host) -> putWord16N2Host + (2, 4, Host) -> putWord16N4Host + (2, 8, Host) -> putWord16N8Host + (2, 16, Host) -> putWord16N16Host + + (4, 1, Big) -> putWord32N1Big + (4, 2, Big) -> putWord32N2Big + (4, 4, Big) -> putWord32N4Big + (4, 8, Big) -> putWord32N8Big + (4, 16, Big) -> putWord32N16Big + (4, 1, Little) -> putWord32N1Little + (4, 2, Little) -> putWord32N2Little + (4, 4, Little) -> putWord32N4Little + (4, 8, Little) -> putWord32N8Little + (4, 16, Little) -> putWord32N16Little + (4, 1, Host) -> putWord32N1Host + (4, 2, Host) -> putWord32N2Host + (4, 4, Host) -> putWord32N4Host + (4, 8, Host) -> putWord32N8Host + (4, 16, Host) -> putWord32N16Host + + (8, 1, Host) -> putWord64N1Host + (8, 2, Host) -> putWord64N2Host + (8, 4, Host) -> putWord64N4Host + (8, 8, Host) -> putWord64N8Host + (8, 16, Host) -> putWord64N16Host + (8, 1, Big) -> putWord64N1Big + (8, 2, Big) -> putWord64N2Big + (8, 4, Big) -> putWord64N4Big + (8, 8, Big) -> putWord64N8Big + (8, 16, Big) -> putWord64N16Big + (8, 1, Little) -> putWord64N1Little + (8, 2, Little) -> putWord64N2Little + (8, 4, Little) -> putWord64N4Little + (8, 8, Little) -> putWord64N8Little + (8, 16, Little) -> putWord64N16Little + +------------------------------------------------------------------------ + +doGet :: Int -> Int -> Endian -> Int -> Get Int +doGet wordSize chunkSize end = + case (wordSize, chunkSize, end) of + (1, 1,_) -> fmap fromIntegral . getWord8N1 + (1, 2,_) -> fmap fromIntegral . getWord8N2 + (1, 4,_) -> fmap fromIntegral . getWord8N4 + (1, 8,_) -> fmap fromIntegral . getWord8N8 + (1, 16,_) -> fmap fromIntegral . getWord8N16 + + (2, 1,Big) -> fmap fromIntegral . getWord16N1Big + (2, 2,Big) -> fmap fromIntegral . getWord16N2Big + (2, 4,Big) -> fmap fromIntegral . getWord16N4Big + (2, 8,Big) -> fmap fromIntegral . getWord16N8Big + (2, 16,Big) -> fmap fromIntegral . getWord16N16Big + (2, 1,Little) -> fmap fromIntegral . getWord16N1Little + (2, 2,Little) -> fmap fromIntegral . getWord16N2Little + (2, 4,Little) -> fmap fromIntegral . getWord16N4Little + (2, 8,Little) -> fmap fromIntegral . getWord16N8Little + (2, 16,Little) -> fmap fromIntegral . getWord16N16Little + (2, 1,Host) -> fmap fromIntegral . getWord16N1Host + (2, 2,Host) -> fmap fromIntegral . getWord16N2Host + (2, 4,Host) -> fmap fromIntegral . getWord16N4Host + (2, 8,Host) -> fmap fromIntegral . getWord16N8Host + (2, 16,Host) -> fmap fromIntegral . getWord16N16Host + + (4, 1,Big) -> fmap fromIntegral . getWord32N1Big + (4, 2,Big) -> fmap fromIntegral . getWord32N2Big + (4, 4,Big) -> fmap fromIntegral . getWord32N4Big + (4, 8,Big) -> fmap fromIntegral . getWord32N8Big + (4, 16,Big) -> fmap fromIntegral . getWord32N16Big + (4, 1,Little) -> fmap fromIntegral . getWord32N1Little + (4, 2,Little) -> fmap fromIntegral . getWord32N2Little + (4, 4,Little) -> fmap fromIntegral . getWord32N4Little + (4, 8,Little) -> fmap fromIntegral . getWord32N8Little + (4, 16,Little) -> fmap fromIntegral . getWord32N16Little + (4, 1,Host) -> fmap fromIntegral . getWord32N1Host + (4, 2,Host) -> fmap fromIntegral . getWord32N2Host + (4, 4,Host) -> fmap fromIntegral . getWord32N4Host + (4, 8,Host) -> fmap fromIntegral . getWord32N8Host + (4, 16,Host) -> fmap fromIntegral . getWord32N16Host + + (8, 1,Host) -> fmap fromIntegral . getWord64N1Host + (8, 2,Host) -> fmap fromIntegral . getWord64N2Host + (8, 4,Host) -> fmap fromIntegral . getWord64N4Host + (8, 8,Host) -> fmap fromIntegral . getWord64N8Host + (8, 16,Host) -> fmap fromIntegral . getWord64N16Host + (8, 1,Big) -> fmap fromIntegral . getWord64N1Big + (8, 2,Big) -> fmap fromIntegral . getWord64N2Big + (8, 4,Big) -> fmap fromIntegral . getWord64N4Big + (8, 8,Big) -> fmap fromIntegral . getWord64N8Big + (8, 16,Big) -> fmap fromIntegral . getWord64N16Big + (8, 1,Little) -> fmap fromIntegral . getWord64N1Little + (8, 2,Little) -> fmap fromIntegral . getWord64N2Little + (8, 4,Little) -> fmap fromIntegral . getWord64N4Little + (8, 8,Little) -> fmap fromIntegral . getWord64N8Little + (8, 16,Little) -> fmap fromIntegral . getWord64N16Little + +------------------------------------------------------------------------ + +putWord8N1 bytes = loop 0 0 + where loop :: Word8 -> Int -> Put + loop !s !n | n == bytes = return () + | otherwise = do putWord8 s + loop (s+1) (n+1) + +putWord8N2 = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord8 (s+0) + putWord8 (s+1) + loop (s+2) (n-2) + +putWord8N4 = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord8 (s+0) + putWord8 (s+1) + putWord8 (s+2) + putWord8 (s+3) + loop (s+4) (n-4) + +putWord8N8 = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord8 (s+0) + putWord8 (s+1) + putWord8 (s+2) + putWord8 (s+3) + putWord8 (s+4) + putWord8 (s+5) + putWord8 (s+6) + putWord8 (s+7) + loop (s+8) (n-8) + +putWord8N16 = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord8 (s+0) + putWord8 (s+1) + putWord8 (s+2) + putWord8 (s+3) + putWord8 (s+4) + putWord8 (s+5) + putWord8 (s+6) + putWord8 (s+7) + putWord8 (s+8) + putWord8 (s+9) + putWord8 (s+10) + putWord8 (s+11) + putWord8 (s+12) + putWord8 (s+13) + putWord8 (s+14) + putWord8 (s+15) + loop (s+16) (n-16) + +------------------------------------------------------------------------ +-- Big endian, word16 writes + +putWord16N1Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16be (s+0) + loop (s+1) (n-1) + +putWord16N2Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16be (s+0) + putWord16be (s+1) + loop (s+2) (n-2) + +putWord16N4Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16be (s+0) + putWord16be (s+1) + putWord16be (s+2) + putWord16be (s+3) + loop (s+4) (n-4) + +putWord16N8Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16be (s+0) + putWord16be (s+1) + putWord16be (s+2) + putWord16be (s+3) + putWord16be (s+4) + putWord16be (s+5) + putWord16be (s+6) + putWord16be (s+7) + loop (s+8) (n-8) + +putWord16N16Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16be (s+0) + putWord16be (s+1) + putWord16be (s+2) + putWord16be (s+3) + putWord16be (s+4) + putWord16be (s+5) + putWord16be (s+6) + putWord16be (s+7) + putWord16be (s+8) + putWord16be (s+9) + putWord16be (s+10) + putWord16be (s+11) + putWord16be (s+12) + putWord16be (s+13) + putWord16be (s+14) + putWord16be (s+15) + loop (s+16) (n-16) + +------------------------------------------------------------------------ +-- Little endian, word16 writes + +putWord16N1Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16le (s+0) + loop (s+1) (n-1) + +putWord16N2Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16le (s+0) + putWord16le (s+1) + loop (s+2) (n-2) + +putWord16N4Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16le (s+0) + putWord16le (s+1) + putWord16le (s+2) + putWord16le (s+3) + loop (s+4) (n-4) + +putWord16N8Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16le (s+0) + putWord16le (s+1) + putWord16le (s+2) + putWord16le (s+3) + putWord16le (s+4) + putWord16le (s+5) + putWord16le (s+6) + putWord16le (s+7) + loop (s+8) (n-8) + +putWord16N16Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16le (s+0) + putWord16le (s+1) + putWord16le (s+2) + putWord16le (s+3) + putWord16le (s+4) + putWord16le (s+5) + putWord16le (s+6) + putWord16le (s+7) + putWord16le (s+8) + putWord16le (s+9) + putWord16le (s+10) + putWord16le (s+11) + putWord16le (s+12) + putWord16le (s+13) + putWord16le (s+14) + putWord16le (s+15) + loop (s+16) (n-16) + +------------------------------------------------------------------------ +-- Host endian, unaligned, word16 writes + +putWord16N1Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16host (s+0) + loop (s+1) (n-1) + +putWord16N2Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16host (s+0) + putWord16host (s+1) + loop (s+2) (n-2) + +putWord16N4Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16host (s+0) + putWord16host (s+1) + putWord16host (s+2) + putWord16host (s+3) + loop (s+4) (n-4) + +putWord16N8Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16host (s+0) + putWord16host (s+1) + putWord16host (s+2) + putWord16host (s+3) + putWord16host (s+4) + putWord16host (s+5) + putWord16host (s+6) + putWord16host (s+7) + loop (s+8) (n-8) + +putWord16N16Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16host (s+0) + putWord16host (s+1) + putWord16host (s+2) + putWord16host (s+3) + putWord16host (s+4) + putWord16host (s+5) + putWord16host (s+6) + putWord16host (s+7) + putWord16host (s+8) + putWord16host (s+9) + putWord16host (s+10) + putWord16host (s+11) + putWord16host (s+12) + putWord16host (s+13) + putWord16host (s+14) + putWord16host (s+15) + loop (s+16) (n-16) + +------------------------------------------------------------------------ + +putWord32N1Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32be (s+0) + loop (s+1) (n-1) + +putWord32N2Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32be (s+0) + putWord32be (s+1) + loop (s+2) (n-2) + +putWord32N4Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32be (s+0) + putWord32be (s+1) + putWord32be (s+2) + putWord32be (s+3) + loop (s+4) (n-4) + +putWord32N8Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32be (s+0) + putWord32be (s+1) + putWord32be (s+2) + putWord32be (s+3) + putWord32be (s+4) + putWord32be (s+5) + putWord32be (s+6) + putWord32be (s+7) + loop (s+8) (n-8) + +putWord32N16Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32be (s+0) + putWord32be (s+1) + putWord32be (s+2) + putWord32be (s+3) + putWord32be (s+4) + putWord32be (s+5) + putWord32be (s+6) + putWord32be (s+7) + putWord32be (s+8) + putWord32be (s+9) + putWord32be (s+10) + putWord32be (s+11) + putWord32be (s+12) + putWord32be (s+13) + putWord32be (s+14) + putWord32be (s+15) + loop (s+16) (n-16) + +------------------------------------------------------------------------ + +putWord32N1Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32le (s+0) + loop (s+1) (n-1) + +putWord32N2Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32le (s+0) + putWord32le (s+1) + loop (s+2) (n-2) + +putWord32N4Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32le (s+0) + putWord32le (s+1) + putWord32le (s+2) + putWord32le (s+3) + loop (s+4) (n-4) + +putWord32N8Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32le (s+0) + putWord32le (s+1) + putWord32le (s+2) + putWord32le (s+3) + putWord32le (s+4) + putWord32le (s+5) + putWord32le (s+6) + putWord32le (s+7) + loop (s+8) (n-8) + +putWord32N16Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32le (s+0) + putWord32le (s+1) + putWord32le (s+2) + putWord32le (s+3) + putWord32le (s+4) + putWord32le (s+5) + putWord32le (s+6) + putWord32le (s+7) + putWord32le (s+8) + putWord32le (s+9) + putWord32le (s+10) + putWord32le (s+11) + putWord32le (s+12) + putWord32le (s+13) + putWord32le (s+14) + putWord32le (s+15) + loop (s+16) (n-16) + +------------------------------------------------------------------------ + +putWord32N1Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32host (s+0) + loop (s+1) (n-1) + +putWord32N2Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32host (s+0) + putWord32host (s+1) + loop (s+2) (n-2) + +putWord32N4Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32host (s+0) + putWord32host (s+1) + putWord32host (s+2) + putWord32host (s+3) + loop (s+4) (n-4) + +putWord32N8Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32host (s+0) + putWord32host (s+1) + putWord32host (s+2) + putWord32host (s+3) + putWord32host (s+4) + putWord32host (s+5) + putWord32host (s+6) + putWord32host (s+7) + loop (s+8) (n-8) + +putWord32N16Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32host (s+0) + putWord32host (s+1) + putWord32host (s+2) + putWord32host (s+3) + putWord32host (s+4) + putWord32host (s+5) + putWord32host (s+6) + putWord32host (s+7) + putWord32host (s+8) + putWord32host (s+9) + putWord32host (s+10) + putWord32host (s+11) + putWord32host (s+12) + putWord32host (s+13) + putWord32host (s+14) + putWord32host (s+15) + loop (s+16) (n-16) + +------------------------------------------------------------------------ + +putWord64N1Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64be (s+0) + loop (s+1) (n-1) + +putWord64N2Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64be (s+0) + putWord64be (s+1) + loop (s+2) (n-2) + +putWord64N4Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64be (s+0) + putWord64be (s+1) + putWord64be (s+2) + putWord64be (s+3) + loop (s+4) (n-4) + +putWord64N8Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64be (s+0) + putWord64be (s+1) + putWord64be (s+2) + putWord64be (s+3) + putWord64be (s+4) + putWord64be (s+5) + putWord64be (s+6) + putWord64be (s+7) + loop (s+8) (n-8) + +putWord64N16Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64be (s+0) + putWord64be (s+1) + putWord64be (s+2) + putWord64be (s+3) + putWord64be (s+4) + putWord64be (s+5) + putWord64be (s+6) + putWord64be (s+7) + putWord64be (s+8) + putWord64be (s+9) + putWord64be (s+10) + putWord64be (s+11) + putWord64be (s+12) + putWord64be (s+13) + putWord64be (s+14) + putWord64be (s+15) + loop (s+16) (n-16) + +------------------------------------------------------------------------ + +putWord64N1Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64le (s+0) + loop (s+1) (n-1) + +putWord64N2Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64le (s+0) + putWord64le (s+1) + loop (s+2) (n-2) + +putWord64N4Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64le (s+0) + putWord64le (s+1) + putWord64le (s+2) + putWord64le (s+3) + loop (s+4) (n-4) + +putWord64N8Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64le (s+0) + putWord64le (s+1) + putWord64le (s+2) + putWord64le (s+3) + putWord64le (s+4) + putWord64le (s+5) + putWord64le (s+6) + putWord64le (s+7) + loop (s+8) (n-8) + +putWord64N16Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64le (s+0) + putWord64le (s+1) + putWord64le (s+2) + putWord64le (s+3) + putWord64le (s+4) + putWord64le (s+5) + putWord64le (s+6) + putWord64le (s+7) + putWord64le (s+8) + putWord64le (s+9) + putWord64le (s+10) + putWord64le (s+11) + putWord64le (s+12) + putWord64le (s+13) + putWord64le (s+14) + putWord64le (s+15) + loop (s+16) (n-16) + +------------------------------------------------------------------------ + +putWord64N1Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64host (s+0) + loop (s+1) (n-1) + +putWord64N2Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64host (s+0) + putWord64host (s+1) + loop (s+2) (n-2) + +putWord64N4Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64host (s+0) + putWord64host (s+1) + putWord64host (s+2) + putWord64host (s+3) + loop (s+4) (n-4) + +putWord64N8Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64host (s+0) + putWord64host (s+1) + putWord64host (s+2) + putWord64host (s+3) + putWord64host (s+4) + putWord64host (s+5) + putWord64host (s+6) + putWord64host (s+7) + loop (s+8) (n-8) + +putWord64N16Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64host (s+0) + putWord64host (s+1) + putWord64host (s+2) + putWord64host (s+3) + putWord64host (s+4) + putWord64host (s+5) + putWord64host (s+6) + putWord64host (s+7) + putWord64host (s+8) + putWord64host (s+9) + putWord64host (s+10) + putWord64host (s+11) + putWord64host (s+12) + putWord64host (s+13) + putWord64host (s+14) + putWord64host (s+15) + loop (s+16) (n-16) + +------------------------------------------------------------------------ +------------------------------------------------------------------------ + +getWord8N1 = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord8 + loop (s+s0) (n-1) + +getWord8N2 = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord8 + s1 <- getWord8 + loop (s+s0+s1) (n-2) + +getWord8N4 = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord8 + s1 <- getWord8 + s2 <- getWord8 + s3 <- getWord8 + loop (s+s0+s1+s2+s3) (n-4) + +getWord8N8 = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord8 + s1 <- getWord8 + s2 <- getWord8 + s3 <- getWord8 + s4 <- getWord8 + s5 <- getWord8 + s6 <- getWord8 + s7 <- getWord8 + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +getWord8N16 = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord8 + s1 <- getWord8 + s2 <- getWord8 + s3 <- getWord8 + s4 <- getWord8 + s5 <- getWord8 + s6 <- getWord8 + s7 <- getWord8 + s8 <- getWord8 + s9 <- getWord8 + s10 <- getWord8 + s11 <- getWord8 + s12 <- getWord8 + s13 <- getWord8 + s14 <- getWord8 + s15 <- getWord8 + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + +------------------------------------------------------------------------ + +getWord16N1Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16be + loop (s+s0) (n-1) + +getWord16N2Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16be + s1 <- getWord16be + loop (s+s0+s1) (n-2) + +getWord16N4Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16be + s1 <- getWord16be + s2 <- getWord16be + s3 <- getWord16be + loop (s+s0+s1+s2+s3) (n-4) + +getWord16N8Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16be + s1 <- getWord16be + s2 <- getWord16be + s3 <- getWord16be + s4 <- getWord16be + s5 <- getWord16be + s6 <- getWord16be + s7 <- getWord16be + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +getWord16N16Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16be + s1 <- getWord16be + s2 <- getWord16be + s3 <- getWord16be + s4 <- getWord16be + s5 <- getWord16be + s6 <- getWord16be + s7 <- getWord16be + s8 <- getWord16be + s9 <- getWord16be + s10 <- getWord16be + s11 <- getWord16be + s12 <- getWord16be + s13 <- getWord16be + s14 <- getWord16be + s15 <- getWord16be + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + +------------------------------------------------------------------------ + +getWord16N1Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16le + loop (s+s0) (n-1) + +getWord16N2Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16le + s1 <- getWord16le + loop (s+s0+s1) (n-2) + +getWord16N4Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16le + s1 <- getWord16le + s2 <- getWord16le + s3 <- getWord16le + loop (s+s0+s1+s2+s3) (n-4) + +getWord16N8Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16le + s1 <- getWord16le + s2 <- getWord16le + s3 <- getWord16le + s4 <- getWord16le + s5 <- getWord16le + s6 <- getWord16le + s7 <- getWord16le + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +getWord16N16Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16le + s1 <- getWord16le + s2 <- getWord16le + s3 <- getWord16le + s4 <- getWord16le + s5 <- getWord16le + s6 <- getWord16le + s7 <- getWord16le + s8 <- getWord16le + s9 <- getWord16le + s10 <- getWord16le + s11 <- getWord16le + s12 <- getWord16le + s13 <- getWord16le + s14 <- getWord16le + s15 <- getWord16le + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + +------------------------------------------------------------------------ + +getWord16N1Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16host + loop (s+s0) (n-1) + +getWord16N2Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16host + s1 <- getWord16host + loop (s+s0+s1) (n-2) + +getWord16N4Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16host + s1 <- getWord16host + s2 <- getWord16host + s3 <- getWord16host + loop (s+s0+s1+s2+s3) (n-4) + +getWord16N8Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16host + s1 <- getWord16host + s2 <- getWord16host + s3 <- getWord16host + s4 <- getWord16host + s5 <- getWord16host + s6 <- getWord16host + s7 <- getWord16host + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +getWord16N16Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16host + s1 <- getWord16host + s2 <- getWord16host + s3 <- getWord16host + s4 <- getWord16host + s5 <- getWord16host + s6 <- getWord16host + s7 <- getWord16host + s8 <- getWord16host + s9 <- getWord16host + s10 <- getWord16host + s11 <- getWord16host + s12 <- getWord16host + s13 <- getWord16host + s14 <- getWord16host + s15 <- getWord16host + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + +------------------------------------------------------------------------ + +getWord32N1Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32be + loop (s+s0) (n-1) + +getWord32N2Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32be + s1 <- getWord32be + loop (s+s0+s1) (n-2) + +getWord32N4Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32be + s1 <- getWord32be + s2 <- getWord32be + s3 <- getWord32be + loop (s+s0+s1+s2+s3) (n-4) + +getWord32N8Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32be + s1 <- getWord32be + s2 <- getWord32be + s3 <- getWord32be + s4 <- getWord32be + s5 <- getWord32be + s6 <- getWord32be + s7 <- getWord32be + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +-- getWordhostN16 = loop 0 +getWord32N16Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32be + s1 <- getWord32be + s2 <- getWord32be + s3 <- getWord32be + s4 <- getWord32be + s5 <- getWord32be + s6 <- getWord32be + s7 <- getWord32be + s8 <- getWord32be + s9 <- getWord32be + s10 <- getWord32be + s11 <- getWord32be + s12 <- getWord32be + s13 <- getWord32be + s14 <- getWord32be + s15 <- getWord32be + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + +------------------------------------------------------------------------ + +getWord32N1Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32le + loop (s+s0) (n-1) + +getWord32N2Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32le + s1 <- getWord32le + loop (s+s0+s1) (n-2) + +getWord32N4Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32le + s1 <- getWord32le + s2 <- getWord32le + s3 <- getWord32le + loop (s+s0+s1+s2+s3) (n-4) + +getWord32N8Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32le + s1 <- getWord32le + s2 <- getWord32le + s3 <- getWord32le + s4 <- getWord32le + s5 <- getWord32le + s6 <- getWord32le + s7 <- getWord32le + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +-- getWordhostN16 = loop 0 +getWord32N16Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32le + s1 <- getWord32le + s2 <- getWord32le + s3 <- getWord32le + s4 <- getWord32le + s5 <- getWord32le + s6 <- getWord32le + s7 <- getWord32le + s8 <- getWord32le + s9 <- getWord32le + s10 <- getWord32le + s11 <- getWord32le + s12 <- getWord32le + s13 <- getWord32le + s14 <- getWord32le + s15 <- getWord32le + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + +------------------------------------------------------------------------ + +getWord32N1Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32host + loop (s+s0) (n-1) + +getWord32N2Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32host + s1 <- getWord32host + loop (s+s0+s1) (n-2) + +getWord32N4Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32host + s1 <- getWord32host + s2 <- getWord32host + s3 <- getWord32host + loop (s+s0+s1+s2+s3) (n-4) + +getWord32N8Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32host + s1 <- getWord32host + s2 <- getWord32host + s3 <- getWord32host + s4 <- getWord32host + s5 <- getWord32host + s6 <- getWord32host + s7 <- getWord32host + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +-- getWordhostN16 = loop 0 +getWord32N16Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32host + s1 <- getWord32host + s2 <- getWord32host + s3 <- getWord32host + s4 <- getWord32host + s5 <- getWord32host + s6 <- getWord32host + s7 <- getWord32host + s8 <- getWord32host + s9 <- getWord32host + s10 <- getWord32host + s11 <- getWord32host + s12 <- getWord32host + s13 <- getWord32host + s14 <- getWord32host + s15 <- getWord32host + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + +------------------------------------------------------------------------ + +getWord64N1Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64be + loop (s+s0) (n-1) + +getWord64N2Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64be + s1 <- getWord64be + loop (s+s0+s1) (n-2) + +getWord64N4Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64be + s1 <- getWord64be + s2 <- getWord64be + s3 <- getWord64be + loop (s+s0+s1+s2+s3) (n-4) + +getWord64N8Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64be + s1 <- getWord64be + s2 <- getWord64be + s3 <- getWord64be + s4 <- getWord64be + s5 <- getWord64be + s6 <- getWord64be + s7 <- getWord64be + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +getWord64N16Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64be + s1 <- getWord64be + s2 <- getWord64be + s3 <- getWord64be + s4 <- getWord64be + s5 <- getWord64be + s6 <- getWord64be + s7 <- getWord64be + s8 <- getWord64be + s9 <- getWord64be + s10 <- getWord64be + s11 <- getWord64be + s12 <- getWord64be + s13 <- getWord64be + s14 <- getWord64be + s15 <- getWord64be + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + +------------------------------------------------------------------------ + +getWord64N1Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64le + loop (s+s0) (n-1) + +getWord64N2Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64le + s1 <- getWord64le + loop (s+s0+s1) (n-2) + +getWord64N4Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64le + s1 <- getWord64le + s2 <- getWord64le + s3 <- getWord64le + loop (s+s0+s1+s2+s3) (n-4) + +getWord64N8Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64le + s1 <- getWord64le + s2 <- getWord64le + s3 <- getWord64le + s4 <- getWord64le + s5 <- getWord64le + s6 <- getWord64le + s7 <- getWord64le + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +getWord64N16Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64le + s1 <- getWord64le + s2 <- getWord64le + s3 <- getWord64le + s4 <- getWord64le + s5 <- getWord64le + s6 <- getWord64le + s7 <- getWord64le + s8 <- getWord64le + s9 <- getWord64le + s10 <- getWord64le + s11 <- getWord64le + s12 <- getWord64le + s13 <- getWord64le + s14 <- getWord64le + s15 <- getWord64le + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + +------------------------------------------------------------------------ + +getWord64N1Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64host + loop (s+s0) (n-1) + +getWord64N2Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64host + s1 <- getWord64host + loop (s+s0+s1) (n-2) + +getWord64N4Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64host + s1 <- getWord64host + s2 <- getWord64host + s3 <- getWord64host + loop (s+s0+s1+s2+s3) (n-4) + +getWord64N8Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64host + s1 <- getWord64host + s2 <- getWord64host + s3 <- getWord64host + s4 <- getWord64host + s5 <- getWord64host + s6 <- getWord64host + s7 <- getWord64host + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +getWord64N16Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64host + s1 <- getWord64host + s2 <- getWord64host + s3 <- getWord64host + s4 <- getWord64host + s5 <- getWord64host + s6 <- getWord64host + s7 <- getWord64host + s8 <- getWord64host + s9 <- getWord64host + s10 <- getWord64host + s11 <- getWord64host + s12 <- getWord64host + s13 <- getWord64host + s14 <- getWord64host + s15 <- getWord64host + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) diff -ruN ghc-6.12.1/libraries/binary/tests/CBenchmark.c ghc-6.13.20091231/libraries/binary/tests/CBenchmark.c --- ghc-6.12.1/libraries/binary/tests/CBenchmark.c 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/binary/tests/CBenchmark.c 2009-12-31 10:24:49.000000000 -0800 @@ -0,0 +1,39 @@ +#include "CBenchmark.h" + +void bytewrite(unsigned char *a, int bytes) { + unsigned char n = 0; + int i = 0; + int iterations = bytes; + while (i < iterations) { + a[i++] = n++; + } +} + +unsigned char byteread(unsigned char *a, int bytes) { + unsigned char n = 0; + int i = 0; + int iterations = bytes; + while (i < iterations) { + n += a[i++]; + } + return n; +} + +void wordwrite(unsigned long *a, int bytes) { + unsigned long n = 0; + int i = 0; + int iterations = bytes / sizeof(unsigned long) ; + while (i < iterations) { + a[i++] = n++; + } +} + +unsigned int wordread(unsigned long *a, int bytes) { + unsigned long n = 0; + int i = 0; + int iterations = bytes / sizeof(unsigned long); + while (i < iterations) { + n += a[i++]; + } + return n; +} diff -ruN ghc-6.12.1/libraries/binary/tests/CBenchmark.h ghc-6.13.20091231/libraries/binary/tests/CBenchmark.h --- ghc-6.12.1/libraries/binary/tests/CBenchmark.h 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/binary/tests/CBenchmark.h 2009-12-31 10:24:49.000000000 -0800 @@ -0,0 +1,4 @@ +void bytewrite(unsigned char *a, int bytes); +unsigned char byteread(unsigned char *a, int bytes); +void wordwrite(unsigned long *a, int bytes); +unsigned int wordread(unsigned long *a, int bytes); diff -ruN ghc-6.12.1/libraries/binary/tests/HeapUse.hs ghc-6.13.20091231/libraries/binary/tests/HeapUse.hs --- ghc-6.12.1/libraries/binary/tests/HeapUse.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/binary/tests/HeapUse.hs 2009-12-31 10:24:49.000000000 -0800 @@ -0,0 +1,17 @@ +-- Checks heap behavior of getBytes + +import Data.Binary.Get (runGet, getBytes) + +import Control.Monad (liftM) +import qualified Data.ByteString.Lazy as L + +main = do + let x = (L.take 110000042 $ L.iterate (+1) 0) + mapM_ (print . L.length) (chunks 20000000 x) + +chunks n = runGet (unfoldM f) + where f = do x <- getBytes 20000000 + return $ if L.null x then Nothing else Just x + +unfoldM :: Monad m => m (Maybe a) -> m [a] +unfoldM f = f >>= maybe (return []) (\x -> liftM (x:) (unfoldM f)) diff -ruN ghc-6.12.1/libraries/binary/tests/Makefile ghc-6.13.20091231/libraries/binary/tests/Makefile --- ghc-6.12.1/libraries/binary/tests/Makefile 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/binary/tests/Makefile 2009-12-31 10:24:49.000000000 -0800 @@ -0,0 +1,34 @@ +all: compiled + +interpreted: + runhaskell QC.hs 1000 + +compiled: + ghc --make -fhpc -O QC.hs -o qc -no-recomp -threaded + ./qc 500 +RTS -qw -N2 + +bench:: Benchmark.hs MemBench.hs CBenchmark.o + ghc --make -O2 -fliberate-case-threshold=1000 -fasm Benchmark.hs CBenchmark.o -o bench -fforce-recomp + ./bench 100 + +bench-nb:: + ghc --make -O2 -fliberate-case-threshold=1000 NewBenchmark.hs -fasm -o bench-nb + ./bench-nb + +CBenchmark.o: CBenchmark.c + gcc -O3 -c $< -o $@ + +hugs: + runhugs -98 QC.hs + + +HeapUse: HeapUse.hs + ghc --make -O $^ -fasm -o $@ + +heap: HeapUse + ./HeapUse +RTS -M10M -t/dev/stderr -RTS + +clean: + rm -f *.o *.hi qc bench bench-nb *~ + +.PHONY: clean bench bench-nb diff -ruN ghc-6.12.1/libraries/binary/tests/MemBench.hs ghc-6.13.20091231/libraries/binary/tests/MemBench.hs --- ghc-6.12.1/libraries/binary/tests/MemBench.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/binary/tests/MemBench.hs 2009-12-31 10:24:49.000000000 -0800 @@ -0,0 +1,85 @@ +{-# LANGUAGE ForeignFunctionInterface, BangPatterns #-} +module MemBench (memBench) where + +import Foreign +import Foreign.C + +import Control.Exception +import System.CPUTime +import Numeric + +memBench :: Int -> IO () +memBench mb = do + let bytes = mb * 2^20 + allocaBytes bytes $ \ptr -> do + let bench label test = do + seconds <- time $ test (castPtr ptr) (fromIntegral bytes) + let throughput = fromIntegral mb / seconds + putStrLn $ show mb ++ "MB of " ++ label + ++ " in " ++ showFFloat (Just 3) seconds "s, at: " + ++ showFFloat (Just 1) throughput "MB/s" + bench "setup " c_wordwrite + putStrLn "" + putStrLn "C memory throughput benchmarks:" + bench "bytes written" c_bytewrite + bench "bytes read " c_byteread + bench "words written" c_wordwrite + bench "words read " c_wordread + putStrLn "" + putStrLn "Haskell memory throughput benchmarks:" + bench "bytes written" hs_bytewrite + bench "bytes read " hs_byteread + bench "words written" hs_wordwrite + bench "words read " hs_wordread + +hs_bytewrite :: Ptr CUChar -> Int -> IO () +hs_bytewrite !ptr bytes = loop 0 0 + where iterations = bytes + loop :: Int -> CUChar -> IO () + loop !i !n | i == iterations = return () + | otherwise = do pokeByteOff ptr i n + loop (i+1) (n+1) + +hs_byteread :: Ptr CUChar -> Int -> IO CUChar +hs_byteread !ptr bytes = loop 0 0 + where iterations = bytes + loop :: Int -> CUChar -> IO CUChar + loop !i !n | i == iterations = return n + | otherwise = do x <- peekByteOff ptr i + loop (i+1) (n+x) + +hs_wordwrite :: Ptr CULong -> Int -> IO () +hs_wordwrite !ptr bytes = loop 0 0 + where iterations = bytes `div` sizeOf (undefined :: CULong) + loop :: Int -> CULong -> IO () + loop !i !n | i == iterations = return () + | otherwise = do pokeByteOff ptr i n + loop (i+1) (n+1) + +hs_wordread :: Ptr CULong -> Int -> IO CULong +hs_wordread !ptr bytes = loop 0 0 + where iterations = bytes `div` sizeOf (undefined :: CULong) + loop :: Int -> CULong -> IO CULong + loop !i !n | i == iterations = return n + | otherwise = do x <- peekByteOff ptr i + loop (i+1) (n+x) + + +foreign import ccall unsafe "CBenchmark.h byteread" + c_byteread :: Ptr CUChar -> CInt -> IO () + +foreign import ccall unsafe "CBenchmark.h bytewrite" + c_bytewrite :: Ptr CUChar -> CInt -> IO () + +foreign import ccall unsafe "CBenchmark.h wordread" + c_wordread :: Ptr CUInt -> CInt -> IO () + +foreign import ccall unsafe "CBenchmark.h wordwrite" + c_wordwrite :: Ptr CUInt -> CInt -> IO () + +time :: IO a -> IO Double +time action = do + start <- getCPUTime + action + end <- getCPUTime + return $! (fromIntegral (end - start)) / (10^12) diff -ruN ghc-6.12.1/libraries/binary/tests/NewBenchmark.hs ghc-6.13.20091231/libraries/binary/tests/NewBenchmark.hs --- ghc-6.12.1/libraries/binary/tests/NewBenchmark.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/binary/tests/NewBenchmark.hs 2009-12-31 10:24:49.000000000 -0800 @@ -0,0 +1,625 @@ +-- +-- benchmark NewBinary +-- + +module Main where + +import System.IO +import Data.Word +import NewBinary + +import Control.Exception +import System.CPUTime +import Numeric + +mb :: Int +mb = 10 + +main :: IO () +main = sequence_ + [ test wordSize chunkSize mb + | wordSize <- [1,2,4,8] + , chunkSize <- [1,2,4,8,16] ] + +time :: IO a -> IO Double +time action = do + start <- getCPUTime + action + end <- getCPUTime + return $! (fromIntegral (end - start)) / (10^12) + +test :: Int -> Int -> Int -> IO () +test wordSize chunkSize mb = do + let bytes :: Int + bytes = mb * 2^20 + iterations = bytes `div` wordSize + putStr $ show mb ++ "MB of Word" ++ show (8 * wordSize) + ++ " in chunks of " ++ show chunkSize ++ ": " + h <- openBinMem bytes undefined + start <- tellBin h + putSeconds <- time $ do + doPut wordSize chunkSize h iterations +-- BinPtr n _ <- tellBin h +-- print n + getSeconds <- time $ do + seekBin h start + sum <- doGet wordSize chunkSize h iterations + evaluate sum +-- BinPtr n _ <- tellBin h +-- print (n, sum) + let putThroughput = fromIntegral mb / putSeconds + getThroughput = fromIntegral mb / getSeconds + putStrLn $ showFFloat (Just 2) putThroughput "MB/s write, " + ++ showFFloat (Just 2) getThroughput "MB/s read" + +doPut :: Int -> Int -> BinHandle -> Int -> IO () +doPut wordSize chunkSize = + case (wordSize, chunkSize) of + (1, 1) -> putWord8N1 + (1, 2) -> putWord8N2 + (1, 4) -> putWord8N4 + (1, 8) -> putWord8N8 + (1, 16) -> putWord8N16 + (2, 1) -> putWord16N1 + (2, 2) -> putWord16N2 + (2, 4) -> putWord16N4 + (2, 8) -> putWord16N8 + (2, 16) -> putWord16N16 + (4, 1) -> putWord32N1 + (4, 2) -> putWord32N2 + (4, 4) -> putWord32N4 + (4, 8) -> putWord32N8 + (4, 16) -> putWord32N16 + (8, 1) -> putWord64N1 + (8, 2) -> putWord64N2 + (8, 4) -> putWord64N4 + (8, 8) -> putWord64N8 + (8, 16) -> putWord64N16 + +putWord8 :: BinHandle -> Word8 -> IO () +putWord8 = put_ +{-# INLINE putWord8 #-} + +putWord16be :: BinHandle -> Word16 -> IO () +putWord16be = put_ +{-# INLINE putWord16be #-} + +putWord32be :: BinHandle -> Word32 -> IO () +putWord32be = put_ +{-# INLINE putWord32be #-} + +putWord64be :: BinHandle -> Word64 -> IO () +putWord64be = put_ +{-# INLINE putWord64be #-} + +getWord8 :: BinHandle -> IO Word8 +getWord8 = get +{-# INLINE getWord8 #-} + +getWord16be :: BinHandle -> IO Word16 +getWord16be = get +{-# INLINE getWord16be #-} + +getWord32be :: BinHandle -> IO Word32 +getWord32be = get +{-# INLINE getWord32be #-} + +getWord64be :: BinHandle -> IO Word64 +getWord64be = get +{-# INLINE getWord64be #-} + +putWord8N1 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord8 hnd (s+0) + loop (s+1) (n-1) + +putWord8N2 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord8 hnd (s+0) + putWord8 hnd (s+1) + loop (s+2) (n-2) + +putWord8N4 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord8 hnd (s+0) + putWord8 hnd (s+1) + putWord8 hnd (s+2) + putWord8 hnd (s+3) + loop (s+4) (n-4) + +putWord8N8 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord8 hnd (s+0) + putWord8 hnd (s+1) + putWord8 hnd (s+2) + putWord8 hnd (s+3) + putWord8 hnd (s+4) + putWord8 hnd (s+5) + putWord8 hnd (s+6) + putWord8 hnd (s+7) + loop (s+8) (n-8) + +putWord8N16 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord8 hnd (s+0) + putWord8 hnd (s+1) + putWord8 hnd (s+2) + putWord8 hnd (s+3) + putWord8 hnd (s+4) + putWord8 hnd (s+5) + putWord8 hnd (s+6) + putWord8 hnd (s+7) + putWord8 hnd (s+8) + putWord8 hnd (s+9) + putWord8 hnd (s+10) + putWord8 hnd (s+11) + putWord8 hnd (s+12) + putWord8 hnd (s+13) + putWord8 hnd (s+14) + putWord8 hnd (s+15) + loop (s+16) (n-16) + + +putWord16N1 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16be hnd (s+0) + loop (s+1) (n-1) + +putWord16N2 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16be hnd (s+0) + putWord16be hnd (s+1) + loop (s+2) (n-2) + +putWord16N4 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16be hnd (s+0) + putWord16be hnd (s+1) + putWord16be hnd (s+2) + putWord16be hnd (s+3) + loop (s+4) (n-4) + +putWord16N8 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16be hnd (s+0) + putWord16be hnd (s+1) + putWord16be hnd (s+2) + putWord16be hnd (s+3) + putWord16be hnd (s+4) + putWord16be hnd (s+5) + putWord16be hnd (s+6) + putWord16be hnd (s+7) + loop (s+8) (n-8) + +putWord16N16 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16be hnd (s+0) + putWord16be hnd (s+1) + putWord16be hnd (s+2) + putWord16be hnd (s+3) + putWord16be hnd (s+4) + putWord16be hnd (s+5) + putWord16be hnd (s+6) + putWord16be hnd (s+7) + putWord16be hnd (s+8) + putWord16be hnd (s+9) + putWord16be hnd (s+10) + putWord16be hnd (s+11) + putWord16be hnd (s+12) + putWord16be hnd (s+13) + putWord16be hnd (s+14) + putWord16be hnd (s+15) + loop (s+16) (n-16) + + +putWord32N1 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32be hnd (s+0) + loop (s+1) (n-1) + +putWord32N2 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32be hnd (s+0) + putWord32be hnd (s+1) + loop (s+2) (n-2) + +putWord32N4 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32be hnd (s+0) + putWord32be hnd (s+1) + putWord32be hnd (s+2) + putWord32be hnd (s+3) + loop (s+4) (n-4) + +putWord32N8 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32be hnd (s+0) + putWord32be hnd (s+1) + putWord32be hnd (s+2) + putWord32be hnd (s+3) + putWord32be hnd (s+4) + putWord32be hnd (s+5) + putWord32be hnd (s+6) + putWord32be hnd (s+7) + loop (s+8) (n-8) + +putWord32N16 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32be hnd (s+0) + putWord32be hnd (s+1) + putWord32be hnd (s+2) + putWord32be hnd (s+3) + putWord32be hnd (s+4) + putWord32be hnd (s+5) + putWord32be hnd (s+6) + putWord32be hnd (s+7) + putWord32be hnd (s+8) + putWord32be hnd (s+9) + putWord32be hnd (s+10) + putWord32be hnd (s+11) + putWord32be hnd (s+12) + putWord32be hnd (s+13) + putWord32be hnd (s+14) + putWord32be hnd (s+15) + loop (s+16) (n-16) + +putWord64N1 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64be hnd (s+0) + loop (s+1) (n-1) + +putWord64N2 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64be hnd (s+0) + putWord64be hnd (s+1) + loop (s+2) (n-2) + +putWord64N4 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64be hnd (s+0) + putWord64be hnd (s+1) + putWord64be hnd (s+2) + putWord64be hnd (s+3) + loop (s+4) (n-4) + +putWord64N8 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64be hnd (s+0) + putWord64be hnd (s+1) + putWord64be hnd (s+2) + putWord64be hnd (s+3) + putWord64be hnd (s+4) + putWord64be hnd (s+5) + putWord64be hnd (s+6) + putWord64be hnd (s+7) + loop (s+8) (n-8) + +putWord64N16 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64be hnd (s+0) + putWord64be hnd (s+1) + putWord64be hnd (s+2) + putWord64be hnd (s+3) + putWord64be hnd (s+4) + putWord64be hnd (s+5) + putWord64be hnd (s+6) + putWord64be hnd (s+7) + putWord64be hnd (s+8) + putWord64be hnd (s+9) + putWord64be hnd (s+10) + putWord64be hnd (s+11) + putWord64be hnd (s+12) + putWord64be hnd (s+13) + putWord64be hnd (s+14) + putWord64be hnd (s+15) + loop (s+16) (n-16) + +doGet :: Int -> Int -> BinHandle -> Int -> IO Int +doGet wordSize chunkSize hnd = + case (wordSize, chunkSize) of + (1, 1) -> fmap fromIntegral . getWord8N1 hnd + (1, 2) -> fmap fromIntegral . getWord8N2 hnd + (1, 4) -> fmap fromIntegral . getWord8N4 hnd + (1, 8) -> fmap fromIntegral . getWord8N8 hnd + (1, 16) -> fmap fromIntegral . getWord8N16 hnd + (2, 1) -> fmap fromIntegral . getWord16N1 hnd + (2, 2) -> fmap fromIntegral . getWord16N2 hnd + (2, 4) -> fmap fromIntegral . getWord16N4 hnd + (2, 8) -> fmap fromIntegral . getWord16N8 hnd + (2, 16) -> fmap fromIntegral . getWord16N16 hnd + (4, 1) -> fmap fromIntegral . getWord32N1 hnd + (4, 2) -> fmap fromIntegral . getWord32N2 hnd + (4, 4) -> fmap fromIntegral . getWord32N4 hnd + (4, 8) -> fmap fromIntegral . getWord32N8 hnd + (4, 16) -> fmap fromIntegral . getWord32N16 hnd + (8, 1) -> fmap fromIntegral . getWord64N1 hnd + (8, 2) -> fmap fromIntegral . getWord64N2 hnd + (8, 4) -> fmap fromIntegral . getWord64N4 hnd + (8, 8) -> fmap fromIntegral . getWord64N8 hnd + (8, 16) -> fmap fromIntegral . getWord64N16 hnd + +getWord8N1 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord8 hnd + loop (s+s0) (n-1) + +getWord8N2 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord8 hnd + s1 <- getWord8 hnd + loop (s+s0+s1) (n-2) + +getWord8N4 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord8 hnd + s1 <- getWord8 hnd + s2 <- getWord8 hnd + s3 <- getWord8 hnd + loop (s+s0+s1+s2+s3) (n-4) + +getWord8N8 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord8 hnd + s1 <- getWord8 hnd + s2 <- getWord8 hnd + s3 <- getWord8 hnd + s4 <- getWord8 hnd + s5 <- getWord8 hnd + s6 <- getWord8 hnd + s7 <- getWord8 hnd + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +getWord8N16 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord8 hnd + s1 <- getWord8 hnd + s2 <- getWord8 hnd + s3 <- getWord8 hnd + s4 <- getWord8 hnd + s5 <- getWord8 hnd + s6 <- getWord8 hnd + s7 <- getWord8 hnd + s8 <- getWord8 hnd + s9 <- getWord8 hnd + s10 <- getWord8 hnd + s11 <- getWord8 hnd + s12 <- getWord8 hnd + s13 <- getWord8 hnd + s14 <- getWord8 hnd + s15 <- getWord8 hnd + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + + +getWord16N1 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16be hnd + loop (s+s0) (n-1) + +getWord16N2 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16be hnd + s1 <- getWord16be hnd + loop (s+s0+s1) (n-2) + +getWord16N4 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16be hnd + s1 <- getWord16be hnd + s2 <- getWord16be hnd + s3 <- getWord16be hnd + loop (s+s0+s1+s2+s3) (n-4) + +getWord16N8 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16be hnd + s1 <- getWord16be hnd + s2 <- getWord16be hnd + s3 <- getWord16be hnd + s4 <- getWord16be hnd + s5 <- getWord16be hnd + s6 <- getWord16be hnd + s7 <- getWord16be hnd + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +getWord16N16 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16be hnd + s1 <- getWord16be hnd + s2 <- getWord16be hnd + s3 <- getWord16be hnd + s4 <- getWord16be hnd + s5 <- getWord16be hnd + s6 <- getWord16be hnd + s7 <- getWord16be hnd + s8 <- getWord16be hnd + s9 <- getWord16be hnd + s10 <- getWord16be hnd + s11 <- getWord16be hnd + s12 <- getWord16be hnd + s13 <- getWord16be hnd + s14 <- getWord16be hnd + s15 <- getWord16be hnd + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + + +getWord32N1 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32be hnd + loop (s+s0) (n-1) + +getWord32N2 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32be hnd + s1 <- getWord32be hnd + loop (s+s0+s1) (n-2) + +getWord32N4 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32be hnd + s1 <- getWord32be hnd + s2 <- getWord32be hnd + s3 <- getWord32be hnd + loop (s+s0+s1+s2+s3) (n-4) + +getWord32N8 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32be hnd + s1 <- getWord32be hnd + s2 <- getWord32be hnd + s3 <- getWord32be hnd + s4 <- getWord32be hnd + s5 <- getWord32be hnd + s6 <- getWord32be hnd + s7 <- getWord32be hnd + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +getWord32N16 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32be hnd + s1 <- getWord32be hnd + s2 <- getWord32be hnd + s3 <- getWord32be hnd + s4 <- getWord32be hnd + s5 <- getWord32be hnd + s6 <- getWord32be hnd + s7 <- getWord32be hnd + s8 <- getWord32be hnd + s9 <- getWord32be hnd + s10 <- getWord32be hnd + s11 <- getWord32be hnd + s12 <- getWord32be hnd + s13 <- getWord32be hnd + s14 <- getWord32be hnd + s15 <- getWord32be hnd + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + +getWord64N1 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64be hnd + loop (s+s0) (n-1) + +getWord64N2 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64be hnd + s1 <- getWord64be hnd + loop (s+s0+s1) (n-2) + +getWord64N4 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64be hnd + s1 <- getWord64be hnd + s2 <- getWord64be hnd + s3 <- getWord64be hnd + loop (s+s0+s1+s2+s3) (n-4) + +getWord64N8 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64be hnd + s1 <- getWord64be hnd + s2 <- getWord64be hnd + s3 <- getWord64be hnd + s4 <- getWord64be hnd + s5 <- getWord64be hnd + s6 <- getWord64be hnd + s7 <- getWord64be hnd + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +getWord64N16 hnd = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64be hnd + s1 <- getWord64be hnd + s2 <- getWord64be hnd + s3 <- getWord64be hnd + s4 <- getWord64be hnd + s5 <- getWord64be hnd + s6 <- getWord64be hnd + s7 <- getWord64be hnd + s8 <- getWord64be hnd + s9 <- getWord64be hnd + s10 <- getWord64be hnd + s11 <- getWord64be hnd + s12 <- getWord64be hnd + s13 <- getWord64be hnd + s14 <- getWord64be hnd + s15 <- getWord64be hnd + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) diff -ruN ghc-6.12.1/libraries/binary/tests/NewBinary.hs ghc-6.13.20091231/libraries/binary/tests/NewBinary.hs --- ghc-6.12.1/libraries/binary/tests/NewBinary.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/binary/tests/NewBinary.hs 2009-12-31 10:24:49.000000000 -0800 @@ -0,0 +1,1006 @@ +{-# OPTIONS -cpp -fglasgow-exts #-} +-- +-- (c) The University of Glasgow 2002 +-- +-- Binary I/O library, with special tweaks for GHC +-- +-- Based on the nhc98 Binary library, which is copyright +-- (c) Malcolm Wallace and Colin Runciman, University of York, 1998. +-- Under the terms of the license for that software, we must tell you +-- where you can obtain the original version of the Binary library, namely +-- http://www.cs.york.ac.uk/fp/nhc98/ + +module NewBinary + ( {-type-} Bin, + {-class-} Binary(..), + {-type-} BinHandle(..), + + openBinIO, + openBinIO_, + openBinMem, +-- closeBin, + +-- getUserData, + + seekBin, + tellBin, + tellBinByte, + castBin, + + writeBinMem, + readBinMem, + + isEOFBin, + + -- for writing instances: + putByte, + getByte, + + -- bit stuff + putBits, + getBits, + flushByte, + finishByte, + putMaybeInt, + getMaybeInt, + + -- lazy Bin I/O + lazyGet, + lazyPut, + + -- GHC only: + ByteArray(..), + getByteArray, + putByteArray, + +-- getBinFileWithDict, -- :: Binary a => FilePath -> IO a +-- putBinFileWithDict, -- :: Binary a => FilePath -> Module -> a -> IO () + + ) where + +#include "MachDeps.h" + +import GHC.Exts +import GHC.IOBase +import GHC.Real +import Data.Array.IO ( IOUArray ) +import Data.Bits +import Data.Int +import Data.Word +import Data.Char +import Control.Monad +import Control.Exception +import Data.Array +import Data.Array.IO +import Data.Array.Base +import System.IO as IO +import System.IO.Error ( mkIOError, eofErrorType ) +import GHC.Handle +import System.IO + +import GHC.Exts +#if __GLASGOW_HASKELL__ >= 504 +import GHC.IOBase +import Data.Word +import Data.Bits +#else +import PrelIOBase +import Word +import Bits +#endif + +#ifndef SIZEOF_HSINT +#define SIZEOF_HSINT INT_SIZE_IN_BYTES +#endif + +#if __GLASGOW_HASKELL__ < 503 +type BinArray = MutableByteArray RealWorld Int +newArray_ bounds = stToIO (newCharArray bounds) +unsafeWrite arr ix e = stToIO (writeWord8Array arr ix e) +unsafeRead arr ix = stToIO (readWord8Array arr ix) + +hPutArray h arr sz = hPutBufBA h arr sz +hGetArray h sz = hGetBufBA h sz + +mkIOError :: IOErrorType -> String -> Maybe Handle -> Maybe FilePath -> Exception +mkIOError t location maybe_hdl maybe_filename + = IOException (IOError maybe_hdl t location "" + maybe_filename + ) + +eofErrorType = EOF + +#ifndef SIZEOF_HSINT +#define SIZEOF_HSINT INT_SIZE_IN_BYTES +#endif + +#ifndef SIZEOF_HSWORD +#define SIZEOF_HSWORD WORD_SIZE_IN_BYTES +#endif + +#else +type BinArray = IOUArray Int Word8 +#endif + +data BinHandle + = BinMem { -- binary data stored in an unboxed array + off_r :: !FastMutInt, -- the current offset + sz_r :: !FastMutInt, -- size of the array (cached) + arr_r :: !(IORef BinArray), -- the array (bounds: (0,size-1)) + bit_off_r :: !FastMutInt, -- the bit offset (see end of file) + bit_cache_r :: !FastMutInt -- the bit cache (see end of file) + } + -- XXX: should really store a "high water mark" for dumping out + -- the binary data to a file. + + | BinIO { -- binary data stored in a file + off_r :: !FastMutInt, -- the current offset (cached) + hdl :: !IO.Handle, -- the file handle (must be seekable) + bit_off_r :: !FastMutInt, -- the bit offset (see end of file) + bit_cache_r :: !FastMutInt -- the bit cache (see end of file) + } + -- cache the file ptr in BinIO; using hTell is too expensive + -- to call repeatedly. If anyone else is modifying this Handle + -- at the same time, we'll be screwed. + +data Bin a = BinPtr !Int !Int -- byte/bit + deriving (Eq, Ord, Show, Bounded) + +castBin :: Bin a -> Bin b +castBin (BinPtr i j) = BinPtr i j + +class Binary a where + put_ :: BinHandle -> a -> IO () + put :: BinHandle -> a -> IO (Bin a) + get :: BinHandle -> IO a + + -- define one of put_, put. Use of put_ is recommended because it + -- is more likely that tail-calls can kick in, and we rarely need the + -- position return value. + put_ bh a = do put bh a; return () + put bh a = do p <- tellBin bh; put_ bh a; return p + +putAt :: Binary a => BinHandle -> Bin a -> a -> IO () +putAt bh p x = do seekBin bh p; put bh x; return () + +getAt :: Binary a => BinHandle -> Bin a -> IO a +getAt bh p = do seekBin bh p; get bh + +openBinIO_ :: IO.Handle -> IO BinHandle +openBinIO_ h = openBinIO h noBinHandleUserData + +newZeroInt = do r <- newFastMutInt; writeFastMutInt r 0; return r + +-- openBinIO :: IO.Handle -> Module -> IO BinHandle +openBinIO :: forall t. Handle -> t -> IO BinHandle +openBinIO h mod = do + r <- newZeroInt + o <- newZeroInt + c <- newZeroInt +-- state <- newWriteState mod + return (BinIO r h o c) + +--openBinMem :: Int -> Module -> IO BinHandle +openBinMem :: forall t. Int -> t -> IO BinHandle +openBinMem size mod + | size <= 0 = error "Data.Binary.openBinMem: size must be > 0" -- fix, was ">= 0" + | otherwise = do + arr <- newArray_ (0,size-1) + arr_r <- newIORef arr + ix_r <- newFastMutInt + writeFastMutInt ix_r 0 + sz_r <- newFastMutInt + writeFastMutInt sz_r size + o <- newZeroInt + c <- newZeroInt +-- state <- newWriteState mod + return (BinMem ix_r sz_r arr_r o c) + +noBinHandleUserData = error "Binary.BinHandle: no user data" + +--getUserData :: BinHandle -> BinHandleState +--getUserData bh = state bh + +tellBin :: BinHandle -> IO (Bin a) +tellBin (BinIO r _ o _) = do ix <- readFastMutInt r; bix <- readFastMutInt o; return (BinPtr ix bix) +tellBin (BinMem r _ _ o _) = do ix <- readFastMutInt r; bix <- readFastMutInt o; return (BinPtr ix bix) + +tellBinByte (BinIO r _ _ _) = do ix <- readFastMutInt r; return ix +tellBinByte (BinMem r _ _ _ _) = do ix <- readFastMutInt r; return ix + +seekBin :: BinHandle -> Bin a -> IO () +seekBin bh@(BinIO ix_r h o c) (BinPtr p bit) = do + writeFastMutInt ix_r p + writeFastMutInt o 0 + writeFastMutInt c 0 + hSeek h AbsoluteSeek (fromIntegral p) + when (bit /= 0) $ getBits bh bit >> return () + return () +seekBin h@(BinMem ix_r sz_r a o c) (BinPtr p bit) = do + sz <- readFastMutInt sz_r + if (p >= sz) + then do expandBin h p + writeFastMutInt ix_r p + writeFastMutInt o 0 + writeFastMutInt c 0 + when (bit /= 0) $ getBits h bit >> return () + return () + + else do writeFastMutInt ix_r p + writeFastMutInt o 0 + writeFastMutInt c 0 + when (bit /= 0) $ getBits h bit >> return () + return () + +isEOFBin :: BinHandle -> IO Bool +isEOFBin (BinMem ix_r sz_r a _ _) = do + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + return (ix >= sz) +isEOFBin (BinIO ix_r h _ _) = hIsEOF h + +writeBinMem :: BinHandle -> FilePath -> IO () +writeBinMem (BinIO _ _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle" +writeBinMem bh@(BinMem ix_r sz_r arr_r bit_off_r bit_cache_r) fn = do + flushByte bh + h <- openBinaryFile fn WriteMode + arr <- readIORef arr_r + ix <- readFastMutInt ix_r + hPutArray h arr ix + hClose h + +flushByte :: BinHandle -> IO () +flushByte bh = do + bit_off <- readFastMutInt (bit_off_r bh) + if bit_off == 0 + then return () + else putBits bh (8 - bit_off) 0 + +finishByte :: BinHandle -> IO () +finishByte bh = do + bit_off <- readFastMutInt (bit_off_r bh) + if bit_off == 0 + then return () + else getBits bh (8 - bit_off) >> return () + +readBinMem :: FilePath -> IO BinHandle +readBinMem filename = do + h <- openBinaryFile filename ReadMode + filesize' <- hFileSize h + let filesize = fromIntegral filesize' + arr <- newArray_ (0,filesize-1) + count <- hGetArray h arr filesize + when (count /= filesize) + (error ("Binary.readBinMem: only read " ++ show count ++ " bytes")) + hClose h + arr_r <- newIORef arr + ix_r <- newFastMutInt + writeFastMutInt ix_r 0 + sz_r <- newFastMutInt + writeFastMutInt sz_r filesize + bit_off_r <- newZeroInt + bit_cache_r <- newZeroInt + return (BinMem {-initReadState-} ix_r sz_r arr_r bit_off_r bit_cache_r) + +-- expand the size of the array to include a specified offset +expandBin :: BinHandle -> Int -> IO () +expandBin (BinMem ix_r sz_r arr_r _ _) off = do + sz <- readFastMutInt sz_r + let sz' = head (dropWhile (<= off) (iterate (* 2) sz)) + arr <- readIORef arr_r + arr' <- newArray_ (0,sz'-1) + sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i + | i <- [ 0 .. sz-1 ] ] + writeFastMutInt sz_r sz' + writeIORef arr_r arr' +-- hPutStrLn stderr ("expanding to size: " ++ show sz') + return () +expandBin (BinIO _ _ _ _) _ = return () + -- no need to expand a file, we'll assume they expand by themselves. + +-- ----------------------------------------------------------------------------- +-- Low-level reading/writing of bytes + +putWord8 :: BinHandle -> Word8 -> IO () +putWord8 h@(BinMem ix_r sz_r arr_r bit_off_r bit_cache_r) w = do + bit_off <- readFastMutInt bit_off_r + if bit_off /= 0 then putBits h 8 w else do -- only do standard putWord8 if bit_off == 0 + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + -- double the size of the array if it overflows + if (ix >= sz) + then do expandBin h ix + putWord8 h w + else do arr <- readIORef arr_r + unsafeWrite arr ix w + writeFastMutInt ix_r (ix+1) + return () + +putWord8 bh@(BinIO ix_r h bit_off_r bit_cache_r) w = do + bit_off <- readFastMutInt bit_off_r + if bit_off /= 0 then putBits bh 8 w else do + ix <- readFastMutInt ix_r + hPutChar h (chr (fromIntegral w)) -- XXX not really correct + writeFastMutInt ix_r (ix+1) + return () + +putByteNoBits :: BinHandle -> Word8 -> IO () +putByteNoBits h@(BinMem ix_r sz_r arr_r _ _) w = do + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + -- double the size of the array if it overflows + if (ix >= sz) + then do expandBin h ix + putByteNoBits h w + else do arr <- readIORef arr_r + unsafeWrite arr ix w + writeFastMutInt ix_r (ix+1) + return () + +putByteNoBits bh@(BinIO ix_r h _ _) w = do + hPutChar h (chr (fromIntegral w)) -- XXX not really correct + incFastMutInt ix_r + return () + +getByteNoBits :: BinHandle -> IO Word8 +getByteNoBits h@(BinMem ix_r sz_r arr_r _ _) = do + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + when (ix >= sz) $ + throw (IOException $ mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing) + arr <- readIORef arr_r + w <- unsafeRead arr ix + writeFastMutInt ix_r (ix+1) + return w + +getByteNoBits bh@(BinIO ix_r h _ _) = do + c <- hGetChar h + incFastMutInt ix_r + return $! (fromIntegral (ord c)) -- XXX not really correct + +getWord8 :: BinHandle -> IO Word8 +getWord8 h@(BinMem ix_r sz_r arr_r bit_off_r _) = do + bit_off <- readFastMutInt bit_off_r + if bit_off /= 0 then getBits h 8 else do + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + when (ix >= sz) $ + throw (IOException $ mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing) + arr <- readIORef arr_r + w <- unsafeRead arr ix + writeFastMutInt ix_r (ix+1) + return w +getWord8 bh@(BinIO ix_r h bit_off_r _) = do + bit_off <- readFastMutInt bit_off_r + if bit_off /= 0 then getBits bh 8 else do + ix <- readFastMutInt ix_r + c <- hGetChar h + writeFastMutInt ix_r (ix+1) + return $! (fromIntegral (ord c)) -- XXX not really correct + +putByte :: BinHandle -> Word8 -> IO () +putByte bh w = put_ bh w + +getByte :: BinHandle -> IO Word8 +getByte = getWord8 + +-- ----------------------------------------------------------------------------- +-- Bit functions + +putBits :: BinHandle -> Int -> Word8 -> IO () +putBits bh num_bits bits {- | num_bits == 0 = return () + | num_bits < 0 = error "putBits cannot write negative numbers of bits" + | num_bits > 8 = error "putBits cannot write more than 8 bits at a time" + | otherwise -} = do + bit_off <- readFastMutInt (bit_off_r bh) + if num_bits + bit_off < 8 + then do incFastMutIntBy (bit_off_r bh) num_bits + orFastMutInt (bit_cache_r bh) (bits `shiftL` bit_off) + else if num_bits + bit_off == 8 + then do writeFastMutInt (bit_off_r bh) 0 + bit_cache <- {-# SCC "bc1" #-} readFastMutInt (bit_cache_r bh) >>= return . fromIntegral + writeFastMutInt (bit_cache_r bh) 0 + --putByte bh (bit_cache .|. (bits `shiftL` bit_off)) -- won't call putBits because bit_off_r == 0 + putByteNoBits bh (bit_cache .|. (bits `shiftL` bit_off)) + + else do let leftover_bits = 8 - bit_off -- we are going over a byte boundary + bit_cache <- {-# SCC "bc2" #-} readFastMutInt (bit_cache_r bh) >>= \x -> return ({-# SCC "fi" #-} fromIntegral x) + writeFastMutInt (bit_off_r bh) 0 + writeFastMutInt (bit_cache_r bh) 0 + {- putByte bh (bit_cache .|. (bits `shiftL` bit_off)) -} -- won't call putBits + putByteNoBits bh (bit_cache .|. (bits `shiftL` bit_off)) + putBits bh (num_bits - leftover_bits) (bits `shiftR` leftover_bits) + +getBits :: BinHandle -> Int -> IO Word8 +getBits bh num_bits {- | num_bits == 0 = return 0 + | num_bits < 0 = error "getBits cannot read negative numbers of bits" + | num_bits > 8 = error "getBits cannot read more than 8 bits at a time" + | otherwise -} = do + bit_off <- readFastMutInt (bit_off_r bh) + if bit_off == 0 + then do bit_cache <- getByte bh + if num_bits == 8 + then do writeFastMutInt (bit_off_r bh) 0 + writeFastMutInt (bit_cache_r bh) 0 + return bit_cache + else do writeFastMutInt (bit_off_r bh) (fromIntegral num_bits) + writeFastMutInt (bit_cache_r bh) (fromIntegral bit_cache) + return (bit_cache .&. bit_mask num_bits) + else if bit_off + num_bits < 8 + then do incFastMutIntBy (bit_off_r bh) num_bits + bit_cache <- readFastMutInt (bit_cache_r bh) >>= return . fromIntegral + return ((bit_cache `shiftR` bit_off) .&. bit_mask num_bits) + else if bit_off + num_bits == 8 + then do writeFastMutInt (bit_off_r bh) 0 + bit_cache <- readFastMutInt (bit_cache_r bh) >>= return . fromIntegral + writeFastMutInt (bit_cache_r bh) 0 + return ((bit_cache `shiftR` bit_off) .&. bit_mask num_bits) + else do let leftover_bits = 8 - bit_off + bit_cache <- readFastMutInt (bit_cache_r bh) >>= return . fromIntegral + let bits = (bit_cache `shiftR` bit_off) .&. bit_mask leftover_bits + writeFastMutInt (bit_cache_r bh) 0 + writeFastMutInt (bit_off_r bh) 0 + {- bit_cache <- getByte bh -} + -- use a version that doesn't care about bits + bit_cache <- getByteNoBits bh + writeFastMutInt (bit_off_r bh) (num_bits - leftover_bits) + writeFastMutInt (bit_cache_r bh) (fromIntegral bit_cache) + return (bits .|. ((bit_cache .&. bit_mask (num_bits - leftover_bits)) `shiftL` leftover_bits)) + + +bit_mask n = (complement 0) `shiftR` (8 - n) + +-- ----------------------------------------------------------------------------- +-- Primitve Word writes + +instance Binary Word8 where + put_ = putWord8 + get = getWord8 + +instance Binary Word16 where + put_ h w = do -- XXX too slow.. inline putWord8? + putByte h (fromIntegral (w `shiftR` 8)) + putByte h (fromIntegral (w .&. 0xff)) + get h = do + w1 <- getWord8 h + w2 <- getWord8 h + return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2) + + +instance Binary Word32 where + put_ h w = do + putByte h (fromIntegral (w `shiftR` 24)) + putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff)) + putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff)) + putByte h (fromIntegral (w .&. 0xff)) + get h = do + w1 <- getWord8 h + w2 <- getWord8 h + w3 <- getWord8 h + w4 <- getWord8 h + return $! ((fromIntegral w1 `shiftL` 24) .|. + (fromIntegral w2 `shiftL` 16) .|. + (fromIntegral w3 `shiftL` 8) .|. + (fromIntegral w4)) + + +instance Binary Word64 where + put_ h w = do + putByte h (fromIntegral (w `shiftR` 56)) + putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff)) + putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff)) + putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff)) + putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff)) + putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff)) + putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff)) + putByte h (fromIntegral (w .&. 0xff)) + get h = do + w1 <- getWord8 h + w2 <- getWord8 h + w3 <- getWord8 h + w4 <- getWord8 h + w5 <- getWord8 h + w6 <- getWord8 h + w7 <- getWord8 h + w8 <- getWord8 h + return $! ((fromIntegral w1 `shiftL` 56) .|. + (fromIntegral w2 `shiftL` 48) .|. + (fromIntegral w3 `shiftL` 40) .|. + (fromIntegral w4 `shiftL` 32) .|. + (fromIntegral w5 `shiftL` 24) .|. + (fromIntegral w6 `shiftL` 16) .|. + (fromIntegral w7 `shiftL` 8) .|. + (fromIntegral w8)) + +-- ----------------------------------------------------------------------------- +-- Primitve Int writes + +instance Binary Int8 where + put_ h w = put_ h (fromIntegral w :: Word8) + get h = do w <- get h; return $! (fromIntegral (w::Word8)) + +instance Binary Int16 where + put_ h w = put_ h (fromIntegral w :: Word16) + get h = do w <- get h; return $! (fromIntegral (w::Word16)) + +instance Binary Int32 where + put_ h w = put_ h (fromIntegral w :: Word32) + get h = do w <- get h; return $! (fromIntegral (w::Word32)) + +put31ofInt32 :: BinHandle -> Int32 -> IO () +put31ofInt32 h i = do + putBits h 7 (fromIntegral (w `shiftR` 24)) + putBits h 8 (fromIntegral ((w `shiftR` 16) .&. 0xff)) + putBits h 8 (fromIntegral ((w `shiftR` 8) .&. 0xff)) + putBits h 8 (fromIntegral (w .&. 0xff)) + where w = fromIntegral i :: Word32 + +get31ofInt32 :: BinHandle -> IO Int32 +get31ofInt32 h = do + w1 <- getBits h 7 + w2 <- getWord8 h + w3 <- getWord8 h + w4 <- getWord8 h + return $! ((fromIntegral w1 `shiftL` 24) .|. + (fromIntegral w2 `shiftL` 16) .|. + (fromIntegral w3 `shiftL` 8) .|. + (fromIntegral w4)) + +instance Binary Int64 where + put_ h w = put_ h (fromIntegral w :: Word64) + get h = do w <- get h; return $! (fromIntegral (w::Word64)) + +-- ----------------------------------------------------------------------------- +-- Instances for standard types + +instance Binary () where + put_ bh () = return () + get _ = return () +-- getF bh p = case getBitsF bh 0 p of (_,b) -> ((),b) + +{- updated for bits +instance Binary Bool where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x)) +-- getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b) +-} + +instance Binary Bool where + put_ bh True = putBits bh 1 1 + put_ bh False = putBits bh 1 0 + get bh = do b <- getBits bh 1; return (b == 1) + +instance Binary Char where + put_ bh c = put_ bh (fromIntegral (ord c) :: Word32) + get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32))) +-- getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b) + +instance Binary Int where +#if SIZEOF_HSINT == 4 + put_ bh i = put_ bh (fromIntegral i :: Int32) + get bh = do + x <- get bh + return $! (fromIntegral (x :: Int32)) +#elif SIZEOF_HSINT == 8 + put_ bh i = put_ bh (fromIntegral i :: Int64) + get bh = do + x <- get bh + return $! (fromIntegral (x :: Int64)) +#else +#error "unsupported sizeof(HsInt)" +#endif +-- getF bh = getBitsF bh 32 + +{- +instance Binary a => Binary [a] where + put_ bh [] = putByte bh 0 + put_ bh (x:xs) = do putByte bh 1; put_ bh x; put_ bh xs + get bh = do h <- getWord8 bh + case h of + 0 -> return [] + _ -> do x <- get bh + xs <- get bh + return (x:xs) +-} + +instance Binary a => Binary [a] where + put_ bh l = do + put_ bh (length l) + mapM (put_ bh) l + return () + get bh = do + len <- get bh + mapM (\_ -> get bh) [1..(len::Int)] + +instance (Binary a, Binary b) => Binary (a,b) where + put_ bh (a,b) = do put_ bh a; put_ bh b + get bh = do a <- get bh + b <- get bh + return (a,b) + +instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where + put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c + get bh = do a <- get bh + b <- get bh + c <- get bh + return (a,b,c) + +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where + put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (a,b,c,d) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where + put_ bh (a,b,c,d,e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + e <- get bh + return (a,b,c,d,e) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d,e,f) where + put_ bh (a,b,c,d,e,f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + e <- get bh + f <- get bh + return (a,b,c,d,e,f) + +instance Binary a => Binary (Maybe a) where + put_ bh Nothing = putByte bh 0 + put_ bh (Just a) = do putByte bh 1; put_ bh a + get bh = do h <- getWord8 bh + case h of + 0 -> return Nothing + _ -> do x <- get bh; return (Just x) + +putMaybeInt :: BinHandle -> Maybe Int -> IO () +getMaybeInt :: BinHandle -> IO (Maybe Int) +putMaybeInt bh Nothing = putBits bh 1 0 +putMaybeInt bh (Just i) = do putBits bh 1 1; put31ofInt32 bh (fromIntegral i) + +getMaybeInt bh = do + b <- getBits bh 1 + case b of + 0 -> return Nothing + _ -> do i <- get31ofInt32 bh + return (Just (fromIntegral i)) + +{- RULES get = getMaybeInt -} + +{- SPECIALIZE put_ :: BinHandle -> Maybe Int -> IO () = putMaybeInt -} +{- SPECIALIZE get :: BinHandle -> IO (Maybe Int) = getMaybeInt -} + + +instance (Binary a, Binary b) => Binary (Either a b) where + put_ bh (Left a) = do putByte bh 0; put_ bh a + put_ bh (Right b) = do putByte bh 1; put_ bh b + get bh = do h <- getWord8 bh + case h of + 0 -> do a <- get bh ; return (Left a) + _ -> do b <- get bh ; return (Right b) + +instance Binary Integer where + put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#) + put_ bh (J# s# a#) = do + p <- putByte bh 1; + put_ bh (I# s#) + let sz# = sizeofByteArray# a# -- in *bytes* + put_ bh (I# sz#) -- in *bytes* + putByteArray bh a# sz# + + get bh = do + b <- getByte bh + case b of + 0 -> do (I# i#) <- get bh + return (S# i#) + _ -> do (I# s#) <- get bh + sz <- get bh + (BA a#) <- getByteArray bh sz + return (J# s# a#) + +putByteArray :: BinHandle -> ByteArray# -> Int# -> IO () +putByteArray bh a s# = loop 0# + where loop n# + | n# ==# s# = return () + | otherwise = do + putByte bh (indexByteArray a n#) + loop (n# +# 1#) + +getByteArray :: BinHandle -> Int -> IO ByteArray +getByteArray bh (I# sz) = do + (MBA arr) <- newByteArray sz + let loop n + | n ==# sz = return () + | otherwise = do + w <- getByte bh + writeByteArray arr n w + loop (n +# 1#) + loop 0# + freezeByteArray arr + + +data ByteArray = BA ByteArray# +data MBA = MBA (MutableByteArray# RealWorld) + +newByteArray :: Int# -> IO MBA +newByteArray sz = IO $ \s -> + case newByteArray# sz s of { (# s, arr #) -> + (# s, MBA arr #) } + +freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray +freezeByteArray arr = IO $ \s -> + case unsafeFreezeByteArray# arr s of { (# s, arr #) -> + (# s, BA arr #) } + +writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO () + +writeByteArray arr i w8 = IO $ \s -> + case fromIntegral w8 of { W# w# -> + case writeCharArray# arr i (chr# (word2Int# w#)) s of { s -> + (# s , () #) }} + +indexByteArray a# n# = fromIntegral (I# (ord# (indexCharArray# a# n#))) + +instance (Integral a, Binary a) => Binary (Ratio a) where + put_ bh (a :% b) = do put_ bh a; put_ bh b + get bh = do a <- get bh; b <- get bh; return (a :% b) + +instance Binary (Bin a) where + put_ bh (BinPtr i j) = put_ bh (i,j) + get bh = do (i,j) <- get bh; return (BinPtr i j) + +-- ----------------------------------------------------------------------------- +-- Lazy reading/writing + +lazyPut :: Binary a => BinHandle -> a -> IO () +lazyPut bh a = do + -- output the obj with a ptr to skip over it: + pre_a <- tellBin bh + put_ bh pre_a -- save a slot for the ptr + put_ bh a -- dump the object + q <- tellBin bh -- q = ptr to after object + putAt bh pre_a q -- fill in slot before a with ptr to q + seekBin bh q -- finally carry on writing at q + +lazyGet :: Binary a => BinHandle -> IO a +lazyGet bh = do + p <- get bh -- a BinPtr + p_a <- tellBin bh + a <- unsafeInterleaveIO (getAt bh p_a) + seekBin bh p -- skip over the object for now + return a + +-- ----------------------------------------------------------------------------- +-- BinHandleState +{- +type BinHandleState = + (Module, + IORef Int, + IORef (UniqFM (Int,FastString)), + Array Int FastString) + +initReadState :: BinHandleState +initReadState = (undef, undef, undef, undef) + +newWriteState :: Module -> IO BinHandleState +newWriteState m = do + j_r <- newIORef 0 + out_r <- newIORef emptyUFM + return (m,j_r,out_r,undef) + +undef = error "Binary.BinHandleState" + +-- ----------------------------------------------------------------------------- +-- FastString binary interface + +getBinFileWithDict :: Binary a => FilePath -> IO a +getBinFileWithDict file_path = do + bh <- Binary.readBinMem file_path + magic <- get bh + when (magic /= binaryInterfaceMagic) $ + throwDyn (ProgramError ( + "magic number mismatch: old/corrupt interface file?")) + dict_p <- Binary.get bh -- get the dictionary ptr + data_p <- tellBin bh + seekBin bh dict_p + dict <- getDictionary bh + seekBin bh data_p + let (mod, j_r, out_r, _) = state bh + get bh{ state = (mod,j_r,out_r,dict) } + +initBinMemSize = (1024*1024) :: Int + +binaryInterfaceMagic = 0x1face :: Word32 + +putBinFileWithDict :: Binary a => FilePath -> Module -> a -> IO () +putBinFileWithDict file_path mod a = do + bh <- openBinMem initBinMemSize mod + put_ bh binaryInterfaceMagic + p <- tellBin bh + put_ bh p -- placeholder for ptr to dictionary + put_ bh a + let (_, j_r, fm_r, _) = state bh + j <- readIORef j_r + fm <- readIORef fm_r + dict_p <- tellBin bh + putAt bh p dict_p -- fill in the placeholder + seekBin bh dict_p -- seek back to the end of the file + putDictionary bh j (constructDictionary j fm) + writeBinMem bh file_path + +type Dictionary = Array Int FastString + -- should be 0-indexed + +putDictionary :: BinHandle -> Int -> Dictionary -> IO () +putDictionary bh sz dict = do + put_ bh sz + mapM_ (putFS bh) (elems dict) + +getDictionary :: BinHandle -> IO Dictionary +getDictionary bh = do + sz <- get bh + elems <- sequence (take sz (repeat (getFS bh))) + return (listArray (0,sz-1) elems) + +constructDictionary :: Int -> UniqFM (Int,FastString) -> Dictionary +constructDictionary j fm = array (0,j-1) (eltsUFM fm) + +putFS bh (FastString id l ba) = do + put_ bh (I# l) + putByteArray bh ba l +putFS bh s = error ("Binary.put_(FastString): " ++ unpackFS s) + -- Note: the length of the FastString is *not* the same as + -- the size of the ByteArray: the latter is rounded up to a + -- multiple of the word size. + +{- -- possible faster version, not quite there yet: +getFS bh@BinMem{} = do + (I# l) <- get bh + arr <- readIORef (arr_r bh) + off <- readFastMutInt (off_r bh) + return $! (mkFastSubStringBA# arr off l) +-} +getFS bh = do + (I# l) <- get bh + (BA ba) <- getByteArray bh (I# l) + return $! (mkFastSubStringBA# ba 0# l) + +instance Binary FastString where + put_ bh f@(FastString id l ba) = + case getUserData bh of { (_, j_r, out_r, dict) -> do + out <- readIORef out_r + let uniq = getUnique f + case lookupUFM out uniq of + Just (j,f) -> put_ bh j + Nothing -> do + j <- readIORef j_r + put_ bh j + writeIORef j_r (j+1) + writeIORef out_r (addToUFM out uniq (j,f)) + } + put_ bh s = error ("Binary.put_(FastString): " ++ show (unpackFS s)) + + get bh = do + j <- get bh + case getUserData bh of (_, _, _, arr) -> return (arr ! j) +-} + + + +{---------------------------------------------------------------------- + ---------- Hal's Notes ----------------------------------------------- + ---------------------------------------------------------------------- + +We are adding support for + + putBits :: BinHandle -> Int -> Word8 -> IO () + getBits :: BinHandle -> Int -> IO Word8 + flushBits :: BinHandle -> Int -> IO () + closeHandle :: BinHandle -> IO () + +where + + `putBits bh num_bits bits' writes the right-most num_bits of bits to + bh. `getBits bh num_bits` reads num_bits from bh and stores them in + the right-most positions of the result. flushBits bh n alignes the + stream to the next 2^n bit boundary. closeHandle flushes all + remaining bits and closes the handle. + +In order to implement this, we need to extend the BinHandles with two +fields: bit_off_r :: Int and bit_cache :: Word8. Based on this, the +basic implementations look something like this: + +putBits bh num_bits bits = + if num_bits + bit_off_r <= 8 + then bit_off_r += num_bits + add num_bits of bits to the tail of bit_cache + if bit_off_r == 8 + then write bit_cache and set bit_cache = 0, bit_off_r = 0 + else let leftover_bits = 8 - bit_off_r + add leftover_bits of bits to tail of bit_cache + write bit_cache and set bit_cache = 0, bit_off_r = 0 + putBits bh (num_bits - leftover_bits) (bits >> leftover_bits) + +(note that this will recurse at most once) + +getBits bh num_bits = + if bit_off_r == 0 + then bit_cache <- read a byte + bit_off_r = num_bits + if bit_off_r == 8, set bit_off_r = 0, bit_cache = 0 + else if bit_off_r + num_bits <= 8 + then bit_off_r += num_bits + bits = bits from bit_off_r -> bit_off_r+num_bits of bit_cache + if bit_off_r == 8, set bit_off_r = 0, bit_cache = 0 + return bits + else let leftover_bits = 8 - bit_off_r + bits = (last leftover_bits from bit_cache) << (num_bits - leftover_bits) + bit_cache <- read a byte + bit_off_r = num_bits - leftover_bits + return (bits || first (num_bits - leftover_bits) of bit_cache) + +Now, we must also modify putByte/getByte. In these, we do a quick +check to see if bit_off_r == 0; if it does, then we just execute +normally. Otherwise, we just call putBits/getBits with num_bits=8. + +closeHandle bh = + if bit_off_r == 0 + then close the handle + else write bit_cache and set bit_cache = 0, bit_off_r =0 + close the handle + +-} + +------------------------------------------------------------------------ + +#if __GLASGOW_HASKELL__ < 411 +newByteArray# = newCharArray# +#endif + +#ifdef __GLASGOW_HASKELL__ + +data FastMutInt = FastMutInt (MutableByteArray# RealWorld) + +newFastMutInt :: IO FastMutInt +newFastMutInt = IO $ \s -> + case newByteArray# size s of { (# s, arr #) -> + (# s, FastMutInt arr #) } + where I# size = SIZEOF_HSINT + +readFastMutInt :: FastMutInt -> IO Int +readFastMutInt (FastMutInt arr) = IO $ \s -> + case readIntArray# arr 0# s of { (# s, i #) -> + (# s, I# i #) } + +writeFastMutInt :: FastMutInt -> Int -> IO () +writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s -> + case writeIntArray# arr 0# i s of { s -> + (# s, () #) } + +incFastMutInt :: FastMutInt -> IO Int -- Returns original value +incFastMutInt (FastMutInt arr) = IO $ \s -> + case readIntArray# arr 0# s of { (# s, i #) -> + case writeIntArray# arr 0# (i +# 1#) s of { s -> + (# s, I# i #) } } + +incFastMutIntBy :: FastMutInt -> Int -> IO Int -- Returns original value +incFastMutIntBy (FastMutInt arr) (I# n) = IO $ \s -> + case readIntArray# arr 0# s of { (# s, i #) -> + case writeIntArray# arr 0# (i +# n) s of { s -> + (# s, I# i #) } } + +-- we should optimize this: ask SimonM :) +orFastMutInt :: FastMutInt -> Word8 -> IO () +orFastMutInt fmi w = do + i <- readFastMutInt fmi + writeFastMutInt fmi (i .|. (fromIntegral w)) + +#endif + diff -ruN ghc-6.12.1/libraries/binary/tests/Parallel.hs ghc-6.13.20091231/libraries/binary/tests/Parallel.hs --- ghc-6.12.1/libraries/binary/tests/Parallel.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/binary/tests/Parallel.hs 2009-12-31 10:24:49.000000000 -0800 @@ -0,0 +1,147 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Test.QuickCheck.Parallel +-- Copyright : (c) Don Stewart 2006 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : dons@cse.unsw.edu.au +-- Stability : experimental +-- Portability : non-portable (uses Control.Exception, Control.Concurrent) +-- +-- A parallel batch driver for running QuickCheck on threaded or SMP systems. +-- See the /Example.hs/ file for a complete overview. +-- + +module Parallel ( + pRun, + pDet, + pNon + ) where + +import Test.QuickCheck +import Data.List +import Control.Concurrent +import Control.Exception hiding (evaluate) +import System.Random +import System.IO (hFlush,stdout) +import Text.Printf + +type Name = String +type Depth = Int +type Test = (Name, Depth -> IO String) + +-- | Run a list of QuickCheck properties in parallel chunks, using +-- 'n' Haskell threads (first argument), and test to a depth of 'd' +-- (second argument). Compile your application with '-threaded' and run +-- with the SMP runtime's '-N4' (or however many OS threads you want to +-- donate), for best results. +-- +-- > import Test.QuickCheck.Parallel +-- > +-- > do n <- getArgs >>= readIO . head +-- > pRun n 1000 [ ("sort1", pDet prop_sort1) ] +-- +-- Will run 'n' threads over the property list, to depth 1000. +-- +pRun :: Int -> Int -> [Test] -> IO () +pRun n depth tests = do + chan <- newChan + ps <- getChanContents chan + work <- newMVar tests + + forM_ [1..n] $ forkIO . thread work chan + + let wait xs i + | i >= n = return () -- done + | otherwise = case xs of + Nothing : xs -> wait xs $! i+1 + Just s : xs -> putStr s >> hFlush stdout >> wait xs i + wait ps 0 + + where + thread :: MVar [Test] -> Chan (Maybe String) -> Int -> IO () + thread work chan me = loop + where + loop = do + job <- modifyMVar work $ \jobs -> return $ case jobs of + [] -> ([], Nothing) + (j:js) -> (js, Just j) + case job of + Nothing -> writeChan chan Nothing -- done + Just (name,prop) -> do + v <- prop depth + writeChan chan . Just $ printf "%d: %-25s: %s" me name v + loop + + +-- | Wrap a property, and run it on a deterministic set of data +pDet :: Testable a => a -> Int -> IO String +pDet a n = mycheck Det defaultConfig + { configMaxTest = n + , configEvery = \n args -> unlines args } a + +-- | Wrap a property, and run it on a non-deterministic set of data +pNon :: Testable a => a -> Int -> IO String +pNon a n = mycheck NonDet defaultConfig + { configMaxTest = n + , configEvery = \n args -> unlines args } a + +data Mode = Det | NonDet + +------------------------------------------------------------------------ + +mycheck :: Testable a => Mode -> Config -> a -> IO String +mycheck Det config a = do + let rnd = mkStdGen 99 -- deterministic + mytests config (evaluate a) rnd 0 0 [] + +mycheck NonDet config a = do + rnd <- newStdGen -- different each run + mytests config (evaluate a) rnd 0 0 [] + +mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO String +mytests config gen rnd0 ntest nfail stamps + | ntest == configMaxTest config = do done "OK," ntest stamps + | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps + | otherwise = do + case ok result of + Nothing -> + mytests config gen rnd1 ntest (nfail+1) stamps + Just True -> + mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps) + Just False -> + return ( "Falsifiable after " + ++ show ntest + ++ " tests:\n" + ++ unlines (arguments result) + ) + where + result = generate (configSize config ntest) rnd2 gen + (rnd1,rnd2) = split rnd0 + +done :: String -> Int -> [[String]] -> IO String +done mesg ntest stamps = + return ( mesg ++ " " ++ show ntest ++ " tests" ++ table ) + where + table = display + . map entry + . reverse + . sort + . map pairLength + . group + . sort + . filter (not . null) + $ stamps + + display [] = ".\n" + display [x] = " (" ++ x ++ ").\n" + display xs = ".\n" ++ unlines (map (++ ".") xs) + + pairLength xss@(xs:_) = (length xss, xs) + entry (n, xs) = percentage n ntest + ++ " " + ++ concat (intersperse ", " xs) + + percentage n m = show ((100 * n) `div` m) ++ "%" + +forM_ = flip mapM_ diff -ruN ghc-6.12.1/libraries/binary/tests/QC.hs ghc-6.13.20091231/libraries/binary/tests/QC.hs --- ghc-6.12.1/libraries/binary/tests/QC.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/binary/tests/QC.hs 2009-12-31 10:24:49.000000000 -0800 @@ -0,0 +1,244 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +module Main where + +import Data.Binary +import Data.Binary.Put +import Data.Binary.Get + +import Parallel + +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Unsafe as B +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Internal as L +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet + +import Data.Array (Array) +import Data.Array.IArray +import Data.Array.Unboxed (UArray) + +import qualified Control.OldException as C (catch,evaluate) +import Control.Monad +import Foreign +import System.Environment +import System.IO +import System.IO.Unsafe + +import Test.QuickCheck hiding (test) +import QuickCheckUtils +import Text.Printf + +-- import qualified Data.Sequence as Seq + +------------------------------------------------------------------------ + +roundTrip :: (Eq a, Binary a) => a -> (L.ByteString -> L.ByteString) -> Bool +roundTrip a f = a == + {-# SCC "decode.refragment.encode" #-} decode (f (encode a)) + +roundTripWith put get x = + forAll positiveList $ \xs -> + x == runGet get (refragment xs (runPut (put x))) + +-- make sure that a test fails +errorish :: B a +errorish a = unsafePerformIO $ + C.catch (do C.evaluate a + return False) + (\_ -> return True) + +-- low level ones: + +prop_Word16be = roundTripWith putWord16be getWord16be +prop_Word16le = roundTripWith putWord16le getWord16le +prop_Word16host = roundTripWith putWord16host getWord16host + +prop_Word32be = roundTripWith putWord32be getWord32be +prop_Word32le = roundTripWith putWord32le getWord32le +prop_Word32host = roundTripWith putWord32host getWord32host + +prop_Word64be = roundTripWith putWord64be getWord64be +prop_Word64le = roundTripWith putWord64le getWord64le +prop_Word64host = roundTripWith putWord64host getWord64host + +prop_Wordhost = roundTripWith putWordhost getWordhost + +-- read too much: + +prop_bookworm x = errorish $ x == a && x /= b + where + (a,b) = decode (encode x) + +-- sanity: + +invariant_lbs :: L.ByteString -> Bool +invariant_lbs (L.Empty) = True +invariant_lbs (L.Chunk x xs) = not (B.null x) && invariant_lbs xs + +prop_invariant :: (Binary a) => a -> Bool +prop_invariant = invariant_lbs . encode + +-- be lazy! + +-- doesn't do fair testing of lazy put/get. +-- tons of untested cases + +-- lazyTrip :: (Binary a, Eq a) => a -> Property +-- lazyTrip a = forAll positiveList $ \xs -> +-- a == (runGet lazyGet . refragment xs . runPut . lazyPut $ a) + +-- refragment a lazy bytestring's chunks +refragment :: [Int] -> L.ByteString -> L.ByteString +refragment [] lps = lps +refragment (x:xs) lps = + let x' = fromIntegral . (+1) . abs $ x + rest = refragment xs (L.drop x' lps) in + L.append (L.fromChunks [B.concat . L.toChunks . L.take x' $ lps]) rest + +-- check identity of refragmentation +prop_refragment lps xs = lps == refragment xs lps + +-- check that refragmention still hold invariant +prop_refragment_inv lps xs = invariant_lbs $ refragment xs lps + +main :: IO () +main = do + hSetBuffering stdout NoBuffering + s <- getArgs + let x = if null s then 100 else read (head s) + pRun 2 x tests + +{- +run :: [(String, Int -> IO ())] -> IO () +run tests = do + x <- getArgs + let n = if null x then 100 else read . head $ x + mapM_ (\(s,a) -> printf "%-50s" s >> a n) tests +-} + +------------------------------------------------------------------------ + +type T a = a -> Property +type B a = a -> Bool + +p :: Testable a => a -> Int -> IO String +p = pNon + +test :: (Eq a, Binary a) => a -> Property +test a = forAll positiveList (roundTrip a . refragment) + +positiveList :: Gen [Int] +positiveList = fmap (filter (/=0) . map abs) $ arbitrary + +-- tests :: [(String, Int -> IO String)] +tests = +-- utils + [ ("refragment id", p prop_refragment ) + , ("refragment invariant", p prop_refragment_inv ) + +-- boundaries + , ("read to much", p (prop_bookworm :: B Word8 )) + +-- Primitives + , ("Word16be", p prop_Word16be) + , ("Word16le", p prop_Word16le) + , ("Word16host", p prop_Word16host) + , ("Word32be", p prop_Word32be) + , ("Word32le", p prop_Word32le) + , ("Word32host", p prop_Word32host) + , ("Word64be", p prop_Word64be) + , ("Word64le", p prop_Word64le) + , ("Word64host", p prop_Word64host) + , ("Wordhost", p prop_Wordhost) + +-- higher level ones using the Binary class + ,("()", p (test :: T () )) + ,("Bool", p (test :: T Bool )) + ,("Ordering", p (test :: T Ordering )) + + ,("Word8", p (test :: T Word8 )) + ,("Word16", p (test :: T Word16 )) + ,("Word32", p (test :: T Word32 )) + ,("Word64", p (test :: T Word64 )) + + ,("Int8", p (test :: T Int8 )) + ,("Int16", p (test :: T Int16 )) + ,("Int32", p (test :: T Int32 )) + ,("Int64", p (test :: T Int64 )) + + ,("Word", p (test :: T Word )) + ,("Int", p (test :: T Int )) + ,("Integer", p (test :: T Integer )) + + ,("Float", p (test :: T Float )) + ,("Double", p (test :: T Double )) + + ,("Char", p (test :: T Char )) + + ,("[()]", p (test :: T [()] )) + ,("[Word8]", p (test :: T [Word8] )) + ,("[Word32]", p (test :: T [Word32] )) + ,("[Word64]", p (test :: T [Word64] )) + ,("[Word]", p (test :: T [Word] )) + ,("[Int]", p (test :: T [Int] )) + ,("[Integer]", p (test :: T [Integer] )) + ,("String", p (test :: T String )) + + ,("((), ())", p (test :: T ((), ()) )) + ,("(Word8, Word32)", p (test :: T (Word8, Word32) )) + ,("(Int8, Int32)", p (test :: T (Int8, Int32) )) + ,("(Int32, [Int])", p (test :: T (Int32, [Int]) )) + + ,("Maybe Int8", p (test :: T (Maybe Int8) )) + ,("Either Int8 Int16", p (test :: T (Either Int8 Int16) )) + + ,("(Maybe Word8, Bool, [Int], Either Bool Word8)", + p (test :: T (Maybe Word8, Bool, [Int], Either Bool Word8) )) + + ,("(Int, ByteString)", p (test :: T (Int, B.ByteString) )) +-- ,("Lazy (Int, ByteString)", p (lazyTrip :: T (Int, B.ByteString) )) + ,("[(Int, ByteString)]", p (test :: T [(Int, B.ByteString)] )) +-- ,("Lazy [(Int, ByteString)]", p (lazyTrip :: T [(Int, B.ByteString)] )) + + +-- ,("Lazy IntMap", p (lazyTrip :: T IntSet.IntSet )) + ,("IntSet", p (test :: T IntSet.IntSet )) + ,("IntMap ByteString", p (test :: T (IntMap.IntMap B.ByteString) )) + + ,("B.ByteString", p (test :: T B.ByteString )) + ,("L.ByteString", p (test :: T L.ByteString )) + + ,("B.ByteString invariant", p (prop_invariant :: B B.ByteString )) + ,("[B.ByteString] invariant", p (prop_invariant :: B [B.ByteString] )) + ,("L.ByteString invariant", p (prop_invariant :: B L.ByteString )) + ,("[L.ByteString] invariant", p (prop_invariant :: B [L.ByteString] )) + ,("IntMap invariant", p (prop_invariant :: B (IntMap.IntMap B.ByteString) )) + + ,("Set Word32", p (test :: T (Set.Set Word32) )) + ,("Map Word16 Int", p (test :: T (Map.Map Word16 Int) )) + + ,("(Maybe Int64, Bool, [Int])", p (test :: T (Maybe Int64, Bool, [Int]))) + +{- +-- +-- Big tuples lack an Arbitrary instance in Hugs/QuickCheck +-- + + ,("(Maybe Word16, Bool, [Int], Either Bool Word16, Int)", + p (test :: T (Maybe Word16, Bool, [Int], Either Bool Word16, Int) )) + + ,("(Maybe Word32, Bool, [Int], Either Bool Word32, Int, Int)", p (roundTrip :: (Maybe Word32, Bool, [Int], Either Bool Word32, Int, Int) -> Bool)) + + ,("(Maybe Word64, Bool, [Int], Either Bool Word64, Int, Int, Int)", p (roundTrip :: (Maybe Word64, Bool, [Int], Either Bool Word64, Int, Int, Int) -> Bool)) +-} + +-- GHC only: +-- ,("Sequence", p (roundTrip :: Seq.Seq Int64 -> Bool)) + +-- Obsolete +-- ,("ensureLeft/Fail", mytest (shouldFail (decode L.empty :: Either ParseError Int))) + ] diff -ruN ghc-6.12.1/libraries/binary/tests/QuickCheckUtils.hs ghc-6.13.20091231/libraries/binary/tests/QuickCheckUtils.hs --- ghc-6.12.1/libraries/binary/tests/QuickCheckUtils.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/binary/tests/QuickCheckUtils.hs 2009-12-31 10:24:49.000000000 -0800 @@ -0,0 +1,258 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +-- +-- Uses multi-param type classes +-- +module QuickCheckUtils where + +import Control.Monad + +import Test.QuickCheck.Batch +import Test.QuickCheck +import Text.Show.Functions + +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Lazy as L +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet + +import qualified Control.Exception as C (evaluate) + +import Control.Monad ( liftM2 ) +import Data.Char +import Data.List +import Data.Word +import Data.Int +import System.Random +import System.IO + +-- import Control.Concurrent +import System.Mem +import System.CPUTime +import Text.Printf + +import qualified Data.ByteString as P +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Internal as L + +-- import qualified Data.Sequence as Seq + +-- Enable this to get verbose test output. Including the actual tests. +debug = False + +mytest :: Testable a => a -> Int -> IO () +mytest a n = mycheck defaultConfig + { configMaxTest=n + , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a + +mycheck :: Testable a => Config -> a -> IO () +mycheck config a = do + rnd <- newStdGen + performGC -- >> threadDelay 100 + t <- mytests config (evaluate a) rnd 0 0 [] 0 -- 0 + printf " %0.3f seconds\n" (t :: Double) + hFlush stdout + +time :: a -> IO (a , Double) +time a = do + start <- getCPUTime + v <- C.evaluate a + v `seq` return () + end <- getCPUTime + return (v, ( (fromIntegral (end - start)) / (10^12))) + +mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> Double -> IO Double +mytests config gen rnd0 ntest nfail stamps t0 + | ntest == configMaxTest config = do done "OK," ntest stamps + return t0 + + | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps + return t0 + + | otherwise = do + (result,t1) <- time (generate (configSize config ntest) rnd2 gen) + + putStr (configEvery config ntest (arguments result)) >> hFlush stdout + case ok result of + Nothing -> + mytests config gen rnd1 ntest (nfail+1) stamps (t0 + t1) + Just True -> + mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps) (t0 + t1) + Just False -> do + putStr ( "Falsifiable after " + ++ show ntest + ++ " tests:\n" + ++ unlines (arguments result) + ) >> hFlush stdout + return t0 + + where + (rnd1,rnd2) = split rnd0 + +done :: String -> Int -> [[String]] -> IO () +done mesg ntest stamps = putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table ) + where + table = display + . map entry + . reverse + . sort + . map pairLength + . group + . sort + . filter (not . null) + $ stamps + + display [] = ". " + display [x] = " (" ++ x ++ "). " + display xs = ".\n" ++ unlines (map (++ ".") xs) + + pairLength xss@(xs:_) = (length xss, xs) + entry (n, xs) = percentage n ntest + ++ " " + ++ concat (intersperse ", " xs) + + percentage n m = show ((100 * n) `div` m) ++ "%" + +------------------------------------------------------------------------ + +instance Random Word8 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Random Int8 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Random Word16 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Random Int16 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Random Word where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Random Word32 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Random Int32 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Random Word64 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Random Int64 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +------------------------------------------------------------------------ + +integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g) +integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer, + fromIntegral b :: Integer) g of + (x,g) -> (fromIntegral x, g) + +------------------------------------------------------------------------ + +instance Arbitrary Word8 where + arbitrary = choose (0, 2^8-1) + coarbitrary w = variant 0 + +instance Arbitrary Word16 where + arbitrary = choose (0, 2^16-1) + coarbitrary = undefined + +instance Arbitrary Word32 where +-- arbitrary = choose (0, 2^32-1) + arbitrary = choose (minBound, maxBound) + coarbitrary = undefined + +instance Arbitrary Word64 where +-- arbitrary = choose (0, 2^64-1) + arbitrary = choose (minBound, maxBound) + coarbitrary = undefined + +instance Arbitrary Int8 where +-- arbitrary = choose (0, 2^8-1) + arbitrary = choose (minBound, maxBound) + coarbitrary w = variant 0 + +instance Arbitrary Int16 where +-- arbitrary = choose (0, 2^16-1) + arbitrary = choose (minBound, maxBound) + coarbitrary = undefined + +instance Arbitrary Int32 where +-- arbitrary = choose (0, 2^32-1) + arbitrary = choose (minBound, maxBound) + coarbitrary = undefined + +instance Arbitrary Int64 where +-- arbitrary = choose (0, 2^64-1) + arbitrary = choose (minBound, maxBound) + coarbitrary = undefined + +instance Arbitrary Word where + arbitrary = choose (minBound, maxBound) + coarbitrary w = variant 0 + +------------------------------------------------------------------------ + +instance Arbitrary Char where + arbitrary = choose (maxBound, minBound) + coarbitrary = undefined + +{- +instance Arbitrary a => Arbitrary (Maybe a) where + arbitrary = oneof [ return Nothing, liftM Just arbitrary] + coarbitrary = undefined + -} + +instance Arbitrary Ordering where + arbitrary = oneof [ return LT,return GT,return EQ ] + coarbitrary = undefined + +{- +instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where + arbitrary = oneof [ liftM Left arbitrary, liftM Right arbitrary] + coarbitrary = undefined + -} + +instance Arbitrary IntSet.IntSet where + arbitrary = fmap IntSet.fromList arbitrary + coarbitrary = undefined + +instance (Arbitrary e) => Arbitrary (IntMap.IntMap e) where + arbitrary = fmap IntMap.fromList arbitrary + coarbitrary = undefined + +instance (Arbitrary a, Ord a) => Arbitrary (Set.Set a) where + arbitrary = fmap Set.fromList arbitrary + coarbitrary = undefined + +instance (Arbitrary a, Ord a, Arbitrary b) => Arbitrary (Map.Map a b) where + arbitrary = fmap Map.fromList arbitrary + coarbitrary = undefined + +{- +instance (Arbitrary a) => Arbitrary (Seq.Seq a) where + arbitrary = fmap Seq.fromList arbitrary + coarbitrary = undefined +-} + +instance Arbitrary L.ByteString where + arbitrary = arbitrary >>= return . L.fromChunks . filter (not. B.null) -- maintain the invariant. + coarbitrary s = coarbitrary (L.unpack s) + +instance Arbitrary B.ByteString where + arbitrary = B.pack `fmap` arbitrary + coarbitrary s = coarbitrary (B.unpack s) diff -ruN ghc-6.12.1/libraries/binary/TODO ghc-6.13.20091231/libraries/binary/TODO --- ghc-6.12.1/libraries/binary/TODO 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/binary/TODO 2009-12-31 10:24:49.000000000 -0800 @@ -0,0 +1,28 @@ +layer handling: + + bit packing + state parameters + string pools + + reading structures from the end of a stream, seek/tell behaviour + +seek based protocols are too hard. + hGetContents/ interleaving. + +user requests: + + get remaining bytestring after a runGet + + some kind of lookahead, or restoring parsing state, or something with + equal functionality. make it another layer on top? + + getLazyByteString takes an Int, which in Haskell98 is only guarantied to + be 29 bits, ie. 512 mb. + maybe we should have a readN64 for allowing reading of larger stuff? + (which could be implemented with readN on 64bit machines) + reference: bringerts tar archive decoder would be limitid to 0.5GB + files, alt. 2GB in GHC + +SYB-deriving + +investigate the UArray instance, it does not seem to compile in GHC 6.4 diff -ruN ghc-6.12.1/libraries/binary/tools/derive/BinaryDerive.hs ghc-6.13.20091231/libraries/binary/tools/derive/BinaryDerive.hs --- ghc-6.12.1/libraries/binary/tools/derive/BinaryDerive.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/binary/tools/derive/BinaryDerive.hs 2009-12-31 10:24:49.000000000 -0800 @@ -0,0 +1,57 @@ +{-# OPTIONS -fglasgow-exts #-} + +module BinaryDerive where + +import Data.Generics +import Data.List + +deriveM :: (Typeable a, Data a) => a -> IO () +deriveM (a :: a) = mapM_ putStrLn . lines $ derive (undefined :: a) + +derive :: (Typeable a, Data a) => a -> String +derive x = + "instance " ++ context ++ "Binary " ++ inst ++ " where\n" ++ + concat putDefs ++ getDefs + where + context + | nTypeChildren > 0 = + wrap (join ", " (map ("Binary "++) typeLetters)) ++ " => " + | otherwise = "" + inst = wrap $ tyConString typeName ++ concatMap (" "++) typeLetters + wrap x = if nTypeChildren > 0 then "("++x++")" else x + join sep lst = concat $ intersperse sep lst + nTypeChildren = length typeChildren + typeLetters = take nTypeChildren manyLetters + manyLetters = map (:[]) ['a'..'z'] + (typeName,typeChildren) = splitTyConApp (typeOf x) + constrs :: [(Int, (String, Int))] + constrs = zip [0..] $ map gen $ dataTypeConstrs (dataTypeOf x) + gen con = ( showConstr con + , length $ gmapQ undefined $ fromConstr con `asTypeOf` x + ) + putDefs = map ((++"\n") . putDef) constrs + putDef (n, (name, ps)) = + let wrap = if ps /= 0 then ("("++) . (++")") else id + pattern = name ++ concatMap (' ':) (take ps manyLetters) + in + " put " ++ wrap pattern ++" = " + ++ concat [ "putWord8 " ++ show n | length constrs > 1 ] + ++ concat [ " >> " | length constrs > 1 && ps > 0 ] + ++ concat [ "return ()" | length constrs == 1 && ps == 0 ] + ++ join " >> " (map ("put "++) (take ps manyLetters)) + getDefs = + (if length constrs > 1 + then " get = do\n tag_ <- getWord8\n case tag_ of\n" + else " get =") + ++ concatMap ((++"\n")) (map getDef constrs) ++ + (if length constrs > 1 + then " _ -> fail \"no parse\"" + else "" + ) + getDef (n, (name, ps)) = + let wrap = if ps /= 0 then ("("++) . (++")") else id + in + concat [ " " ++ show n ++ " ->" | length constrs > 1 ] + ++ concatMap (\x -> " get >>= \\"++x++" ->") (take ps manyLetters) + ++ " return " + ++ wrap (name ++ concatMap (" "++) (take ps manyLetters)) diff -ruN ghc-6.12.1/libraries/binary/tools/derive/Example.hs ghc-6.13.20091231/libraries/binary/tools/derive/Example.hs --- ghc-6.12.1/libraries/binary/tools/derive/Example.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/binary/tools/derive/Example.hs 2009-12-31 10:24:49.000000000 -0800 @@ -0,0 +1,68 @@ + +import Data.Generics + +import Data.Binary + +import BinaryDerive + +data Foo = Bar + deriving (Typeable, Data, Show, Eq) + +instance Binary Main.Foo where + put Bar = return () + get = return Bar + +data Color = RGB Int Int Int + | CMYK Int Int Int Int + deriving (Typeable, Data, Show, Eq) + +instance Binary Main.Color where + put (RGB a b c) = putWord8 0 >> put a >> put b >> put c + put (CMYK a b c d) = putWord8 1 >> put a >> put b >> put c >> put d + get = do + tag_ <- getWord8 + case tag_ of + 0 -> get >>= \a -> get >>= \b -> get >>= \c -> return (RGB a b c) + 1 -> get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> return (CMYK a b c d) + +data Computer = Laptop { weight :: Int } + | Desktop { speed :: Int, memory :: Int } + deriving (Typeable, Data, Show, Eq) + +instance Binary Main.Computer where + put (Laptop a) = putWord8 0 >> put a + put (Desktop a b) = putWord8 1 >> put a >> put b + get = do + tag_ <- getWord8 + case tag_ of + 0 -> get >>= \a -> return (Laptop a) + 1 -> get >>= \a -> get >>= \b -> return (Desktop a b) + +-- | All drinks mankind will ever need +data Drinks = Beer Bool{-ale?-} + | Coffee + | Tea + | EnergyDrink + | Water + | Wine + | Whisky + deriving (Typeable, Data, Show, Eq) + +instance Binary Main.Drinks where + put (Beer a) = putWord8 0 >> put a + put Coffee = putWord8 1 + put Tea = putWord8 2 + put EnergyDrink = putWord8 3 + put Water = putWord8 4 + put Wine = putWord8 5 + put Whisky = putWord8 6 + get = do + tag_ <- getWord8 + case tag_ of + 0 -> get >>= \a -> return (Beer a) + 1 -> return Coffee + 2 -> return Tea + 3 -> return EnergyDrink + 4 -> return Water + 5 -> return Wine + 6 -> return Whisky diff -ruN ghc-6.12.1/libraries/bin-package-db/bin-package-db.cabal ghc-6.13.20091231/libraries/bin-package-db/bin-package-db.cabal --- ghc-6.12.1/libraries/bin-package-db/bin-package-db.cabal 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/libraries/bin-package-db/bin-package-db.cabal 2009-12-31 10:14:18.000000000 -0800 @@ -11,11 +11,21 @@ type: darcs location: http://darcs.haskell.org/ghc +flag base3 + default: False + Library { exposed-modules: Distribution.InstalledPackageInfo.Binary - build-depends: base >= 3 && < 5, - ghc-binary == 0.5.*, - Cabal == 1.8.* + if flag(base3) + build-depends: base >= 3 && < 4 + cpp-options: -DBASE3 + else + build-depends: base >= 4 && < 5 + + build-depends: binary == 0.5.*, + Cabal >= 1.8 && < 1.10 + + extensions: CPP } diff -ruN ghc-6.12.1/libraries/bin-package-db/Distribution/InstalledPackageInfo/Binary.hs ghc-6.13.20091231/libraries/bin-package-db/Distribution/InstalledPackageInfo/Binary.hs --- ghc-6.12.1/libraries/bin-package-db/Distribution/InstalledPackageInfo/Binary.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13.20091231/libraries/bin-package-db/Distribution/InstalledPackageInfo/Binary.hs 2009-12-31 10:14:18.000000000 -0800 @@ -1,5 +1,8 @@ {-# LANGUAGE RecordWildCards, TypeSynonymInstances, StandaloneDeriving, GeneralizedNewtypeDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +-- This module deliberately defines orphan instances for now. Should +-- become unnecessary once we move to using the binary package properly: +{-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.InstalledPackageInfo.Binary @@ -19,9 +22,24 @@ import Distribution.License import Distribution.InstalledPackageInfo as IPI import Data.Binary as Bin +import Control.Exception as Exception readBinPackageDB :: Binary m => FilePath -> IO [InstalledPackageInfo_ m] -readBinPackageDB file = Bin.decodeFile file +readBinPackageDB file + = do xs <- Bin.decodeFile file + _ <- Exception.evaluate $ length xs + return xs + `catchUserError` + (\err -> error ("While parsing " ++ show file ++ ": " ++ err)) + +catchUserError :: IO a -> (String -> IO a) -> IO a +#ifdef BASE3 +catchUserError io f = io `Exception.catch` \e -> case e of + ErrorCall err -> f err + _ -> throw e +#else +catchUserError io f = io `Exception.catch` \(ErrorCall err) -> f err +#endif writeBinPackageDB :: Binary m => FilePath -> [InstalledPackageInfo_ m] -> IO () writeBinPackageDB file ipis = Bin.encodeFile file ipis diff -ruN ghc-6.12.1/libraries/Cabal/Cabal.cabal ghc-6.13.20091231/libraries/Cabal/Cabal.cabal --- ghc-6.12.1/libraries/Cabal/Cabal.cabal 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Cabal.cabal 2009-12-31 10:25:27.000000000 -0800 @@ -1,5 +1,5 @@ Name: Cabal -Version: 1.8.0.2 +Version: 1.9.0 Copyright: 2003-2006, Isaac Jones 2005-2009, Duncan Coutts License: BSD3 @@ -29,11 +29,6 @@ type: darcs location: http://darcs.haskell.org/cabal/ -source-repository this - type: darcs - location: http://darcs.haskell.org/cabal-branches/cabal-1.8/ - tag: 1.8.0.2 - Flag base4 Description: Choose the even newer, even smaller, split-up base package. @@ -54,12 +49,12 @@ pretty >= 1 && < 1.1 if !os(windows) - Build-Depends: unix >= 2.1 && < 2.5 + Build-Depends: unix >= 2.0 && < 2.5 ghc-options: -Wall -fno-ignore-asserts if impl(ghc >= 6.8) ghc-options: -fwarn-tabs - cpp-options: "-DCABAL_VERSION=1,8,0,2" + cpp-options: "-DCABAL_VERSION=1,9,0" nhc98-Options: -K4M Exposed-Modules: diff -ruN ghc-6.12.1/libraries/Cabal/changelog ghc-6.13.20091231/libraries/Cabal/changelog --- ghc-6.12.1/libraries/Cabal/changelog 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/changelog 2009-12-31 10:25:27.000000000 -0800 @@ -1,5 +1,7 @@ -*-change-log-*- +1.9.x (current development version) + 1.8.0.x (next stable release version) * Support for GHC-6.12 * New unique installed package IDs which use a package hash diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/Compat/Exception.hs ghc-6.13.20091231/libraries/Cabal/Distribution/Compat/Exception.hs --- ghc-6.12.1/libraries/Cabal/Distribution/Compat/Exception.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/Compat/Exception.hs 2009-12-31 10:25:27.000000000 -0800 @@ -5,7 +5,7 @@ {-# OPTIONS_NHC98 -cpp #-} {-# OPTIONS_JHC -fcpp #-} -#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ >= 609) +#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 610)) #define NEW_EXCEPTION #endif diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/Compat/ReadP.hs ghc-6.13.20091231/libraries/Cabal/Distribution/Compat/ReadP.hs --- ghc-6.12.1/libraries/Cabal/Distribution/Compat/ReadP.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/Compat/ReadP.hs 2009-12-31 10:25:27.000000000 -0800 @@ -248,7 +248,8 @@ -- ^ Parses the first one or more characters satisfying the predicate. munch1 p = do c <- get - if p c then do s <- munch p; return (c:s) else pfail + if p c then do s <- munch p; return (c:s) + else pfail choice :: [ReadP r a] -> ReadP r a -- ^ Combines all parsers in the specified list. diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/Compat/TempFile.hs ghc-6.13.20091231/libraries/Cabal/Distribution/Compat/TempFile.hs --- ghc-6.12.1/libraries/Cabal/Distribution/Compat/TempFile.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/Compat/TempFile.hs 2009-12-31 10:25:27.000000000 -0800 @@ -21,6 +21,7 @@ Handle, IOMode(ReadWriteMode)) import System.Directory (doesFileExist) import System.FilePath ((<.>), splitExtension) +import System.IO.Error (try, isAlreadyExistsError) #else import System.IO (Handle, openTempFile, openBinaryTempFile) import Data.Bits ((.|.)) @@ -141,7 +142,7 @@ then findTempName (x+1) else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir)) else do - -- XXX We want to tell fdToHandle what the filepath is, + -- TODO: We want to tell fdToHandle what the filepath is, -- as any exceptions etc will only be able to report the -- fd currently h <- @@ -160,14 +161,14 @@ filename = prefix ++ show x ++ suffix filepath = dir `combine` filename - -- XXX bits copied from System.FilePath, since that's not available here + -- FIXME: bits copied from System.FilePath combine a b | null b = a | null a = b | last a == pathSeparator = a ++ b | otherwise = a ++ [pathSeparator] ++ b --- XXX Should use filepath library +-- FIXME: Should use filepath library pathSeparator :: Char #ifdef mingw32_HOST_OS pathSeparator = '\\' @@ -175,7 +176,7 @@ pathSeparator = '/' #endif --- XXX Copied from GHC.Handle +-- FIXME: Copied from GHC.Handle std_flags, output_flags, rw_flags :: CInt std_flags = o_NONBLOCK .|. o_NOCTTY output_flags = std_flags .|. o_CREAT diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/Make.hs ghc-6.13.20091231/libraries/Cabal/Distribution/Make.hs --- ghc-6.12.1/libraries/Cabal/Distribution/Make.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/Make.hs 2009-12-31 10:25:27.000000000 -0800 @@ -171,8 +171,6 @@ let destArgs = case fromFlag $ copyDest flags of NoCopyDest -> ["install"] CopyTo path -> ["copy", "destdir=" ++ path] - CopyPrefix path -> ["install", "prefix=" ++ path] - -- CopyPrefix is backwards compat, DEPRECATED rawSystemExit (fromFlag $ copyVerbosity flags) "make" destArgs installAction :: InstallFlags -> [String] -> IO () diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/ModuleName.hs ghc-6.13.20091231/libraries/Cabal/Distribution/ModuleName.hs --- ghc-6.12.1/libraries/Cabal/Distribution/ModuleName.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/ModuleName.hs 2009-12-31 10:25:27.000000000 -0800 @@ -86,9 +86,9 @@ validModuleComponent (c:cs) = Char.isUpper c && all validModuleChar cs --- XXX This is used in Distribution/Simple/PreProcess.hs, so we can't +-- FIXME This is used in Distribution/Simple/PreProcess.hs, so we can't -- deprecate it yet without getting warnings, and thus build failures --- {-# DEPRECATED simple "use ModuleName.fromString instead" #-} +{-# DEPRECATED simple "use ModuleName.fromString instead" #-} simple :: String -> ModuleName simple str = ModuleName [str] diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/PackageDescription/Check.hs ghc-6.13.20091231/libraries/Cabal/Distribution/PackageDescription/Check.hs --- ghc-6.12.1/libraries/Cabal/Distribution/PackageDescription/Check.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/PackageDescription/Check.hs 2009-12-31 10:25:27.000000000 -0800 @@ -443,19 +443,21 @@ "'ghc-options: -d*' debug flags are not appropriate for a distributed package." , checkFlags ["-prof"] $ - PackageDistInexcusable $ - "'ghc-options: -prof' is not needed. Use the --enable-library-profiling configure flag." + PackageBuildWarning $ + "'ghc-options: -prof' is not necessary and will lead to problems " + ++ "when used on a library. Use the configure flag " + ++ "--enable-library-profiling and/or --enable-executable-profiling." , checkFlags ["-o"] $ - PackageDistInexcusable $ - "'ghc-options: -o' is not allowed. The output files are named automatically." + PackageBuildWarning $ + "'ghc-options: -o' is not needed. The output files are named automatically." , checkFlags ["-hide-package"] $ - PackageDistInexcusable $ + PackageBuildWarning $ "'ghc-options: -hide-package' is never needed. Cabal hides all packages." , checkFlags ["--make"] $ - PackageDistInexcusable $ + PackageBuildWarning $ "'ghc-options: --make' is never needed. Cabal uses this automatically." , checkFlags ["-main-is"] $ @@ -477,7 +479,7 @@ ++ "and not just imposing longer compile times on your users." , checkFlags ["-split-objs"] $ - PackageDistInexcusable $ + PackageBuildWarning $ "'ghc-options: -split-objs' is not needed. Use the --enable-split-objs configure flag." , checkFlags ["-optl-Wl,-s", "-optl-s"] $ @@ -756,7 +758,7 @@ requiresAtLeast = case cabalVersionIntervals of (LowerBound ver' _,_):_ -> (ver' >=) _ -> const False - where cabalVersionIntervals = asVersionIntervals (descCabalVersion pkg) + where cabalVersionIntervals = asVersionIntervals (descCabalVersion pkg) dataFilesUsingGlobSyntax = filter usesGlobSyntax (dataFiles pkg) extraSrcFilesUsingGlobSyntax = filter usesGlobSyntax (extraSrcFiles pkg) @@ -1067,7 +1069,7 @@ Left err -> Just err Right [] -> Nothing Right (_:_) -> Just noSplit - where + where -- drop the '/' between the name and prefix: remainder = init first : rest diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/PackageDescription/Configuration.hs ghc-6.13.20091231/libraries/Cabal/Distribution/PackageDescription/Configuration.hs --- ghc-6.12.1/libraries/Cabal/Distribution/PackageDescription/Configuration.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/PackageDescription/Configuration.hs 2009-12-31 10:25:27.000000000 -0800 @@ -65,9 +65,7 @@ , Flag(..), FlagName(..), FlagAssignment , CondTree(..), ConfVar(..), Condition(..) ) import Distribution.Version - ( VersionRange, anyVersion, intersectVersionRanges, withinRange - , toVersionIntervals, intersectVersionIntervals - , fromVersionIntervals ) + ( VersionRange, anyVersion, intersectVersionRanges, withinRange ) import Distribution.Compiler ( CompilerId(CompilerId) ) import Distribution.System @@ -81,7 +79,6 @@ import Control.Arrow (first) import qualified Distribution.Compat.ReadP as ReadP ( char ) -import Control.Exception (assert) import Data.Char ( isAlphaNum ) import Data.Maybe ( catMaybes, maybeToList ) import Data.Map ( Map, fromListWith, toList ) @@ -142,7 +139,7 @@ && compVer `withinRange` vr interp (Flag f) = Left f --- XXX: Add instances and check +-- TODO: Add instances and check -- -- prop_sC_idempotent cond a o = cond' == cond'' -- where @@ -224,9 +221,9 @@ -- assignments. -- -- In case of failure, the _smallest_ number of of missing dependencies is --- returned. [XXX: Could also be specified with a function argument.] +-- returned. [TODO: Could also be specified with a function argument.] -- --- XXX: The current algorithm is rather naive. A better approach would be to: +-- TODO: The current algorithm is rather naive. A better approach would be to: -- -- * Rule out possible paths, by taking a look at the associated dependencies. -- @@ -489,29 +486,13 @@ Right ((mlib, exes'), targetSet, flagVals) -> Right ( pkg { library = mlib , executables = exes' - , buildDepends = assert sanity overallDeps + , buildDepends = fromDepMap (overallDependencies targetSet) + --TODO: we need to find a way to avoid pulling in deps + -- for non-buildable components. However cannot simply + -- filter at this stage, since if the package were not + -- available we would have failed already. } , flagVals ) - where - -- Note that we exclude non-buildable components. This means your tools and - -- test progs to not contribute to the overall package dependencies. - -- - overallDeps = canonicalise - . concatMap targetBuildDepends - . filter buildable - $ buildInfos - buildInfos = map libBuildInfo (maybeToList mlib) ++ map buildInfo exes' - - -- as a sanity check, check that the overall deps from the target set - -- matches those from the (unfiltered for being buildable) components - sanity = canonicalise overallDeps' == canonicalise overallDeps'' - overallDeps' = concatMap targetBuildDepends buildInfos - overallDeps'' = fromDepMap (overallDependencies targetSet) - canonicalise = - map (\(name, vi) -> Dependency name (fromVersionIntervals vi)) - . Map.toList - . Map.fromListWith intersectVersionIntervals - . map (\(Dependency name vr) -> (name, toVersionIntervals vr)) Left missing -> Left missing where @@ -556,7 +537,7 @@ -- joined into one field, which may not be possible in the original package -- description, due to the use of exclusive choices (if ... else ...). -- --- XXX: One particularly tricky case is defaulting. In the original package +-- TODO: One particularly tricky case is defaulting. In the original package -- description, e.g., the source directory might either be the default or a -- certain, explicitly set path. Since defaults are filled in only after the -- package has been resolved and when no explicit value has been set, the diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/PackageDescription.hs ghc-6.13.20091231/libraries/Cabal/Distribution/PackageDescription.hs --- ghc-6.12.1/libraries/Cabal/Distribution/PackageDescription.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/PackageDescription.hs 2009-12-31 10:25:27.000000000 -0800 @@ -592,26 +592,7 @@ instance Package GenericPackageDescription where packageId = packageId . packageDescription -{- --- XXX: I think we really want a PPrint or Pretty or ShowPretty class. -instance Show GenericPackageDescription where - show (GenericPackageDescription pkg flgs mlib exes) = - showPackageDescription pkg ++ "\n" ++ - (render $ vcat $ map ppFlag flgs) ++ "\n" ++ - render (maybe empty (\l -> showStanza "Library" (ppCondTree l showDeps)) mlib) - ++ "\n" ++ - (render $ vcat $ - map (\(n,ct) -> showStanza ("Executable " ++ n) (ppCondTree ct showDeps)) exes) - where - ppFlag (MkFlag name desc dflt manual) = - showStanza ("Flag " ++ name) - ((if (null desc) then empty else - text ("Description: " ++ desc)) $+$ - text ("Default: " ++ show dflt) $+$ - text ("Manual: " ++ show manual)) - showDeps = fsep . punctuate comma . map showDependency - showStanza h b = text h <+> lbrace $+$ nest 2 b $+$ rbrace --} +--TODO: make PackageDescription an instance of Text. -- | A flag can represent a feature to be included, or a way of linking -- a target against its dependencies, or in fact whatever you can think of. diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/ParseUtils.hs ghc-6.13.20091231/libraries/Cabal/Distribution/ParseUtils.hs --- ghc-6.12.1/libraries/Cabal/Distribution/ParseUtils.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/ParseUtils.hs 2009-12-31 10:25:27.000000000 -0800 @@ -515,7 +515,7 @@ (fieldValue rest' followingLines) rest' -> do ts' <- mapM (mkField (d+1)) ts return (Section n (map toLower name) rest' ts') - where fieldValue firstLine followingLines = + where fieldValue firstLine followingLines = let firstLine' = trimLeading firstLine followingLines' = map (\(_,_,s) -> stripDot s) followingLines allLines | null firstLine' = followingLines' diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/Simple/Build/Macros.hs ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/Build/Macros.hs --- ghc-6.12.1/libraries/Cabal/Distribution/Simple/Build/Macros.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/Build/Macros.hs 2009-12-31 10:25:27.000000000 -0800 @@ -40,10 +40,10 @@ "/* DO NOT EDIT: This file is automatically generated by Cabal */\n\n" : [ concat ["/* package ",display pkgid," */\n" - ,"#define MIN_VERSION_",pkgname,"(major1,major2,minor) \\\n" + ,"#define MIN_VERSION_",pkgname,"(major1,major2,minor) (\\\n" ," (major1) < ",major1," || \\\n" ," (major1) == ",major1," && (major2) < ",major2," || \\\n" - ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor + ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" ,"\n\n" ] | (_, pkgid@(PackageIdentifier name version)) <- externalPackageDeps lbi diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/Simple/Build/PathsModule.hs ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/Build/PathsModule.hs --- ghc-6.12.1/libraries/Cabal/Distribution/Simple/Build/PathsModule.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/Build/PathsModule.hs 2009-12-31 10:25:27.000000000 -0800 @@ -151,6 +151,7 @@ absolute = hasLibs pkg_descr -- we can only make progs relocatable || isNothing flat_bindirrel -- if the bin dir is an absolute path + || (isHugs && isNothing flat_progdirrel) || not (supportsRelocatableProgs (compilerFlavor (compiler lbi))) supportsRelocatableProgs Hugs = True diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/Simple/Build.hs ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/Build.hs --- ghc-6.12.1/libraries/Cabal/Distribution/Simple/Build.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/Build.hs 2009-12-31 10:25:27.000000000 -0800 @@ -123,7 +123,8 @@ -- Register the library in-place, so exes can depend -- on internally defined libraries. registerPackage verbosity - installedPkgInfo pkg_descr lbi True{-inplace-} internalPackageDB + installedPkgInfo pkg_descr lbi True -- True meaning inplace + (withPackageDB lbi ++ [internalPackageDB]) -- Use the internal package db for the exes. let lbi' = lbi { withPackageDB = withPackageDB lbi ++ [internalPackageDB] } diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/Simple/Command.hs ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/Command.hs --- ghc-6.12.1/libraries/Cabal/Distribution/Simple/Command.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/Command.hs 2009-12-31 10:25:27.000000000 -0800 @@ -382,7 +382,7 @@ commonFlags showOrParseArgs = case showOrParseArgs of ShowArgs -> [help] ParseArgs -> [help, list] - where + where help = GetOpt.Option helpShortFlags ["help"] (GetOpt.NoArg HelpFlag) "Show this help text" helpShortFlags = case showOrParseArgs of @@ -475,9 +475,9 @@ [Command _ _ action] -> CommandReadyToGo (flags, action cmdArgs) _ -> CommandReadyToGo (flags, badCommand name) [] -> CommandReadyToGo (flags, noCommand) - where flags = mkflags (commandDefaultFlags globalCommand) + where flags = mkflags (commandDefaultFlags globalCommand) - where + where lookupCommand cname = [ cmd | cmd@(Command cname' _ _) <- commands' , cname'==cname ] noCommand = CommandErrors ["no command given (try --help)\n"] @@ -521,7 +521,7 @@ _ -> CommandHelp globalHelp _ -> badCommand name - where globalHelp = commandHelp globalCommand' + where globalHelp = commandHelp globalCommand' helpCommandUI = (makeCommand "help" "Help about commands" Nothing () (const [])) { commandUsage = \pname -> diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/Simple/Compiler.hs ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/Compiler.hs --- ghc-6.12.1/libraries/Cabal/Distribution/Simple/Compiler.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/Compiler.hs 2009-12-31 10:25:27.000000000 -0800 @@ -105,7 +105,7 @@ data PackageDB = GlobalPackageDB | UserPackageDB | SpecificPackageDB FilePath - deriving (Eq, Show, Read) + deriving (Eq, Ord, Show, Read) -- | We typically get packages from several databases, and stack them -- together. This type lets us be explicit about that stacking. For example diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/Simple/Configure.hs ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/Configure.hs --- ghc-6.12.1/libraries/Cabal/Distribution/Simple/Configure.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/Configure.hs 2009-12-31 10:25:27.000000000 -0800 @@ -91,7 +91,7 @@ , ProgramConfiguration, defaultProgramConfiguration , configureAllKnownPrograms, knownPrograms, lookupKnownProgram , userSpecifyArgss, userSpecifyPaths - , lookupProgram, requireProgram, requireProgramVersion + , requireProgram, requireProgramVersion , pkgConfigProgram, gccProgram, rawSystemProgramStdoutConf ) import Distribution.Simple.Setup ( ConfigFlags(..), CopyDest(..), fromFlag, fromFlagOrDefault, flagToMaybe ) @@ -108,9 +108,8 @@ import Distribution.System ( OS(..), buildOS, buildPlatform ) import Distribution.Version - ( Version(..), anyVersion, orLaterVersion, withinRange - , isSpecificVersion, isAnyVersion - , LowerBound(..), asVersionIntervals ) + ( Version(..), anyVersion, orLaterVersion, withinRange, isAnyVersion + , LowerBound(..), asVersionIntervals ) import Distribution.Verbosity ( Verbosity, lessVerbose ) @@ -125,7 +124,7 @@ import Data.List ( nub, partition, isPrefixOf, inits ) import Data.Maybe - ( fromMaybe, isNothing ) + ( isNothing ) import Data.Monoid ( Monoid(..) ) import System.Directory @@ -311,16 +310,14 @@ Installed.sourcePackageId = pid } internalPackageSet = PackageIndex.fromList [internalPackage] - maybeInstalledPackageSet <- getInstalledPackages (lessVerbose verbosity) comp + installedPackageSet <- getInstalledPackages (lessVerbose verbosity) comp packageDbs programsConfig' let -- Constraint test function for the solver - dependencySatisfiable = case maybeInstalledPackageSet of - Nothing -> const True -- we do not know what is available so - -- we pretend everything is available - Just pkgs -> not . null . PackageIndex.lookupDependency pkgs' - where - pkgs' = PackageIndex.insert internalPackage pkgs + dependencySatisfiable = + not . null . PackageIndex.lookupDependency pkgs' + where + pkgs' = PackageIndex.insert internalPackage installedPackageSet (pkg_descr0', flags) <- case finalizePackageDescription @@ -349,31 +346,11 @@ checkPackageProblems verbosity pkg_descr0 (updatePackageDescription pbi pkg_descr) - let installedPackageSet = fromMaybe bogusPackageSet maybeInstalledPackageSet - -- FIXME: For Hugs, nhc98 and other compilers we do not know what - -- packages are already installed, so we just make some up, pretend - -- that they do exist and just hope for the best. We make them up - -- based on what other package the package we're currently building - -- happens to depend on. See 'inventBogusPackageInfo' below. - -- Let's hope they really are installed... :-) - bogusDependencies = map inventBogusPackageInfo - (buildDepends pkg_descr) - bogusPackageSet = PackageIndex.fromList bogusDependencies - - selectDependencies = + let selectDependencies = (\xs -> ([ x | Left x <- xs ], [ x | Right x <- xs ])) . map (selectDependency internalPackageSet installedPackageSet) - (failedDeps, allPkgDeps) = case flavor of - GHC -> selectDependencies (buildDepends pkg_descr) - JHC -> selectDependencies (buildDepends pkg_descr) - LHC -> selectDependencies (buildDepends pkg_descr) - _ -> ([], bogusSelection) - where - bogusSelection :: [ResolvedDependency] - bogusSelection = zipWith ExternalDependency - (buildDepends pkg_descr) - bogusDependencies + (failedDeps, allPkgDeps) = selectDependencies (buildDepends pkg_descr) internalPkgDeps = [ pkgid | InternalDependency _ pkgid <- allPkgDeps ] externalPkgDeps = [ pkg | ExternalDependency _ pkg <- allPkgDeps ] @@ -428,9 +405,11 @@ -- check extensions let extlist = nub $ concatMap extensions (allBuildInfo pkg_descr) let exts = unsupportedExtensions comp extlist - unless (null exts) $ warn verbosity $ -- Just warn, FIXME: Should this be an error? - display flavor ++ " does not support the following extensions: " ++ - intercalate ", " (map display exts) + when (not (null exts)) $ + die $ "The package " ++ display (packageId pkg_descr0) + ++ " requires the following language extensions which are not " + ++ "supported by " ++ display (compilerId comp) ++ ": " + ++ intercalate ", " (map display exts) let requiredBuildTools = concatMap buildTools (allBuildInfo pkg_descr) programsConfig'' <- @@ -541,18 +520,6 @@ -- ----------------------------------------------------------------------------- -- Configuring package dependencies --- |Converts build dependencies to a versioned dependency. only sets --- version information for exact versioned dependencies. -inventBogusPackageInfo :: Dependency -> InstalledPackageInfo -inventBogusPackageInfo (Dependency s vr) = - emptyInstalledPackageInfo { - Installed.sourcePackageId = case isSpecificVersion vr of - -- if they specify the exact version, use that: - Just v -> PackageIdentifier s v - -- otherwise, just set it to empty - Nothing -> PackageIdentifier s (Version [] []) - } - reportProgram :: Verbosity -> Program -> Maybe ConfiguredProgram -> IO () reportProgram verbosity prog Nothing = info verbosity $ "No " ++ programName prog ++ " found" @@ -633,14 +600,17 @@ getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramConfiguration - -> IO (Maybe PackageIndex) + -> IO PackageIndex getInstalledPackages verbosity comp packageDBs progconf = do info verbosity "Reading installed packages..." case compilerFlavor comp of - GHC -> Just `fmap` GHC.getInstalledPackages verbosity packageDBs progconf - JHC -> Just `fmap` JHC.getInstalledPackages verbosity packageDBs progconf - LHC -> Just `fmap` LHC.getInstalledPackages verbosity packageDBs progconf - _ -> return Nothing + GHC -> GHC.getInstalledPackages verbosity packageDBs progconf + Hugs->Hugs.getInstalledPackages verbosity packageDBs progconf + JHC -> JHC.getInstalledPackages verbosity packageDBs progconf + LHC -> LHC.getInstalledPackages verbosity packageDBs progconf + NHC -> NHC.getInstalledPackages verbosity packageDBs progconf + flv -> die $ "don't know how to find the installed packages for " + ++ display flv -- | Currently the user interface specifies the package dbs to use with just a -- single valued option, a 'PackageDB'. However internally we represent the @@ -846,8 +816,7 @@ libExists lib = builds (makeProgram []) (makeLdArgs [lib]) - commonCcArgs = programArgs gccProg - ++ hcDefines (compiler lbi) + commonCcArgs = hcDefines (compiler lbi) ++ [ "-I" ++ dir | dir <- collectField PD.includeDirs ] ++ ["-I."] ++ collectField PD.cppOptions @@ -873,7 +842,6 @@ collectField f = concatMap f allBi allBi = allBuildInfo pkg - Just gccProg = lookupProgram gccProgram (withPrograms lbi) deps = PackageIndex.topologicalOrder (installedPkgs lbi) builds program args = do diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/Simple/GHC.hs ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/GHC.hs --- ghc-6.12.1/libraries/Cabal/Distribution/Simple/GHC.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/GHC.hs 2009-12-31 10:25:27.000000000 -0800 @@ -65,8 +65,11 @@ buildLib, buildExe, installLib, installExe, libAbiHash, + registerPackage, ghcOptions, - ghcVerbosityOptions + ghcVerbosityOptions, + ghcPackageDbOptions, + ghcLibDir, ) where import qualified Distribution.Simple.GHC.IPI641 as IPI641 @@ -83,8 +86,9 @@ import Distribution.Simple.PackageIndex (PackageIndex) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) ) -import Distribution.Simple.InstallDirs + ( LocalBuildInfo(..), ComponentLocalBuildInfo(..), + absoluteInstallDirs ) +import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs ) import Distribution.Simple.BuildPaths import Distribution.Simple.Utils import Distribution.Package @@ -115,6 +119,7 @@ import Language.Haskell.Extension (Extension(..)) import Control.Monad ( unless, when ) +import Data.Char ( isSpace ) import Data.List import Data.Maybe ( catMaybes ) import Data.Monoid ( Monoid(..) ) @@ -352,6 +357,7 @@ getInstalledPackages verbosity packagedbs conf = do checkPackageDbStack packagedbs pkgss <- getInstalledPackages' verbosity packagedbs conf + topDir <- ghcLibDir' verbosity ghcProg let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs) | (_, pkgs) <- pkgss ] return $! hackRtsPackage (mconcat indexes) @@ -361,8 +367,6 @@ -- paths. We need to substitute the right value in so that when -- we, for example, call gcc, we have proper paths to give it Just ghcProg = lookupProgram ghcProgram conf - compilerDir = takeDirectory (programPath ghcProg) - topDir = takeDirectory compilerDir hackRtsPackage index = case PackageIndex.lookupPackageName index (PackageName "rts") of @@ -371,6 +375,16 @@ _ -> index -- No (or multiple) ghc rts package is registered!! -- Feh, whatever, the ghc testsuite does some crazy stuff. +ghcLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath +ghcLibDir verbosity lbi = + (reverse . dropWhile isSpace . reverse) `fmap` + rawSystemProgramStdoutConf verbosity ghcProgram (withPrograms lbi) ["--print-libdir"] + +ghcLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath +ghcLibDir' verbosity ghcProg = + (reverse . dropWhile isSpace . reverse) `fmap` + rawSystemProgramStdout verbosity ghcProg ["--print-libdir"] + checkPackageDbStack :: PackageDBStack -> IO () checkPackageDbStack (GlobalPackageDB:rest) | GlobalPackageDB `notElem` rest = return () @@ -521,6 +535,9 @@ sharedLibFilePath = libTargetDir mkSharedLibName pkgid (compilerId (compiler lbi)) ghciLibFilePath = libTargetDir mkGHCiLibName pkgid + libInstallPath = libdir $ absoluteInstallDirs pkg_descr lbi NoCopyDest + sharedLibInstallPath = libInstallPath mkSharedLibName pkgid + (compilerId (compiler lbi)) stubObjs <- fmap catMaybes $ sequence [ findFileWithExtension [objExtension] [libTargetDir] @@ -579,6 +596,11 @@ "-shared", "-dynamic", "-o", sharedLibFilePath ] + -- For dynamic libs, Mac OS/X needs to know the install location + -- at build time. + ++ (if buildOS == OSX + then ["-dylib-install-name", sharedLibInstallPath] + else []) ++ dynamicObjectFiles ++ ["-package-name", display pkgid ] ++ ghcPackageFlags lbi clbi @@ -786,15 +808,14 @@ ghcPackageDbOptions :: PackageDBStack -> [String] ghcPackageDbOptions dbstack = case dbstack of - (GlobalPackageDB:dbs) - | UserPackageDB `elem` dbs -> concatMap specific dbs - | otherwise -> "-no-user-package-conf" - : concatMap specific dbs - _ -> ierror + (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs + (GlobalPackageDB:dbs) -> "-no-user-package-conf" + : concatMap specific dbs + _ -> ierror where specific (SpecificPackageDB db) = [ "-package-conf", db ] - specific _ = [] - ierror = error "internal error: unexpected package db stack" + specific _ = ierror + ierror = error "internal error: unexpected package db stack" constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> FilePath -> Verbosity -> Bool @@ -936,3 +957,19 @@ (ranlib, _) <- requireProgram verbosity ranlibProgram (withPrograms lbi) rawSystemProgram verbosity ranlib [path] | otherwise = return () + + +-- ----------------------------------------------------------------------------- +-- Registering + +registerPackage + :: Verbosity + -> InstalledPackageInfo + -> PackageDescription + -> LocalBuildInfo + -> Bool + -> PackageDBStack + -> IO () +registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do + let Just ghcPkg = lookupProgram ghcPkgProgram (withPrograms lbi) + HcPkg.reregister verbosity ghcPkg packageDbs (Right installedPkgInfo) diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/Simple/Haddock.hs ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/Haddock.hs --- ghc-6.12.1/libraries/Cabal/Distribution/Simple/Haddock.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/Haddock.hs 2009-12-31 10:25:27.000000000 -0800 @@ -60,10 +60,11 @@ Executable(..), withExe) import Distribution.Simple.Compiler ( Compiler(..), compilerVersion ) +import Distribution.Simple.GHC ( ghcLibDir ) import Distribution.Simple.Program ( ConfiguredProgram(..), requireProgramVersion - , rawSystemProgram, rawSystemProgramStdoutConf, rawSystemProgramStdout - , hscolourProgram, haddockProgram, ghcProgram ) + , rawSystemProgram, rawSystemProgramStdout + , hscolourProgram, haddockProgram ) import Distribution.Simple.PreProcess (ppCpp', ppUnlit, PPSuffixHandler, runSimplePreProcessor) import Distribution.Simple.Setup @@ -103,7 +104,6 @@ import Control.Exception (assert) import Data.Monoid import Data.Maybe ( fromMaybe, listToMaybe ) -import Data.Char (isSpace) import System.FilePath((), (<.>), splitFileName, splitExtension, normalise, splitPath, joinPath) @@ -547,11 +547,6 @@ exeBuildDir :: LocalBuildInfo -> Executable -> FilePath exeBuildDir lbi exe = buildDir lbi exeName exe exeName exe ++ "-tmp" -ghcLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath -ghcLibDir verbosity lbi = - (reverse . dropWhile isSpace . reverse) `fmap` - rawSystemProgramStdoutConf verbosity ghcProgram (withPrograms lbi) ["--print-libdir"] - --------------------------------------------------------------------------------------------- diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/Simple/Hugs.hs ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/Hugs.hs --- ghc-6.12.1/libraries/Cabal/Distribution/Simple/Hugs.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/Hugs.hs 2009-12-31 10:25:27.000000000 -0800 @@ -2,6 +2,7 @@ -- | -- Module : Distribution.Simple.Hugs -- Copyright : Isaac Jones 2003-2006 +-- Duncan Coutts 2009 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable @@ -41,36 +42,56 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} module Distribution.Simple.Hugs ( - configure, - buildLib, - buildExe, - install - ) where - + configure, + getInstalledPackages, + buildLib, + buildExe, + install, + registerPackage, + ) where + +import Distribution.Package + ( PackageName, PackageIdentifier(..), InstalledPackageId(..) + , packageName ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo, emptyInstalledPackageInfo + , InstalledPackageInfo_( InstalledPackageInfo, installedPackageId + , sourcePackageId ) + , parseInstalledPackageInfo, showInstalledPackageInfo ) import Distribution.PackageDescription ( PackageDescription(..), BuildInfo(..), hcOptions, Executable(..), withExe, Library(..), withLib, libModules ) import Distribution.ModuleName (ModuleName) import qualified Distribution.ModuleName as ModuleName import Distribution.Simple.Compiler - ( CompilerFlavor(..), CompilerId(..), Compiler(..), Flag ) -import Distribution.Simple.Program ( ProgramConfiguration, userMaybeSpecifyPath, - requireProgram, rawSystemProgramConf, - ffihugsProgram, hugsProgram ) + ( CompilerFlavor(..), CompilerId(..), Compiler(..), Flag + , PackageDB(..), PackageDBStack ) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (PackageIndex) +import Distribution.Simple.Program + ( Program(programFindVersion) + , ProgramConfiguration, userMaybeSpecifyPath + , requireProgram, requireProgramVersion + , rawSystemProgramConf, programPath + , ffihugsProgram, hugsProgram ) import Distribution.Version - ( Version(..) ) + ( Version(..), orLaterVersion ) import Distribution.Simple.PreProcess ( ppCpp, runSimplePreProcessor ) import Distribution.Simple.PreProcess.Unlit ( unlit ) import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) ) + ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) + , InstallDirs(..), absoluteInstallDirs ) import Distribution.Simple.BuildPaths ( autogenModuleName, autogenModulesDir, dllExtension ) +import Distribution.Simple.Setup + ( CopyDest(..) ) import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose, installOrdinaryFiles - , withUTF8FileContents, writeFileAtomic, copyFileVerbose - , findFile, findFileWithExtension, findModuleFiles + , withUTF8FileContents, writeFileAtomic, writeUTF8File + , copyFileVerbose, findFile, findFileWithExtension, findModuleFiles + , rawSystemStdInOut , die, info, notice ) import Language.Haskell.Extension ( Extension(..) ) @@ -79,14 +100,21 @@ import Distribution.System ( OS(..), buildOS ) import Distribution.Text - ( display ) + ( display, simpleParse ) +import Distribution.ParseUtils + ( ParseResult(..) ) import Distribution.Verbosity import Data.Char ( isSpace ) import Data.Maybe ( mapMaybe, catMaybes ) +import Data.Monoid ( Monoid(..) ) import Control.Monad ( unless, when, filterM ) import Data.List ( nub, sort, isSuffixOf ) -import System.Directory ( removeDirectoryRecursive ) +import System.Directory + ( doesFileExist, doesDirectoryExist, getDirectoryContents + , removeDirectoryRecursive, getHomeDirectory ) +import System.Exit + ( ExitCode(ExitSuccess) ) import Distribution.Compat.CopyFile ( setFileExecutable ) import Distribution.Compat.Exception @@ -100,14 +128,46 @@ (_ffihugsProg, conf') <- requireProgram verbosity ffihugsProgram (userMaybeSpecifyPath "ffihugs" hcPath conf) - (_hugsProg, conf'') <- requireProgram verbosity hugsProgram conf' + (_hugsProg, version, conf'') + <- requireProgramVersion verbosity hugsProgram' + (orLaterVersion (Version [2006] [])) conf' let comp = Compiler { - compilerId = CompilerId Hugs (Version [] []), + compilerId = CompilerId Hugs version, compilerExtensions = hugsLanguageExtensions } return (comp, conf'') + where + hugsProgram' = hugsProgram { programFindVersion = getVersion } + +getVersion :: Verbosity -> FilePath -> IO (Maybe Version) +getVersion verbosity hugsPath = do + (output, _err, exit) <- rawSystemStdInOut verbosity hugsPath [] + (Just (":quit", False)) False + if exit == ExitSuccess + then return $! findVersion output + else return Nothing + + where + findVersion output = do + (monthStr, yearStr) <- selectWords output + year <- convertYear yearStr + month <- convertMonth monthStr + return (Version [year, month] []) + + selectWords output = + case [ (month, year) + | [_,_,"Version:", month, year,_] <- map words (lines output) ] of + [(month, year)] -> Just (month, year) + _ -> Nothing + convertYear year = case reads year of + [(y, [])] | y >= 1999 && y < 2020 -> Just y + _ -> Nothing + convertMonth month = lookup month (zip months [1..]) + months = [ "January", "February", "March", "April", "May", "June", "July" + , "August", "September", "October", "November", "December" ] + -- | The flags for the supported extensions hugsLanguageExtensions :: [(Extension, Flag)] hugsLanguageExtensions = @@ -133,6 +193,114 @@ ,(CPP , "") ] +getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration + -> IO PackageIndex +getInstalledPackages verbosity packagedbs conf = do + homedir <- getHomeDirectory + (hugsProg, _) <- requireProgram verbosity hugsProgram conf + let hugsbindir = takeDirectory (programPath hugsProg) + hugslibdir = takeDirectory hugsbindir "lib" "hugs" + dbdirs = nub (concatMap (packageDbPaths homedir hugslibdir) packagedbs) + indexes <- mapM getIndividualDBPackages dbdirs + return $! mconcat indexes + + where + getIndividualDBPackages :: FilePath -> IO PackageIndex + getIndividualDBPackages dbdir = do + pkgdirs <- getPackageDbDirs dbdir + pkgs <- sequence [ getInstalledPackage pkgname pkgdir + | (pkgname, pkgdir) <- pkgdirs ] + let pkgs' = map setInstalledPackageId (catMaybes pkgs) + return (PackageIndex.fromList pkgs') + +packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath] +packageDbPaths home hugslibdir db = case db of + GlobalPackageDB -> [ hugslibdir "packages" + , "/usr/local/lib/hugs/packages" ] + UserPackageDB -> [ home "lib/hugs/packages" ] + SpecificPackageDB path -> [ path ] + +getPackageDbDirs :: FilePath -> IO [(PackageName, FilePath)] +getPackageDbDirs dbdir = do + dbexists <- doesDirectoryExist dbdir + if not dbexists + then return [] + else do + entries <- getDirectoryContents dbdir + pkgdirs <- sequence + [ do pkgdirExists <- doesDirectoryExist pkgdir + return (pkgname, pkgdir, pkgdirExists) + | (entry, Just pkgname) <- [ (entry, simpleParse entry) + | entry <- entries ] + , let pkgdir = dbdir entry ] + return [ (pkgname, pkgdir) | (pkgname, pkgdir, True) <- pkgdirs ] + +getInstalledPackage :: PackageName -> FilePath -> IO (Maybe InstalledPackageInfo) +getInstalledPackage pkgname pkgdir = do + let pkgconfFile = pkgdir "package.conf" + pkgconfExists <- doesFileExist pkgconfFile + + let pathsModule = pkgdir ("Paths_" ++ display pkgname) <.> "hs" + pathsModuleExists <- doesFileExist pathsModule + + case () of + _ | pkgconfExists -> getFullInstalledPackageInfo pkgname pkgconfFile + | pathsModuleExists -> getPhonyInstalledPackageInfo pkgname pathsModule + | otherwise -> return Nothing + +getFullInstalledPackageInfo :: PackageName -> FilePath + -> IO (Maybe InstalledPackageInfo) +getFullInstalledPackageInfo pkgname pkgconfFile = + withUTF8FileContents pkgconfFile $ \contents -> + case parseInstalledPackageInfo contents of + ParseOk _ pkginfo | packageName pkginfo == pkgname + -> return (Just pkginfo) + _ -> return Nothing + +-- | This is a backup option for existing versions of Hugs which do not supply +-- proper installed package info files for the bundled libs. Instead we look +-- for the Paths_pkgname.hs file and extract the package version from that. +-- We don't know any other details for such packages, in particular we pretend +-- that they have no dependencies. +-- +getPhonyInstalledPackageInfo :: PackageName -> FilePath + -> IO (Maybe InstalledPackageInfo) +getPhonyInstalledPackageInfo pkgname pathsModule = do + content <- readFile pathsModule + case extractVersion content of + Nothing -> return Nothing + Just version -> return (Just pkginfo) + where + pkgid = PackageIdentifier pkgname version + pkginfo = emptyInstalledPackageInfo { sourcePackageId = pkgid } + where + -- search through the Paths_pkgname.hs file, looking for a line like: + -- + -- > version = Version {versionBranch = [2,0], versionTags = []} + -- + -- and parse it using 'Read'. Yes we are that evil. + -- + extractVersion content = + case [ version + | ("version":"=":rest) <- map words (lines content) + , (version, []) <- reads (concat rest) ] of + [version] -> Just version + _ -> Nothing + +-- Older installed package info files did not have the installedPackageId +-- field, so if it is missing then we fill it as the source package ID. +setInstalledPackageId :: InstalledPackageInfo -> InstalledPackageInfo +setInstalledPackageId pkginfo@InstalledPackageInfo { + installedPackageId = InstalledPackageId "", + sourcePackageId = pkgid + } + = pkginfo { + --TODO use a proper named function for the conversion + -- from source package id to installed package id + installedPackageId = InstalledPackageId (display pkgid) + } +setInstalledPackageId pkginfo = pkginfo + -- ----------------------------------------------------------------------------- -- Building @@ -148,6 +316,8 @@ where paths_modulename = ModuleName.toFilePath (autogenModuleName pkg_descr) <.> ".hs" + --TODO: switch to using autogenModulesDir as a search dir, rather than + -- always copying the file over. -- |Building an executable for Hugs. buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo @@ -181,6 +351,7 @@ -> BuildInfo -> LocalBuildInfo -> IO () +--TODO: should not be using mLibSrcDirs at all compileBuildInfo verbosity destDir mLibSrcDirs mods bi lbi = do -- Pass 1: copy or cpp files from build directory to scratch directory let useCpp = CPP `elem` extensions bi @@ -424,3 +595,24 @@ hugsMainFilename :: Executable -> FilePath hugsMainFilename exe = "Main" <.> ext where ext = takeExtension (modulePath exe) + +-- ----------------------------------------------------------------------------- +-- Registering + +registerPackage + :: Verbosity + -> InstalledPackageInfo + -> PackageDescription + -> LocalBuildInfo + -> Bool + -> PackageDBStack + -> IO () +registerPackage verbosity installedPkgInfo pkg lbi inplace _packageDbs = do + --TODO: prefer to have it based on the packageDbs, but how do we know + -- the package subdir based on the name? the user can set crazy libsubdir + let installDirs = absoluteInstallDirs pkg lbi NoCopyDest + pkgdir | inplace = buildDir lbi + | otherwise = libdir installDirs + createDirectoryIfMissingVerbose verbosity True pkgdir + writeUTF8File (pkgdir "package.conf") + (showInstalledPackageInfo installedPkgInfo) diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/Simple/InstallDirs.hs ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/InstallDirs.hs --- ghc-6.12.1/libraries/Cabal/Distribution/Simple/InstallDirs.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/InstallDirs.hs 2009-12-31 10:25:27.000000000 -0800 @@ -216,7 +216,7 @@ -- Default installation directories defaultInstallDirs :: CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates -defaultInstallDirs comp userInstall hasLibs = do +defaultInstallDirs comp userInstall _hasLibs = do windowsProgramFilesDir <- getWindowsProgramFilesDir userInstallPrefix <- getAppUserDataDirectory "cabal" lhcPrefix <- getAppUserDataDirectory "lhc" @@ -244,13 +244,10 @@ progdir = "$libdir" "hugs" "programs", includedir = "$libdir" "$libsubdir" "include", datadir = case buildOS of - Windows | hasLibs -> windowsProgramFilesDir "Haskell" - | otherwise -> "$prefix" + Windows -> "$prefix" _other -> "$prefix" "share", datasubdir = "$pkgid", - docdir = case buildOS of - Windows -> "$prefix" "doc" "$pkgid" - _other -> "$datadir" "doc" "$pkgid", + docdir = "$datadir" "doc" "$pkgid", mandir = "$datadir" "man", htmldir = "$docdir" "html", haddockdir = "$htmldir" @@ -318,12 +315,7 @@ _ -> id) . appendSubdirs () . fmap fromPathTemplate - $ substituteInstallDirTemplates env dirs { - prefix = case copydest of - -- possibly override the prefix - CopyPrefix p -> toPathTemplate p - _ -> prefix dirs - } + $ substituteInstallDirTemplates env dirs where env = initialPathTemplateEnv pkgId compilerId @@ -332,7 +324,6 @@ data CopyDest = NoCopyDest | CopyTo FilePath - | CopyPrefix FilePath -- DEPRECATED deriving (Eq, Show) -- | Check which of the paths are relative to the installation $prefix. diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/Simple/LHC.hs ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/LHC.hs --- ghc-6.12.1/libraries/Cabal/Distribution/Simple/LHC.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/LHC.hs 2009-12-31 10:25:27.000000000 -0800 @@ -64,6 +64,7 @@ configure, getInstalledPackages, buildLib, buildExe, installLib, installExe, + registerPackage, ghcOptions, ghcVerbosityOptions ) where @@ -98,6 +99,7 @@ , arProgram, ranlibProgram, ldProgram , gccProgram, stripProgram , lhcProgram, lhcPkgProgram ) +import qualified Distribution.Simple.Program.HcPkg as HcPkg import Distribution.Simple.Compiler ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion , OptimisationLevel(..), PackageDB(..), PackageDBStack @@ -654,7 +656,7 @@ (GlobalPackageDB:dbs) -> "-no-user-package-conf" : concatMap specific dbs _ -> ierror - where + where specific (SpecificPackageDB db) = [ "-package-conf", db ] specific _ = ierror ierror = error "internal error: unexpected package db stack" @@ -797,3 +799,18 @@ "Unable to generate a symbol index for the static " ++ "library '" ++ path ++ "' (missing the 'ranlib' and 'ar' programs)" + +-- ----------------------------------------------------------------------------- +-- Registering + +registerPackage + :: Verbosity + -> InstalledPackageInfo + -> PackageDescription + -> LocalBuildInfo + -> Bool + -> PackageDBStack + -> IO () +registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do + let Just lhcPkg = lookupProgram lhcPkgProgram (withPrograms lbi) + HcPkg.reregister verbosity lhcPkg packageDbs (Right installedPkgInfo) diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/Simple/LocalBuildInfo.hs ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/LocalBuildInfo.hs --- ghc-6.12.1/libraries/Cabal/Distribution/Simple/LocalBuildInfo.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/LocalBuildInfo.hs 2009-12-31 10:25:27.000000000 -0800 @@ -53,10 +53,7 @@ -- * Installation directories module Distribution.Simple.InstallDirs, absoluteInstallDirs, prefixRelativeInstallDirs, - substPathTemplate, - - -- * Deprecated - packageDeps + substPathTemplate ) where @@ -85,10 +82,12 @@ installDirTemplates :: InstallDirTemplates, -- ^ The installation directories for the various differnt -- kinds of files + --TODO: inplaceDirTemplates :: InstallDirs FilePath compiler :: Compiler, -- ^ The compiler we're building with buildDir :: FilePath, -- ^ Where to build the package. + --TODO: eliminate hugs's scratchDir, use builddir scratchDir :: FilePath, -- ^ Where to put the result of the Hugs build. libraryConfig :: Maybe ComponentLocalBuildInfo, @@ -123,10 +122,6 @@ } deriving (Read, Show) -{-# DEPRECATED packageDeps "use externalPackageDeps or componentPackageDeps" #-} -packageDeps :: LocalBuildInfo -> [PackageId] -packageDeps = map snd . externalPackageDeps - -- | External package dependencies for the package as a whole, the union of the -- individual 'targetPackageDeps'. externalPackageDeps :: LocalBuildInfo -> [(InstalledPackageId, PackageId)] diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/Simple/NHC.hs ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/NHC.hs --- ghc-6.12.1/libraries/Cabal/Distribution/Simple/NHC.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/NHC.hs 2009-12-31 10:25:27.000000000 -0800 @@ -2,6 +2,7 @@ -- | -- Module : Distribution.Simple.NHC -- Copyright : Isaac Jones 2003-2006 +-- Duncan Coutts 2009 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable @@ -40,14 +41,23 @@ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} -module Distribution.Simple.NHC - ( configure - , buildLib, buildExe - , installLib, installExe +module Distribution.Simple.NHC ( + configure, + getInstalledPackages, + buildLib, + buildExe, + installLib, + installExe, ) where import Distribution.Package - ( PackageIdentifier, packageName, Package(..) ) + ( PackageName, PackageIdentifier(..), InstalledPackageId(..) + , packageId, packageName ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo + , InstalledPackageInfo_( InstalledPackageInfo, installedPackageId + , sourcePackageId ) + , emptyInstalledPackageInfo, parseInstalledPackageInfo ) import Distribution.PackageDescription ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..) , hcOptions ) @@ -59,7 +69,9 @@ ( mkLibName, objExtension, exeExtension ) import Distribution.Simple.Compiler ( CompilerFlavor(..), CompilerId(..), Compiler(..) - , Flag, extensionsToFlags ) + , Flag, extensionsToFlags, PackageDB(..), PackageDBStack ) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (PackageIndex) import Language.Haskell.Extension ( Extension(..) ) import Distribution.Simple.Program @@ -70,19 +82,25 @@ import Distribution.Simple.Utils ( die, info, findFileWithExtension, findModuleFiles , installOrdinaryFile, installExecutableFile, installOrdinaryFiles - , createDirectoryIfMissingVerbose ) + , createDirectoryIfMissingVerbose, withUTF8FileContents ) import Distribution.Version ( Version(..), orLaterVersion ) import Distribution.Verbosity import Distribution.Text - ( display ) + ( display, simpleParse ) +import Distribution.ParseUtils + ( ParseResult(..) ) import System.FilePath ( (), (<.>), normalise, takeDirectory, dropExtension ) import System.Directory - ( removeFile ) + ( doesFileExist, doesDirectoryExist, getDirectoryContents + , removeFile, getHomeDirectory ) +import Data.Char ( toLower ) import Data.List ( nub ) +import Data.Maybe ( catMaybes ) +import Data.Monoid ( Monoid(..) ) import Control.Monad ( when, unless ) import Distribution.Compat.Exception @@ -121,6 +139,7 @@ nhcLanguageExtensions = -- TODO: use -98 when no extensions are specified. -- NHC doesn't enforce the monomorphism restriction at all. + -- TODO: pattern guards in 1.20 [(NoMonomorphismRestriction, "") ,(ForeignFunctionInterface, "") ,(ExistentialQuantification, "") @@ -129,6 +148,118 @@ ,(CPP, "-cpp") ] +getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration + -> IO PackageIndex +getInstalledPackages verbosity packagedbs conf = do + homedir <- getHomeDirectory + (nhcProg, _) <- requireProgram verbosity nhcProgram conf + let bindir = takeDirectory (programPath nhcProg) + incdir = takeDirectory bindir "include" "nhc98" + dbdirs = nub (concatMap (packageDbPaths homedir incdir) packagedbs) + indexes <- mapM getIndividualDBPackages dbdirs + return $! mconcat indexes + + where + getIndividualDBPackages :: FilePath -> IO PackageIndex + getIndividualDBPackages dbdir = do + pkgdirs <- getPackageDbDirs dbdir + pkgs <- sequence [ getInstalledPackage pkgname pkgdir + | (pkgname, pkgdir) <- pkgdirs ] + let pkgs' = map setInstalledPackageId (catMaybes pkgs) + return (PackageIndex.fromList pkgs') + +packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath] +packageDbPaths _home incdir db = case db of + GlobalPackageDB -> [ incdir "packages" ] + UserPackageDB -> [] --TODO any standard per-user db? + SpecificPackageDB path -> [ path ] + +getPackageDbDirs :: FilePath -> IO [(PackageName, FilePath)] +getPackageDbDirs dbdir = do + dbexists <- doesDirectoryExist dbdir + if not dbexists + then return [] + else do + entries <- getDirectoryContents dbdir + pkgdirs <- sequence + [ do pkgdirExists <- doesDirectoryExist pkgdir + return (pkgname, pkgdir, pkgdirExists) + | (entry, Just pkgname) <- [ (entry, simpleParse entry) + | entry <- entries ] + , let pkgdir = dbdir entry ] + return [ (pkgname, pkgdir) | (pkgname, pkgdir, True) <- pkgdirs ] + +getInstalledPackage :: PackageName -> FilePath -> IO (Maybe InstalledPackageInfo) +getInstalledPackage pkgname pkgdir = do + let pkgconfFile = pkgdir "package.conf" + pkgconfExists <- doesFileExist pkgconfFile + + let cabalFile = pkgdir <.> "cabal" + cabalExists <- doesFileExist cabalFile + + case () of + _ | pkgconfExists -> getFullInstalledPackageInfo pkgname pkgconfFile + | cabalExists -> getPhonyInstalledPackageInfo pkgname cabalFile + | otherwise -> return Nothing + +getFullInstalledPackageInfo :: PackageName -> FilePath + -> IO (Maybe InstalledPackageInfo) +getFullInstalledPackageInfo pkgname pkgconfFile = + withUTF8FileContents pkgconfFile $ \contents -> + case parseInstalledPackageInfo contents of + ParseOk _ pkginfo | packageName pkginfo == pkgname + -> return (Just pkginfo) + _ -> return Nothing + +-- | This is a backup option for existing versions of nhc98 which do not supply +-- proper installed package info files for the bundled libs. Instead we look +-- for the .cabal file and extract the package version from that. +-- We don't know any other details for such packages, in particular we pretend +-- that they have no dependencies. +-- +getPhonyInstalledPackageInfo :: PackageName -> FilePath + -> IO (Maybe InstalledPackageInfo) +getPhonyInstalledPackageInfo pkgname pathsModule = do + content <- readFile pathsModule + case extractVersion content of + Nothing -> return Nothing + Just version -> return (Just pkginfo) + where + pkgid = PackageIdentifier pkgname version + pkginfo = emptyInstalledPackageInfo { sourcePackageId = pkgid } + where + -- search through the .cabal file, looking for a line like: + -- + -- > version: 2.0 + -- + extractVersion :: String -> Maybe Version + extractVersion content = + case catMaybes (map extractVersionLine (lines content)) of + [version] -> Just version + _ -> Nothing + extractVersionLine :: String -> Maybe Version + extractVersionLine line = + case words line of + [versionTag, ":", versionStr] + | map toLower versionTag == "version" -> simpleParse versionStr + [versionTag, versionStr] + | map toLower versionTag == "version:" -> simpleParse versionStr + _ -> Nothing + +-- Older installed package info files did not have the installedPackageId +-- field, so if it is missing then we fill it as the source package ID. +setInstalledPackageId :: InstalledPackageInfo -> InstalledPackageInfo +setInstalledPackageId pkginfo@InstalledPackageInfo { + installedPackageId = InstalledPackageId "", + sourcePackageId = pkgid + } + = pkginfo { + --TODO use a proper named function for the conversion + -- from source package id to installed package id + installedPackageId = InstalledPackageId (display pkgid) + } +setInstalledPackageId pkginfo = pkginfo + -- ----------------------------------------------------------------------------- -- Building diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/Simple/PackageIndex.hs ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/PackageIndex.hs --- ghc-6.12.1/libraries/Cabal/Distribution/Simple/PackageIndex.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/PackageIndex.hs 2009-12-31 10:25:27.000000000 -0800 @@ -445,7 +445,7 @@ dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of (completed, []) -> Left completed (completed, _) -> Right (brokenPackages completed) - where + where closure completed failed [] = (completed, failed) closure completed failed (pkgid:pkgids) = case lookupInstalledPackageId index pkgid of Nothing -> closure completed (pkgid:failed) pkgids diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/Simple/PreProcess.hs ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/PreProcess.hs --- ghc-6.12.1/libraries/Cabal/Distribution/Simple/PreProcess.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/PreProcess.hs 2009-12-31 10:25:27.000000000 -0800 @@ -59,7 +59,6 @@ import Distribution.Simple.PreProcess.Unlit (unlit) import Distribution.Package ( Package(..), PackageName(..) ) -import Distribution.ModuleName (ModuleName) import qualified Distribution.ModuleName as ModuleName import Distribution.PackageDescription as PD ( PackageDescription(..), BuildInfo(..), Executable(..), withExe @@ -84,8 +83,6 @@ ( OS(OSX, Windows), buildOS ) import Distribution.Version (Version(..)) import Distribution.Verbosity -import Distribution.Text - ( display ) import Control.Monad (when, unless) import Data.Maybe (fromMaybe) @@ -182,8 +179,9 @@ setupMessage verbosity "Preprocessing library" (packageId pkg_descr) let bi = libBuildInfo lib let biHandlers = localHandlers bi - sequence_ [ preprocessModule (hsSourceDirs bi ++ [autogenModulesDir lbi]) (buildDir lbi) forSDist - modu verbosity builtinSuffixes biHandlers + sequence_ [ preprocessFile (hsSourceDirs bi ++ [autogenModulesDir lbi]) (buildDir lbi) forSDist + (ModuleName.toFilePath modu) verbosity + builtinSuffixes biHandlers | modu <- libModules lib ] unless (null (executables pkg_descr)) $ setupMessage verbosity "Preprocessing executables for" (packageId pkg_descr) @@ -191,12 +189,12 @@ let bi = buildInfo theExe let biHandlers = localHandlers bi let exeDir = buildDir lbi exeName theExe exeName theExe ++ "-tmp" - sequence_ [ preprocessModule (hsSourceDirs bi ++ [autogenModulesDir lbi]) exeDir forSDist - modu verbosity builtinSuffixes biHandlers + sequence_ [ preprocessFile (hsSourceDirs bi ++ [autogenModulesDir lbi]) exeDir forSDist + (ModuleName.toFilePath modu) verbosity + builtinSuffixes biHandlers | modu <- otherModules bi] - preprocessModule (hsSourceDirs bi) exeDir forSDist - --FIXME: we should not pretend it's a module name: - (ModuleName.simple (dropExtensions (modulePath theExe))) + preprocessFile (hsSourceDirs bi) exeDir forSDist + (dropExtensions (modulePath theExe)) verbosity builtinSuffixes biHandlers where hc = compilerFlavor (compiler lbi) builtinSuffixes @@ -206,27 +204,25 @@ -- |Find the first extension of the file that exists, and preprocess it -- if required. -preprocessModule +preprocessFile :: [FilePath] -- ^source directories -> FilePath -- ^build directory -> Bool -- ^preprocess for sdist - -> ModuleName -- ^module name + -> FilePath -- ^module file name -> Verbosity -- ^verbosity -> [String] -- ^builtin suffixes -> [(String, PreProcessor)] -- ^possible preprocessors -> IO () -preprocessModule searchLoc buildLoc forSDist modu verbosity builtinSuffixes handlers = do +preprocessFile searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes handlers = do -- look for files in the various source dirs with this module name -- and a file extension of a known preprocessor - psrcFiles <- findFileWithExtension' (map fst handlers) searchLoc - (ModuleName.toFilePath modu) + psrcFiles <- findFileWithExtension' (map fst handlers) searchLoc baseFile case psrcFiles of -- no preprocessor file exists, look for an ordinary source file Nothing -> do - bsrcFiles <- findFileWithExtension builtinSuffixes searchLoc - (ModuleName.toFilePath modu) + bsrcFiles <- findFileWithExtension builtinSuffixes searchLoc baseFile case bsrcFiles of - Nothing -> die $ "can't find source for " ++ display modu + Nothing -> die $ "can't find source for " ++ baseFile ++ " in " ++ intercalate ", " searchLoc _ -> return () -- found a pre-processable file in one of the source dirs @@ -243,11 +239,11 @@ -- platform independent files and put them into the 'buildLoc' -- (which we assume is set to the temp. directory that will become -- the tarball). + --TODO: eliminate sdist variant, just supply different handlers when (not forSDist || forSDist && platformIndependent pp) $ do -- look for existing pre-processed source file in the dest dir to -- see if we really have to re-run the preprocessor. - ppsrcFiles <- findFileWithExtension builtinSuffixes [buildLoc] - (ModuleName.toFilePath modu) + ppsrcFiles <- findFileWithExtension builtinSuffixes [buildLoc] baseFile recomp <- case ppsrcFiles of Nothing -> return True Just ppsrcFile -> do @@ -261,9 +257,9 @@ (psrcLoc, psrcRelFile) (buildLoc, srcStem <.> "hs") verbosity - where dirName = takeDirectory - tailNotNull [] = [] - tailNotNull x = tail x + where dirName = takeDirectory + tailNotNull [] = [] + tailNotNull x = tail x -- ------------------------------------------------------------ -- * known preprocessors @@ -357,8 +353,10 @@ , "--ld=" ++ programPath gccProg ] -- Additional gcc options - ++ [ "--cflag=" ++ opt | opt <- programArgs gccProg ] - ++ [ "--lflag=" ++ opt | opt <- programArgs gccProg ] + ++ [ "--cflag=" ++ opt | opt <- programDefaultArgs gccProg + ++ programOverrideArgs gccProg ] + ++ [ "--lflag=" ++ opt | opt <- programDefaultArgs gccProg + ++ programOverrideArgs gccProg ] -- OSX frameworks: ++ [ what ++ "=-F" ++ opt @@ -484,7 +482,7 @@ runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do rawSystemProgramConf verbosity prog (withPrograms lbi) (args ++ ["-o", outFile, inFile]) - -- XXX This is a nasty hack. GHC requires that hs-boot files + -- Note: This is a nasty hack. GHC requires that hs-boot files -- be in the same place as the hs files, so if we put the hs -- file in dist/... then we need to copy the hs-boot file -- there too. This should probably be done another way, e.g. diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/Simple/Program/Db.hs ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/Program/Db.hs --- ghc-6.12.1/libraries/Cabal/Distribution/Simple/Program/Db.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/Program/Db.hs 2009-12-31 10:25:27.000000000 -0800 @@ -197,7 +197,8 @@ \(prog, path, args) -> Just (prog, path, args ++ args')) . updateConfiguredProgs (flip Map.update name $ - \prog -> Just prog { programArgs = programArgs prog ++ args' }) + \prog -> Just prog { programOverrideArgs = programOverrideArgs prog + ++ args' }) -- | Like 'userSpecifyPath' but for a list of progs and their paths. @@ -285,15 +286,16 @@ Nothing -> return conf Just location -> do version <- programFindVersion prog verbosity (locationPath location) - let configuredProg = ConfiguredProgram { - programId = name, - programVersion = version, - programArgs = userSpecifiedArgs prog conf, - programLocation = location + let configuredProg = ConfiguredProgram { + programId = name, + programVersion = version, + programDefaultArgs = [], + programOverrideArgs = userSpecifiedArgs prog conf, + programLocation = location } extraArgs <- programPostConf prog verbosity configuredProg - let configuredProg' = configuredProg { - programArgs = extraArgs ++ programArgs configuredProg + let configuredProg' = configuredProg { + programDefaultArgs = extraArgs } return (updateConfiguredProgs (Map.insert name configuredProg') conf) diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/Simple/Program/HcPkg.hs ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/Program/HcPkg.hs --- ghc-6.12.1/libraries/Cabal/Distribution/Simple/Program/HcPkg.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/Program/HcPkg.hs 2009-12-31 10:25:27.000000000 -0800 @@ -34,7 +34,7 @@ import Distribution.ParseUtils ( ParseResult(..) ) import Distribution.Simple.Compiler - ( PackageDB(..) ) + ( PackageDB(..), PackageDBStack ) import Distribution.Simple.Program.Types ( ConfiguredProgram(programId, programVersion) ) import Distribution.Simple.Program.Run @@ -58,7 +58,7 @@ -- -- > hc-pkg register {filename | -} [--user | --global | --package-conf] -- -register :: Verbosity -> ConfiguredProgram -> PackageDB +register :: Verbosity -> ConfiguredProgram -> PackageDBStack -> Either FilePath InstalledPackageInfo -> IO () @@ -71,7 +71,7 @@ -- -- > hc-pkg register {filename | -} [--user | --global | --package-conf] -- -reregister :: Verbosity -> ConfiguredProgram -> PackageDB +reregister :: Verbosity -> ConfiguredProgram -> PackageDBStack -> Either FilePath InstalledPackageInfo -> IO () @@ -164,7 +164,7 @@ -- registerInvocation, reregisterInvocation - :: ConfiguredProgram -> Verbosity -> PackageDB + :: ConfiguredProgram -> Verbosity -> PackageDBStack -> Either FilePath InstalledPackageInfo -> ProgramInvocation registerInvocation = registerInvocation' "register" @@ -172,22 +172,22 @@ registerInvocation' :: String - -> ConfiguredProgram -> Verbosity -> PackageDB + -> ConfiguredProgram -> Verbosity -> PackageDBStack -> Either FilePath InstalledPackageInfo -> ProgramInvocation -registerInvocation' cmdname hcPkg verbosity packagedb (Left pkgFile) = +registerInvocation' cmdname hcPkg verbosity packagedbs (Left pkgFile) = programInvocation hcPkg args where - args = [cmdname, pkgFile, packageDbOpts packagedb] + args = [cmdname, pkgFile] ++ packageDbStackOpts packagedbs ++ verbosityOpts hcPkg verbosity -registerInvocation' cmdname hcPkg verbosity packagedb (Right pkgInfo) = +registerInvocation' cmdname hcPkg verbosity packagedbs (Right pkgInfo) = (programInvocation hcPkg args) { progInvokeInput = Just (showInstalledPackageInfo pkgInfo), progInvokeInputEncoding = IOEncodingUTF8 } where - args = [cmdname, "-", packageDbOpts packagedb] + args = [cmdname, "-"] ++ packageDbStackOpts packagedbs ++ verbosityOpts hcPkg verbosity @@ -227,6 +227,20 @@ ++ verbosityOpts hcPkg verbosity +packageDbStackOpts :: PackageDBStack -> [String] +packageDbStackOpts dbstack = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) -> "--global" + : "--user" + : map specific dbs + (GlobalPackageDB:dbs) -> "--global" + : "--no-user-package-conf" + : map specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = "--package-conf=" ++ db + specific _ = ierror + ierror = error "internal error: unexpected package db stack" + packageDbOpts :: PackageDB -> String packageDbOpts GlobalPackageDB = "--global" packageDbOpts UserPackageDB = "--user" diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/Simple/Program/Run.hs ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/Program/Run.hs --- ghc-6.12.1/libraries/Cabal/Distribution/Simple/Program/Run.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/Program/Run.hs 2009-12-31 10:25:27.000000000 -0800 @@ -77,10 +77,12 @@ } programInvocation :: ConfiguredProgram -> [String] -> ProgramInvocation -programInvocation prog extraArgs = +programInvocation prog args = emptyProgramInvocation { progInvokePath = programPath prog, - progInvokeArgs = programArgs prog ++ extraArgs + progInvokeArgs = programDefaultArgs prog + ++ args + ++ programOverrideArgs prog } diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/Simple/Program/Types.hs ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/Program/Types.hs --- ghc-6.12.1/libraries/Cabal/Distribution/Simple/Program/Types.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/Program/Types.hs 2009-12-31 10:25:27.000000000 -0800 @@ -65,7 +65,12 @@ -- | Default command-line args for this program. -- These flags will appear first on the command line, so they can be -- overridden by subsequent flags. - programArgs :: [String], + programDefaultArgs :: [String], + + -- | Override command-line args for this program. + -- These flags will appear last on the command line, so they override + -- all earlier flags. + programOverrideArgs :: [String], -- | Location of the program. eg. @\/usr\/bin\/ghc-6.4@ programLocation :: ProgramLocation diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/Simple/Register.hs ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/Register.hs --- ghc-6.12.1/libraries/Cabal/Distribution/Simple/Register.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/Register.hs 2009-12-31 10:25:27.000000000 -0800 @@ -68,10 +68,12 @@ ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) , InstallDirs(..), absoluteInstallDirs ) import Distribution.Simple.BuildPaths (haddockName) -import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.LHC as LHC +import qualified Distribution.Simple.Hugs as Hugs import Distribution.Simple.Compiler ( compilerVersion, CompilerFlavor(..), compilerFlavor - , PackageDB(..), registrationPackageDB ) + , PackageDBStack, registrationPackageDB ) import Distribution.Simple.Program ( ConfiguredProgram, runProgramInvocation , requireProgram, lookupProgram, ghcPkgProgram, lhcPkgProgram ) @@ -90,7 +92,7 @@ , showInstalledPackageInfo ) import qualified Distribution.InstalledPackageInfo as IPI import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, writeUTF8File, writeFileAtomic + ( writeUTF8File, writeFileAtomic , die, notice, setupMessage ) import Distribution.System ( OS(..), buildOS ) @@ -107,9 +109,8 @@ ( getCurrentDirectory, removeDirectoryRecursive ) import System.IO.Error (try) -import Control.Monad (when) import Data.Maybe - ( isJust, fromMaybe ) + ( isJust, fromMaybe, maybeToList ) import Data.List (partition) @@ -131,7 +132,7 @@ _ | modeGenerateRegFile -> writeRegistrationFile installedPkgInfo | modeGenerateRegScript -> writeRegisterScript installedPkgInfo | otherwise -> registerPackage verbosity - installedPkgInfo pkg lbi inplace packageDb + installedPkgInfo pkg lbi inplace packageDbs where modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) @@ -141,8 +142,8 @@ modeGenerateRegScript = fromFlag (regGenScript regFlags) inplace = fromFlag (regInPlace regFlags) - packageDb = fromFlagOrDefault (registrationPackageDB (withPackageDB lbi)) - (regPackageDB regFlags) + packageDbs = withPackageDB lbi + ++ maybeToList (flagToMaybe (regPackageDB regFlags)) distPref = fromFlag (regDistPref regFlags) verbosity = fromFlag (regVerbosity regFlags) @@ -153,9 +154,9 @@ writeRegisterScript installedPkgInfo = case compilerFlavor (compiler lbi) of GHC -> do (ghcPkg, _) <- requireProgram verbosity ghcPkgProgram (withPrograms lbi) - writeHcPkgRegisterScript verbosity installedPkgInfo ghcPkg packageDb + writeHcPkgRegisterScript verbosity installedPkgInfo ghcPkg packageDbs LHC -> do (lhcPkg, _) <- requireProgram verbosity lhcPkgProgram (withPrograms lbi) - writeHcPkgRegisterScript verbosity installedPkgInfo lhcPkg packageDb + writeHcPkgRegisterScript verbosity installedPkgInfo lhcPkg packageDbs Hugs -> notice verbosity "Registration scripts not needed for hugs" JHC -> notice verbosity "Registration scripts not needed for jhc" NHC -> notice verbosity "Registration scripts not needed for nhc98" @@ -203,51 +204,27 @@ -> PackageDescription -> LocalBuildInfo -> Bool - -> PackageDB + -> PackageDBStack -> IO () -registerPackage verbosity installedPkgInfo pkg lbi inplace packageDb = do +registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs = do setupMessage verbosity "Registering" (packageId pkg) case compilerFlavor (compiler lbi) of - GHC -> registerPackageGHC verbosity installedPkgInfo pkg lbi inplace packageDb - LHC -> registerPackageLHC verbosity installedPkgInfo pkg lbi inplace packageDb - Hugs -> registerPackageHugs verbosity installedPkgInfo pkg lbi inplace packageDb + GHC -> GHC.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs + LHC -> LHC.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs + Hugs -> Hugs.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs JHC -> notice verbosity "Registering for jhc (nothing to do)" NHC -> notice verbosity "Registering for nhc98 (nothing to do)" _ -> die "Registering is not implemented for this compiler" -registerPackageGHC, registerPackageLHC, registerPackageHugs - :: Verbosity - -> InstalledPackageInfo - -> PackageDescription - -> LocalBuildInfo - -> Bool - -> PackageDB - -> IO () -registerPackageGHC verbosity installedPkgInfo _pkg lbi _inplace packageDb = do - let Just ghcPkg = lookupProgram ghcPkgProgram (withPrograms lbi) - HcPkg.reregister verbosity ghcPkg packageDb (Right installedPkgInfo) - -registerPackageLHC verbosity installedPkgInfo _pkg lbi _inplace packageDb = do - let Just lhcPkg = lookupProgram lhcPkgProgram (withPrograms lbi) - HcPkg.reregister verbosity lhcPkg packageDb (Right installedPkgInfo) - -registerPackageHugs verbosity installedPkgInfo pkg lbi inplace _packageDb = do - when inplace $ die "--inplace is not supported with Hugs" - let installDirs = absoluteInstallDirs pkg lbi NoCopyDest - createDirectoryIfMissingVerbose verbosity True (libdir installDirs) - writeUTF8File (libdir installDirs "package.conf") - (showInstalledPackageInfo installedPkgInfo) - - writeHcPkgRegisterScript :: Verbosity -> InstalledPackageInfo -> ConfiguredProgram - -> PackageDB + -> PackageDBStack -> IO () -writeHcPkgRegisterScript verbosity installedPkgInfo hcPkg packageDb = do +writeHcPkgRegisterScript verbosity installedPkgInfo hcPkg packageDbs = do let invocation = HcPkg.reregisterInvocation hcPkg Verbosity.normal - packageDb (Right installedPkgInfo) + packageDbs (Right installedPkgInfo) regScript = invocationAsSystemScript buildOS invocation notice verbosity ("Creating package registration script: " ++ regScriptFileName) diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/Simple/Setup.hs ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/Setup.hs --- ghc-6.12.1/libraries/Cabal/Distribution/Simple/Setup.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/Setup.hs 2009-12-31 10:25:27.000000000 -0800 @@ -110,7 +110,7 @@ import Data.Monoid (Monoid(..)) import Distribution.Verbosity --- XXX Not sure where this should live +-- FIXME Not sure where this should live defaultDistPref :: FilePath defaultDistPref = "dist" @@ -350,6 +350,7 @@ "directory to receive the built package (hugs-only)" configScratchDir (\v flags -> flags { configScratchDir = v }) (reqArgFlag "DIR") + --TODO: eliminate scratchdir flag ,option "" ["program-prefix"] "prefix to be applied to installed executables" @@ -631,13 +632,6 @@ copyDest (\v flags -> flags { copyDest = v }) (reqArg "DIR" (succeedReadE (Flag . CopyTo)) (\f -> case f of Flag (CopyTo p) -> [p]; _ -> [])) - - ,option "" ["copy-prefix"] - "[DEPRECATED, directory to copy files to instead of prefix]" - copyDest (\v flags -> flags { copyDest = v }) - (reqArg' "DIR" (Flag . CopyPrefix) - (\f -> case f of Flag (CopyPrefix p) -> [p]; _ -> [])) - ] emptyCopyFlags :: CopyFlags diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/Simple/SrcDist.hs ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/SrcDist.hs --- ghc-6.12.1/libraries/Cabal/Distribution/Simple/SrcDist.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/SrcDist.hs 2009-12-31 10:25:27.000000000 -0800 @@ -127,7 +127,7 @@ | otherwise = pkg setupMessage verbosity "Building source dist for" (packageId pkg') - -- XXX This looks a bit suspicious. Should createArchive be passed + -- FIXME This looks a bit suspicious. Should createArchive be passed -- the result of prepareSnapshotTree/prepareTree? _ <- if snapshot then prepareSnapshotTree verbosity pkg' mb_lbi distPref tmpDir pps diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/Simple/Utils.hs ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/Utils.hs --- ghc-6.12.1/libraries/Cabal/Distribution/Simple/Utils.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/Simple/Utils.hs 2009-12-31 10:25:27.000000000 -0800 @@ -161,7 +161,7 @@ , hGetContents, stderr, stdout, hPutStr, hFlush, hClose ) import System.IO.Error as IO.Error ( isDoesNotExistError, ioeSetFileName, ioeGetFileName, ioeGetErrorString ) -#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ >= 608) +#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608)) import System.IO.Error ( ioeSetLocation, ioeGetLocation ) #endif @@ -220,7 +220,7 @@ . flip ioeSetFileName (normalise filename) $ userError msg where -#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 608) +#if defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608) setLocation _ err = err #else setLocation Nothing err = err @@ -243,7 +243,7 @@ file = case ioeGetFileName ioe of Nothing -> "" Just path -> path ++ location ++ ": " -#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 608) +#if defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608) location = "" #else location = case ioeGetLocation ioe of diff -ruN ghc-6.12.1/libraries/Cabal/Distribution/Simple.hs ghc-6.13.20091231/libraries/Cabal/Distribution/Simple.hs --- ghc-6.12.1/libraries/Cabal/Distribution/Simple.hs 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Distribution/Simple.hs 2009-12-31 10:25:27.000000000 -0800 @@ -354,7 +354,7 @@ let pkg_descr0 = localPkgDescr localbuildinfo --pkg_descr0 <- get_pkg_descr (get_verbose flags) let pkg_descr = updatePackageDescription pbi pkg_descr0 - -- XXX: should we write the modified package descr back to the + -- TODO: should we write the modified package descr back to the -- localbuildinfo? cmd_hook hooks pkg_descr localbuildinfo hooks flags post_hook hooks args flags pkg_descr localbuildinfo diff -ruN ghc-6.12.1/libraries/Cabal/Makefile ghc-6.13.20091231/libraries/Cabal/Makefile --- ghc-6.12.1/libraries/Cabal/Makefile 2009-12-10 10:24:35.000000000 -0800 +++ ghc-6.13.20091231/libraries/Cabal/Makefile 2009-12-31 10:25:27.000000000 -0800 @@ -1,5 +1,5 @@ -VERSION=1.8.0.2 +VERSION=1.9.0 #KIND=devel KIND=rc @@ -66,11 +66,17 @@ XSLTPROC=xsltproc XSLTPROC_HTML_OUTDIR=dist/doc/users-guide/ +XSLTPROC_HTML_DOCTYPE_PUBLIC="-//W3C//DTD HTML 4.01 Transitional//EN" +XSLTPROC_HTML_DOCTYPE_SYSTEM="http://www.w3.org/TR/html4/loose.dtd" +XSLTPROC_HTML_ENCODING=UTF-8 XSLTPROC_HTML_CSS=Cabal.css XSLTPROC_HTML_PARAMS=\ --param use.id.as.filename 1 \ --param toc.section.depth 3 \ --stringparam base.dir $(XSLTPROC_HTML_OUTDIR) \ + --stringparam chunker.output.doctype-public $(XSLTPROC_HTML_DOCTYPE_PUBLIC) \ + --stringparam chunker.output.doctype-system $(XSLTPROC_HTML_DOCTYPE_SYSTEM) \ + --stringparam chunker.output.encoding $(XSLTPROC_HTML_ENCODING) \ --stringparam html.stylesheet $(XSLTPROC_HTML_CSS) XSLTPROC_HTML_STYLESHEET=http://docbook.sourceforge.net/release/xsl/current/html/chunk.xsl XSLTPROC_OPTIONS=--nonet $(XSLTPROC_HTML_PARAMS) $(XSLTPROC_HTML_STYLESHEET) diff -ruN ghc-6.12.1/libraries/containers/containers.cabal ghc-6.13.20091231/libraries/containers/containers.cabal --- ghc-6.12.1/libraries/containers/containers.cabal 2009-11-19 07:51:36.000000000 -0800 +++ ghc-6.13.20091231/libraries/containers/containers.cabal 2009-12-31 10:25:36.000000000 -0800 @@ -22,15 +22,18 @@ Library { build-depends: base >= 4.2 && < 6, array exposed-modules: - Data.Graph Data.IntMap Data.IntSet Data.Map - Data.Sequence Data.Set - Data.Tree include-dirs: include extensions: CPP + if !impl(nhc98) { + exposed-modules: + Data.Graph + Data.Sequence + Data.Tree + } if impl(ghc) { extensions: DeriveDataTypeable, MagicHash, Rank2Types } diff -ruN ghc-6.12.1/libraries/containers/.darcs-boring ghc-6.13.20091231/libraries/containers/.darcs-boring --- ghc-6.12.1/libraries/containers/.darcs-boring 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/containers/.darcs-boring 2009-12-31 10:25:36.000000000 -0800 @@ -0,0 +1,5 @@ +^dist(/|$) +^setup(/|$) +^GNUmakefile$ +^Makefile.local$ +^.depend(.bak)?$ diff -ruN ghc-6.12.1/libraries/containers/Data/Map.hs ghc-6.13.20091231/libraries/containers/Data/Map.hs --- ghc-6.12.1/libraries/containers/Data/Map.hs 2009-11-19 07:51:36.000000000 -0800 +++ ghc-6.13.20091231/libraries/containers/Data/Map.hs 2009-12-31 10:25:36.000000000 -0800 @@ -1278,7 +1278,7 @@ mapEitherWithKey f (Bin _ kx x l r) = case f kx x of Left y -> (join kx y l1 r1, merge l2 r2) Right z -> (merge l1 r1, join kx z l2 r2) - where + where (l1,l2) = mapEitherWithKey f l (r1,r2) = mapEitherWithKey f r diff -ruN ghc-6.12.1/libraries/containers/Data/Sequence.hs ghc-6.13.20091231/libraries/containers/Data/Sequence.hs --- ghc-6.12.1/libraries/containers/Data/Sequence.hs 2009-11-19 07:51:36.000000000 -0800 +++ ghc-6.13.20091231/libraries/containers/Data/Sequence.hs 2009-12-31 10:25:36.000000000 -0800 @@ -169,7 +169,9 @@ instance Functor Seq where fmap f (Seq xs) = Seq (fmap (fmap f) xs) +#ifdef __GLASGOW_HASKELL__ x <$ s = replicate (length s) x +#endif instance Foldable Seq where foldr f z (Seq xs) = foldr (flip (foldr f)) z xs @@ -1500,8 +1502,8 @@ findIndicesL p xs = build (\ c n -> let g i x z = if p x then c i z else z in foldrWithIndex g n xs) #else -findIndicesL p xs = foldrWithIndex g [] xs where -g i x is = if p x then i:is else is +findIndicesL p xs = foldrWithIndex g [] xs + where g i x is = if p x then i:is else is #endif {-# INLINE findIndicesR #-} @@ -1512,8 +1514,8 @@ findIndicesR p xs = build (\ c n -> let g z i x = if p x then c i z else z in foldlWithIndex g n xs) #else -findIndicesR p xs = foldlWithIndex g [] xs where -g is i x = if p x then i:is else is +findIndicesR p xs = foldlWithIndex g [] xs + where g is i x = if p x then i:is else is #endif ------------------------------------------------------------------------ diff -ruN ghc-6.12.1/libraries/containers/prologue.txt ghc-6.13.20091231/libraries/containers/prologue.txt --- ghc-6.12.1/libraries/containers/prologue.txt 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/containers/prologue.txt 2009-12-31 10:25:36.000000000 -0800 @@ -0,0 +1 @@ +This package contains basic container classes and containers. diff -ruN ghc-6.12.1/libraries/containers/tests/all.T ghc-6.13.20091231/libraries/containers/tests/all.T --- ghc-6.12.1/libraries/containers/tests/all.T 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/containers/tests/all.T 2009-12-31 10:25:36.000000000 -0800 @@ -0,0 +1,5 @@ +# This is a test script for use with GHC's testsuite framework, see +# http://darcs.haskell.org/testsuite + +test('datamap001', normal, compile_and_run, ['-package containers']) +test('dataintset001', normal, compile_and_run, ['-package containers']) diff -ruN ghc-6.12.1/libraries/containers/tests/dataintset001.hs ghc-6.13.20091231/libraries/containers/tests/dataintset001.hs --- ghc-6.12.1/libraries/containers/tests/dataintset001.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/containers/tests/dataintset001.hs 2009-12-31 10:25:36.000000000 -0800 @@ -0,0 +1,11 @@ + +{- +Through 6.8.1 this printed False, should be True. +-} + +module Main (main) where + +import Data.IntSet + +main :: IO () +main = print $ isProperSubsetOf (fromList [2,3]) $ fromList [2,3,4] diff -ruN ghc-6.12.1/libraries/containers/tests/dataintset001.stdout ghc-6.13.20091231/libraries/containers/tests/dataintset001.stdout --- ghc-6.12.1/libraries/containers/tests/dataintset001.stdout 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/containers/tests/dataintset001.stdout 2009-12-31 10:25:36.000000000 -0800 @@ -0,0 +1 @@ +True diff -ruN ghc-6.12.1/libraries/containers/tests/datamap001.hs ghc-6.13.20091231/libraries/containers/tests/datamap001.hs --- ghc-6.12.1/libraries/containers/tests/datamap001.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/containers/tests/datamap001.hs 2009-12-31 10:25:36.000000000 -0800 @@ -0,0 +1,14 @@ + +{- +In the 6.6 era this printed [(5,"x")]; should be [(3,"b"),(5,"a")] +-} + +module Main (main) where + +import Data.Map + +main :: IO () +main = do let m = fromList [(3,"b"),(5,"a")] + f k a = Just "x" + m' = updateAt f 1 m + print m' diff -ruN ghc-6.12.1/libraries/containers/tests/datamap001.stdout ghc-6.13.20091231/libraries/containers/tests/datamap001.stdout --- ghc-6.12.1/libraries/containers/tests/datamap001.stdout 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/containers/tests/datamap001.stdout 2009-12-31 10:25:36.000000000 -0800 @@ -0,0 +1 @@ +fromList [(3,"b"),(5,"x")] diff -ruN ghc-6.12.1/libraries/containers/tests/Makefile ghc-6.13.20091231/libraries/containers/tests/Makefile --- ghc-6.12.1/libraries/containers/tests/Makefile 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/containers/tests/Makefile 2009-12-31 10:25:36.000000000 -0800 @@ -0,0 +1,7 @@ +# This Makefile runs the tests using GHC's testsuite framework. It +# assumes the package is part of a GHC build tree with the testsuite +# installed in ../../../testsuite. + +TOP=../../../testsuite +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff -ruN ghc-6.12.1/libraries/directory/.darcs-boring ghc-6.13.20091231/libraries/directory/.darcs-boring --- ghc-6.12.1/libraries/directory/.darcs-boring 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/.darcs-boring 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1,11 @@ +^dist(/|$) +^setup(/|$) +^GNUmakefile$ +^Makefile.local$ +^.depend(.bak)?$ +^autom4te.cache(/|$) +^config.log$ +^config.status$ +^configure$ +^include/HsDirectoryConfig.h$ +^include/HsDirectoryConfig.h.in$ diff -ruN ghc-6.12.1/libraries/directory/prologue.txt ghc-6.13.20091231/libraries/directory/prologue.txt --- ghc-6.12.1/libraries/directory/prologue.txt 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/prologue.txt 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1 @@ +This package provides a library for handling directories. diff -ruN ghc-6.12.1/libraries/directory/System/Directory.hs ghc-6.13.20091231/libraries/directory/System/Directory.hs --- ghc-6.12.1/libraries/directory/System/Directory.hs 2009-11-19 07:47:33.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/System/Directory.hs 2009-12-31 10:25:43.000000000 -0800 @@ -21,7 +21,9 @@ -- * Actions on directories createDirectory -- :: FilePath -> IO () +#ifndef __NHC__ , createDirectoryIfMissing -- :: Bool -> FilePath -> IO () +#endif , removeDirectory -- :: FilePath -> IO () , removeDirectoryRecursive -- :: FilePath -> IO () , renameDirectory -- :: FilePath -> FilePath -> IO () @@ -82,9 +84,9 @@ import Control.Exception.Base #ifdef __NHC__ -import Directory hiding ( getDirectoryContents - , doesDirectoryExist, doesFileExist - , getModificationTime ) +import Directory -- hiding ( getDirectoryContents + -- , doesDirectoryExist, doesFileExist + -- , getModificationTime ) import System (system) #endif /* __NHC__ */ @@ -329,6 +331,7 @@ #endif +#ifndef __NHC__ -- | @'createDirectoryIfMissing' parents dir@ creates a new directory -- @dir@ if it doesn\'t exist. If the first argument is 'True' -- the function will also create all parent directories if they are missing. @@ -376,6 +379,7 @@ #endif ) `catch` ((\_ -> return ()) :: IOException -> IO ()) | otherwise -> throw e +#endif /* !__NHC__ */ #if __GLASGOW_HASKELL__ {- | @'removeDirectory' dir@ removes an existing directory /dir/. The @@ -739,7 +743,7 @@ #endif -#ifndef __HUGS__ +#ifdef __GLASGOW_HASKELL__ {- |@'getDirectoryContents' dir@ returns a list of /all/ entries in /dir/. @@ -776,16 +780,16 @@ modifyIOError ((`ioeSetFileName` path) . (`ioeSetLocation` "getDirectoryContents")) $ do #ifndef mingw32_HOST_OS - bracket - (Posix.openDirStream path) - Posix.closeDirStream - loop + bracket + (Posix.openDirStream path) + Posix.closeDirStream + loop where loop dirp = do e <- Posix.readDirStream dirp if null e then return [] else do - es <- loop dirp - return (e:es) + es <- loop dirp + return (e:es) #else bracket (Win32.findFirstFile (path "*")) @@ -804,7 +808,7 @@ -- no need to reverse, ordering is undefined #endif /* mingw32 */ -#endif /* !__HUGS__ */ +#endif /* __GLASGOW_HASKELL__ */ {- |If the operating system has a notion of current directories, @@ -883,7 +887,7 @@ #endif /* __GLASGOW_HASKELL__ */ -#ifndef __HUGS__ +#ifdef __GLASGOW_HASKELL__ {- |The operation 'doesDirectoryExist' returns 'True' if the argument file exists and is a directory, and 'False' otherwise. -} @@ -937,7 +941,7 @@ #endif -#endif /* !__HUGS__ */ +#endif /* __GLASGOW_HASKELL__ */ #ifdef mingw32_HOST_OS withFileStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a @@ -1011,16 +1015,16 @@ getHomeDirectory = modifyIOError ((`ioeSetLocation` "getHomeDirectory")) $ do #if defined(mingw32_HOST_OS) - r <- try $ Win32.sHGetFolderPath nullPtr Win32.cSIDL_PROFILE nullPtr 0 - case (r :: Either IOException String) of - Right s -> return s - Left _ -> do - r1 <- try $ Win32.sHGetFolderPath nullPtr Win32.cSIDL_WINDOWS nullPtr 0 - case r1 of - Right s -> return s - Left e -> ioError (e :: IOException) + r <- try $ Win32.sHGetFolderPath nullPtr Win32.cSIDL_PROFILE nullPtr 0 + case (r :: Either IOException String) of + Right s -> return s + Left _ -> do + r1 <- try $ Win32.sHGetFolderPath nullPtr Win32.cSIDL_WINDOWS nullPtr 0 + case r1 of + Right s -> return s + Left e -> ioError (e :: IOException) #else - getEnv "HOME" + getEnv "HOME" #endif {- | Returns the pathname of a directory in which application-specific @@ -1054,11 +1058,11 @@ getAppUserDataDirectory appName = do modifyIOError ((`ioeSetLocation` "getAppUserDataDirectory")) $ do #if defined(mingw32_HOST_OS) - s <- Win32.sHGetFolderPath nullPtr Win32.cSIDL_APPDATA nullPtr 0 - return (s++'\\':appName) + s <- Win32.sHGetFolderPath nullPtr Win32.cSIDL_APPDATA nullPtr 0 + return (s++'\\':appName) #else - path <- getEnv "HOME" - return (path++'/':'.':appName) + path <- getEnv "HOME" + return (path++'/':'.':appName) #endif {- | Returns the current user's document directory. @@ -1086,9 +1090,9 @@ getUserDocumentsDirectory = do modifyIOError ((`ioeSetLocation` "getUserDocumentsDirectory")) $ do #if defined(mingw32_HOST_OS) - Win32.sHGetFolderPath nullPtr Win32.cSIDL_PERSONAL nullPtr 0 + Win32.sHGetFolderPath nullPtr Win32.cSIDL_PERSONAL nullPtr 0 #else - getEnv "HOME" + getEnv "HOME" #endif {- | Returns the current directory for temporary files. diff -ruN ghc-6.12.1/libraries/directory/tests/all.T ghc-6.13.20091231/libraries/directory/tests/all.T --- ghc-6.12.1/libraries/directory/tests/all.T 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/all.T 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1,24 @@ +test('currentDirectory001', normal, compile_and_run, ['']) +test('directory001', normal, compile_and_run, ['']) +test('doesDirectoryExist001', normal, compile_and_run, ['']) + +# This test is a bit bogus. Disable for GHCi. +test('getDirContents001', omit_ways(['ghci']), compile_and_run, ['-fno-gen-manifest']) + +test('getDirContents002', exit_code(1), compile_and_run, ['']) + +# Depends on binary from previous run, which gets removed by the driver way=ghci +test('getPermissions001', omit_ways(['ghci']), compile_and_run, ['-cpp']) + +test('copyFile001', extra_clean(['copyFile/target']), compile_and_run, ['']) +test('copyFile002', extra_clean(['copyFile/target']), compile_and_run, ['']) + +test('renameFile001', extra_clean(['renameFile001.tmp1','renameFile001.tmp2']), + compile_and_run, ['']) + +test('createDirectory001', normal, compile_and_run, ['']) + +test('createDirectoryIfMissing001', normal, compile_and_run, ['']) + +# No sane way to tell whether the output is reasonable here... +test('getHomeDirectory001', ignore_output, compile_and_run, ['']) diff -ruN ghc-6.12.1/libraries/directory/tests/copyFile001dir/source ghc-6.13.20091231/libraries/directory/tests/copyFile001dir/source --- ghc-6.12.1/libraries/directory/tests/copyFile001dir/source 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/copyFile001dir/source 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1 @@ +This is the data \ No newline at end of file diff -ruN ghc-6.12.1/libraries/directory/tests/copyFile001.hs ghc-6.13.20091231/libraries/directory/tests/copyFile001.hs --- ghc-6.12.1/libraries/directory/tests/copyFile001.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/copyFile001.hs 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1,26 @@ + +module Main (main) where + +import Control.Exception +import Data.List +import System.Directory +import System.IO + +main :: IO () +main = do tryIO $ removeFile to + cs_before <- getDirectoryContents "copyFile001dir" + putStrLn "Before:" + print $ sort cs_before + copyFile from to + cs_before <- getDirectoryContents "copyFile001dir" + putStrLn "After:" + print $ sort cs_before + readFile to >>= print + +tryIO :: IO a -> IO (Either IOException a) +tryIO = try + +from, to :: FilePath +from = "copyFile001dir/source" +to = "copyFile001dir/target" + diff -ruN ghc-6.12.1/libraries/directory/tests/copyFile001.stdout ghc-6.13.20091231/libraries/directory/tests/copyFile001.stdout --- ghc-6.12.1/libraries/directory/tests/copyFile001.stdout 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/copyFile001.stdout 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1,5 @@ +Before: +[".","..","source"] +After: +[".","..","source","target"] +"This is the data" diff -ruN ghc-6.12.1/libraries/directory/tests/copyFile002dir/source ghc-6.13.20091231/libraries/directory/tests/copyFile002dir/source --- ghc-6.12.1/libraries/directory/tests/copyFile002dir/source 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/copyFile002dir/source 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1 @@ +This is the data \ No newline at end of file diff -ruN ghc-6.12.1/libraries/directory/tests/copyFile002.hs ghc-6.13.20091231/libraries/directory/tests/copyFile002.hs --- ghc-6.12.1/libraries/directory/tests/copyFile002.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/copyFile002.hs 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1,31 @@ + +module Main (main) where + +import Control.Exception +import Data.List +import System.Directory +import System.IO + +-- like copyFile001, but moves a file in the current directory +-- See bug #1652 +main :: IO () +main = do d <- getCurrentDirectory + flip finally (setCurrentDirectory d) $ do + setCurrentDirectory "copyFile002dir" + tryIO $ removeFile to + cs_before <- getDirectoryContents "." + putStrLn "Before:" + print $ sort cs_before + copyFile from to + cs_before <- getDirectoryContents "." + putStrLn "After:" + print $ sort cs_before + readFile to >>= print + +tryIO :: IO a -> IO (Either IOException a) +tryIO = try + +from, to :: FilePath +from = "source" +to = "target" + diff -ruN ghc-6.12.1/libraries/directory/tests/copyFile002.stdout ghc-6.13.20091231/libraries/directory/tests/copyFile002.stdout --- ghc-6.12.1/libraries/directory/tests/copyFile002.stdout 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/copyFile002.stdout 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1,5 @@ +Before: +[".","..","source"] +After: +[".","..","source","target"] +"This is the data" diff -ruN ghc-6.12.1/libraries/directory/tests/createDirectory001.hs ghc-6.13.20091231/libraries/directory/tests/createDirectory001.hs --- ghc-6.12.1/libraries/directory/tests/createDirectory001.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/createDirectory001.hs 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1,12 @@ +import System.Directory +import Control.Exception + +testdir = "createDirectory001.dir" + +main = do + try (removeDirectory testdir) :: IO (Either IOException ()) + createDirectory testdir + r <- try $ createDirectory testdir + print (r :: Either IOException ()) -- already exists + removeDirectory testdir + diff -ruN ghc-6.12.1/libraries/directory/tests/createDirectory001.stdout ghc-6.13.20091231/libraries/directory/tests/createDirectory001.stdout --- ghc-6.12.1/libraries/directory/tests/createDirectory001.stdout 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/createDirectory001.stdout 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1 @@ +Left createDirectory001.dir: createDirectory: already exists (File exists) diff -ruN ghc-6.12.1/libraries/directory/tests/createDirectory001.stdout-i386-unknown-mingw32 ghc-6.13.20091231/libraries/directory/tests/createDirectory001.stdout-i386-unknown-mingw32 --- ghc-6.12.1/libraries/directory/tests/createDirectory001.stdout-i386-unknown-mingw32 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/createDirectory001.stdout-i386-unknown-mingw32 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1 @@ +Left CreateDirectory "createDirectory001.dir": already exists (Cannot create a file when that file already exists.) diff -ruN ghc-6.12.1/libraries/directory/tests/createDirectoryIfMissing001.hs ghc-6.13.20091231/libraries/directory/tests/createDirectoryIfMissing001.hs --- ghc-6.12.1/libraries/directory/tests/createDirectoryIfMissing001.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/createDirectoryIfMissing001.hs 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1,65 @@ +module Main(main) where + +import Control.Concurrent +import Control.Monad +import Control.Exception +import System.Directory +import System.FilePath +import System.IO.Error hiding (try) + +testdir = "createDirectoryIfMissing001.d" +testdir_a = testdir "a" + +main = do + cleanup + + report $ createDirectoryIfMissing False testdir + cleanup + + report $ createDirectoryIfMissing False testdir_a + -- should fail with does not exist + + report $ createDirectoryIfMissing True testdir_a + -- should succeed with no error + report $ createDirectoryIfMissing False testdir_a + -- should succeed with no error + report $ createDirectoryIfMissing False (addTrailingPathSeparator testdir_a) + -- should succeed with no error + + cleanup + report $ createDirectoryIfMissing True (addTrailingPathSeparator testdir_a) + + -- look for race conditions: #2808. This fails with + -- +RTS -N2 and directory 1.0.0.2. + m <- newEmptyMVar + forkIO $ do replicateM_ 10000 create; putMVar m () + forkIO $ do replicateM_ 10000 cleanup; putMVar m () + replicateM_ 2 $ takeMVar m + +-- This test fails on Windows; see #2924 +-- replicateM_ 2 $ +-- forkIO $ do replicateM_ 5000 (do create; cleanup); putMVar m () +-- replicateM_ 2 $ takeMVar m + + cleanup + +-- createDirectoryIfMissing is allowed to fail with isDoesNotExistError if +-- another process/thread removes one of the directories during the proces +-- of creating the hierarchy. +create = tryJust (guard . isDoesNotExistError) $ createDirectoryIfMissing True testdir_a + +cleanup = ignore $ removeDirectoryRecursive testdir + +report :: Show a => IO a -> IO () +report io = do + r <- try io + case r of + Left e -> print (e :: SomeException) + Right a -> print a + +ignore :: IO a -> IO () +ignore io = do + r <- try io + case r of + Left e -> let _ = e :: SomeException in return () + Right a -> return () diff -ruN ghc-6.12.1/libraries/directory/tests/createDirectoryIfMissing001.stdout ghc-6.13.20091231/libraries/directory/tests/createDirectoryIfMissing001.stdout --- ghc-6.12.1/libraries/directory/tests/createDirectoryIfMissing001.stdout 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/createDirectoryIfMissing001.stdout 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1,6 @@ +() +createDirectoryIfMissing001.d/a: createDirectory: does not exist (No such file or directory) +() +() +() +() diff -ruN ghc-6.12.1/libraries/directory/tests/createDirectoryIfMissing001.stdout-i386-unknown-mingw32 ghc-6.13.20091231/libraries/directory/tests/createDirectoryIfMissing001.stdout-i386-unknown-mingw32 --- ghc-6.12.1/libraries/directory/tests/createDirectoryIfMissing001.stdout-i386-unknown-mingw32 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/createDirectoryIfMissing001.stdout-i386-unknown-mingw32 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1,6 @@ +() +CreateDirectory "createDirectoryIfMissing001.d\\a": does not exist (The system cannot find the path specified.) +() +() +() +() diff -ruN ghc-6.12.1/libraries/directory/tests/currentDirectory001.hs ghc-6.13.20091231/libraries/directory/tests/currentDirectory001.hs --- ghc-6.12.1/libraries/directory/tests/currentDirectory001.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/currentDirectory001.hs 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1,27 @@ + +import System.Directory (getCurrentDirectory, setCurrentDirectory, + createDirectory, removeDirectory, + getDirectoryContents) + +main :: IO () +main = do + oldpwd <- getCurrentDirectory + createDirectory dir + setCurrentDirectory dir + ~[n1, n2] <- getDirectoryContents "." + if dot n1 && dot n2 + then do + setCurrentDirectory oldpwd + removeDirectory dir + putStr "Okay\n" + else + ioError (userError "Oops") + +dot :: String -> Bool +dot "." = True +dot ".." = True +dot _ = False + +dir :: FilePath +dir = "currentDirectory001-dir" + diff -ruN ghc-6.12.1/libraries/directory/tests/currentDirectory001.stdout ghc-6.13.20091231/libraries/directory/tests/currentDirectory001.stdout --- ghc-6.12.1/libraries/directory/tests/currentDirectory001.stdout 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/currentDirectory001.stdout 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1 @@ +Okay diff -ruN ghc-6.12.1/libraries/directory/tests/directory001.hs ghc-6.13.20091231/libraries/directory/tests/directory001.hs --- ghc-6.12.1/libraries/directory/tests/directory001.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/directory001.hs 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1,16 @@ +import System.IO +import System.Directory + +main = do + createDirectory "foo" + h <- openFile "foo/bar" WriteMode + hPutStr h "Okay\n" + hClose h + renameFile "foo/bar" "foo/baz" + renameDirectory "foo" "bar" + h <- openFile "bar/baz" ReadMode + stuff <- hGetContents h + putStr stuff +-- hClose h -- an error ! + removeFile "bar/baz" + removeDirectory "bar" diff -ruN ghc-6.12.1/libraries/directory/tests/directory001.stdout ghc-6.13.20091231/libraries/directory/tests/directory001.stdout --- ghc-6.12.1/libraries/directory/tests/directory001.stdout 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/directory001.stdout 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1 @@ +Okay diff -ruN ghc-6.12.1/libraries/directory/tests/doesDirectoryExist001.hs ghc-6.13.20091231/libraries/directory/tests/doesDirectoryExist001.hs --- ghc-6.12.1/libraries/directory/tests/doesDirectoryExist001.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/doesDirectoryExist001.hs 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1,11 @@ +{-# LANGUAGE CPP #-} +-- !!! "/" was not recognised as a directory in 6.0.x +import System.Directory + +#ifdef mingw32_HOST_OS +root = "C:\\" +#else +root = "/" +#endif + +main = doesDirectoryExist root >>= print diff -ruN ghc-6.12.1/libraries/directory/tests/doesDirectoryExist001.stdout ghc-6.13.20091231/libraries/directory/tests/doesDirectoryExist001.stdout --- ghc-6.12.1/libraries/directory/tests/doesDirectoryExist001.stdout 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/doesDirectoryExist001.stdout 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1 @@ +True diff -ruN ghc-6.12.1/libraries/directory/tests/getDirContents001.hs ghc-6.13.20091231/libraries/directory/tests/getDirContents001.hs --- ghc-6.12.1/libraries/directory/tests/getDirContents001.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/getDirContents001.hs 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1,18 @@ +import System.Directory +import Control.Exception +import System.FilePath +import Data.List + +dir = "getDirContents001.dir" + +main = do + try cleanup :: IO (Either IOException ()) + bracket (createDirectory dir) (const cleanup) $ \_ -> do + getDirectoryContents dir >>= print . sort + mapM_ (\s -> writeFile (dir ('f':show s)) (show s)) [1..100] + getDirectoryContents dir >>= print . sort + +cleanup = do + files <- getDirectoryContents dir + mapM_ (removeFile . (dir )) (filter (not . ("." `isPrefixOf`)) files) + removeDirectory dir diff -ruN ghc-6.12.1/libraries/directory/tests/getDirContents001.stdout ghc-6.13.20091231/libraries/directory/tests/getDirContents001.stdout --- ghc-6.12.1/libraries/directory/tests/getDirContents001.stdout 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/getDirContents001.stdout 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1,2 @@ +[".",".."] +[".","..","f1","f10","f100","f11","f12","f13","f14","f15","f16","f17","f18","f19","f2","f20","f21","f22","f23","f24","f25","f26","f27","f28","f29","f3","f30","f31","f32","f33","f34","f35","f36","f37","f38","f39","f4","f40","f41","f42","f43","f44","f45","f46","f47","f48","f49","f5","f50","f51","f52","f53","f54","f55","f56","f57","f58","f59","f6","f60","f61","f62","f63","f64","f65","f66","f67","f68","f69","f7","f70","f71","f72","f73","f74","f75","f76","f77","f78","f79","f8","f80","f81","f82","f83","f84","f85","f86","f87","f88","f89","f9","f90","f91","f92","f93","f94","f95","f96","f97","f98","f99"] diff -ruN ghc-6.12.1/libraries/directory/tests/getDirContents002.hs ghc-6.13.20091231/libraries/directory/tests/getDirContents002.hs --- ghc-6.12.1/libraries/directory/tests/getDirContents002.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/getDirContents002.hs 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1,3 @@ +import System.Directory + +main = getDirectoryContents "nonexistent" diff -ruN ghc-6.12.1/libraries/directory/tests/getDirContents002.stderr ghc-6.13.20091231/libraries/directory/tests/getDirContents002.stderr --- ghc-6.12.1/libraries/directory/tests/getDirContents002.stderr 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/getDirContents002.stderr 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1 @@ +getDirContents002: nonexistent: getDirectoryContents: does not exist (No such file or directory) diff -ruN ghc-6.12.1/libraries/directory/tests/getDirContents002.stderr-i386-unknown-mingw32 ghc-6.13.20091231/libraries/directory/tests/getDirContents002.stderr-i386-unknown-mingw32 --- ghc-6.12.1/libraries/directory/tests/getDirContents002.stderr-i386-unknown-mingw32 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/getDirContents002.stderr-i386-unknown-mingw32 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1 @@ +getDirContents002.exe: nonexistent: getDirectoryContents: does not exist (The system cannot find the path specified.) diff -ruN ghc-6.12.1/libraries/directory/tests/getHomeDirectory001.hs ghc-6.13.20091231/libraries/directory/tests/getHomeDirectory001.hs --- ghc-6.12.1/libraries/directory/tests/getHomeDirectory001.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/getHomeDirectory001.hs 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1,8 @@ +import System.Directory + +main = do + getHomeDirectory >>= print + getAppUserDataDirectory "test" >>= print + getUserDocumentsDirectory >>= print + getTemporaryDirectory >>= print + return () diff -ruN ghc-6.12.1/libraries/directory/tests/getPermissions001.hs ghc-6.13.20091231/libraries/directory/tests/getPermissions001.hs --- ghc-6.12.1/libraries/directory/tests/getPermissions001.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/getPermissions001.hs 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1,13 @@ +import System.Directory + +main = do + p <- getPermissions "." + print p + p <- getPermissions "getPermissions001.hs" + print p +#ifndef mingw32_HOST_OS + p <- getPermissions "getPermissions001" +#else + p <- getPermissions "getPermissions001.exe" +#endif + print p diff -ruN ghc-6.12.1/libraries/directory/tests/getPermissions001.stdout ghc-6.13.20091231/libraries/directory/tests/getPermissions001.stdout --- ghc-6.12.1/libraries/directory/tests/getPermissions001.stdout 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/getPermissions001.stdout 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1,3 @@ +Permissions {readable = True, writable = True, executable = False, searchable = True} +Permissions {readable = True, writable = True, executable = False, searchable = False} +Permissions {readable = True, writable = True, executable = True, searchable = False} diff -ruN ghc-6.12.1/libraries/directory/tests/getPermissions001.stdout-alpha-dec-osf3 ghc-6.13.20091231/libraries/directory/tests/getPermissions001.stdout-alpha-dec-osf3 --- ghc-6.12.1/libraries/directory/tests/getPermissions001.stdout-alpha-dec-osf3 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/getPermissions001.stdout-alpha-dec-osf3 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1,3 @@ +Permissions {readable = True, writable = True, executable = False, searchable = True} +Permissions {readable = True, writable = True, executable = False, searchable = False} +Permissions {readable = True, writable = False, executable = True, searchable = False} diff -ruN ghc-6.12.1/libraries/directory/tests/getPermissions001.stdout-i386-unknown-freebsd ghc-6.13.20091231/libraries/directory/tests/getPermissions001.stdout-i386-unknown-freebsd --- ghc-6.12.1/libraries/directory/tests/getPermissions001.stdout-i386-unknown-freebsd 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/getPermissions001.stdout-i386-unknown-freebsd 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1,3 @@ +Permissions {readable = True, writable = True, executable = False, searchable = True} +Permissions {readable = True, writable = True, executable = False, searchable = False} +Permissions {readable = True, writable = False, executable = True, searchable = False} diff -ruN ghc-6.12.1/libraries/directory/tests/getPermissions001.stdout-i386-unknown-openbsd ghc-6.13.20091231/libraries/directory/tests/getPermissions001.stdout-i386-unknown-openbsd --- ghc-6.12.1/libraries/directory/tests/getPermissions001.stdout-i386-unknown-openbsd 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/getPermissions001.stdout-i386-unknown-openbsd 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1,3 @@ +Permissions {readable = True, writable = True, executable = False, searchable = True} +Permissions {readable = True, writable = True, executable = False, searchable = False} +Permissions {readable = True, writable = False, executable = True, searchable = False} diff -ruN ghc-6.12.1/libraries/directory/tests/getPermissions001.stdout-mingw ghc-6.13.20091231/libraries/directory/tests/getPermissions001.stdout-mingw --- ghc-6.12.1/libraries/directory/tests/getPermissions001.stdout-mingw 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/getPermissions001.stdout-mingw 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1,3 @@ +Permissions {readable = True, writable = True, executable = True, searchable = True} +Permissions {readable = True, writable = True, executable = True, searchable = True} +Permissions {readable = True, writable = True, executable = True, searchable = True} diff -ruN ghc-6.12.1/libraries/directory/tests/getPermissions001.stdout-x86_64-unknown-openbsd ghc-6.13.20091231/libraries/directory/tests/getPermissions001.stdout-x86_64-unknown-openbsd --- ghc-6.12.1/libraries/directory/tests/getPermissions001.stdout-x86_64-unknown-openbsd 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/getPermissions001.stdout-x86_64-unknown-openbsd 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1,3 @@ +Permissions {readable = True, writable = True, executable = False, searchable = True} +Permissions {readable = True, writable = True, executable = False, searchable = False} +Permissions {readable = True, writable = False, executable = True, searchable = False} diff -ruN ghc-6.12.1/libraries/directory/tests/Makefile ghc-6.13.20091231/libraries/directory/tests/Makefile --- ghc-6.12.1/libraries/directory/tests/Makefile 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/Makefile 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1,7 @@ +# This Makefile runs the tests using GHC's testsuite framework. It +# assumes the package is part of a GHC build tree with the testsuite +# installed in ../../../testsuite. + +TOP=../../../testsuite +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff -ruN ghc-6.12.1/libraries/directory/tests/renameFile001.hs ghc-6.13.20091231/libraries/directory/tests/renameFile001.hs --- ghc-6.12.1/libraries/directory/tests/renameFile001.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/renameFile001.hs 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1,13 @@ +import System.Directory + +tmp1 = "renameFile001.tmp1" +tmp2 = "renameFile001.tmp2" + +main = do + writeFile tmp1 "test" + renameFile tmp1 tmp2 + readFile tmp2 >>= print + writeFile tmp1 "test2" + renameFile tmp2 tmp1 + readFile tmp1 >>= print + diff -ruN ghc-6.12.1/libraries/directory/tests/renameFile001.stdout ghc-6.13.20091231/libraries/directory/tests/renameFile001.stdout --- ghc-6.12.1/libraries/directory/tests/renameFile001.stdout 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/directory/tests/renameFile001.stdout 2009-12-31 10:25:43.000000000 -0800 @@ -0,0 +1,2 @@ +"test" +"test" diff -ruN ghc-6.12.1/libraries/dph/dph-base/Data/Array/Parallel/Arr/BUArr.hs ghc-6.13.20091231/libraries/dph/dph-base/Data/Array/Parallel/Arr/BUArr.hs --- ghc-6.12.1/libraries/dph/dph-base/Data/Array/Parallel/Arr/BUArr.hs 2009-12-10 10:24:53.000000000 -0800 +++ ghc-6.13.20091231/libraries/dph/dph-base/Data/Array/Parallel/Arr/BUArr.hs 2009-12-31 10:26:12.000000000 -0800 @@ -58,7 +58,7 @@ -- * Operations on immutable arrays -- ** Basic operations - lengthBU, emptyBU, replicateBU, indexBU, sliceBU, extractBU, + lengthBU, emptyBU, replicateBU, indexBU, sliceBU, extractBU, appBU, -- ** Streaming streamBU, unstreamBU, @@ -129,7 +129,7 @@ -- | Class of elements that can be stored in unboxed arrays -class HS e => UAE e where +class (HS e, Rebox e) => UAE e where -- | Compute the size of an unboxed array with @n@ elements. The second -- argument is just for type inference and will not be inspected. -- @@ -396,7 +396,7 @@ -- streamBU :: UAE e => BUArr e -> Stream e {-# INLINE [1] streamBU #-} -streamBU arr = Stream next 0 (lengthBU arr) +streamBU arr = Stream next 0 (lengthBU arr) (sNoArgs "streamBU") where n = lengthBU arr -- @@ -407,10 +407,11 @@ -- unstreamBU :: UAE e => Stream e -> BUArr e {-# INLINE [1] unstreamBU #-} -unstreamBU (Stream next s n) = +unstreamBU (Stream next s n c) = runST (do marr <- newMBU n - n' <- fill0 marr + n' <- traceLoopST ("unstreamBU" `sArgs` c) + $ fill0 marr unsafeFreezeMBU marr n' ) where @@ -443,6 +444,10 @@ {-# INLINE replicateBU #-} replicateBU n = unstreamBU . replicateS n +appBU :: UAE e => BUArr e -> BUArr e -> BUArr e +{-# INLINE appBU #-} +appBU xs ys = unstreamBU (streamBU xs +++ streamBU ys) + -- |Extract a slice from an array (given by its start index and length) -- @@ -484,7 +489,7 @@ -- |Reduce an unboxed array -- -foldlBU :: UAE b => (a -> b -> a) -> a -> BUArr b -> a +foldlBU :: (Rebox a, UAE b) => (a -> b -> a) -> a -> BUArr b -> a {-# INLINE foldlBU #-} foldlBU f z = foldS f z . streamBU @@ -525,7 +530,7 @@ -- copyMBU :: UAE e => MBUArr s e -> Int -> BUArr e -> ST s () {-# INLINE copyMBU #-} -copyMBU marr i arr = ins i 0 +copyMBU marr i arr = traceLoopST "copyMBU" $ ins i 0 where n = lengthBU arr -- diff -ruN ghc-6.12.1/libraries/dph/dph-base/Data/Array/Parallel/Base/DTrace.hs ghc-6.13.20091231/libraries/dph/dph-base/Data/Array/Parallel/Base/DTrace.hs --- ghc-6.12.1/libraries/dph/dph-base/Data/Array/Parallel/Base/DTrace.hs 1969-12-31 16:00:00.000000000 -0800 +++ ghc-6.13.20091231/libraries/dph/dph-base/Data/Array/Parallel/Base/DTrace.hs 2009-12-31 10:26:12.000000000 -0800 @@ -0,0 +1,82 @@ +{-# LANGUAGE ForeignFunctionInterface, CPP #-} +module Data.Array.Parallel.Base.DTrace ( + traceLoopEntry, traceLoopExit, + + traceLoopST, traceLoopEntryST, traceLoopExitST, + traceLoopIO, traceLoopEntryIO, traceLoopExitIO, + + traceFn, traceArg +) where + +#ifdef DPH_ENABLE_DTRACE +import Foreign +import Foreign.C.Types +import Foreign.C.String +#endif + +import GHC.ST ( ST ) +import GHC.IOBase ( unsafeIOToST ) + +traceLoopST :: String -> ST s a -> ST s a +{-# INLINE traceLoopST #-} +traceLoopST s p = do + traceLoopEntryST s + x <- p + traceLoopExitST s + return x + +traceLoopIO :: String -> IO a -> IO a +{-# INLINE traceLoopIO #-} +traceLoopIO s p = do + traceLoopEntryIO s + x <- p + traceLoopExitIO s + return x + + +traceLoopEntryST :: String -> ST s () +traceLoopExitST :: String -> ST s () + +traceLoopEntryIO :: String -> IO () +traceLoopExitIO :: String -> IO () + +traceLoopEntry :: String -> a -> a +traceLoopExit :: String -> a -> a + +#ifdef DPH_ENABLE_DTRACE + +traceLoopEntry s x = unsafePerformIO (traceLoopEntryIO s >> return x) +traceLoopExit s x = unsafePerformIO (traceLoopExitIO s >> return x) + +traceLoopEntryST s = unsafeIOToST (traceLoopEntryIO s) +traceLoopExitST s = unsafeIOToST (traceLoopExitIO s) + +traceLoopEntryIO s = withCString s dph_loop_entry +traceLoopExitIO s = withCString s dph_loop_exit + +foreign import ccall safe dph_loop_entry :: Ptr CChar -> IO () +foreign import ccall safe dph_loop_exit :: Ptr CChar -> IO () + +#else + +traceLoopEntry s x = x +traceLoopExit s x = x + +traceLoopEntryST s = return () +traceLoopExitST s = return () + +traceLoopEntryIO s = return () +traceLoopExitIO s = return () + +#endif + + +-- FIXME: make these use DTrace as well +traceFn :: String -> String -> a -> a +-- traceFn fn ty x = trace (fn ++ "<" ++ ty ++ ">") x +traceFn _ _ x = x + +traceArg :: Show a => String -> a -> b -> b +-- traceArg name arg x = trace (" " ++ name ++ " = " ++ show arg) x +traceArg _ _ x = x + diff -ruN ghc-6.12.1/libraries/dph/dph-base/Data/Array/Parallel/Base/Rebox.hs ghc-6.13.20091231/libraries/dph/dph-base/Data/Array/Parallel/Base/Rebox.hs --- ghc-6.12.1/libraries/dph/dph-base/Data/Array/Parallel/Base/Rebox.hs 2009-12-10 10:24:53.000000000 -0800 +++ ghc-6.13.20091231/libraries/dph/dph-base/Data/Array/Parallel/Base/Rebox.hs 2009-12-31 10:26:12.000000000 -0800 @@ -14,13 +14,14 @@ module Data.Array.Parallel.Base.Rebox ( - Rebox(..), Box(..) + Rebox(..), Box(..), Strict(..) ) where import Data.Array.Parallel.Base.Hyperstrict import GHC.Base (Int(..), Char(..)) import GHC.Float (Float(..), Double(..)) +import GHC.Word (Word8(..)) class Rebox a where rebox :: a -> a @@ -69,6 +70,10 @@ {-# INLINE [0] dseq #-} dseq = seq +instance Rebox Word8 where + rebox = id + dseq = seq + instance (Rebox a, Rebox b) => Rebox (a :*: b) where {-# INLINE [0] rebox #-} rebox (x :*: y) = rebox x :*: rebox y @@ -110,3 +115,9 @@ {-# INLINE [0] dseq #-} dseq (Lazy a) x = x +data Strict a = Strict a + +instance Rebox (Strict a) where + rebox = id + dseq = seq + diff -ruN ghc-6.12.1/libraries/dph/dph-base/Data/Array/Parallel/Base/Util.hs ghc-6.13.20091231/libraries/dph/dph-base/Data/Array/Parallel/Base/Util.hs --- ghc-6.12.1/libraries/dph/dph-base/Data/Array/Parallel/Base/Util.hs 2009-12-10 10:24:53.000000000 -0800 +++ ghc-6.13.20091231/libraries/dph/dph-base/Data/Array/Parallel/Base/Util.hs 2009-12-31 10:26:12.000000000 -0800 @@ -2,12 +2,12 @@ fromBool, toBool ) where -fromBool :: Num a => Bool -> a +fromBool :: Bool -> Int fromBool False = 0 fromBool True = 1 {-# INLINE fromBool #-} -toBool :: Num a => a -> Bool +toBool :: Int -> Bool toBool n | n == 0 = False | otherwise = True {-# INLINE toBool #-} diff -ruN ghc-6.12.1/libraries/dph/dph-base/Data/Array/Parallel/Base.hs ghc-6.13.20091231/libraries/dph/dph-base/Data/Array/Parallel/Base.hs --- ghc-6.12.1/libraries/dph/dph-base/Data/Array/Parallel/Base.hs 2009-12-10 10:24:53.000000000 -0800 +++ ghc-6.13.20091231/libraries/dph/dph-base/Data/Array/Parallel/Base.hs 2009-12-31 10:26:12.000000000 -0800 @@ -18,6 +18,7 @@ module Data.Array.Parallel.Base.Util, module Data.Array.Parallel.Base.Text, module Data.Array.Parallel.Base.Rebox, + module Data.Array.Parallel.Base.DTrace, ST(..), runST ) where @@ -27,6 +28,7 @@ import Data.Array.Parallel.Base.Util import Data.Array.Parallel.Base.Text import Data.Array.Parallel.Base.Rebox +import Data.Array.Parallel.Base.DTrace import GHC.ST (ST(..), runST) diff -ruN ghc-6.12.1/libraries/dph/dph-base/Data/Array/Parallel/Stream/Flat/Basics.hs ghc-6.13.20091231/libraries/dph/dph-base/Data/Array/Parallel/Stream/Flat/Basics.hs --- ghc-6.12.1/libraries/dph/dph-base/Data/Array/Parallel/Stream/Flat/Basics.hs 2009-12-10 10:24:53.000000000 -0800 +++ ghc-6.13.20091231/libraries/dph/dph-base/Data/Array/Parallel/Stream/Flat/Basics.hs 2009-12-31 10:26:12.000000000 -0800 @@ -27,19 +27,19 @@ ) where import Data.Array.Parallel.Base ( - (:*:)(..), MaybeS(..), EitherS(..), Box(..)) + (:*:)(..), MaybeS(..), EitherS(..), Box(..), Strict(..)) import Data.Array.Parallel.Stream.Flat.Stream -- | Empty stream -- emptyS :: Stream a -emptyS = Stream (const Done) () 0 +emptyS = Stream (const Done) () 0 (sNoArgs "emptyS") -- | Singleton stream -- singletonS :: a -> Stream a {-# INLINE_STREAM singletonS #-} -singletonS x = Stream next True 1 +singletonS x = Stream next True 1 (sNoArgs "singletonS") where {-# INLINE next #-} next True = Yield x False @@ -49,20 +49,20 @@ -- consS :: a -> Stream a -> Stream a {-# INLINE_STREAM consS #-} -consS x (Stream next s n) = Stream next' (JustS (Box x) :*: s) (n+1) +consS x (Stream next s n c) = Stream next' (JustS (Strict x) :*: s) (n+1) ("consS" `sArgs` c) where {-# INLINE next' #-} - next' (JustS (Box x) :*: s) = Yield x (NothingS :*: s) - next' (NothingS :*: s) = case next s of - Yield y s' -> Yield y (NothingS :*: s') - Skip s' -> Skip (NothingS :*: s') - Done -> Done + next' (JustS (Strict x) :*: s) = Yield x (NothingS :*: s) + next' (NothingS :*: s) = case next s of + Yield y s' -> Yield y (NothingS :*: s') + Skip s' -> Skip (NothingS :*: s') + Done -> Done -- | Replication -- replicateS :: Int -> a -> Stream a {-# INLINE_STREAM replicateS #-} -replicateS n x = Stream next 0 n +replicateS n x = Stream next 0 n (sNoArgs "replicateS") where {-# INLINE next #-} next i | i == n = Done @@ -73,39 +73,40 @@ -- replicateEachS :: Int -> Stream (Int :*: a) -> Stream a {-# INLINE_STREAM replicateEachS #-} -replicateEachS n (Stream next s _) = - Stream next' (0 :*: NothingS :*: s) n +replicateEachS n (Stream next s _ c) = + Stream next' (0 :*: NothingS :*: s) n ("replicateEachS" `sArgs` c) where {-# INLINE next' #-} next' (0 :*: _ :*: s) = case next s of Done -> Done Skip s' -> Skip (0 :*: NothingS :*: s') - Yield (k :*: x) s' -> Skip (k :*: JustS (Box x) :*: s') + Yield (k :*: x) s' -> Skip (k :*: JustS (Strict x) :*: s') next' (k :*: NothingS :*: s) = Done -- FIXME: unreachable - next' (k :*: JustS (Box x) :*: s) = - Yield x (k-1 :*: JustS (Box x) :*: s) + next' (k :*: JustS (Strict x) :*: s) = + Yield x (k-1 :*: JustS (Strict x) :*: s) -- | Repeat each element in the stream n times -- replicateEachRS :: Int -> Stream a -> Stream a {-# INLINE_STREAM replicateEachRS #-} -replicateEachRS !n (Stream next s m) - = Stream next' (0 :*: NothingS :*: s) (m * n) +replicateEachRS !n (Stream next s m c) + = Stream next' (0 :*: NothingS :*: s) (m * n) ("replicateEachRS" `sArgs` c) where next' (0 :*: _ :*: s) = case next s of Done -> Done Skip s' -> Skip (0 :*: NothingS :*: s') - Yield x s' -> Skip (n :*: JustS (Box x) :*: s') + Yield x s' -> Skip (n :*: JustS (Strict x) :*: s') next' (i :*: NothingS :*: s) = Done -- unreachable - next' (i :*: JustS (Box x) :*: s) = Yield x (i-1 :*: JustS (Box x) :*: s) + next' (i :*: JustS (Strict x) :*: s) = Yield x (i-1 :*: JustS (Strict x) :*: s) -- | Concatenation -- (+++) :: Stream a -> Stream a -> Stream a {-# INLINE_STREAM (+++) #-} -Stream next1 s1 n1 +++ Stream next2 s2 n2 = Stream next (LeftS s1) (n1 + n2) +Stream next1 s1 n1 c1 +++ Stream next2 s2 n2 c2 + = Stream next (LeftS s1) (n1 + n2) ("(+++)" `sArgs` (c1,c2)) where {-# INLINE next #-} next (LeftS s1) = @@ -124,7 +125,7 @@ -- indexedS :: Stream a -> Stream (Int :*: a) {-# INLINE_STREAM indexedS #-} -indexedS (Stream next s n) = Stream next' (0 :*: s) n +indexedS (Stream next s n c) = Stream next' (0 :*: s) n ("indexedS" `sArgs` c) where {-# INLINE next' #-} next' (i :*: s) = case next s of @@ -136,7 +137,7 @@ -- tailS :: Stream a -> Stream a {-# INLINE_STREAM tailS #-} -tailS (Stream next s n) = Stream next' (False :*: s) (n-1) +tailS (Stream next s n c) = Stream next' (False :*: s) (n-1) ("tailS" `sArgs` c) where {-# INLINE next' #-} next' (False :*: s) = case next s of @@ -153,7 +154,7 @@ -- toStream :: [a] -> Stream a {-# INLINE_STREAM toStream #-} -toStream xs = Stream gen (Box xs) (length xs) +toStream xs = Stream gen (Box xs) (length xs) (sNoArgs "toStream") where {-# INLINE gen #-} gen (Box []) = Done @@ -163,7 +164,7 @@ -- fromStream :: Stream a -> [a] {-# INLINE_STREAM fromStream #-} -fromStream (Stream next s _) = gen s +fromStream (Stream next s _ _) = gen s where gen s = case next s of Done -> [] diff -ruN ghc-6.12.1/libraries/dph/dph-base/Data/Array/Parallel/Stream/Flat/Combinators.hs ghc-6.13.20091231/libraries/dph/dph-base/Data/Array/Parallel/Stream/Flat/Combinators.hs --- ghc-6.12.1/libraries/dph/dph-base/Data/Array/Parallel/Stream/Flat/Combinators.hs 2009-12-10 10:24:53.000000000 -0800 +++ ghc-6.13.20091231/libraries/dph/dph-base/Data/Array/Parallel/Stream/Flat/Combinators.hs 2009-12-31 10:26:12.000000000 -0800 @@ -18,21 +18,21 @@ module Data.Array.Parallel.Stream.Flat.Combinators ( mapS, filterS, foldS, fold1MaybeS, scanS, scan1S, mapAccumS, - zipWithS, zipWith3S, zipS, zip3S, combineS + zipWithS, zipWith3S, zipS, zip3S, combineS, combine2ByTagS ) where import Data.Array.Parallel.Base ( - (:*:)(..), MaybeS(..), Rebox(..), Box(..)) + (:*:)(..), MaybeS(..), Rebox(..) ) +import Data.Array.Parallel.Base.DTrace import Data.Array.Parallel.Stream.Flat.Stream -import Debug.Trace -- | Mapping -- mapS :: (a -> b) -> Stream a -> Stream b {-# INLINE_STREAM mapS #-} -mapS f (Stream next s n) = Stream next' s n +mapS f (Stream next s n c) = Stream next' s n ("mapS" `sArgs` c) where {-# INLINE next' #-} next' s = case next s of @@ -44,7 +44,7 @@ -- filterS :: (a -> Bool) -> Stream a -> Stream a {-# INLINE_STREAM filterS #-} -filterS f (Stream next s n) = Stream next' s n +filterS f (Stream next s n c) = Stream next' s n ("filterS" `sArgs` c) where {-# INLINE next' #-} next' s = case next s of @@ -56,79 +56,85 @@ -- | Folding -- -foldS :: (b -> a -> b) -> b -> Stream a -> b +foldS :: Rebox b => (b -> a -> b) -> b -> Stream a -> b {-# INLINE_STREAM foldS #-} -foldS f z (Stream next s _) = fold z s +foldS f z (Stream next s _ c) = traceLoopEntry c' $ fold z s where fold z s = case next s of - Done -> z - Skip s' -> s' `dseq` fold z s' - Yield x s' -> s' `dseq` fold (f z x) s' + Done -> traceLoopExit c' z + Skip s' -> z `dseq` s' `dseq` fold z s' + Yield x s' -> let z' = f z x + in s' `dseq` z' `dseq` fold z' s' + + c' = "foldS" `sArgs` c -- | Yield 'NothingS' if the 'Stream' is empty and fold it otherwise. -- -fold1MaybeS :: (a -> a -> a) -> Stream a -> MaybeS a +fold1MaybeS :: Rebox a => (a -> a -> a) -> Stream a -> MaybeS a {-# INLINE_STREAM fold1MaybeS #-} -fold1MaybeS f (Stream next s _) = fold0 s +fold1MaybeS f (Stream next s _ c) = traceLoopEntry c' $ fold0 s where fold0 s = case next s of - Done -> NothingS + Done -> traceLoopExit c' NothingS Skip s' -> s' `dseq` fold0 s' Yield x s' -> s' `dseq` fold1 x s' fold1 z s = case next s of - Done -> JustS z - Skip s' -> s' `dseq` fold1 z s' - Yield x s' -> s' `dseq` fold1 (f z x) s' + Done -> traceLoopExit c' $ JustS z + Skip s' -> s' `dseq` z `dseq` fold1 z s' + Yield x s' -> let z' = f z x + in s' `dseq` z' `dseq` fold1 z' s' + + c' = "fold1MaybeS" `sArgs` c -- | Scanning -- -scanS :: (b -> a -> b) -> b -> Stream a -> Stream b +scanS :: Rebox b => (b -> a -> b) -> b -> Stream a -> Stream b {-# INLINE_STREAM scanS #-} -scanS f z (Stream next s n) = Stream next' (Box z :*: s) n +scanS f z (Stream next s n c) = Stream next' (z :*: s) n ("scanS" `sArgs` c) where {-# INLINE next' #-} - next' (Box z :*: s) = case next s of + next' (z :*: s) = case next s of Done -> Done - Skip s' -> Skip (Box z :*: s') - Yield x s' -> Yield z (Box (f z x) :*: s') + Skip s' -> Skip (z :*: s') + Yield x s' -> Yield z (f z x :*: s') -- | Scan over a non-empty 'Stream' -- -scan1S :: (a -> a -> a) -> Stream a -> Stream a +scan1S :: Rebox a => (a -> a -> a) -> Stream a -> Stream a {-# INLINE_STREAM scan1S #-} -scan1S f (Stream next s n) = Stream next' (NothingS :*: s) n +scan1S f (Stream next s n c) = Stream next' (NothingS :*: s) n ("scan1S" `sArgs` c) where {-# INLINE next' #-} next' (NothingS :*: s) = case next s of - Yield x s' -> Yield x (JustS (Box x) :*: s') + Yield x s' -> Yield x (JustS x :*: s') Skip s' -> Skip (NothingS :*: s') Done -> Done - next' (JustS (Box z) :*: s) = + next' (JustS z :*: s) = case next s of Yield x s' -> let y = f z x in - Yield y (JustS (Box y) :*: s') - Skip s' -> Skip (JustS (Box z) :*: s) + Yield y (JustS y :*: s') + Skip s' -> Skip (JustS z :*: s) Done -> Done -mapAccumS :: (acc -> a -> acc :*: b) -> acc -> Stream a -> Stream b +mapAccumS :: Rebox acc => (acc -> a -> acc :*: b) -> acc -> Stream a -> Stream b {-# INLINE_STREAM mapAccumS #-} -mapAccumS f acc (Stream step s n) = Stream step' (s :*: Box acc) n +mapAccumS f acc (Stream step s n c) = Stream step' (s :*: acc) n ("mapAccumS" `sArgs` c) where - step' (s :*: Box acc) = case step s of + step' (s :*: acc) = case step s of Done -> Done - Skip s' -> Skip (s' :*: Box acc) + Skip s' -> Skip (s' :*: acc) Yield x s' -> let acc' :*: y = f acc x in - Yield y (s' :*: Box acc') + Yield y (s' :*: acc') combineS:: Stream Bool -> Stream a -> Stream a -> Stream a {-# INLINE_STREAM combineS #-} -combineS (Stream next1 s m) (Stream nextS1 t1 n1) (Stream nextS2 t2 n2) = - Stream next (s :*: t1 :*: t2) m +combineS (Stream next1 s m c) (Stream nextS1 t1 n1 c1) (Stream nextS2 t2 n2 c2) + = Stream next (s :*: t1 :*: t2) m ("combineS" `sArgs` (c,c1,c2)) where {-# INLINE next #-} next (s :*: t1 :*: t2) = @@ -144,7 +150,33 @@ Done -> error "combineS: stream 2 terminated unexpectedly" Skip t2' -> Skip (s :*: t1 :*: t2') Yield x t2' -> Yield x (s' :*: t1 :*: t2') - + + +combine2ByTagS :: Stream Int -> Stream a -> Stream a -> Stream a +{-# INLINE_STREAM combine2ByTagS #-} +combine2ByTagS (Stream next_tag s m c) (Stream next0 s0 _ c1) + (Stream next1 s1 _ c2) + = Stream next (NothingS :*: s :*: s0 :*: s1) m ("combine2ByTagS" `sArgs` (c,c1,c2)) + where + {-# INLINE next #-} + next (NothingS :*: s :*: s0 :*: s1) + = case next_tag s of + Done -> Done + Skip s' -> Skip (NothingS :*: s' :*: s0 :*: s1) + Yield t s' -> Skip (JustS t :*: s' :*: s0 :*: s1) + + next (JustS 0 :*: s :*: s0 :*: s1) + = case next0 s0 of + Done -> error "combine2ByTagS: stream 1 too short" + Skip s0' -> Skip (JustS 0 :*: s :*: s0' :*: s1) + Yield x s0' -> Yield x (NothingS :*: s :*: s0' :*: s1) + + next (JustS t :*: s :*: s0 :*: s1) + = case next1 s1 of + Done -> error "combine2ByTagS: stream 2 too short" + Skip s1' -> Skip (JustS t :*: s :*: s0 :*: s1') + Yield x s1' -> Yield x (NothingS :*: s :*: s0 :*: s1') + -- | Zipping -- @@ -153,8 +185,8 @@ -- SpecConstr with the correct definition. zipWithS :: (a -> b -> c) -> Stream a -> Stream b -> Stream c {-# INLINE_STREAM zipWithS #-} -zipWithS f (Stream next1 s m) (Stream next2 t n) = - Stream next (s :*: t) m +zipWithS f (Stream next1 s m c1) (Stream next2 t n c2) = + Stream next (s :*: t) m ("zipWithS" `sArgs` (c1,c2)) where {-# INLINE next #-} next (s :*: t) = @@ -196,8 +228,8 @@ zipWith3S :: (a -> b -> c -> d) -> Stream a -> Stream b -> Stream c -> Stream d {-# INLINE_STREAM zipWith3S #-} -zipWith3S f (Stream next1 s1 n) (Stream next2 s2 _) (Stream next3 s3 _) = - Stream next (s1 :*: s2 :*: s3) n +zipWith3S f (Stream next1 s1 n c1) (Stream next2 s2 _ c2) (Stream next3 s3 _ c3) + = Stream next (s1 :*: s2 :*: s3) n ("zipWith3S" `sArgs` (c1,c2,c3)) where {-# INLINE next #-} next (s1 :*: s2 :*: s3) = diff -ruN ghc-6.12.1/libraries/dph/dph-base/Data/Array/Parallel/Stream/Flat/Enum.hs ghc-6.13.20091231/libraries/dph/dph-base/Data/Array/Parallel/Stream/Flat/Enum.hs --- ghc-6.12.1/libraries/dph/dph-base/Data/Array/Parallel/Stream/Flat/Enum.hs 2009-12-10 10:24:53.000000000 -0800 +++ ghc-6.13.20091231/libraries/dph/dph-base/Data/Array/Parallel/Stream/Flat/Enum.hs 2009-12-31 10:26:12.000000000 -0800 @@ -40,7 +40,7 @@ enumFromToS :: Int -> Int -> Stream Int {-# INLINE_STREAM enumFromToS #-} enumFromToS start end - = Stream step start (max 0 (end - start + 1)) + = Stream step start (max 0 (end - start + 1)) (sNoArgs "enumFromToS") where {-# INLINE step #-} step s | s > end = Done @@ -63,7 +63,7 @@ enumFromStepLenS :: Int -> Int -> Int -> Stream Int {-# INLINE_STREAM enumFromStepLenS #-} -enumFromStepLenS s !d n = Stream step (s :*: n) n +enumFromStepLenS s !d n = Stream step (s :*: n) n (sNoArgs "enumFromStepLenS") where step (s :*: 0) = Done step (s :*: n) = Yield s ((s+d) :*: (n-1)) @@ -74,7 +74,8 @@ -- enumFromToEachS :: Int -> Stream (Int :*: Int) -> Stream Int {-# INLINE_STREAM enumFromToEachS #-} -enumFromToEachS n (Stream next s _) = Stream next' (NothingS :*: s) n +enumFromToEachS n (Stream next s _ c) + = Stream next' (NothingS :*: s) n ("enumFromToEachS" `sArgs` c) where {-# INLINE next' #-} next' (NothingS :*: s) @@ -90,7 +91,9 @@ -- FIXME: monomorphic for now because we need Rebox a otherwise! -- enumFromStepLenEachS :: Int -> Stream (Int :*: Int :*: Int) -> Stream Int -enumFromStepLenEachS len (Stream next s n) = Stream next' (NothingS :*: s) len +{-# INLINE_STREAM enumFromStepLenEachS #-} +enumFromStepLenEachS len (Stream next s n c) + = Stream next' (NothingS :*: s) len ("enumFromStepLenEachS" `sArgs` c) where {-# INLINE next' #-} next' (NothingS :*: s) @@ -102,4 +105,4 @@ next' (JustS (from :*: step :*: 0) :*: s) = Skip (NothingS :*: s) next' (JustS (from :*: step :*: n) :*: s) = Yield from (JustS (from+step :*: step :*: (n-1)) :*: s) - \ No newline at end of file + diff -ruN ghc-6.12.1/libraries/dph/dph-base/Data/Array/Parallel/Stream/Flat/Random.hs ghc-6.13.20091231/libraries/dph/dph-base/Data/Array/Parallel/Stream/Flat/Random.hs --- ghc-6.12.1/libraries/dph/dph-base/Data/Array/Parallel/Stream/Flat/Random.hs 2009-12-10 10:24:53.000000000 -0800 +++ ghc-6.13.20091231/libraries/dph/dph-base/Data/Array/Parallel/Stream/Flat/Random.hs 2009-12-31 10:26:12.000000000 -0800 @@ -27,7 +27,7 @@ randomS :: (RandomGen g, Random a) => Int -> g -> Stream a {-# INLINE_STREAM randomS #-} -randomS n g = Stream step (Lazy g :*: n) n +randomS n g = Stream step (Lazy g :*: n) n (sNoArgs "randomS") where {-# INLINE step #-} step (Lazy g :*: 0) = Done @@ -36,7 +36,7 @@ randomRS :: (RandomGen g, Random a) => Int -> (a,a) -> g -> Stream a {-# INLINE_STREAM randomRS #-} -randomRS n r g = Stream step (Lazy g :*: n) n +randomRS n r g = Stream step (Lazy g :*: n) n (sNoArgs "randomRS") where {-# INLINE step #-} step (Lazy g :*: 0) = Done diff -ruN ghc-6.12.1/libraries/dph/dph-base/Data/Array/Parallel/Stream/Flat/Search.hs ghc-6.13.20091231/libraries/dph/dph-base/Data/Array/Parallel/Stream/Flat/Search.hs --- ghc-6.12.1/libraries/dph/dph-base/Data/Array/Parallel/Stream/Flat/Search.hs 2009-12-10 10:24:53.000000000 -0800 +++ ghc-6.13.20091231/libraries/dph/dph-base/Data/Array/Parallel/Stream/Flat/Search.hs 2009-12-31 10:26:12.000000000 -0800 @@ -21,24 +21,29 @@ ) where import Data.Array.Parallel.Stream.Flat.Stream +import Data.Array.Parallel.Base.DTrace findS :: (a -> Bool) -> Stream a -> Maybe a {-# INLINE_STREAM findS #-} -findS p (Stream next s _) = go s +findS p (Stream next s _ c) = traceLoopEntry c' $ go s where go s = case next s of - Yield x s' | p x -> Just x + Yield x s' | p x -> traceLoopExit c' $ Just x | otherwise -> go s' Skip s' -> go s' - Done -> Nothing + Done -> traceLoopExit c' Nothing + + c' = "findS" `sArgs` c findIndexS :: (a -> Bool) -> Stream a -> Maybe Int {-# INLINE_STREAM findIndexS #-} -findIndexS p (Stream next s _) = go 0 s +findIndexS p (Stream next s _ c) = traceLoopEntry c' $ go 0 s where go i s = case next s of - Yield x s' | p x -> Just i + Yield x s' | p x -> traceLoopExit c' $ Just i | otherwise -> go (i+1) s' Skip s' -> go i s' - Done -> Nothing + Done -> traceLoopExit c' Nothing + + c' = "findIndexS" `sArgs` c diff -ruN ghc-6.12.1/libraries/dph/dph-base/Data/Array/Parallel/Stream/Flat/Stream.hs ghc-6.13.20091231/libraries/dph/dph-base/Data/Array/Parallel/Stream/Flat/Stream.hs --- ghc-6.12.1/libraries/dph/dph-base/Data/Array/Parallel/Stream/Flat/Stream.hs 2009-12-10 10:24:53.000000000 -0800 +++ ghc-6.13.20091231/libraries/dph/dph-base/Data/Array/Parallel/Stream/Flat/Stream.hs 2009-12-31 10:26:12.000000000 -0800 @@ -1,4 +1,5 @@ -{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ExistentialQuantification, FlexibleInstances, + TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | @@ -15,7 +16,9 @@ -- module Data.Array.Parallel.Stream.Flat.Stream ( - Step(..), Stream(..) + Step(..), Stream(..), + + SArgs(..), sNoArgs ) where import Data.Array.Parallel.Base ( @@ -30,5 +33,32 @@ fmap f (Skip s) = Skip s fmap f (Yield x s) = Yield (f x) s -data Stream a = forall s. Rebox s => Stream (s -> Step s a) !s Int +data Stream a = forall s. Rebox s => Stream (s -> Step s a) !s Int String + +sNoArgs :: String -> String +sNoArgs = id + +class SArgs a where + sArgs :: String -> a -> String + +instance SArgs () where + sArgs fn _ = fn + +instance SArgs String where + sArgs fn arg = fn ++ " <- " ++ arg + +instance SArgs (String, String) where + sArgs fn (arg1, arg2) = fn ++ " <- (" ++ arg1 ++ ", " ++ arg2 ++ ")" + +instance SArgs (String, String, String) where + sArgs fn (arg1, arg2, arg3) + = fn ++ " <- (" ++ arg1 ++ ", " ++ arg2 ++ ", " ++ arg3 ++ ")" + +instance SArgs (String, String, String, String) where + sArgs fn (arg1, arg2, arg3, arg4) + = fn ++ " <- (" ++ arg1 ++ ", " ++ arg2 ++ ", " ++ arg3 ++ ", " ++ arg4 ++ ")" + +instance SArgs (String, String, String, String, String) where + sArgs fn (arg1, arg2, arg3, arg4, arg5) + = fn ++ " <- (" ++ arg1 ++ ", " ++ arg2 ++ ", " ++ arg3 ++ ", " ++ arg4 ++ ", " ++ arg5 ++ ")" diff -ruN ghc-6.12.1/libraries/dph/dph-base/Data/Array/Parallel/Stream/Flat.hs ghc-6.13.20091231/libraries/dph/dph-base/Data/Array/Parallel/Stream/Flat.hs --- ghc-6.12.1/libraries/dph/dph-base/Data/Array/Parallel/Stream/Flat.hs 2009-12-10 10:24:53.000000000 -0800 +++ ghc-6.13.20091231/libraries/dph/dph-base/Data/Array/Parallel/Stream/Flat.hs 2009-12-31 10:26:12.000000000 -0800 @@ -21,11 +21,13 @@ toStream, fromStream, mapS, filterS, foldS, fold1MaybeS, scanS, scan1S, mapAccumS, - zipWithS, zipWith3S, zipS, zip3S, combineS, + zipWithS, zipWith3S, zipS, zip3S, combineS, combine2ByTagS, findS, findIndexS, - randomS, randomRS + randomS, randomRS, + + SArgs(..), sNoArgs ) where import Data.Array.Parallel.Stream.Flat.Stream diff -ruN ghc-6.12.1/libraries/dph/dph-base/Data/Array/Parallel/Stream/Segmented.hs ghc-6.13.20091231/libraries/dph/dph-base/Data/Array/Parallel/Stream/Segmented.hs --- ghc-6.12.1/libraries/dph/dph-base/Data/Array/Parallel/Stream/Segmented.hs 2009-12-10 10:24:53.000000000 -0800 +++ ghc-6.13.20091231/libraries/dph/dph-base/Data/Array/Parallel/Stream/Segmented.hs 2009-12-31 10:26:12.000000000 -0800 @@ -20,40 +20,40 @@ ) where import Data.Array.Parallel.Base ( - (:*:)(..), Box(..), MaybeS(..)) + (:*:)(..), Rebox, MaybeS(..)) import Data.Array.Parallel.Stream.Flat ( - Step(..), Stream(..)) + Step(..), Stream(..), SArgs(..)) -foldSS :: (a -> b -> a) -> a -> Stream Int -> Stream b -> Stream a +foldSS :: Rebox a => (a -> b -> a) -> a -> Stream Int -> Stream b -> Stream a {-# INLINE_STREAM foldSS #-} -foldSS f z (Stream nexts ss ns) (Stream nextv vs nv) = - Stream next (NothingS :*: Box z :*: ss :*: vs) ns +foldSS f z (Stream nexts ss ns c1) (Stream nextv vs nv c2) = + Stream next (NothingS :*: z :*: ss :*: vs) ns ("foldSS" `sArgs` (c1,c2)) where {-# INLINE next #-} - next (NothingS :*: Box x :*: ss :*: vs) = + next (NothingS :*: x :*: ss :*: vs) = case nexts ss of Done -> Done - Skip ss' -> Skip (NothingS :*: Box x :*: ss' :*: vs) - Yield n ss' -> Skip (JustS n :*: Box z :*: ss' :*: vs) + Skip ss' -> Skip (NothingS :*: x :*: ss' :*: vs) + Yield n ss' -> Skip (JustS n :*: z :*: ss' :*: vs) - next (JustS 0 :*: Box x :*: ss :*: vs) = - Yield x (NothingS :*: Box z :*: ss :*: vs) - next (JustS n :*: Box x :*: ss :*: vs) = + next (JustS 0 :*: x :*: ss :*: vs) = + Yield x (NothingS :*: z :*: ss :*: vs) + next (JustS n :*: x :*: ss :*: vs) = case nextv vs of Done -> Done -- FIXME -- error -- "Stream.Segmented.foldSS: invalid segment descriptor" - Skip vs' -> Skip (JustS n :*: Box x :*: ss :*: vs') - Yield y vs' -> Skip (JustS (n-1) :*: Box (f x y) :*: ss :*: vs') + Skip vs' -> Skip (JustS n :*: x :*: ss :*: vs') + Yield y vs' -> Skip (JustS (n-1) :*: (f x y) :*: ss :*: vs') -fold1SS :: (a -> a -> a) -> Stream Int -> Stream a -> Stream a +fold1SS :: Rebox a => (a -> a -> a) -> Stream Int -> Stream a -> Stream a {-# INLINE_STREAM fold1SS #-} -fold1SS f (Stream nexts ss ns) (Stream nextv vs nv) = - Stream next (NothingS :*: NothingS :*: ss :*: vs) ns +fold1SS f (Stream nexts ss ns c1) (Stream nextv vs nv c2) = + Stream next (NothingS :*: NothingS :*: ss :*: vs) ns ("fold1SS" `sArgs` (c1,c2)) where {-# INLINE next #-} - next (NothingS :*: _ :*: ss :*: vs) = + next (NothingS :*: NothingS :*: ss :*: vs) = case nexts ss of Done -> Done Skip ss' -> Skip (NothingS :*: NothingS :*: ss' :*: vs) @@ -63,26 +63,27 @@ case nextv vs of Done -> Done -- FIXME: error Skip vs' -> Skip (JustS n :*: NothingS :*: ss :*: vs') - Yield x vs' -> Skip (JustS (n-1) :*: JustS (Box x) :*: ss :*: vs') + Yield x vs' -> Skip (JustS (n-1) :*: JustS x :*: ss :*: vs') - next (JustS 0 :*: JustS (Box x) :*: ss :*: vs) = + next (JustS 0 :*: JustS x :*: ss :*: vs) = Yield x (NothingS :*: NothingS :*: ss :*: vs) - next (JustS n :*: JustS (Box x) :*: ss :*: vs) = + next (JustS n :*: JustS x :*: ss :*: vs) = case nextv vs of Done -> Done -- FIXME: error - Skip vs' -> Skip (JustS n :*: JustS (Box x) :*: ss :*: vs') - Yield y vs' -> Skip (JustS (n-1) :*: JustS (Box (f x y)) :*: ss :*: vs') + Skip vs' -> Skip (JustS n :*: JustS x :*: ss :*: vs') + Yield y vs' -> Skip (JustS (n-1) :*: JustS (f x y) :*: ss :*: vs') combineSS:: Stream Bool -> Stream Int -> Stream a -> Stream Int -> Stream a -> Stream a {-# INLINE_STREAM combineSS #-} -combineSS (Stream nextf sf nf) - (Stream nexts1 ss1 ns1) (Stream nextv1 vs1 nv1) - (Stream nexts2 ss2 ns2) (Stream nextv2 vs2 nv2) +combineSS (Stream nextf sf nf cf) + (Stream nexts1 ss1 ns1 c1) (Stream nextv1 vs1 nv1 cv1) + (Stream nexts2 ss2 ns2 c2) (Stream nextv2 vs2 nv2 cv2) = Stream next (NothingS :*: True :*: sf :*: ss1 :*: vs1 :*: ss2 :*: vs2) (nv1+nv2) + ("combineSS" `sArgs` (cf,c1,cv1,c2,cv2)) where {-# INLINE next #-} next (NothingS :*: f :*: sf :*: ss1 :*: vs1 :*: ss2 :*: vs2) = @@ -113,9 +114,10 @@ appendSS :: Stream Int -> Stream a -> Stream Int -> Stream a -> Stream a {-# INLINE_STREAM appendSS #-} -appendSS (Stream nexts1 ss1 ns1) (Stream nextv1 sv1 nv1) - (Stream nexts2 ss2 ns2) (Stream nextv2 sv2 nv2) +appendSS (Stream nexts1 ss1 ns1 c1) (Stream nextv1 sv1 nv1 cv1) + (Stream nexts2 ss2 ns2 c2) (Stream nextv2 sv2 nv2 cv2) = Stream next (True :*: NothingS :*: ss1 :*: sv1 :*: ss2 :*: sv2) (nv1 + nv2) + ("appendSS" `sArgs` (c1,cv1,c2,cv2)) where {-# INLINE next #-} next (True :*: NothingS :*: ss1 :*: sv1 :*: ss2 :*: sv2) @@ -157,17 +159,17 @@ :*: ss1 :*: sv1 :*: ss2 :*: sv2') -foldValuesR :: (a -> b -> a) -> a -> Int -> Int -> Stream b -> Stream a +foldValuesR :: Rebox a => (a -> b -> a) -> a -> Int -> Int -> Stream b -> Stream a {-# INLINE_STREAM foldValuesR #-} -foldValuesR f z noOfSegs segSize (Stream nextv vs nv) = - Stream next (segSize :*: Box z :*: vs) noOfSegs +foldValuesR f z noOfSegs segSize (Stream nextv vs nv c) = + Stream next (segSize :*: z :*: vs) noOfSegs ("foldValuesR" `sArgs` c) where {-# INLINE next #-} - next (0 :*: Box x :*: vs) = - Yield x (segSize :*: Box z :*: vs) + next (0 :*: x :*: vs) = + Yield x (segSize :*: z :*: vs) - next (n :*: Box x :*: vs) = + next (n :*: x :*: vs) = case nextv vs of Done -> Done - Skip vs' -> Skip (n :*: Box x :*: vs') - Yield y vs' -> Skip ((n-1) :*: Box (f x y) :*: vs') + Skip vs' -> Skip (n :*: x :*: vs') + Yield y vs' -> Skip ((n-1) :*: f x y :*: vs') diff -ruN ghc-6.12.1/libraries/dph/dph-base/dph-base.cabal ghc-6.13.20091231/libraries/dph/dph-base/dph-base.cabal --- ghc-6.12.1/libraries/dph/dph-base/dph-base.cabal 2009-12-10 10:24:53.000000000 -0800 +++ ghc-6.13.20091231/libraries/dph/dph-base/dph-base.cabal 2009-12-31 10:26:12.000000000 -0800 @@ -11,11 +11,16 @@ Cabal-Version: >= 1.2.3 Build-Type: Simple +Flag DTrace + Description: Enable experimental support for dtrace-based profiling + Default: False + Library Exposed-Modules: Data.Array.Parallel.Base Data.Array.Parallel.Arr Data.Array.Parallel.Stream + Data.Array.Parallel.Base.DTrace Other-Modules: Data.Array.Parallel.Base.Config @@ -41,7 +46,12 @@ Install-Includes: fusion-phases.h - Exposed: False + Exposed: True + + if flag(DTrace) + CPP-Options: -DDPH_ENABLE_DTRACE + Extra-Libraries: dph-trace + Extra-Lib-Dirs: /Users/rl/projects/ndp/ghc-inline/libraries/dph/dtrace Extensions: TypeFamilies, GADTs, RankNTypes, BangPatterns, MagicHash, UnboxedTuples, TypeOperators diff -ruN ghc-6.12.1/libraries/dph/dph-base/include/fusion-ph