From: simonpj Date: Thu, 14 Sep 2000 13:46:42 +0000 (+0000) Subject: [project @ 2000-09-14 13:46:39 by simonpj] X-Git-Tag: Approximately_9120_patches~3746 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=cae34044d89a87bd3da83b0e867b4a5d6994079a;p=ghc-hetmet.git [project @ 2000-09-14 13:46:39 by simonpj] --------------------------------------- Simon's tuning changes: early Sept 2000 --------------------------------------- Library changes ~~~~~~~~~~~~~~~ * Eta expand PrelShow.showLitChar. It's impossible to compile this well, and it makes a big difference to some programs (e.g. gen_regexps) * Make PrelList.concat into a good producer (in the foldr/build sense) Flag changes ~~~~~~~~~~~~ * Add -ddump-hi-diffs to print out changes in interface files. Useful when watching what the compiler is doing * Add -funfolding-update-in-place to enable the experimental optimisation that makes the inliner a bit keener to inline if it's in the RHS of a thunk that might be updated in place. Sometimes this is a bad idea (one example is in spectral/sphere; see notes in nofib/Simon-nofib-notes) Tuning things ~~~~~~~~~~~~~ * Fix a bug in SetLevels.lvlMFE. (change ctxt_lvl to dest_level) I don't think this has any performance effect, but it saves making a redundant let-binding that is later eliminated. * Desugar.dsProgram and DsForeign Glom together all the bindings into a single Rec. Previously the bindings generated by 'foreign' declarations were not glommed together, but this led to an infelicity (i.e. poorer code than necessary) in the modules that actually declare Float and Double (explained a bit more in Desugar.dsProgram) * OccurAnal.shortMeOut and IdInfo.shortableIdInfo Don't do the occurrence analyser's shorting out stuff for things which have rules. Comments near IdInfo.shortableIdInfo. This is deeply boring, and mainly to do with making rules work well. Maybe rules should have phases attached too.... * CprAnalyse.addIdCprInfo Be a bit more willing to add CPR information to thunks; in particular, if the strictness analyser has just discovered that this is a strict let, then the let-to-case transform will happen, and CPR is fine. 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 * MkId.mkDataConWrapId Arrange that vanilla constructors, like (:) and I#, get unfoldings that are just a simple variable $w:, $wI#. This ensures they'll be inlined even into rules etc, which makes matching a bit more reliable. The downside is that in situations like (map (:) xs), we'll end up with (map (\y ys. $w: y ys) xs. Which is tiresome but it doesn't happen much. * SaAbsInt.findStrictness Deal with the case where a thing with no arguments is bottom. This is Good. E.g. module M where { foo = error "help" } Suppose we have in another module case M.foo of ... Then we'd like to do the case-of-error transform, without inlining foo. Tidying up things ~~~~~~~~~~~~~~~~~ * Reorganised Simplify.completeBinding (again). * Removed the is_bot field in CoreUnfolding (is_cheap is true if is_bot is!) This is just a tidy up * HsDecls and others Remove the NewCon constructor from ConDecl. It just added code, and nothing else. And it led to a bug in MkIface, which though that a newtype decl was always changing! * IdInfo and many others Remove all vestiges of UpdateInfo (hasn't been used for years) --- diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 4901db0..c743dbb 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -48,7 +48,6 @@ module Id ( setIdStrictness, setIdWorkerInfo, setIdSpecialisation, - setIdUpdateInfo, setIdCafInfo, setIdCprInfo, setIdOccInfo, @@ -60,7 +59,6 @@ module Id ( idWorkerInfo, idUnfolding, idSpecialisation, - idUpdateInfo, idCafInfo, idCprInfo, idLBVarInfo, @@ -106,7 +104,6 @@ infixl 1 `setIdUnfolding`, `setIdStrictness`, `setIdWorkerInfo`, `setIdSpecialisation`, - `setIdUpdateInfo`, `setInlinePragma`, `idCafInfo`, `idCprInfo` @@ -353,14 +350,6 @@ setIdDemandInfo :: Id -> Demand -> Id setIdDemandInfo id demand_info = modifyIdInfo (`setDemandInfo` demand_info) id --------------------------------- - -- UPDATE INFO -idUpdateInfo :: Id -> UpdateInfo -idUpdateInfo id = updateInfo (idInfo id) - -setIdUpdateInfo :: Id -> UpdateInfo -> Id -setIdUpdateInfo id upd_info = modifyIdInfo (`setUpdateInfo` upd_info) id - - --------------------------------- -- SPECIALISATION idSpecialisation :: Id -> CoreRules idSpecialisation id = specInfo (idInfo id) diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 1cf25b1..0db72f1 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -13,7 +13,7 @@ module IdInfo ( vanillaIdInfo, mkIdInfo, seqIdInfo, megaSeqIdInfo, -- Zapping - zapFragileInfo, zapLamInfo, zapSpecPragInfo, copyIdInfo, + zapFragileInfo, zapLamInfo, zapSpecPragInfo, shortableIdInfo, copyIdInfo, -- Flavour IdFlavour(..), flavourInfo, @@ -55,10 +55,6 @@ module IdInfo ( -- Specialisation specInfo, setSpecInfo, - -- Update - UpdateInfo, UpdateSpec, - mkUpdateInfo, updateInfo, updateInfoMaybe, ppUpdateInfo, setUpdateInfo, - -- CAF info CafInfo(..), cafInfo, setCafInfo, ppCafInfo, @@ -86,8 +82,7 @@ import Demand -- Lots of stuff import Outputable import Maybe ( isJust ) -infixl 1 `setUpdateInfo`, - `setDemandInfo`, +infixl 1 `setDemandInfo`, `setStrictnessInfo`, `setSpecInfo`, `setArityInfo`, @@ -127,7 +122,6 @@ data IdInfo strictnessInfo :: StrictnessInfo, -- Strictness properties workerInfo :: WorkerInfo, -- Pointer to Worker Function unfoldingInfo :: Unfolding, -- Its unfolding - updateInfo :: UpdateInfo, -- Which args should be updated cafInfo :: CafInfo, cprInfo :: CprInfo, -- Function always constructs a product result lbvarInfo :: LBVarInfo, -- Info about a lambda-bound variable @@ -185,7 +179,6 @@ setUnfoldingInfo info uf -- actually increases residency significantly. = info { unfoldingInfo = uf } -setUpdateInfo info ud = info { updateInfo = ud } setDemandInfo info dd = info { demandInfo = dd } setArityInfo info ar = info { arityInfo = ar } setCafInfo info cf = info { cafInfo = cf } @@ -214,7 +207,6 @@ mkIdInfo flv = IdInfo { workerInfo = NoWorker, strictnessInfo = NoStrictnessInfo, unfoldingInfo = noUnfolding, - updateInfo = NoUpdateInfo, cafInfo = MayHaveCafRefs, cprInfo = NoCPRInfo, lbvarInfo = NoLBVarInfo, @@ -402,40 +394,6 @@ wrapperArity (HasWorker _ a) = a %************************************************************************ %* * -\subsection[update-IdInfo]{Update-analysis info about an @Id@} -%* * -%************************************************************************ - -\begin{code} -data UpdateInfo - = NoUpdateInfo - | SomeUpdateInfo UpdateSpec - deriving (Eq, Ord) - -- we need Eq/Ord to cross-chk update infos in interfaces - --- the form in which we pass update-analysis info between modules: -type UpdateSpec = [Int] -\end{code} - -\begin{code} -mkUpdateInfo = SomeUpdateInfo - -updateInfoMaybe NoUpdateInfo = Nothing -updateInfoMaybe (SomeUpdateInfo []) = Nothing -updateInfoMaybe (SomeUpdateInfo u) = Just u -\end{code} - -Text instance so that the update annotations can be read in. - -\begin{code} -ppUpdateInfo NoUpdateInfo = empty -ppUpdateInfo (SomeUpdateInfo []) = empty -ppUpdateInfo (SomeUpdateInfo spec) = (<>) (ptext SLIT("__UA ")) (hcat (map int spec)) - -- was "__U "; changed to avoid conflict with unfoldings. KSW 1999-07. -\end{code} - -%************************************************************************ -%* * \subsection[CAF-IdInfo]{CAF-related information} %* * %************************************************************************ @@ -649,26 +607,60 @@ copyIdInfo is used when shorting out a top-level binding where f is exported. We are going to swizzle it around to f = BIG f_local = f -but we must be careful to combine their IdInfos right. -The fact that things can go wrong here is a bad sign, but I can't see -how to make it 'patently right', so copyIdInfo is derived (pretty much) by trial and error -Here 'from' is f_local, 'to' is f, and the result is attached to f +BUT (a) we must be careful about messing up rules + (b) we must ensure f's IdInfo ends up right + +(a) Messing up the rules +~~~~~~~~~~~~~~~~~~~~ +The example that went bad on me was this one: + + iterate :: (a -> a) -> a -> [a] + iterate = iterateList + + iterateFB c f x = x `c` iterateFB c f (f x) + iterateList f x = x : iterateList f (f x) + + {-# RULES + "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) + "iterateFB" iterateFB (:) = iterateList + #-} + +This got shorted out to: + + iterateList :: (a -> a) -> a -> [a] + iterateList = iterate + + iterateFB c f x = x `c` iterateFB c f (f x) + iterate f x = x : iterate f (f x) + + {-# RULES + "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) + "iterateFB" iterateFB (:) = iterate + #-} + +And now we get an infinite loop in the rule system + iterate f x -> build (\cn -> iterateFB c f x + -> iterateFB (:) f x + -> iterate f x + +Tiresome solution: don't do shorting out if f has rewrite rules. +Hence shortableIdInfo. + +(b) Keeping the IdInfo right +~~~~~~~~~~~~~~~~~~~~~~~~ +We want to move strictness/worker info from f_local to f, but keep the rest. +Hence copyIdInfo. \begin{code} -copyIdInfo :: IdInfo -- From - -> IdInfo -- To - -> IdInfo -- To, updated with stuff from From; except flavour unchanged -copyIdInfo from to = from { flavourInfo = flavourInfo to, - specInfo = specInfo to, - inlinePragInfo = inlinePragInfo to +shortableIdInfo :: IdInfo -> Bool +shortableIdInfo info = isEmptyCoreRules (specInfo info) + +copyIdInfo :: IdInfo -- f_local + -> IdInfo -- f (the exported one) + -> IdInfo -- New info for f +copyIdInfo f_local f = f { strictnessInfo = strictnessInfo f_local, + workerInfo = workerInfo f_local, + cprInfo = cprInfo f_local } - -- It's important to preserve the inline pragma on 'f'; e.g. consider - -- {-# NOINLINE f #-} - -- f = local - -- - -- similarly, transformation rules may be attached to f - -- and we want to preserve them. - -- - -- On the other hand, we want the strictness info from f_local. \end{code} diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 0bb7540..87b49ef 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -258,10 +258,6 @@ mkDataConWrapId data_con mkLams tyvars $ mkLams dict_args $ Lam id_arg1 $ Note (Coerce result_ty (head orig_arg_tys)) (Var id_arg1) -{- I nuked this because map (:) xs would create a - new local lambda for the (:) in core-to-stg. - There isn't a defn for the worker! - | null dict_args && all not_marked_strict strict_marks = Var work_id -- The common case. Not only is this efficient, -- but it also ensures that the wrapper is replaced @@ -270,10 +266,16 @@ mkDataConWrapId data_con -- becomes -- f $w: x -- This is really important in rule matching, - -- which is a bit sad. (We could match on the wrappers, + -- (We could match on the wrappers, -- but that makes it less likely that rules will match - -- when we bring bits of unfoldings together --} + -- when we bring bits of unfoldings together.) + -- + -- NB: because of this special case, (map (:) ys) turns into + -- (map $w: ys), and thence into (map (\x xs. $w: x xs) ys) + -- in core-to-stg. The top-level defn for (:) is never used. + -- This is somewhat of a bore, but I'm currently leaving it + -- as is, so that there still is a top level curried (:) for + -- the interpreter to call. | otherwise = mkLams all_tyvars $ mkLams dict_args $ diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 43e82a7..60a7db0 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -180,12 +180,11 @@ data Unfolding | CoreUnfolding -- An unfolding with redundant cached information CoreExpr -- Template; binder-info is correct - Bool -- This is a top-level binding - Bool -- exprIsCheap template (cached); it won't duplicate (much) work - -- if you inline this in more than one place + Bool -- True <=> top level binding Bool -- exprIsValue template (cached); it is ok to discard a `seq` on -- this variable - Bool -- exprIsBottom template (cached) + Bool -- True <=> doesn't waste (much) work to expand inside an inlining + -- Basically it's exprIsCheap UnfoldingGuidance -- Tells about the *size* of the template. @@ -208,8 +207,8 @@ noUnfolding = NoUnfolding 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 e top b1 b2 g) + = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g seqUnfolding other = () seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` () @@ -218,14 +217,14 @@ seqGuidance other = () \begin{code} unfoldingTemplate :: Unfolding -> CoreExpr -unfoldingTemplate (CoreUnfolding expr _ _ _ _ _) = expr -unfoldingTemplate (CompulsoryUnfolding expr) = expr +unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr +unfoldingTemplate (CompulsoryUnfolding expr) = expr unfoldingTemplate other = panic "getUnfoldingTemplate" maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr -maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _ _) = Just expr -maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr -maybeUnfoldingTemplate other = Nothing +maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr +maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr +maybeUnfoldingTemplate other = Nothing otherCons :: Unfolding -> [AltCon] otherCons (OtherCon cons) = cons @@ -233,27 +232,27 @@ otherCons other = [] isValueUnfolding :: Unfolding -> Bool -- Returns False for OtherCon -isValueUnfolding (CoreUnfolding _ _ _ is_evald _ _) = is_evald -isValueUnfolding other = False +isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald +isValueUnfolding other = False isEvaldUnfolding :: Unfolding -> Bool -- Returns True for OtherCon -isEvaldUnfolding (OtherCon _) = True -isEvaldUnfolding (CoreUnfolding _ _ _ is_evald _ _) = is_evald -isEvaldUnfolding other = False +isEvaldUnfolding (OtherCon _) = True +isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald +isEvaldUnfolding other = False isCheapUnfolding :: Unfolding -> Bool -isCheapUnfolding (CoreUnfolding _ _ is_cheap _ _ _) = is_cheap -isCheapUnfolding other = False +isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _) = is_cheap +isCheapUnfolding other = False isCompulsoryUnfolding :: Unfolding -> Bool isCompulsoryUnfolding (CompulsoryUnfolding _) = True isCompulsoryUnfolding other = False hasUnfolding :: Unfolding -> Bool -hasUnfolding (CoreUnfolding _ _ _ _ _ _) = True -hasUnfolding (CompulsoryUnfolding _) = True -hasUnfolding other = False +hasUnfolding (CoreUnfolding _ _ _ _ _) = True +hasUnfolding (CompulsoryUnfolding _) = True +hasUnfolding other = False hasSomeUnfolding :: Unfolding -> Bool hasSomeUnfolding NoUnfolding = False diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index ae9fbb6..7f7f20a 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -33,10 +33,8 @@ module CoreUnfold ( import CmdLineOpts ( opt_UF_CreationThreshold, opt_UF_UseThreshold, - opt_UF_ScrutConDiscount, opt_UF_FunAppDiscount, - opt_UF_PrimArgDiscount, - opt_UF_KeenessFactor, + opt_UF_KeenessFactor, opt_UF_CheapOp, opt_UF_DearOp, opt_UnfoldCasms, opt_PprStyle_Debug, opt_D_dump_inlinings @@ -78,9 +76,12 @@ mkTopUnfolding expr = mkUnfolding True {- Top level -} expr mkUnfolding top_lvl expr = CoreUnfolding (occurAnalyseGlobalExpr expr) top_lvl - (exprIsCheap expr) (exprIsValue expr) - (exprIsBottom expr) + -- Already evaluated + + (exprIsCheap expr) + -- OK to inline inside a lambda + (calcUnfoldingGuidance 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 @@ -444,7 +445,7 @@ certainlyWillInline :: Id -> Bool certainlyWillInline v = case idUnfolding v of - CoreUnfolding _ _ _ is_value _ g@(UnfoldIfGoodArgs n_vals _ size _) + CoreUnfolding _ _ is_value _ g@(UnfoldIfGoodArgs n_vals _ size _) -> is_value && size - (n_vals +1) <= opt_UF_UseThreshold @@ -526,7 +527,7 @@ callSiteInline black_listed inline_call occ id arg_infos interesting_cont -- Constructors have compulsory unfoldings, but -- may have rules, in which case they are -- black listed till later - CoreUnfolding unf_template is_top is_cheap is_value is_bot guidance -> + CoreUnfolding unf_template is_top is_value is_cheap guidance -> let result | yes_or_no = Just unf_template @@ -534,16 +535,13 @@ callSiteInline black_listed inline_call occ id arg_infos interesting_cont n_val_args = length arg_infos - ok_inside_lam = is_value || is_bot || (is_cheap && not is_top) - -- I'm experimenting with is_cheap && not is_top - yes_or_no | black_listed = False | otherwise = case occ of IAmDead -> pprTrace "callSiteInline: dead" (ppr id) False IAmALoopBreaker -> False - OneOcc in_lam one_br -> (not in_lam || ok_inside_lam) && consider_safe in_lam True one_br - NoOccInfo -> ok_inside_lam && consider_safe True False False + OneOcc in_lam one_br -> (not in_lam || is_cheap) && consider_safe in_lam True one_br + NoOccInfo -> is_cheap && consider_safe True False False consider_safe in_lam once once_in_one_branch -- consider_safe decides whether it's a good idea to inline something, @@ -622,8 +620,6 @@ callSiteInline black_listed inline_call occ id arg_infos interesting_cont text "interesting continuation" <+> ppr interesting_cont, text "is value:" <+> ppr is_value, text "is cheap:" <+> ppr is_cheap, - text "is bottom:" <+> ppr is_bot, - text "is top-level:" <+> ppr is_top, text "guidance" <+> ppr guidance, text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO", if yes_or_no then diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index c6e847a..0c9ad37 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -25,7 +25,7 @@ import Id ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity, import Var ( isTyVar ) import IdInfo ( IdInfo, megaSeqIdInfo, occInfo, arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo, - demandInfo, updateInfo, ppUpdateInfo, specInfo, + demandInfo, specInfo, strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo, cprInfo, ppCprInfo, lbvarInfo, workerInfo, ppWorkerInfo @@ -340,7 +340,6 @@ ppIdInfo b info = hsep [ ppFlavourInfo (flavourInfo info), ppArityInfo a, - ppUpdateInfo u, ppWorkerInfo (workerInfo info), ppStrictnessInfo s, ppCafInfo c, @@ -353,7 +352,6 @@ ppIdInfo b info where a = arityInfo info s = strictnessInfo info - u = updateInfo info c = cafInfo info m = cprInfo info p = specInfo info diff --git a/ghc/compiler/cprAnalysis/CprAnalyse.lhs b/ghc/compiler/cprAnalysis/CprAnalyse.lhs index 07cddce..5ae0851 100644 --- a/ghc/compiler/cprAnalysis/CprAnalyse.lhs +++ b/ghc/compiler/cprAnalysis/CprAnalyse.lhs @@ -10,9 +10,10 @@ import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_cpranal ) import CoreLint ( beginPass, endPass ) import CoreSyn import CoreUtils ( exprIsValue ) -import Id ( setIdCprInfo, idCprInfo, idArity, - isBottomingId ) +import Id ( Id, setIdCprInfo, idCprInfo, idArity, + isBottomingId, idDemandInfo ) import IdInfo ( CprInfo(..) ) +import Demand ( isStrict ) import VarEnv import Util ( nTimes, mapAccumL ) import Outputable @@ -158,16 +159,16 @@ cprAnalBind :: CPREnv -> CoreBind -> (CPREnv, CoreBind) cprAnalBind rho (NonRec b e) = (extendVarEnv rho b absval, NonRec b' e') where - (e', absval) = cprAnalRhs rho e - b' = setIdCprInfo b (absToCprInfo absval) + (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' = setIdCprInfo b (absToCprInfo absval) - (e', absval) = cprAnalRhs final_rho e + 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. @@ -176,18 +177,12 @@ cprAnalBind rho (Rec prs) 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 (cprAnalRhs rho e))) + do_one_pass rho = foldl (\ rho (b,e) -> extendVarEnv rho b (snd (cprAnalExpr rho e))) rho prs -cprAnalRhs :: CPREnv -> CoreExpr -> (CoreExpr, AbsVal) -cprAnalRhs rho e - = case cprAnalExpr rho e of - (e_pluscpr, e_absval) -> (e_pluscpr, pinCPR e e_absval) - 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. @@ -264,56 +259,47 @@ cprAnalCaseAlts rho alts rho' = rho `extendVarEnvList` (zip binds (repeat Top)) --- take a binding pair and the abs val calculated from the rhs and --- calculate a new absval taking into account sufficient manifest --- lambda condition --- Also we pin the var's CPR property to it. A var only has the CPR property if --- it is a function - -pinCPR :: CoreExpr -> AbsVal -> AbsVal -pinCPR e av = case av of - -- is v a function with insufficent lambdas? - Fun _ | n_fun_tys av /= length val_binders -> - -- argtys must be greater than val_binders. So stripped_exp - -- has a function type. The head of this expr can't be lambda - -- a note, because we stripped them off before. It can't be a - -- constructor because it has a function type. It can't be a Type. - -- If its an app, let or case then there is work to get the - -- and we can't do anything because we may lose laziness. *But* - -- if its a var (i.e. a function name) then we are fine. Note - -- that I don't think this case is at all interesting, but I have - -- a test program that generates it. - - -- UPDATE: 20 Jul 1999 - -- I've decided not to allow this (useless) optimisation. It will make - -- the w/w split more complex. - -- if isVar stripped_exp then - -- (addCpr av, av) - -- else - Top - - Tuple | exprIsValue e -> av - | otherwise -> 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 -> exprIsValue 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 - _ -> av - where - n_fun_tys :: AbsVal -> Int - n_fun_tys (Fun av) = 1 + n_fun_tys av - n_fun_tys other = 0 + _ -> False + + n_fun_tys :: AbsVal -> Int + n_fun_tys (Fun av) = 1 + n_fun_tys av + n_fun_tys other = 0 - -- val_binders are the explicit lambdas at the head of the expression - -- Don't get confused by inline pragamas - val_binders = filter isId (fst (collectBindersIgnoringNotes e)) 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 diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 557ac73..b45b8c5 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -72,10 +72,15 @@ deSugar mod_name us (TcResults {tc_env = global_val_env, dsProgram mod_name all_binds rules fo_decls = dsMonoBinds auto_scc all_binds [] `thenDs` \ core_prs -> - dsForeigns mod_name fo_decls `thenDs` \ (fi_binds, fe_binds, h_code, c_code) -> + dsForeigns mod_name fo_decls `thenDs` \ (fe_binders, foreign_binds, h_code, c_code) -> let - ds_binds = fi_binds ++ [Rec core_prs] ++ fe_binds - fe_binders = bindersOfBinds fe_binds + ds_binds = [Rec (foreign_binds ++ core_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# + -- we want F# to be in scope in the foreign marshalling code! + -- You might think it doesn't matter, but the simplifier brings all top-level + -- things into the in-scope set before simplifying; so we get no unfolding for F#! + local_binders = mkVarSet (bindersOfBinds ds_binds) in mapDs (dsRule local_binders) rules `thenDs` \ rules' -> diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index 6c7ad10..7959282 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -63,31 +63,35 @@ is the same as so we reuse the desugaring code in @DsCCall@ to deal with these. \begin{code} +type Binding = (Id, CoreExpr) -- No rec/nonrec structure; + -- the occurrence analyser will sort it all out + dsForeigns :: Module -> [TypecheckedForeignDecl] - -> DsM ( [CoreBind] -- desugared foreign imports - , [CoreBind] -- helper functions for foreign exports + -> DsM ( [Id] -- Foreign-exported binders; + -- we have to generate code to register these + , [Binding] , SDoc -- Header file prototypes for -- "foreign exported" functions. , SDoc -- C stubs to use when calling -- "foreign exported" functions. ) -dsForeigns mod_name fos = foldlDs combine ([],[],empty,empty) fos +dsForeigns mod_name fos = foldlDs combine ([], [], empty, empty) fos where - combine (acc_fi, acc_fe, acc_h, acc_c) fo@(ForeignDecl i imp_exp _ ext_nm cconv _) + combine (acc_feb, acc_f, acc_h, acc_c) fo@(ForeignDecl i imp_exp _ ext_nm cconv _) | isForeignImport = -- foreign import (dynamic)? dsFImport i (idType i) uns ext_nm cconv `thenDs` \ bs -> - returnDs (bs ++ acc_fi, acc_fe, acc_h, acc_c) + returnDs (acc_feb, bs ++ acc_f, acc_h, acc_c) | isForeignLabel = dsFLabel i (idType i) ext_nm `thenDs` \ b -> - returnDs (b:acc_fi, acc_fe, acc_h, acc_c) + returnDs (acc_feb, b:acc_f, acc_h, acc_c) | isDynamicExtName ext_nm = - dsFExportDynamic i (idType i) mod_name ext_nm cconv `thenDs` \ (fi,fe,h,c) -> - returnDs (fi:acc_fi, fe:acc_fe, h $$ acc_h, c $$ acc_c) + dsFExportDynamic i (idType i) mod_name ext_nm cconv `thenDs` \ (feb,bs,h,c) -> + returnDs (feb:acc_feb, bs ++ acc_f, h $$ acc_h, c $$ acc_c) | otherwise = -- foreign export - dsFExport i (idType i) mod_name ext_nm cconv False `thenDs` \ (fe,h,c) -> - returnDs (acc_fi, fe:acc_fe, h $$ acc_h, c $$ acc_c) + dsFExport i (idType i) mod_name ext_nm cconv False `thenDs` \ (feb,fe,h,c) -> + returnDs (feb:acc_feb, fe:acc_f, h $$ acc_h, c $$ acc_c) where isForeignImport = case imp_exp of @@ -128,7 +132,7 @@ dsFImport :: Id -> Bool -- True <=> might cause Haskell GC -> ExtName -> CallConv - -> DsM [CoreBind] + -> DsM [Binding] dsFImport fn_id ty may_not_gc ext_name cconv = let (tvs, fun_ty) = splitForAllTys ty @@ -158,16 +162,16 @@ dsFImport fn_id ty may_not_gc ext_name cconv wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers wrap_rhs = mkInlineMe (mkLams (tvs ++ args) wrapper_body) in - returnDs [NonRec work_id work_rhs, NonRec fn_id wrap_rhs] + returnDs [(work_id, work_rhs), (fn_id, wrap_rhs)] \end{code} Foreign labels \begin{code} -dsFLabel :: Id -> Type -> ExtName -> DsM CoreBind +dsFLabel :: Id -> Type -> ExtName -> DsM Binding dsFLabel nm ty ext_name = ASSERT(fromJust res_ty == addrPrimTy) -- typechecker ensures this - returnDs (NonRec nm (fo_rhs (mkLit (MachLabel enm)))) + returnDs (nm, fo_rhs (mkLit (MachLabel enm))) where (res_ty, fo_rhs) = resultWrapper ty enm = extNameStatic ext_name @@ -192,7 +196,8 @@ dsFExport :: Id -> CallConv -> Bool -- True => invoke IO action that's hanging off -- the first argument's stable pointer - -> DsM ( CoreBind + -> DsM ( Id -- The foreign-exported Id + , Binding , SDoc , SDoc ) @@ -277,7 +282,7 @@ dsFExport fn_id ty mod_name ext_name cconv isDyn c_nm f_helper_glob wrapper_arg_tys res_ty cconv isDyn in - returnDs (NonRec f_helper_glob the_body, h_stub, c_stub) + returnDs (f_helper_glob, (f_helper_glob, the_body), h_stub, c_stub) where (tvs,sans_foralls) = splitForAllTys ty @@ -321,7 +326,7 @@ dsFExportDynamic :: Id -> Module -> ExtName -> CallConv - -> DsM (CoreBind, CoreBind, SDoc, SDoc) + -> DsM (Id, [Binding], SDoc, SDoc) dsFExportDynamic i ty mod_name ext_name cconv = newSysLocalDs ty `thenDs` \ fe_id -> let @@ -330,7 +335,7 @@ dsFExportDynamic i ty mod_name ext_name cconv = fe_ext_name = ExtName (_PK_ fe_nm) Nothing in dsFExport i export_ty mod_name fe_ext_name cconv True - `thenDs` \ (fe@(NonRec fe_helper fe_expr), h_code, c_code) -> + `thenDs` \ (feb, fe, h_code, c_code) -> newSysLocalDs arg_ty `thenDs` \ cback -> dsLookupGlobalValue makeStablePtrIdKey `thenDs` \ makeStablePtrId -> let @@ -371,10 +376,11 @@ dsFExportDynamic i ty mod_name ext_name cconv = let io_app = mkLams tvs $ mkLams [cback] $ stbl_app ccall_io_adj res_ty + fed = (i `setInlinePragma` neverInlinePrag, io_app) + -- Never inline the f.e.d. function, because the litlit + -- might not be in scope in other modules. in - -- Never inline the f.e.d. function, because the litlit might not be in scope - -- in other modules. - returnDs (NonRec (i `setInlinePragma` neverInlinePrag) io_app, fe, h_code, c_code) + returnDs (feb, [fed, fe], h_code, c_code) where (tvs,sans_foralls) = splitForAllTys ty diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index e91e601..29c8d1b 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -34,7 +34,7 @@ import HsTypes ( HsType, pprParendHsType, pprHsTyVarBndr, toHsType, -- others: import Id ( idArity, idType, isDataConId_maybe, isPrimOpId_maybe ) import Var ( varType, isId ) -import IdInfo ( ArityInfo, UpdateInfo, InlinePragInfo, +import IdInfo ( ArityInfo, InlinePragInfo, pprInlinePragInfo, ppArityInfo, ppStrictnessInfo ) import RdrName ( RdrName ) @@ -347,7 +347,6 @@ data HsIdInfo name = HsArity ArityInfo | HsStrictness StrictnessInfo | HsUnfold InlinePragInfo (UfExpr name) - | HsUpdate UpdateInfo | HsNoCafRefs | HsCprInfo | HsWorker name -- Worker, if any diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index fd1212a..81fac47 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -211,7 +211,7 @@ instance Ord name => Eq (TyClDecl name pat) where = n1 == n2 && nd1 == nd2 && eqWithHsTyVars tvs1 tvs2 (\ env -> - eq_hsContext env cxt1 cxt2 && + eq_hsContext env cxt1 cxt2 && eqListBy (eq_ConDecl env) cons1 cons2 ) @@ -364,10 +364,6 @@ data ConDetails name | RecCon -- record-style con decl [([name], BangType name)] -- list of "fields" - | NewCon -- newtype con decl, possibly with a labelled field. - (HsType name) - (Maybe name) -- Just x => labelled field 'x' - eq_ConDecl env (ConDecl n1 _ tvs1 cxt1 cds1 _) (ConDecl n2 _ tvs2 cxt2 cds2 _) = n1 == n2 && @@ -381,8 +377,6 @@ eq_ConDetails env (InfixCon bta1 btb1) (InfixCon bta2 btb2) = eq_btype env bta1 bta2 && eq_btype env btb1 btb2 eq_ConDetails env (RecCon fs1) (RecCon fs2) = eqListBy (eq_fld env) fs1 fs2 -eq_ConDetails env (NewCon t1 mn1) (NewCon t2 mn2) - = eq_hsType env t1 t2 && mn1 == mn2 eq_ConDetails env _ _ = False eq_fld env (ns1,bt1) (ns2, bt2) = ns1==ns2 && eq_btype env bt1 bt2 @@ -414,14 +408,6 @@ ppr_con_details con (InfixCon ty1 ty2) ppr_con_details con (VanillaCon tys) = ppr con <+> hsep (map (ppr_bang) tys) -ppr_con_details con (NewCon ty Nothing) - = ppr con <+> pprParendHsType ty - -ppr_con_details con (NewCon ty (Just x)) - = ppr con <+> braces pp_field - where - pp_field = ppr x <+> dcolon <+> pprParendHsType ty - ppr_con_details con (RecCon fields) = ppr con <+> braces (hsep (punctuate comma (map ppr_field fields))) where diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 73bc069..d93c8b0 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -25,6 +25,7 @@ module CmdLineOpts ( opt_D_dump_ds, opt_D_dump_flatC, opt_D_dump_foreign, + opt_D_dump_hi_diffs, opt_D_dump_inlinings, opt_D_dump_occur_anal, opt_D_dump_parsed, @@ -113,10 +114,9 @@ module CmdLineOpts ( opt_UF_HiFileThreshold, opt_UF_CreationThreshold, opt_UF_UseThreshold, - opt_UF_ScrutConDiscount, opt_UF_FunAppDiscount, - opt_UF_PrimArgDiscount, opt_UF_KeenessFactor, + opt_UF_UpdateInPlace, opt_UF_CheapOp, opt_UF_DearOp, @@ -343,6 +343,8 @@ opt_D_dump_simpl_stats = opt_D_dump_most || lookUp SLIT("-ddump-simpl-stats") opt_D_source_stats = opt_D_dump_most || lookUp SLIT("-dsource-stats") opt_D_verbose_core2core = opt_D_dump_all || lookUp SLIT("-dverbose-simpl") opt_D_verbose_stg2stg = opt_D_dump_all || lookUp SLIT("-dverbose-stg") +opt_D_dump_hi_diffs = opt_D_dump_all || lookUp SLIT("-ddump-hi-diffs") + opt_D_dump_minimal_imports = lookUp SLIT("-ddump-minimal-imports") opt_DoCoreLinting = lookUp SLIT("-dcore-lint") @@ -453,10 +455,9 @@ opt_SimplExcessPrecision = lookUp SLIT("-fexcess-precision") opt_UF_HiFileThreshold = lookup_def_int "-funfolding-interface-threshold" (45::Int) opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (45::Int) opt_UF_UseThreshold = lookup_def_int "-funfolding-use-threshold" (8::Int) -- Discounts can be big -opt_UF_ScrutConDiscount = lookup_def_int "-funfolding-con-discount" (2::Int) opt_UF_FunAppDiscount = lookup_def_int "-funfolding-fun-discount" (6::Int) -- It's great to inline a fn -opt_UF_PrimArgDiscount = lookup_def_int "-funfolding-prim-discount" (1::Int) opt_UF_KeenessFactor = lookup_def_float "-funfolding-keeness-factor" (1.5::Float) +opt_UF_UpdateInPlace = lookUp SLIT("-funfolding-update-in-place") opt_UF_CheapOp = ( 1 :: Int) -- Only one instruction; and the args are charged for opt_UF_DearOp = ( 4 :: Int) diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index da7b866..678aaec 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -66,6 +66,7 @@ import Util ( sortLt, mapAccumL ) import SrcLoc ( noSrcLoc ) import Bag import Outputable +import ErrUtils ( dumpIfSet ) import Maybe ( isNothing ) import List ( partition ) @@ -100,21 +101,22 @@ writeIface this_mod old_iface new_iface }} in - case checkIface old_iface full_new_iface of { - Nothing -> when opt_D_dump_rn_trace $ - putStrLn "Interface file unchanged" ; -- No need to update .hi file + do maybe_final_iface <- checkIface old_iface full_new_iface + case maybe_final_iface of { + Nothing -> when opt_D_dump_rn_trace $ + putStrLn "Interface file unchanged" ; -- No need to update .hi file - Just final_iface -> + Just final_iface -> - do let mod_vers_unchanged = case old_iface of + do let mod_vers_unchanged = case old_iface of Just iface -> pi_vers iface == pi_vers final_iface Nothing -> False - when (mod_vers_unchanged && opt_D_dump_rn_trace) $ - putStrLn "Module version unchanged, but usages differ; hence need new hi file" + when (mod_vers_unchanged && opt_D_dump_rn_trace) $ + putStrLn "Module version unchanged, but usages differ; hence need new hi file" - if_hdl <- openFile filename WriteMode - printForIface if_hdl (pprIface final_iface) - hClose if_hdl + if_hdl <- openFile filename WriteMode + printForIface if_hdl (pprIface final_iface) + hClose if_hdl } where full_new_iface = completeIface new_iface local_tycons local_classes @@ -132,9 +134,10 @@ writeIface this_mod old_iface new_iface \begin{code} checkIface :: Maybe ParsedIface -- The old interface, read from M.hi -> ParsedIface -- The new interface; but with all version numbers = 1 - -> Maybe ParsedIface -- Nothing => no change; no need to write new Iface + -> IO (Maybe ParsedIface) -- Nothing => no change; no need to write new Iface -- Just pi => Here is the new interface to write -- with correct version numbers + -- The I/O part is just so it can print differences -- NB: the fixities, declarations, rules are all assumed -- to be sorted by increasing order of hsDeclName, so that @@ -142,29 +145,22 @@ checkIface :: Maybe ParsedIface -- The old interface, read from M.hi checkIface Nothing new_iface -- No old interface, so definitely write a new one! - = Just new_iface + = return (Just new_iface) checkIface (Just iface) new_iface | no_output_change && no_usage_change - = Nothing + = return Nothing | otherwise -- Add updated version numbers - = -{- pprTrace "checkIface" ( - vcat [ppr no_decl_changed <+> ppr no_export_change <+> ppr no_usage_change, - text "--------", - vcat (map ppr (pi_decls iface)), - text "--------", - vcat (map ppr (pi_decls new_iface)) - ]) $ --} - Just (new_iface { pi_vers = new_mod_vers, - pi_fixity = (new_fixity_vers, new_fixities), - pi_rules = (new_rules_vers, new_rules), - pi_decls = final_decls - }) + = do { dumpIfSet opt_D_dump_hi_diffs "Interface file changes" pp_diffs ; + return (Just new_iface )} where + final_iface = new_iface { pi_vers = new_mod_vers, + pi_fixity = (new_fixity_vers, new_fixities), + pi_rules = (new_rules_vers, new_rules), + pi_decls = final_decls } + no_usage_change = pi_usages iface == pi_usages new_iface no_output_change = no_decl_changed && @@ -189,24 +185,29 @@ checkIface (Just iface) new_iface new_rules_vers | rules == new_rules = rules_vers | otherwise = bumpVersion rules_vers - (no_decl_changed, final_decls) = merge_decls True [] (pi_decls iface) (pi_decls new_iface) + (no_decl_changed, pp_diffs, final_decls) = merge_decls True empty [] (pi_decls iface) (pi_decls new_iface) -- Fill in the version number on the new declarations -- by looking at the old declarations. -- Set the flag if anything changes. -- Assumes that the decls are sorted by hsDeclName - merge_decls ok_so_far acc [] [] = (ok_so_far, reverse acc) - merge_decls ok_so_far acc old [] = (False, reverse acc) - merge_decls ok_so_far acc [] (nvd:nvds) = merge_decls False (nvd:acc) [] nvds - merge_decls ok_so_far acc (vd@(v,d):vds) (nvd@(_,nd):nvds) + merge_decls ok_so_far pp acc [] [] = (ok_so_far, pp, reverse acc) + merge_decls ok_so_far pp acc old [] = (False, pp, reverse acc) + merge_decls ok_so_far pp acc [] (nvd:nvds) = merge_decls False (pp $$ only_new nvd) (nvd:acc) [] nvds + merge_decls ok_so_far pp acc (vd@(v,d):vds) (nvd@(_,nd):nvds) = case d_name `compare` nd_name of - LT -> merge_decls False acc vds (nvd:nvds) - GT -> merge_decls False (nvd:acc) (vd:vds) nvds - EQ | d == nd -> merge_decls ok_so_far (vd:acc) vds nvds - | otherwise -> merge_decls False ((bumpVersion v, nd):acc) vds nvds + LT -> merge_decls False (pp $$ only_old vd) acc vds (nvd:nvds) + GT -> merge_decls False (pp $$ only_new nvd) (nvd:acc) (vd:vds) nvds + EQ | d == nd -> merge_decls ok_so_far pp (vd:acc) vds nvds + | otherwise -> merge_decls False (pp $$ changed d nd) ((bumpVersion v, nd):acc) vds nvds where d_name = hsDeclName d nd_name = hsDeclName nd + + only_old (_,d) = ptext SLIT("Only in old iface:") <+> ppr d + only_new (_,d) = ptext SLIT("Only in new iface:") <+> ppr d + changed d nd = ptext SLIT("Changed in iface: ") <+> ((ptext SLIT("Old:") <+> ppr d) $$ + (ptext SLIT("New:") <+> ppr nd)) \end{code} diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index 095f828..544b922 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.34 2000/08/01 09:08:27 simonpj Exp $ +$Id: Parser.y,v 1.35 2000/09/14 13:46:40 simonpj Exp $ Haskell grammar. @@ -588,9 +588,9 @@ constr_stuff :: { (RdrName, RdrNameConDetails) } | con '{' fielddecls '}' { ($1, RecCon (reverse $3)) } newconstr :: { RdrNameConDecl } - : srcloc conid atype { mkConDecl $2 [] [] (NewCon $3 Nothing) $1 } + : srcloc conid atype { mkConDecl $2 [] [] (VanillaCon [Unbanged $3]) $1 } | srcloc conid '{' var '::' type '}' - { mkConDecl $2 [] [] (NewCon $6 (Just $4)) $1 } + { mkConDecl $2 [] [] (RecCon [([$4], Unbanged $6)]) $1 } scontype :: { (RdrName, [RdrNameBangType]) } : btype {% splitForConApp $1 [] } diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index d9c6b95..26a1fc0 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -463,9 +463,9 @@ constr : src_loc ex_stuff data_name batypes { mk_con_decl $3 $2 (VanillaCon $ -- We use "data_fs" so as to include () newtype_constr :: { [RdrNameConDecl] {- Not allowed to be empty -} } -newtype_constr : src_loc '=' ex_stuff data_name atype { [mk_con_decl $4 $3 (NewCon $5 Nothing) $1] } +newtype_constr : src_loc '=' ex_stuff data_name atype { [mk_con_decl $4 $3 (VanillaCon [Unbanged $5]) $1] } | src_loc '=' ex_stuff data_name '{' var_name '::' atype '}' - { [mk_con_decl $4 $3 (NewCon $8 (Just $6)) $1] } + { [mk_con_decl $4 $3 (RecCon [([$6], Unbanged $8)]) $1] } ex_stuff :: { ([HsTyVarBndr RdrName], RdrNameContext) } ex_stuff : { ([],[]) } diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index df72d31..df5fd66 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -548,7 +548,6 @@ getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _)) get_details (VanillaCon tys) = plusFVs (map get_bang tys) get_details (InfixCon t1 t2) = get_bang t1 `plusFV` get_bang t2 get_details (RecCon fields) = plusFVs [get_bang t | (_, t) <- fields] - get_details (NewCon t _) = extractHsTyNames t get_field (fs,t) | any (`elemNameSet` source_fvs) fs = get_bang t | otherwise = emptyFVs diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index a9e9d3e..6a24e25 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -1071,13 +1071,8 @@ getConFieldNames new_name (ConDecl con _ _ _ (RecCon fielddecls) src_loc : rest) getConFieldNames new_name (ConDecl con _ _ _ condecl src_loc : rest) = new_name con src_loc `thenRn` \ n -> - (case condecl of - NewCon _ (Just f) -> - new_name f src_loc `thenRn` \ new_f -> - returnRn [n,new_f] - _ -> returnRn [n]) `thenRn` \ nn -> getConFieldNames new_name rest `thenRn` \ ns -> - returnRn (nn ++ ns) + returnRn (n : ns) getConFieldNames new_name [] = returnRn [] diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index a588c59..6f7dc48 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -476,16 +476,6 @@ rnConDetails doc locn (InfixCon ty1 ty2) rnBangTy doc ty2 `thenRn` \ (new_ty2, fvs2) -> returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) -rnConDetails doc locn (NewCon ty mb_field) - = rnHsType doc ty `thenRn` \ (new_ty, fvs) -> - rn_field mb_field `thenRn` \ new_mb_field -> - returnRn (NewCon new_ty new_mb_field, fvs) - where - rn_field Nothing = returnRn Nothing - rn_field (Just f) = - lookupTopBndrRn f `thenRn` \ new_f -> - returnRn (Just new_f) - rnConDetails doc locn (RecCon fields) = checkDupOrQualNames doc field_names `thenRn_` mapFvRn (rnField doc) fields `thenRn` \ (new_fields, fvs) -> @@ -724,7 +714,6 @@ rnIdInfo (HsWorker worker) rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ (expr', fvs) -> returnRn (HsUnfold inline expr', fvs) rnIdInfo (HsArity arity) = returnRn (HsArity arity, emptyFVs) -rnIdInfo (HsUpdate update) = returnRn (HsUpdate update, emptyFVs) rnIdInfo HsNoCafRefs = returnRn (HsNoCafRefs, emptyFVs) rnIdInfo HsCprInfo = returnRn (HsCprInfo, emptyFVs) diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index ad9b70f..afe7ac0 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -27,7 +27,7 @@ import Id ( isSpecPragmaId, isDataConId, isOneShotLambda, setOneShotLambda, idSpecialisation, idType, idUnique, Id ) -import IdInfo ( OccInfo(..), insideLam, copyIdInfo ) +import IdInfo ( OccInfo(..), insideLam, shortableIdInfo, copyIdInfo ) import VarSet import VarEnv @@ -187,27 +187,34 @@ zapBind ind_env (Rec pairs) zapBind ind_env bind = bind -zap ind_env pair@(bndr,rhs) - = case lookupVarEnv ind_env bndr of +zap ind_env pair@(local_id,rhs) + = case lookupVarEnv ind_env local_id of Nothing -> [pair] - Just exported_id -> [(bndr, Var exported_id), - (exported_id_w_info, rhs)] - where - exported_id_w_info = modifyIdInfo (copyIdInfo (idInfo bndr)) exported_id - -- See notes with copyIdInfo about propagating IdInfo from - -- one to t'other + Just exported_id -> [(local_id, Var exported_id), + (exported_id', rhs)] + where + exported_id' = modifyIdInfo (copyIdInfo (idInfo local_id)) exported_id shortMeOut ind_env exported_id local_id - = isExportedId exported_id && -- Only if this is exported - - isLocallyDefined local_id && -- Only if this one is defined in this - -- module, so that we *can* change its - -- binding to be the exported thing! - - not (isExportedId local_id) && -- Only if this one is not itself exported, - -- since the transformation will nuke it - - not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for +-- The if-then-else stuff is just so I can get a pprTrace to see +-- how often I don't get shorting out becuase of IdInfo stuff + = if isExportedId exported_id && -- Only if this is exported + + isLocallyDefined local_id && -- Only if this one is defined in this + -- module, so that we *can* change its + -- binding to be the exported thing! + + not (isExportedId local_id) && -- Only if this one is not itself exported, + -- since the transformation will nuke it + + not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for + then + if shortableIdInfo (idInfo exported_id) -- Only if its IdInfo is 'shortable' + -- (see the defn of IdInfo.shortableIdInfo + then True + else pprTrace "shortMeOut:" (ppr exported_id) False + else + False \end{code} diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index 515185f..806d9df 100644 --- a/ghc/compiler/simplCore/SetLevels.lhs +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -353,7 +353,7 @@ lvlBind :: TopLevelFlag -- Used solely to decide whether to clone lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_)) | null abs_vars = -- No type abstraction; clone existing binder - lvlExpr ctxt_lvl env rhs `thenLvl` \ rhs' -> + lvlExpr dest_lvl env rhs `thenLvl` \ rhs' -> cloneVar top_lvl env bndr ctxt_lvl dest_lvl `thenLvl` \ (env', bndr') -> returnLvl (NonRec (bndr', dest_lvl) rhs', env') diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 85c1c4d..29f9a6a 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -19,7 +19,8 @@ module SimplUtils ( #include "HsVersions.h" import CmdLineOpts ( switchIsOn, SimplifierSwitch(..), - opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge, opt_DictsStrict + opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge, opt_DictsStrict, + opt_UF_UpdateInPlace ) import CoreSyn import CoreUnfold ( isValueUnfolding ) @@ -29,7 +30,7 @@ import Id ( Id, idType, isId, idName, idOccInfo, idUnfolding, idStrictness, mkId, idInfo ) -import IdInfo ( StrictnessInfo(..), arityLowerBound, setOccInfo, vanillaIdInfo ) +import IdInfo ( StrictnessInfo(..), ArityInfo, atLeastArity, setOccInfo, vanillaIdInfo ) import Maybes ( maybeToBool, catMaybes ) import Name ( isLocalName, setNameUnique ) import Demand ( Demand, isStrict, wwLazy, wwLazy ) @@ -399,7 +400,10 @@ canUpdateInPlace :: Type -> Bool -- Note the repType: we want to look through newtypes for this purpose -canUpdateInPlace ty = case splitTyConApp_maybe (repType ty) of { +canUpdateInPlace ty + | not opt_UF_UpdateInPlace = False + | otherwise + = case splitTyConApp_maybe (repType ty) of { Nothing -> False ; Just (tycon, _) -> @@ -472,7 +476,7 @@ Try (a) eta expansion \begin{code} transformRhs :: OutExpr - -> (Arity -> OutExpr -> SimplM (OutStuff a)) + -> (ArityInfo -> OutExpr -> SimplM (OutStuff a)) -> SimplM (OutStuff a) transformRhs rhs thing_inside @@ -689,7 +693,7 @@ what the final test in the first equation is for. \begin{code} tryEtaExpansion :: OutExpr - -> (Arity -> OutExpr -> SimplM (OutStuff a)) + -> (ArityInfo -> OutExpr -> SimplM (OutStuff a)) -> SimplM (OutStuff a) tryEtaExpansion rhs thing_inside | not opt_SimplDoLambdaEtaExpansion @@ -727,8 +731,8 @@ tryEtaExpansion rhs thing_inside fun_arity = exprEtaExpandArity fun - final_arity | all_trivial_args = x_arity + extra_args_wanted - | otherwise = x_arity + final_arity | all_trivial_args = atLeastArity (x_arity + extra_args_wanted) + | otherwise = atLeastArity x_arity -- Arity can be more than the number of lambdas -- because of coerces. E.g. \x -> coerce t (\y -> e) -- will have arity at least 2 diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 5c09ebc..bfd7f70 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -29,7 +29,7 @@ import Id ( Id, idType, idInfo, isDataConId, zapLamIdInfo, setOneShotLambda, ) import IdInfo ( OccInfo(..), isDeadOcc, isLoopBreaker, - ArityInfo, setArityInfo, atLeastArity, + ArityInfo, setArityInfo, unknownArity, setUnfoldingInfo, occInfo ) @@ -497,11 +497,43 @@ completeBinding old_bndr new_bndr top_lvl black_listed new_rhs thing_inside = thing_inside | exprIsTrivial new_rhs - = completeTrivialBinding old_bndr new_bndr - black_listed loop_breaker new_rhs - thing_inside + -- We're looking at a binding with a trivial RHS, so + -- perhaps we can discard it altogether! + -- + -- NB: a loop breaker never has postInlineUnconditionally True + -- and non-loop-breakers only have *forward* references + -- Hence, it's safe to discard the binding + -- + -- NOTE: This isn't our last opportunity to inline. + -- We're at the binding site right now, and + -- we'll get another opportunity when we get to the ocurrence(s) + + -- Note that we do this unconditional inlining only for trival RHSs. + -- Don't inline even WHNFs inside lambdas; doing so may + -- simply increase allocation when the function is called + -- This isn't the last chance; see NOTE above. + -- + -- NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here + -- Why? Because we don't even want to inline them into the + -- RHS of constructor arguments. See NOTE above + -- + -- NB: Even NOINLINEis ignored here: if the rhs is trivial + -- it's best to inline it anyway. We often get a=E; b=a + -- from desugaring, with both a and b marked NOINLINE. + = if must_keep_binding then -- Keep the binding + finally_bind_it unknownArity new_rhs + -- Arity doesn't really matter because for a trivial RHS + -- we will inline like crazy at call sites + -- If this turns out be false, we can easily compute arity + else -- Drop the binding + extendSubst 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 + tick (PostInlineUnconditionally old_bndr) `thenSmpl_` + thing_inside | Note coercion@(Coerce _ inner_ty) inner_rhs <- new_rhs + -- [NB inner_rhs is guaranteed non-trivial by now] -- x = coerce t e ==> c = e; x = inline_me (coerce t c) -- Now x can get inlined, which moves the coercion -- to the usage site. This is a bit like worker/wrapper stuff, @@ -509,7 +541,7 @@ completeBinding old_bndr new_bndr top_lvl black_listed new_rhs thing_inside -- x = coerce T (I# 3) -- get's w/wd to -- c = I# 3 - -- x = coerce T $wx + -- x = coerce T c -- This in turn means that -- case (coerce Int x) of ... -- will inline x. @@ -520,99 +552,48 @@ completeBinding old_bndr new_bndr top_lvl black_listed new_rhs thing_inside -- get substituted away, but not if it's exported.) = newId SLIT("c") inner_ty $ \ c_id -> completeBinding c_id c_id top_lvl False inner_rhs $ - completeTrivialBinding old_bndr new_bndr black_listed loop_breaker - (Note InlineMe (Note coercion (Var c_id))) $ + completeBinding old_bndr new_bndr top_lvl black_listed + (Note InlineMe (Note coercion (Var c_id))) $ thing_inside | otherwise - = transformRhs new_rhs $ \ arity new_rhs' -> - getSubst `thenSmpl` \ subst -> - let - -- We make new IdInfo for the new binder by starting from the old binder, - -- doing appropriate substitutions. - -- Then we add arity and unfolding info to get the new binder - new_bndr_info = substIdInfo subst old_info (idInfo new_bndr) - `setArityInfo` atLeastArity arity - - -- 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 - info_w_unf | loop_breaker = new_bndr_info - | otherwise = new_bndr_info `setUnfoldingInfo` mkUnfolding top_lvl new_rhs' - - final_id = new_bndr `setIdInfo` info_w_unf - in - -- These seqs forces the Id, and hence its IdInfo, - -- and hence any inner substitutions - final_id `seq` - addLetBind (NonRec final_id new_rhs') $ - modifyInScope new_bndr final_id thing_inside + = transformRhs new_rhs finally_bind_it where - old_info = idInfo old_bndr - occ_info = occInfo old_info - loop_breaker = isLoopBreaker occ_info + old_info = idInfo old_bndr + occ_info = occInfo old_info + loop_breaker = isLoopBreaker occ_info + trivial_rhs = exprIsTrivial new_rhs + must_keep_binding = black_listed || loop_breaker || isExportedId old_bndr + + finally_bind_it arity_info new_rhs + = getSubst `thenSmpl` \ subst -> + let + -- We make new IdInfo for the new binder by starting from the old binder, + -- doing appropriate substitutions. + -- Then we add arity and unfolding info to get the new binder + new_bndr_info = substIdInfo subst old_info (idInfo new_bndr) + `setArityInfo` arity_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 + info_w_unf | loop_breaker = new_bndr_info + | otherwise = new_bndr_info `setUnfoldingInfo` mkUnfolding top_lvl new_rhs + + final_id = new_bndr `setIdInfo` info_w_unf + in + -- These seqs forces the Id, and hence its IdInfo, + -- and hence any inner substitutions + final_id `seq` + addLetBind (NonRec final_id new_rhs) $ + modifyInScope new_bndr final_id thing_inside \end{code} -\begin{code} -completeTrivialBinding old_bndr new_bndr black_listed loop_breaker new_rhs thing_inside - -- We're looking at a binding with a trivial RHS, so - -- perhaps we can discard it altogether! - -- - -- NB: a loop breaker never has postInlineUnconditionally True - -- and non-loop-breakers only have *forward* references - -- Hence, it's safe to discard the binding - -- - -- NB: You might think that postInlineUnconditionally is an optimisation, - -- but if we have - -- let x = f Bool in (x, y) - -- then because of the constructor, x will not be *inlined* in the pair, - -- so the trivial binding will stay. But in this postInlineUnconditionally - -- gag we use the *substitution* to substitute (f Bool) for x, and that *will* - -- happen. - - -- NOTE: This isn't our last opportunity to inline. - -- We're at the binding site right now, and - -- we'll get another opportunity when we get to the ocurrence(s) - - -- Note that we do this unconditional inlining only for trival RHSs. - -- Don't inline even WHNFs inside lambdas; doing so may - -- simply increase allocation when the function is called - -- This isn't the last chance; see NOTE above. - -- - -- NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here - -- Why? Because we don't even want to inline them into the - -- RHS of constructor arguments. See NOTE above - -- - -- NB: Even NOINLINEis ignored here: if the rhs is trivial - -- it's best to inline it anyway. We often get a=E; b=a - -- from desugaring, with both a and b marked NOINLINE. - - | not keep_binding -- Can discard binding, inlining everywhere - = extendSubst old_bndr (DoneEx new_rhs) $ - tick (PostInlineUnconditionally old_bndr) `thenSmpl_` - thing_inside - - | otherwise -- We must keep the binding, but we may still inline - = getSubst `thenSmpl` \ subst -> - let - new_bndr_info = substIdInfo subst (idInfo old_bndr) (idInfo new_bndr) - final_id = new_bndr `setIdInfo` new_bndr_info - in - addLetBind (NonRec final_id new_rhs) $ - if dont_inline then - modifyInScope new_bndr final_id thing_inside - else - extendSubst old_bndr (DoneEx new_rhs) thing_inside - where - dont_inline = black_listed || loop_breaker - keep_binding = dont_inline || isExportedId old_bndr -\end{code} - %************************************************************************ %* * diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs index 32b3469..5fd46c4 100644 --- a/ghc/compiler/stranal/SaAbsInt.lhs +++ b/ghc/compiler/stranal/SaAbsInt.lhs @@ -605,7 +605,9 @@ findStrictness id (AbsApproxFun str_ds str_res) (AbsApproxFun abs_ds _) -- See notes with WwLib.worthSplitting = find_strictness id str_ds str_res abs_ds -findStrictness id str_val abs_val = NoStrictnessInfo +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 diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index b05737d..86f6437 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -10,9 +10,7 @@ module WorkWrap ( wwTopBinds, mkWrapper ) where import CoreSyn import CoreUnfold ( Unfolding, certainlyWillInline ) -import CmdLineOpts ( opt_UF_CreationThreshold , opt_D_verbose_core2core, - opt_D_dump_worker_wrapper - ) +import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_worker_wrapper ) import CoreLint ( beginPass, endPass ) import CoreUtils ( exprType, exprEtaExpandArity ) import MkId ( mkWorkerId ) diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 4bce6a4..eceff0e 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -78,7 +78,6 @@ tcIdInfo unf_env in_scope_vars name ty info info_ins = foldlTc tcPrag vanillaIdInfo info_ins where tcPrag info (HsArity arity) = returnTc (info `setArityInfo` arity) - tcPrag info (HsUpdate upd) = returnTc (info `setUpdateInfo` upd) tcPrag info (HsNoCafRefs) = returnTc (info `setCafInfo` NoCafRefs) tcPrag info HsCprInfo = returnTc (info `setCprInfo` ReturnsCPR) diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 8d803fd..6e4e0d6 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -426,7 +426,6 @@ get_con (ConDecl _ _ _ ctxt details _) ---------------------------------------------------- get_con_details (VanillaCon btys) = unionManyUniqSets (map get_bty btys) get_con_details (InfixCon bty1 bty2) = unionUniqSets (get_bty bty1) (get_bty bty2) -get_con_details (NewCon ty _) = get_ty ty get_con_details (RecCon nbtys) = unionManyUniqSets (map (get_bty.snd) nbtys) ---------------------------------------------------- diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 955d812..e95a944 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -81,7 +81,7 @@ tcTyDecl1 (TySynonym tycon_name tyvar_names rhs src_loc) returnTc (tycon_name, SynTyDetails rhs_ty) -tcTyDecl1 (TyData _ context tycon_name _ con_decls _ derivings _ src_loc) +tcTyDecl1 (TyData new_or_data context tycon_name _ con_decls _ derivings _ src_loc) = tcLookupTy tycon_name `thenNF_Tc` \ (ATyCon tycon) -> let tyvars = tyConTyVars tycon @@ -89,9 +89,9 @@ tcTyDecl1 (TyData _ context tycon_name _ con_decls _ derivings _ src_loc) tcExtendTyVarEnv tyvars $ -- Typecheck the pieces - tcClassContext context `thenTc` \ ctxt -> - tc_derivs derivings `thenTc` \ derived_classes -> - mapTc (tcConDecl tycon tyvars ctxt) con_decls `thenTc` \ data_cons -> + tcClassContext context `thenTc` \ ctxt -> + tc_derivs derivings `thenTc` \ derived_classes -> + mapTc (tcConDecl new_or_data tycon tyvars ctxt) con_decls `thenTc` \ data_cons -> returnTc (tycon_name, DataTyDetails ctxt data_cons derived_classes) where @@ -138,16 +138,15 @@ kcConDetails ex_ctxt details where kc_con_details (VanillaCon btys) = mapTc_ kc_bty btys kc_con_details (InfixCon bty1 bty2) = mapTc_ kc_bty [bty1,bty2] - kc_con_details (NewCon ty _) = kcHsSigType ty kc_con_details (RecCon flds) = mapTc_ kc_field flds kc_field (_, bty) = kc_bty bty kc_bty bty = kcHsSigType (getBangType bty) -tcConDecl :: TyCon -> [TyVar] -> ClassContext -> RenamedConDecl -> TcM s DataCon +tcConDecl :: NewOrData -> TyCon -> [TyVar] -> ClassContext -> RenamedConDecl -> TcM s DataCon -tcConDecl tycon tyvars ctxt (ConDecl name wkr_name ex_tvs ex_ctxt details src_loc) +tcConDecl new_or_data tycon tyvars ctxt (ConDecl name wkr_name ex_tvs ex_ctxt details src_loc) = tcAddSrcLoc src_loc $ kcTyVarScope ex_tvs (kcConDetails ex_ctxt details) `thenTc` \ ex_tv_kinds -> let @@ -158,29 +157,22 @@ tcConDecl tycon tyvars ctxt (ConDecl name wkr_name ex_tvs ex_ctxt details src_lo case details of VanillaCon btys -> tc_datacon ex_tyvars ex_theta btys InfixCon bty1 bty2 -> tc_datacon ex_tyvars ex_theta [bty1,bty2] - NewCon ty mb_f -> tc_newcon ex_tyvars ex_theta ty mb_f RecCon fields -> tc_rec_con ex_tyvars ex_theta fields where + tc_sig_type = case new_or_data of + DataType -> tcHsSigType + NewType -> tcHsBoxedSigType + -- Can't allow an unboxed type here, because we're effectively + -- going to remove the constructor while coercing it to a boxed type. + tc_datacon ex_tyvars ex_theta btys = let arg_stricts = map getBangStrictness btys tys = map getBangType btys in - mapTc tcHsSigType tys `thenTc` \ arg_tys -> + mapTc tc_sig_type tys `thenTc` \ arg_tys -> mk_data_con ex_tyvars ex_theta arg_stricts arg_tys [] - tc_newcon ex_tyvars ex_theta ty mb_f - = tcHsBoxedSigType ty `thenTc` \ arg_ty -> - -- can't allow an unboxed type here, because we're effectively - -- going to remove the constructor while coercing it to a boxed type. - let - field_label = - case mb_f of - Nothing -> [] - Just f -> [mkFieldLabel (getName f) tycon arg_ty (head allFieldLabelTags)] - in - mk_data_con ex_tyvars ex_theta [notMarkedStrict] [arg_ty] field_label - tc_rec_con ex_tyvars ex_theta fields = checkTc (null ex_tyvars) (exRecConErr name) `thenTc_` mapTc tc_field (fields `zip` allFieldLabelTags) `thenTc` \ field_labels_s -> @@ -195,7 +187,7 @@ tcConDecl tycon tyvars ctxt (ConDecl name wkr_name ex_tvs ex_ctxt details src_lo (map fieldLabelType field_labels) field_labels tc_field ((field_label_names, bty), tag) - = tcHsSigType (getBangType bty) `thenTc` \ field_ty -> + = tc_sig_type (getBangType bty) `thenTc` \ field_ty -> returnTc [mkFieldLabel (getName name) tycon field_ty tag | name <- field_label_names] mk_data_con ex_tyvars ex_theta arg_stricts arg_tys fields diff --git a/ghc/docs/users_guide/debugging.sgml b/ghc/docs/users_guide/debugging.sgml index 521e9a4..bc0f985 100644 --- a/ghc/docs/users_guide/debugging.sgml +++ b/ghc/docs/users_guide/debugging.sgml @@ -222,6 +222,16 @@ intended to reduce the labour. +: + + +Dump to stdout a summary of the differences between the existing interface file (if any) +for this module, and the new one. + + + + + : diff --git a/ghc/docs/users_guide/using.sgml b/ghc/docs/users_guide/using.sgml index 7663cd7..5423f04 100644 --- a/ghc/docs/users_guide/using.sgml +++ b/ghc/docs/users_guide/using.sgml @@ -2114,27 +2114,22 @@ apply (see ). + -: +: - --funfolding-con-discount option -inlining, controlling -unfolding, controlling -(Default: 2) If the compiler decides that it can eliminate some -computation by performing an unfolding, then this is a discount factor -that it applies to the funciton size before deciding whether to unfold -it or not. - - - -OK, folks, these magic numbers `30', `8', and '2' are mildly -arbitrary; they are of the “seem to be OK” variety. The `8' is the -more critical one; it's what determines how eager GHC is about -expanding unfoldings. +Switches on an experimental "optimisation". Switching it on makes the compiler +a little keener to inline a function that returns a constructor, if the context is +that of a thunk. + + x = plusInt a b + +If we inlined plusInt we might get an opportunity to use update-in-place for +the thunk 'x'. + : diff --git a/ghc/lib/std/CPUTime.lhs b/ghc/lib/std/CPUTime.lhs index f8f9eeb..acf514e 100644 --- a/ghc/lib/std/CPUTime.lhs +++ b/ghc/lib/std/CPUTime.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: CPUTime.lhs,v 1.24 2000/07/07 11:03:57 simonmar Exp $ +% $Id: CPUTime.lhs,v 1.25 2000/09/14 13:46:42 simonpj Exp $ % % (c) The University of Glasgow, 1995-2000 % @@ -25,7 +25,7 @@ import PrelBase ( Int(..) ) import PrelByteArr ( ByteArray(..), newIntArray ) import PrelArrExtra ( unsafeFreezeByteArray ) import PrelNum ( fromInt ) -import PrelIOBase ( IOError(..), IOException(..), +import PrelIOBase ( IOError, IOException(..), IOErrorType( UnsupportedOperation ), unsafePerformIO, stToIO, ioException ) import Ratio diff --git a/ghc/lib/std/PrelList.lhs b/ghc/lib/std/PrelList.lhs index 496aa1e..27d0d4f 100644 --- a/ghc/lib/std/PrelList.lhs +++ b/ghc/lib/std/PrelList.lhs @@ -1,5 +1,5 @@ % ------------------------------------------------------------------------------ -% $Id: PrelList.lhs,v 1.21 2000/08/29 16:35:56 simonpj Exp $ +% $Id: PrelList.lhs,v 1.22 2000/09/14 13:46:42 simonpj Exp $ % % (c) The University of Glasgow, 1994-2000 % @@ -435,8 +435,11 @@ concatMap :: (a -> [b]) -> [a] -> [b] concatMap f = foldr ((++) . f) [] concat :: [[a]] -> [a] -{-# INLINE concat #-} concat = foldr (++) [] + +{-# RULES + "concat" forall xs. concat xs = build (\c n -> foldr (\x y -> foldr c y x) n xs) + #-} \end{code} diff --git a/ghc/lib/std/PrelShow.lhs b/ghc/lib/std/PrelShow.lhs index 4af798c..2868103 100644 --- a/ghc/lib/std/PrelShow.lhs +++ b/ghc/lib/std/PrelShow.lhs @@ -1,5 +1,5 @@ % ------------------------------------------------------------------------------ -% $Id: PrelShow.lhs,v 1.11 2000/06/30 13:39:36 simonmar Exp $ +% $Id: PrelShow.lhs,v 1.12 2000/09/14 13:46:42 simonpj Exp $ % % (c) The University of Glasgow, 1992-2000 % @@ -112,13 +112,13 @@ instance Show Int where instance Show a => Show (Maybe a) where showsPrec _p Nothing s = showString "Nothing" s - showsPrec p@(I# p#) (Just x) s + showsPrec (I# p#) (Just x) s = (showParen (p# >=# 10#) $ showString "Just " . showsPrec (I# 10#) x) s instance (Show a, Show b) => Show (Either a b) where - showsPrec p@(I# p#) e s = + showsPrec (I# p#) e s = (showParen (p# >=# 10#) $ case e of Left a -> showString "Left " . showsPrec (I# 10#) a @@ -196,22 +196,21 @@ Code specific for characters \begin{code} showLitChar :: Char -> ShowS -showLitChar c | c > '\DEL' = \s -> showChar '\\' (protectEsc isDigit (shows (ord c)) s) -showLitChar '\DEL' = showString "\\DEL" -showLitChar '\\' = showString "\\\\" -showLitChar c | c >= ' ' = showChar c -showLitChar '\a' = showString "\\a" -showLitChar '\b' = showString "\\b" -showLitChar '\f' = showString "\\f" -showLitChar '\n' = showString "\\n" -showLitChar '\r' = showString "\\r" -showLitChar '\t' = showString "\\t" -showLitChar '\v' = showString "\\v" -showLitChar '\SO' = \s -> protectEsc (== 'H') (showString "\\SO") s -showLitChar c = \s -> showString ('\\' : asciiTab!!ord c) s - -- The "\s ->" here means that GHC knows it's ok to put the - -- asciiTab!!ord c inside the lambda. Otherwise we get an extra - -- lambda allocated, and that can be pretty bad +showLitChar c s | c > '\DEL' = showChar '\\' (protectEsc isDigit (shows (ord c)) s) +showLitChar '\DEL' s = showString "\\DEL" s +showLitChar '\\' s = showString "\\\\" s +showLitChar c s | c >= ' ' = showChar c s +showLitChar '\a' s = showString "\\a" s +showLitChar '\b' s = showString "\\b" s +showLitChar '\f' s = showString "\\f" s +showLitChar '\n' s = showString "\\n" s +showLitChar '\r' s = showString "\\r" s +showLitChar '\t' s = showString "\\t" s +showLitChar '\v' s = showString "\\v" s +showLitChar '\SO' s = protectEsc (== 'H') (showString "\\SO") s +showLitChar c s = showString ('\\' : asciiTab!!ord c) s + -- I've done manual eta-expansion here, becuase otherwise it's + -- impossible to stop (asciiTab!!ord) getting floated out as an MFE protectEsc :: (Char -> Bool) -> ShowS -> ShowS protectEsc p f = f . cont @@ -257,7 +256,8 @@ itos n r \begin{code} isAscii, isLatin1, isControl, isPrint, isSpace, isUpper, - isLower, isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum :: Char -> Bool + isLower, isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum, + isAsciiUpper, isAsciiLower :: Char -> Bool isAscii c = c < '\x80' isLatin1 c = c <= '\xff' isControl c = c < ' ' || c >= '\DEL' && c <= '\x9f' diff --git a/ghc/lib/std/PrelTup.lhs b/ghc/lib/std/PrelTup.lhs index 8cc2c22..e3d0c9b 100644 --- a/ghc/lib/std/PrelTup.lhs +++ b/ghc/lib/std/PrelTup.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: PrelTup.lhs,v 1.9 2000/06/30 13:39:36 simonmar Exp $ +% $Id: PrelTup.lhs,v 1.10 2000/09/14 13:46:42 simonpj Exp $ % % (c) The University of Glasgow, 1992-2000 % @@ -13,7 +13,6 @@ This modules defines the typle data types. module PrelTup where -import {-# SOURCE #-} PrelErr ( error ) import PrelBase default () -- Double isn't available yet