From 4e7d56fde0f44d38bbb9a6fc72cf9c603264899d Mon Sep 17 00:00:00 2001 From: simonpj Date: Wed, 14 Jul 1999 14:41:04 +0000 Subject: [PATCH] [project @ 1999-07-14 14:40:20 by simonpj] Main things: * Add splitProductType_maybe to DataCon.lhs, with type splitProductType_maybe :: Type -- A product type, perhaps -> Maybe (TyCon, -- The type constructor [Type], -- Type args of the tycon DataCon, -- The data constructor [Type]) -- Its *representation* arg types Then use it in many places (e.g. worker-wrapper places) instead of a pile of junk * Clean up various uses of dataConArgTys, which were plain wrong because they weren't passed the existential type arguments. Most of these calls are eliminated by using splitProductType_maybe above. I hope I correctly squashed the others. This fixes a bug that Meurig's programs showed up. module FailGHC (killSustainer) where import Weak import IOExts data Sustainer = forall a . Sustainer (IORef (Maybe a)) (IO ()) killSustainer :: Sustainer -> IO () killSustainer (Sustainer _ act) = act The above program used to kill the compiler. * A fairly concerted attack on the Dreaded Space Leak. - Add Type.seqType, CoreSyn.seqExpr, CoreSyn.seqRules - Add some seq'ing when building Ids and IdInfos These reduce the space usage a lot - Add CoreSyn.coreBindsSize, which is pretty strict in the program, and call it when we have -dshow-passes. - Do not put the inlining in an Id that is being plugged into the result-expression of the simplifier. This cures a the 'wedge' in the space profile for reasons I don't understand fully Together, these things reduce the max space usage when compiling PrelNum from 17M to about 7Mbytes. I think there are now *too many* seqs, and they waste work, but I don't have time to find which ones. Furthermore, we aren't done. For some reason, some of the stuff allocated by the simplifier makes it through all during code generation and I don't see why. There's a should-be-unnecessary call to coreBindsSize in Main.main which zaps some, but not all of this space. -dshow-passes reduces space usage a bit, but I don't think it should really. All the measurements were made on a compiler compiled with profiling by GHC 3.03. I hope they carry over to other builds! * One trivial thing: changed all variables 'label' to 'lbl', becuase the former is a keyword with -fglagow-exts in GHC 3.03 (which I was compiling with). Something similar in StringBuffer. --- ghc/compiler/absCSyn/AbsCUtils.lhs | 6 +- ghc/compiler/absCSyn/PprAbsC.lhs | 36 +++---- ghc/compiler/basicTypes/DataCon.lhs | 153 ++++++++++++++--------------- ghc/compiler/basicTypes/Demand.lhs | 10 +- ghc/compiler/basicTypes/Id.lhs | 8 +- ghc/compiler/basicTypes/IdInfo.hi-boot | 3 +- ghc/compiler/basicTypes/IdInfo.hi-boot-5 | 4 +- ghc/compiler/basicTypes/IdInfo.lhs | 86 +++++++++++++--- ghc/compiler/basicTypes/Var.lhs | 22 +++-- ghc/compiler/basicTypes/VarSet.lhs | 9 +- ghc/compiler/codeGen/CgClosure.lhs | 6 +- ghc/compiler/coreSyn/CoreLint.lhs | 11 ++- ghc/compiler/coreSyn/CoreSyn.hi-boot | 3 +- ghc/compiler/coreSyn/CoreSyn.hi-boot-5 | 3 +- ghc/compiler/coreSyn/CoreSyn.lhs | 91 ++++++++++++++++- ghc/compiler/coreSyn/CoreUnfold.hi-boot | 3 +- ghc/compiler/coreSyn/CoreUnfold.hi-boot-5 | 3 +- ghc/compiler/coreSyn/CoreUnfold.lhs | 12 ++- ghc/compiler/coreSyn/Subst.lhs | 49 ++++++--- ghc/compiler/cprAnalysis/CprAnalyse.lhs | 56 ++++------- ghc/compiler/deSugar/DsCCall.lhs | 74 +++++--------- ghc/compiler/deSugar/DsExpr.lhs | 5 +- ghc/compiler/deSugar/DsForeign.lhs | 4 +- ghc/compiler/deSugar/DsUtils.lhs | 25 ++--- ghc/compiler/deSugar/Match.lhs | 10 +- ghc/compiler/hsSyn/HsExpr.lhs | 9 +- ghc/compiler/main/Main.lhs | 6 ++ ghc/compiler/main/MkIface.lhs | 17 ++-- ghc/compiler/nativeGen/AbsCStixGen.lhs | 14 +-- ghc/compiler/nativeGen/AsmCodeGen.lhs | 4 +- ghc/compiler/nativeGen/RegAllocInfo.lhs | 2 +- ghc/compiler/rename/RnExpr.lhs | 23 ++++- ghc/compiler/simplCore/SetLevels.lhs | 4 +- ghc/compiler/simplCore/SimplMonad.lhs | 3 - ghc/compiler/simplCore/SimplUtils.lhs | 24 +++-- ghc/compiler/simplCore/Simplify.lhs | 75 ++++++++------ ghc/compiler/simplStg/StgVarInfo.lhs | 4 +- ghc/compiler/stgSyn/CoreToStg.lhs | 85 +++++++++++----- ghc/compiler/stgSyn/StgLint.lhs | 1 + ghc/compiler/stranal/SaAbsInt.lhs | 46 ++++----- ghc/compiler/stranal/WwLib.lhs | 59 +++-------- ghc/compiler/typecheck/TcEnv.lhs | 4 +- ghc/compiler/typecheck/TcExpr.lhs | 6 +- ghc/compiler/typecheck/TcHsSyn.lhs | 18 ++-- ghc/compiler/typecheck/TcInstDcls.lhs | 11 +-- ghc/compiler/types/TyCon.lhs | 4 +- ghc/compiler/types/Type.lhs | 53 ++++++++-- ghc/compiler/utils/Digraph.lhs | 8 +- ghc/compiler/utils/StringBuffer.lhs | 7 +- 49 files changed, 719 insertions(+), 460 deletions(-) diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index 029c7c7..6f6772c 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -152,7 +152,7 @@ getAmodeRep (CVal _ kind) = kind getAmodeRep (CAddr _) = PtrRep getAmodeRep (CReg magic_id) = magicIdPrimRep magic_id getAmodeRep (CTemp uniq kind) = kind -getAmodeRep (CLbl label kind) = kind +getAmodeRep (CLbl _ kind) = kind getAmodeRep (CCharLike _) = PtrRep getAmodeRep (CIntLike _) = PtrRep getAmodeRep (CLit lit) = literalPrimRep lit @@ -308,9 +308,9 @@ flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast descr) CClosureInfoAndCode cl_info slow_heres fast_heres descr] ) -flatAbsC (CCodeBlock label abs_C) +flatAbsC (CCodeBlock lbl abs_C) = flatAbsC abs_C `thenFlt` \ (absC_heres, absC_tops) -> - returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock label absC_heres) + returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock lbl absC_heres) flatAbsC (CRetDirect uniq slow_code srt liveness) = flatAbsC slow_code `thenFlt` \ (heres, tops) -> diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index f65ab5c..c5c91f1 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -318,16 +318,16 @@ pprAbsC stmt@(CCallTypedef op@(CCallOp op_str is_asm may_gc cconv) results args) let nvrs = grab_non_void_amodes results in ASSERT (length nvrs <= 1) nvrs -pprAbsC (CCodeBlock label abs_C) _ +pprAbsC (CCodeBlock lbl abs_C) _ = if not (maybeToBool(nonemptyAbsC abs_C)) then - pprTrace "pprAbsC: curious empty code block for" (pprCLabel label) empty + pprTrace "pprAbsC: curious empty code block for" (pprCLabel lbl) empty else case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) -> vcat [ - hcat [text (if (externallyVisibleCLabel label) + hcat [text (if (externallyVisibleCLabel lbl) then "FN_(" -- abbreviations to save on output else "IFN_("), - pprCLabel label, text ") {"], + pprCLabel lbl, text ") {"], pp_exts, pp_temps, @@ -498,18 +498,18 @@ pprAbsC stmt@(CRetDirect uniq code srt liveness) _ LvSmall _ -> SLIT("RET_SMALL") LvLarge _ -> SLIT("RET_BIG") -pprAbsC stmt@(CRetVector label amodes srt liveness) _ +pprAbsC stmt@(CRetVector lbl amodes srt liveness) _ = case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> vcat [ pp_exts, hcat [ ptext SLIT("VEC_INFO_") <> int size, lparen, - pprCLabel label, comma, + pprCLabel lbl, comma, pp_liveness liveness, comma, -- bitmap liveness mask pp_srt_info srt, -- SRT ptext type_str, comma, - ppLocalness label, comma + ppLocalness lbl, comma ], nest 2 (sep (punctuate comma (map ppr_item amodes))), text ");" @@ -530,8 +530,8 @@ pprAbsC (CCostCentreStackDecl ccs) _ = pprCostCentreStackDecl ccs \end{code} \begin{code} -ppLocalness label - = if (externallyVisibleCLabel label) +ppLocalness lbl + = if (externallyVisibleCLabel lbl) then empty else ptext SLIT("static ") @@ -1137,7 +1137,7 @@ ppr_amode (CReg magic_id) = pprMagicId magic_id ppr_amode (CTemp uniq kind) = char '_' <> pprUnique uniq <> char '_' -ppr_amode (CLbl label kind) = pprCLabelAddr label +ppr_amode (CLbl lbl kind) = pprCLabelAddr lbl ppr_amode (CCharLike ch) = hcat [ptext SLIT("CHARLIKE_CLOSURE"), char '(', pprAmode ch, rparen ] @@ -1409,11 +1409,11 @@ tempSeenTE uniq env@(seen_uniqs, seen_labels) False) labelSeenTE :: CLabel -> TeM Bool -labelSeenTE label env@(seen_uniqs, seen_labels) - = if (label `elementOfCLabelSet` seen_labels) +labelSeenTE lbl env@(seen_uniqs, seen_labels) + = if (lbl `elementOfCLabelSet` seen_labels) then (env, True) else ((seen_uniqs, - addToCLabelSet seen_labels label), + addToCLabelSet seen_labels lbl), False) \end{code} @@ -1466,7 +1466,7 @@ ppr_decls_AbsC (CSwitch discrim alts deflt) where ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC -ppr_decls_AbsC (CCodeBlock label absC) +ppr_decls_AbsC (CCodeBlock lbl absC) = ppr_decls_AbsC absC ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre) @@ -1550,13 +1550,13 @@ ppr_decls_Amode (CTemp uniq kind) returnTE (if temp_seen then Nothing else Just (pprTempDecl uniq kind), Nothing) -ppr_decls_Amode (CLbl label VoidRep) +ppr_decls_Amode (CLbl lbl VoidRep) = returnTE (Nothing, Nothing) -ppr_decls_Amode (CLbl label kind) - = labelSeenTE label `thenTE` \ label_seen -> +ppr_decls_Amode (CLbl lbl kind) + = labelSeenTE lbl `thenTE` \ label_seen -> returnTE (Nothing, - if label_seen then Nothing else Just (pprExternDecl False{-not in an SRT decl-} label)) + if label_seen then Nothing else Just (pprExternDecl False{-not in an SRT decl-} lbl)) ppr_decls_Amode (CMacroExpr _ _ amodes) = ppr_decls_Amodes amodes diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs index 2c5f7b4..f8aa66a 100644 --- a/ghc/compiler/basicTypes/DataCon.lhs +++ b/ghc/compiler/basicTypes/DataCon.lhs @@ -9,12 +9,12 @@ module DataCon ( ConTag, fIRST_TAG, mkDataCon, dataConType, dataConSig, dataConName, dataConTag, - dataConOrigArgTys, dataConArgTys, dataConTyCon, + dataConArgTys, dataConTyCon, dataConRawArgTys, dataConAllRawArgTys, dataConFieldLabels, dataConStrictMarks, dataConSourceArity, dataConNumFields, dataConNumInstArgs, dataConId, dataConRepStrictness, isNullaryDataCon, isTupleCon, isUnboxedTupleCon, - isExistentialDataCon, + isExistentialDataCon, splitProductType_maybe, StrictnessMark(..), -- Representation visible to MkId only markedStrict, notMarkedStrict, markedUnboxed, maybeMarkedUnboxed @@ -32,10 +32,10 @@ import Type ( Type, ThetaType, TauType, splitAlgTyConApp_maybe ) import PprType -import TyCon ( TyCon, tyConDataCons, isDataTyCon, +import TyCon ( TyCon, tyConDataCons, isDataTyCon, isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon ) import Class ( classTyCon ) -import Name ( Name, NamedThing(..), nameUnique, isLocallyDefinedName ) +import Name ( Name, NamedThing(..), nameUnique, isLocallyDefined ) import Var ( TyVar, Id ) import FieldLabel ( FieldLabel ) import BasicTypes ( Arity ) @@ -44,6 +44,7 @@ import Outputable import Unique ( Unique, Uniquable(..) ) import CmdLineOpts ( opt_UnboxStrictFields ) import UniqSet +import Maybes ( maybeToBool ) import Maybe import Util ( assoc ) \end{code} @@ -246,76 +247,8 @@ mk_dict_strict_mark (clas,tys) -- Don't mark newtype things as strict! isDataTyCon (classTyCon clas) = MarkedStrict | otherwise = NotMarkedStrict - --- We attempt to unbox/unpack a strict field when either: --- (i) The tycon is imported, and the field is marked '! !', or --- (ii) The tycon is defined in this module, the field is marked '!', --- and the -funbox-strict-fields flag is on. --- --- This ensures that if we compile some modules with -funbox-strict-fields and --- some without, the compiler doesn't get confused about the constructor --- representations. - -unbox_strict_arg_ty :: TyCon -> StrictnessMark -> Type -> (StrictnessMark, [Type]) -unbox_strict_arg_ty tycon NotMarkedStrict ty - = (NotMarkedStrict, [ty]) -unbox_strict_arg_ty tycon MarkedStrict ty - | not opt_UnboxStrictFields - || not (isLocallyDefinedName (getName tycon)) = (MarkedStrict, [ty]) -unbox_strict_arg_ty tycon marked_unboxed ty - -- MarkedUnboxed || (MarkedStrict && opt_UnboxStrictFields && not imported) - = case splitAlgTyConApp_maybe ty of - Just (tycon,_,[]) - -> panic (showSDoc (hcat [ - text "unbox_strict_arg_ty: constructors for ", - ppr tycon, - text " not available." - ])) - Just (tycon,ty_args,[con]) - -> case maybe_unpack_fields emptyUniqSet - (zip (dataConOrigArgTys con ty_args) - (dcUserStricts con)) - of - Nothing -> (MarkedStrict, [ty]) - Just tys -> (MarkedUnboxed con tys, tys) - _ -> (MarkedStrict, [ty]) - --- bail out if we encounter the same tycon twice. This avoids problems like --- --- data A = !B --- data B = !A --- --- where no useful unpacking can be done. - -maybe_unpack_field :: UniqSet TyCon -> Type -> StrictnessMark -> Maybe [Type] -maybe_unpack_field set ty NotMarkedStrict - = Just [ty] -maybe_unpack_field set ty MarkedStrict | not opt_UnboxStrictFields - = Just [ty] -maybe_unpack_field set ty strict - = case splitAlgTyConApp_maybe ty of - Just (tycon,ty_args,[con]) - -- loop breaker - | tycon `elementOfUniqSet` set -> Nothing - -- don't unpack constructors with existential tyvars - | not (null ex_tyvars) -> Nothing - -- ok, let's do it - | otherwise -> - let set' = addOneToUniqSet set tycon in - maybe_unpack_fields set' - (zip (dataConOrigArgTys con ty_args) - (dcUserStricts con)) - where (_, _, ex_tyvars, _, _, _) = dataConSig con - _ -> Just [ty] - -maybe_unpack_fields :: UniqSet TyCon -> [(Type,StrictnessMark)] -> Maybe [Type] -maybe_unpack_fields set tys - | all isJust unpacked_fields = Just (concat (catMaybes unpacked_fields)) - | otherwise = Nothing - where unpacked_fields = map (\(ty,str) -> maybe_unpack_field set ty str) tys \end{code} - \begin{code} dataConName :: DataCon -> Name dataConName = dcName @@ -363,7 +296,7 @@ dataConSig (MkData {dcTyVars = tyvars, dcTheta = theta, dcOrigArgTys = arg_tys, dcTyCon = tycon}) = (tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon) -dataConArgTys, dataConOrigArgTys :: DataCon +dataConArgTys :: DataCon -> [Type] -- Instantiated at these types -- NB: these INCLUDE the existentially quantified arg types -> [Type] -- Needs arguments of these types @@ -374,11 +307,6 @@ dataConArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars, dcExTyVars = ex_tyvars, dcExTheta = ex_theta}) inst_tys = map (substTy (mkTyVarSubst (tyvars ++ ex_tyvars) inst_tys)) ([mkDictTy cls tys | (cls,tys) <- ex_theta] ++ arg_tys) - -dataConOrigArgTys (MkData {dcOrigArgTys = arg_tys, dcTyVars = tyvars, - dcExTyVars = ex_tyvars, dcExTheta = ex_theta}) inst_tys - = map (substTy (mkTyVarSubst (tyvars ++ ex_tyvars) inst_tys)) - ([mkDictTy cls tys | (cls,tys) <- ex_theta] ++ arg_tys) \end{code} These two functions get the real argument types of the constructor, @@ -421,3 +349,72 @@ isUnboxedTupleCon (MkData {dcTyCon = tc}) = isUnboxedTupleTyCon tc isExistentialDataCon :: DataCon -> Bool isExistentialDataCon (MkData {dcExTyVars = tvs}) = not (null tvs) \end{code} + + +%************************************************************************ +%* * +\subsection{Splitting products} +%* * +%************************************************************************ + +\begin{code} +splitProductType_maybe + :: Type -- A product type, perhaps + -> Maybe (TyCon, -- The type constructor + [Type], -- Type args of the tycon + DataCon, -- The data constructor + [Type]) -- Its *representation* arg types + + -- Returns (Just ...) for any + -- single-constructor + -- non-recursive type + -- not existentially quantified + -- type whether a data type or a new type + -- + -- Rejecing existentials is conservative. Maybe some things + -- could be made to work with them, but I'm not going to sweat + -- it through till someone finds it's important. + +splitProductType_maybe ty + = case splitAlgTyConApp_maybe ty of + Just (tycon,ty_args,[data_con]) + | isProductTyCon tycon && -- Checks for non-recursive + not (isExistentialDataCon data_con) + -> Just (tycon, ty_args, data_con, data_con_arg_tys) + where + data_con_arg_tys = map (substTy (mkTyVarSubst (dcTyVars data_con) ty_args)) + (dcRepArgTys data_con) + other -> Nothing + + +-- We attempt to unbox/unpack a strict field when either: +-- (i) The tycon is imported, and the field is marked '! !', or +-- (ii) The tycon is defined in this module, the field is marked '!', +-- and the -funbox-strict-fields flag is on. +-- +-- This ensures that if we compile some modules with -funbox-strict-fields and +-- some without, the compiler doesn't get confused about the constructor +-- representations. + +unbox_strict_arg_ty :: TyCon -> StrictnessMark -> Type -> (StrictnessMark, [Type]) + +unbox_strict_arg_ty tycon strict_mark ty + | case strict_mark of + NotMarkedStrict -> False + MarkedUnboxed _ _ -> True + MarkedStrict -> opt_UnboxStrictFields && + isLocallyDefined tycon && + maybeToBool maybe_product && + isDataTyCon arg_tycon + -- We can't look through newtypes in arguments (yet) + = (MarkedUnboxed con arg_tys, arg_tys) + + | otherwise + = (strict_mark, [ty]) + + where + maybe_product = splitProductType_maybe ty + Just (arg_tycon, _, con, arg_tys) = maybe_product +\end{code} + + diff --git a/ghc/compiler/basicTypes/Demand.lhs b/ghc/compiler/basicTypes/Demand.lhs index 7a4dbfe..cb45ddc 100644 --- a/ghc/compiler/basicTypes/Demand.lhs +++ b/ghc/compiler/basicTypes/Demand.lhs @@ -10,7 +10,7 @@ module Demand( wwLazy, wwStrict, wwUnpackData, wwUnpackNew, wwPrim, wwEnum, isStrict, isLazy, isPrim, - pprDemands + pprDemands, seqDemand, seqDemands ) where #include "HsVersions.h" @@ -63,6 +63,14 @@ wwUnpackData xs = WwUnpack DataType False xs wwUnpackNew x = WwUnpack NewType False [x] wwPrim = WwPrim wwEnum = WwEnum + +seqDemand :: Demand -> () +seqDemand (WwLazy a) = a `seq` () +seqDemand (WwUnpack nd b ds) = nd `seq` b `seq` seqDemands ds +seqDemand other = () + +seqDemands [] = () +seqDemands (d:ds) = seqDemand d `seq` seqDemands ds \end{code} diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index aa086a1..25ff7b5 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -18,7 +18,7 @@ module Id ( -- Modifying an Id setIdName, setIdUnique, setIdType, setIdNoDiscard, - setIdInfo, modifyIdInfo, maybeModifyIdInfo, + setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, -- Predicates omitIfaceSigForId, @@ -70,11 +70,11 @@ import Var ( Id, DictId, isId, mkIdVar, idName, idType, idUnique, idInfo, setIdName, setVarType, setIdUnique, - setIdInfo, modifyIdInfo, maybeModifyIdInfo, + setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, externallyVisibleId ) import VarSet -import Type ( Type, tyVarsOfType, typePrimRep, addFreeTyVars ) +import Type ( Type, tyVarsOfType, typePrimRep, addFreeTyVars, seqType ) import IdInfo import Demand ( Demand, isStrict, wwLazy ) import Name ( Name, OccName, @@ -170,7 +170,7 @@ idFreeTyVars id = tyVarsOfType (idType id) setIdType :: Id -> Type -> Id -- Add free tyvar info to the type -setIdType id ty = setVarType id (addFreeTyVars ty) +setIdType id ty = seqType ty `seq` setVarType id (addFreeTyVars ty) idPrimRep :: Id -> PrimRep idPrimRep id = typePrimRep (idType id) diff --git a/ghc/compiler/basicTypes/IdInfo.hi-boot b/ghc/compiler/basicTypes/IdInfo.hi-boot index d57e7be..f88c4f6 100644 --- a/ghc/compiler/basicTypes/IdInfo.hi-boot +++ b/ghc/compiler/basicTypes/IdInfo.hi-boot @@ -1,5 +1,6 @@ _interface_ IdInfo 1 _exports_ -IdInfo IdInfo ; +IdInfo IdInfo seqIdInfo ; _declarations_ 1 data IdInfo ; +1 seqIdInfo _:_ IdInfo -> PrelBase.() ;; diff --git a/ghc/compiler/basicTypes/IdInfo.hi-boot-5 b/ghc/compiler/basicTypes/IdInfo.hi-boot-5 index 5c76c93..7e3e942 100644 --- a/ghc/compiler/basicTypes/IdInfo.hi-boot-5 +++ b/ghc/compiler/basicTypes/IdInfo.hi-boot-5 @@ -1,3 +1,5 @@ __interface IdInfo 1 0 where -__export IdInfo IdInfo ; +__export IdInfo IdInfo seqIdInfo ; 1 data IdInfo ; +1 seqIdInfo :: IdInfo -> PrelBase.Z0T ; + diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 2c36363..52a4ad5 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -10,7 +10,7 @@ Haskell. [WDP 94/11]) module IdInfo ( IdInfo, -- Abstract - vanillaIdInfo, mkIdInfo, + vanillaIdInfo, mkIdInfo, seqIdInfo, megaSeqIdInfo, -- Flavour IdFlavour(..), flavourInfo, @@ -57,7 +57,7 @@ module IdInfo ( CprInfo(..), cprInfo, setCprInfo, ppCprInfo, noCprInfo, -- Zapping - zapLamIdInfo, zapFragileIdInfo, + zapLamIdInfo, zapFragileIdInfo, zapIdInfoForStg, -- Lambda-bound variable info LBVarInfo(..), lbvarInfo, setLBVarInfo, noLBVarInfo @@ -66,13 +66,13 @@ module IdInfo ( #include "HsVersions.h" -import {-# SOURCE #-} CoreUnfold ( Unfolding, noUnfolding, hasUnfolding ) -import {-# SOURCE #-} CoreSyn ( CoreExpr, CoreRules, emptyCoreRules, isEmptyCoreRules ) +import {-# SOURCE #-} CoreUnfold ( Unfolding, noUnfolding, hasUnfolding, seqUnfolding ) +import {-# SOURCE #-} CoreSyn ( CoreExpr, CoreRules, emptyCoreRules, isEmptyCoreRules, seqRules ) import {-# SOURCE #-} Const ( Con ) import Var ( Id ) import FieldLabel ( FieldLabel ) -import Demand ( Demand, isStrict, isLazy, wwLazy, pprDemands ) +import Demand ( Demand, isStrict, isLazy, wwLazy, pprDemands, seqDemand, seqDemands ) import Type ( UsageAnn ) import Outputable import Maybe ( isJust ) @@ -121,21 +121,47 @@ data IdInfo cafInfo :: CafInfo, cprInfo :: CprInfo, -- Function always constructs a product result lbvarInfo :: LBVarInfo, -- Info about a lambda-bound variable - inlinePragInfo :: !InlinePragInfo -- Inline pragmas + inlinePragInfo :: InlinePragInfo -- Inline pragmas } + +seqIdInfo :: IdInfo -> () +seqIdInfo (IdInfo {}) = () + +megaSeqIdInfo :: IdInfo -> () +megaSeqIdInfo info + = seqFlavour (flavourInfo info) `seq` + seqArity (arityInfo info) `seq` + seqDemand (demandInfo info) `seq` + seqRules (specInfo info) `seq` + seqStrictness (strictnessInfo info) `seq` + seqWorker (workerInfo info) `seq` + +-- seqUnfolding (unfoldingInfo info) `seq` +-- Omitting this improves runtimes a little, presumably because +-- some unfoldings are not calculated at all + + seqCaf (cafInfo info) `seq` + seqCpr (cprInfo info) `seq` + seqLBVar (lbvarInfo info) `seq` + seqInlinePrag (inlinePragInfo info) \end{code} Setters \begin{code} +setWorkerInfo info wk = wk `seq` info { workerInfo = wk } +setSpecInfo info sp = sp `seq` info { specInfo = sp } +setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr } +setStrictnessInfo info st = st `seq` info { strictnessInfo = st } + -- Try to avoid spack leaks by seq'ing + +setUnfoldingInfo info uf = info { unfoldingInfo = uf } + -- We do *not* seq on the unfolding info, For some reason, doing so + -- actually increases residency significantly. + setUpdateInfo info ud = info { updateInfo = ud } setDemandInfo info dd = info { demandInfo = dd } -setStrictnessInfo info st = info { strictnessInfo = st } -setWorkerInfo info wk = info { workerInfo = wk } -setSpecInfo info sp = info { specInfo = sp } setArityInfo info ar = info { arityInfo = ar } -setInlinePragInfo info pr = info { inlinePragInfo = pr } -setUnfoldingInfo info uf = info { unfoldingInfo = uf } setCafInfo info cf = info { cafInfo = cf } setCprInfo info cp = info { cprInfo = cp } setLBVarInfo info lb = info { lbvarInfo = lb } @@ -229,6 +255,9 @@ ppFlavourInfo (ConstantId _) = ptext SLIT("[Constr]") ppFlavourInfo (RecordSelId _) = ptext SLIT("[RecSel]") ppFlavourInfo SpecPragmaId = ptext SLIT("[SpecPrag]") ppFlavourInfo NoDiscardId = ptext SLIT("[NoDiscard]") + +seqFlavour :: IdFlavour -> () +seqFlavour f = f `seq` () \end{code} The @SpecPragmaId@ exists only to make Ids that are @@ -258,6 +287,9 @@ data ArityInfo | ArityExactly Int -- Arity is exactly this | ArityAtLeast Int -- Arity is this or greater +seqArity :: ArityInfo -> () +seqArity a = arityLowerBound a `seq` () + exactArity = ArityExactly atLeastArity = ArityAtLeast unknownArity = UnknownArity @@ -307,6 +339,12 @@ data InlinePragInfo | IMustBeINLINEd -- Absolutely must inline; used for PrimOps and -- constructors only. +seqInlinePrag :: InlinePragInfo -> () +seqInlinePrag (ICanSafelyBeINLINEd occ alts) + = occ `seq` alts `seq` () +seqInlinePrag other + = () + instance Outputable InlinePragInfo where ppr NoInlinePragInfo = empty ppr IMustBeINLINEd = ptext SLIT("__UU") @@ -367,6 +405,10 @@ data StrictnessInfo -- 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 + +seqStrictness :: StrictnessInfo -> () +seqStrictness (StrictnessInfo ds b) = b `seq` seqDemands ds +seqStrictness other = () \end{code} \begin{code} @@ -414,6 +456,10 @@ mkWorkerInfo :: Id -> WorkerInfo mkWorkerInfo wk_id = Just wk_id -} +seqWorker :: WorkerInfo -> () +seqWorker (Just id) = id `seq` () +seqWorker Nothing = () + ppWorkerInfo Nothing = empty ppWorkerInfo (Just wk_id) = ptext SLIT("__P") <+> ppr wk_id @@ -480,6 +526,8 @@ data CafInfo -- | OneCafRef Id +seqCaf c = c `seq` () + ppCafInfo NoCafRefs = ptext SLIT("__C") ppCafInfo MayHaveCafRefs = empty \end{code} @@ -569,6 +617,13 @@ zapLamIdInfo info@(IdInfo {inlinePragInfo = inline_prag, demandInfo = demand}) other -> inline_prag \end{code} +\begin{code} +zapIdInfoForStg :: IdInfo -> IdInfo + -- Return only the info needed for STG stuff + -- Namely, nothing, I think +zapIdInfoForStg info = vanillaIdInfo +\end{code} + %************************************************************************ %* * @@ -616,6 +671,13 @@ data CprInfo \end{code} \begin{code} +seqCpr :: CprInfo -> () +seqCpr (CPRInfo cs) = seqCprs cs +seqCpr NoCPRInfo = () + +seqCprs [] = () +seqCprs (c:cs) = seqCpr c `seq` seqCprs cs + noCprInfo = NoCPRInfo @@ -658,6 +720,8 @@ data LBVarInfo -- HACK ALERT! placing this info here is a short-term hack, -- but it minimises changes to the rest of the compiler. -- Hack agreed by SLPJ/KSW 1999-04. + +seqLBVar l = l `seq` () \end{code} \begin{code} diff --git a/ghc/compiler/basicTypes/Var.lhs b/ghc/compiler/basicTypes/Var.lhs index 4d5be70..d80eab6 100644 --- a/ghc/compiler/basicTypes/Var.lhs +++ b/ghc/compiler/basicTypes/Var.lhs @@ -1,4 +1,4 @@ -% +s% % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section{@Vars@: Variables} @@ -26,14 +26,14 @@ module Var ( -- Ids Id, DictId, idName, idType, idUnique, idInfo, modifyIdInfo, maybeModifyIdInfo, - setIdName, setIdUnique, setIdInfo, + setIdName, setIdUnique, setIdInfo, lazySetIdInfo, mkIdVar, isId, externallyVisibleId ) where #include "HsVersions.h" import {-# SOURCE #-} Type( Type, Kind ) -import {-# SOURCE #-} IdInfo( IdInfo ) +import {-# SOURCE #-} IdInfo( IdInfo, seqIdInfo ) import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey ) import Name ( Name, OccName, NamedThing(..), @@ -118,8 +118,9 @@ varUnique :: Var -> Unique varUnique (Var {realUnique = uniq}) = mkUniqueGrimily uniq setVarUnique :: Var -> Unique -> Var -setVarUnique var uniq = var {realUnique = getKey uniq, - varName = setNameUnique (varName var) uniq} +setVarUnique var@(Var {varName = name}) uniq + = var {realUnique = getKey uniq, + varName = setNameUnique name uniq} setVarName :: Var -> Name -> Var setVarName var new_name @@ -266,11 +267,18 @@ setIdUnique = setVarUnique setIdName :: Id -> Name -> Id setIdName = setVarName +lazySetIdInfo :: Id -> IdInfo -> Id +lazySetIdInfo var info = var {varInfo = info} + setIdInfo :: Id -> IdInfo -> Id -setIdInfo var info = var {varInfo = info} +setIdInfo var info = seqIdInfo info `seq` var {varInfo = info} + -- Try to avoid spack leaks by seq'ing modifyIdInfo :: (IdInfo -> IdInfo) -> Id -> Id -modifyIdInfo fn var@(Var {varInfo = info}) = var {varInfo = fn info} +modifyIdInfo fn var@(Var {varInfo = info}) + = seqIdInfo new_info `seq` var {varInfo = new_info} + where + new_info = fn info -- maybeModifyIdInfo tries to avoid unnecesary thrashing maybeModifyIdInfo :: (IdInfo -> Maybe IdInfo) -> Id -> Id diff --git a/ghc/compiler/basicTypes/VarSet.lhs b/ghc/compiler/basicTypes/VarSet.lhs index 277c5d3..18579d3 100644 --- a/ghc/compiler/basicTypes/VarSet.lhs +++ b/ghc/compiler/basicTypes/VarSet.lhs @@ -13,7 +13,7 @@ module VarSet ( intersectVarSet, intersectsVarSet, isEmptyVarSet, delVarSet, delVarSetByKey, minusVarSet, foldVarSet, filterVarSet, - lookupVarSet, mapVarSet, + lookupVarSet, mapVarSet, sizeVarSet, seqVarSet, uniqAway ) where @@ -58,6 +58,7 @@ lookupVarSet :: VarSet -> Var -> Maybe Var -- Returns the set element, which may be -- (==) to the argument, but not the same as mapVarSet :: (Var -> Var) -> VarSet -> VarSet +sizeVarSet :: VarSet -> Int filterVarSet :: (Var -> Bool) -> VarSet -> VarSet subVarSet :: VarSet -> VarSet -> Bool @@ -79,12 +80,18 @@ mkVarSet = mkUniqSet foldVarSet = foldUniqSet lookupVarSet = lookupUniqSet mapVarSet = mapUniqSet +sizeVarSet = sizeUniqSet filterVarSet = filterUniqSet a `subVarSet` b = isEmptyVarSet (a `minusVarSet` b) delVarSetByKey = delFromUFM_Directly -- Can't be bothered to add this to UniqSet \end{code} \begin{code} +seqVarSet :: VarSet -> () +seqVarSet s = sizeVarSet s `seq` () +\end{code} + +\begin{code} uniqAway :: VarSet -> Var -> Var -- Give the Var a new unique, different to any in the VarSet uniqAway set var diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index e04a4c2..26c7e51 100644 --- a/ghc/compiler/codeGen/CgClosure.lhs +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgClosure.lhs,v 1.33 1999/06/24 13:04:17 simonmar Exp $ +% $Id: CgClosure.lhs,v 1.34 1999/07/14 14:40:28 simonpj Exp $ % \section[CgClosure]{Code generation for closures} @@ -538,7 +538,7 @@ argSatisfactionCheck closure_info \begin{code} thunkWrapper:: ClosureInfo -> CLabel -> Code -> Code -thunkWrapper closure_info label thunk_code +thunkWrapper closure_info lbl thunk_code = -- Stack and heap overflow checks nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points -> @@ -554,7 +554,7 @@ thunkWrapper closure_info label thunk_code else absC AbsCNop) `thenC` -- stack and/or heap checks - thunkChecks label node_points ( + thunkChecks lbl node_points ( -- Overwrite with black hole if necessary blackHoleIt closure_info node_points `thenC` diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index 95d4118..fb9f014 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -12,7 +12,7 @@ module CoreLint ( #include "HsVersions.h" -import IO ( hPutStr, stderr ) +import IO ( hPutStr, hPutStrLn, stderr ) import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting, opt_PprStyle_Debug ) import CoreSyn @@ -60,7 +60,7 @@ and do Core Lint when necessary. beginPass :: String -> IO () beginPass pass_name | opt_D_show_passes - = hPutStr stderr ("*** " ++ pass_name ++ "\n") + = hPutStrLn stderr ("*** " ++ pass_name) | otherwise = return () @@ -68,6 +68,13 @@ beginPass pass_name endPass :: String -> Bool -> [CoreBind] -> IO [CoreBind] endPass pass_name dump_flag binds = do + -- Report result size if required + -- This has the side effect of forcing the intermediate to be evaluated + if opt_D_show_passes then + hPutStrLn stderr (" Result size = " ++ show (coreBindsSize binds)) + else + return () + -- Report verbosely, if required dumpIfSet dump_flag pass_name (pprCoreBindings binds) diff --git a/ghc/compiler/coreSyn/CoreSyn.hi-boot b/ghc/compiler/coreSyn/CoreSyn.hi-boot index f8ae27c..3ea40f4 100644 --- a/ghc/compiler/coreSyn/CoreSyn.hi-boot +++ b/ghc/compiler/coreSyn/CoreSyn.hi-boot @@ -1,6 +1,6 @@ _interface_ CoreSyn 1 _exports_ -CoreSyn CoreExpr CoreRule CoreRules emptyCoreRules isEmptyCoreRules ; +CoreSyn CoreExpr CoreRule CoreRules emptyCoreRules isEmptyCoreRules seqRules ; _declarations_ -- Needed by IdInfo @@ -10,4 +10,5 @@ _declarations_ 1 data CoreRule ; 1 type CoreRules = [CoreRule] ; 1 emptyCoreRules _:_ CoreRules ;; +1 seqRules _:_ CoreRules -> PrelBase.() ;; 1 isEmptyCoreRules _:_ CoreRules -> PrelBase.Bool ;; diff --git a/ghc/compiler/coreSyn/CoreSyn.hi-boot-5 b/ghc/compiler/coreSyn/CoreSyn.hi-boot-5 index 58df923..d8ad7ff 100644 --- a/ghc/compiler/coreSyn/CoreSyn.hi-boot-5 +++ b/ghc/compiler/coreSyn/CoreSyn.hi-boot-5 @@ -1,5 +1,5 @@ __interface CoreSyn 1 0 where -__export CoreSyn CoreExpr CoreRules CoreRule emptyCoreRules isEmptyCoreRules ; +__export CoreSyn CoreExpr CoreRules CoreRule emptyCoreRules isEmptyCoreRules seqRules ; -- Needed by IdInfo 1 type CoreExpr = Expr Var.IdOrTyVar; @@ -8,4 +8,5 @@ __export CoreSyn CoreExpr CoreRules CoreRule emptyCoreRules isEmptyCoreRules ; 1 data CoreRule ; 1 type CoreRules = [CoreRule] ; 1 emptyCoreRules :: CoreRules ; +1 seqRules :: CoreRules -> PrelBase.Z0T ; 1 isEmptyCoreRules :: CoreRules -> PrelBase.Bool ; diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index e59fec1..c1eb1f0 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -22,6 +22,12 @@ module CoreSyn ( isValArg, isTypeArg, valArgCount, valBndrCount, + -- Seq stuff + seqRules, seqExpr, seqExprs, + + -- Size + coreBindsSize, + -- Annotated expressions AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, deAnnotate, @@ -37,9 +43,9 @@ import TysWiredIn ( boolTy, stringTy, nilDataCon ) import CostCentre ( CostCentre, isDupdCC, noCostCentre ) import Var ( Var, Id, TyVar, IdOrTyVar, isTyVar, isId, idType ) import VarEnv -import Id ( mkWildId, getInlinePragma ) -import Type ( Type, UsageAnn, mkTyVarTy, isUnLiftedType ) -import IdInfo ( InlinePragInfo(..) ) +import Id ( mkWildId, getInlinePragma, idInfo ) +import Type ( Type, UsageAnn, mkTyVarTy, isUnLiftedType, seqType ) +import IdInfo ( InlinePragInfo(..), megaSeqIdInfo ) import Const ( Con(..), DataCon, Literal(NoRepStr), PrimOp ) import TysWiredIn ( trueDataCon, falseDataCon ) import VarSet @@ -384,6 +390,85 @@ valArgCount (other : args) = 1 + valArgCount args %************************************************************************ %* * +\subsection{Seq stuff} +%* * +%************************************************************************ + +\begin{code} +seqExpr :: CoreExpr -> () +seqExpr (Var v) = v `seq` () +seqExpr (Con c as) = seqExprs as +seqExpr (App f a) = seqExpr f `seq` seqExpr a +seqExpr (Lam b e) = seqBndr b `seq` seqExpr e +seqExpr (Let b e) = seqBind b `seq` seqExpr e +seqExpr (Case e b as) = seqExpr e `seq` seqBndr b `seq` seqAlts as +seqExpr (Note n e) = seqNote n `seq` seqExpr e +seqExpr (Type t) = seqType t + +seqExprs [] = () +seqExprs (e:es) = seqExpr e `seq` seqExprs es + +seqNote (Coerce t1 t2) = seqType t1 `seq` seqType t2 +seqNote other = () + +seqBndr b = b `seq` () + +seqBndrs [] = () +seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs + +seqBind (NonRec b e) = seqBndr b `seq` seqExpr e +seqBind (Rec prs) = seqPairs prs + +seqPairs [] = () +seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs + +seqAlts [] = () +seqAlts ((c,bs,e):alts) = seqBndrs bs `seq` seqExpr e `seq` seqAlts alts + +seqRules :: CoreRules -> () +seqRules (Rules rules fvs) = seq_rules rules `seq` seqVarSet fvs + +seq_rules [] = () +seq_rules (Rule fs bs es e : rules) = seqBndrs bs `seq` seqExprs (e:es) `seq` seq_rules rules +\end{code} + +\begin{code} +coreBindsSize :: [CoreBind] -> Int +coreBindsSize bs = foldr ((+) . bindSize) 0 bs + +exprSize :: CoreExpr -> Int + -- A measure of the size of the expressions + -- It also forces the expression pretty drastically as a side effect +exprSize (Var v) = varSize v +exprSize (Con c as) = c `seq` exprsSize as +exprSize (App f a) = exprSize f + exprSize a +exprSize (Lam b e) = varSize b + exprSize e +exprSize (Let b e) = bindSize b + exprSize e +exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as +exprSize (Note n e) = exprSize e +exprSize (Type t) = seqType t `seq` 1 + +exprsSize = foldr ((+) . exprSize) 0 + +varSize :: IdOrTyVar -> Int +varSize b | isTyVar b = 1 + | otherwise = seqType (idType b) `seq` + megaSeqIdInfo (idInfo b) `seq` + 1 + +varsSize = foldr ((+) . varSize) 0 + +bindSize (NonRec b e) = varSize b + exprSize e +bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs + +pairSize (b,e) = varSize b + exprSize e + +altSize (c,bs,e) = c `seq` varsSize bs + exprSize e +\end{code} + + +%************************************************************************ +%* * \subsection{Annotated core; annotation at every node in the tree} %* * %************************************************************************ diff --git a/ghc/compiler/coreSyn/CoreUnfold.hi-boot b/ghc/compiler/coreSyn/CoreUnfold.hi-boot index e670f2d..86ee1da 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.hi-boot +++ b/ghc/compiler/coreSyn/CoreUnfold.hi-boot @@ -1,10 +1,11 @@ _interface_ CoreUnfold 1 _exports_ -CoreUnfold Unfolding UnfoldingGuidance mkUnfolding noUnfolding hasUnfolding isEvaldUnfolding; +CoreUnfold Unfolding UnfoldingGuidance mkUnfolding noUnfolding hasUnfolding isEvaldUnfolding seqUnfolding ; _declarations_ 1 data Unfolding; 1 data UnfoldingGuidance; 1 mkUnfolding _:_ CoreSyn.CoreExpr -> Unfolding ;; 1 noUnfolding _:_ Unfolding ;; 1 hasUnfolding _:_ Unfolding -> PrelBase.Bool ;; +1 seqUnfolding _:_ Unfolding -> PrelBase.() ;; 1 isEvaldUnfolding _:_ Unfolding -> PrelBase.Bool ;; diff --git a/ghc/compiler/coreSyn/CoreUnfold.hi-boot-5 b/ghc/compiler/coreSyn/CoreUnfold.hi-boot-5 index d86aa99..32c1673 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.hi-boot-5 +++ b/ghc/compiler/coreSyn/CoreUnfold.hi-boot-5 @@ -1,8 +1,9 @@ __interface CoreUnfold 1 0 where -__export CoreUnfold Unfolding UnfoldingGuidance mkUnfolding noUnfolding hasUnfolding isEvaldUnfolding; +__export CoreUnfold Unfolding UnfoldingGuidance mkUnfolding noUnfolding hasUnfolding isEvaldUnfolding seqUnfolding ; 1 data Unfolding; 1 data UnfoldingGuidance; 1 mkUnfolding :: CoreSyn.CoreExpr -> Unfolding ; 1 noUnfolding :: Unfolding ; 1 hasUnfolding :: Unfolding -> PrelBase.Bool ; +1 seqUnfolding :: Unfolding -> PrelBase.Z0T ; 1 isEvaldUnfolding :: Unfolding -> PrelBase.Bool ; diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 0c8e6e1..c59b937 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -16,7 +16,7 @@ find, unsurprisingly, a Core expression. module CoreUnfold ( Unfolding, UnfoldingGuidance, -- types - noUnfolding, mkUnfolding, + noUnfolding, mkUnfolding, seqUnfolding, mkOtherCon, otherCons, unfoldingTemplate, maybeUnfoldingTemplate, isEvaldUnfolding, isCheapUnfolding, @@ -26,7 +26,7 @@ module CoreUnfold ( certainlySmallEnoughToInline, okToUnfoldInHiFile, - calcUnfoldingGuidance, + calcUnfoldingGuidance, callSiteInline, blackListed ) where @@ -92,6 +92,11 @@ data Unfolding Bool -- exprIsValue template (cached); it is ok to discard a `seq` on -- this variable UnfoldingGuidance -- Tells about the *size* of the template. + +seqUnfolding :: Unfolding -> () +seqUnfolding (CoreUnfolding e b1 b2 g) + = seqExpr e `seq` b1 `seq` b2 `seq` seqGuidance g +seqUnfolding other = () \end{code} \begin{code} @@ -151,6 +156,9 @@ data UnfoldingGuidance 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.) + +seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` () +seqGuidance other = () \end{code} \begin{code} diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs index 64d4d50..7bc2c10 100644 --- a/ghc/compiler/coreSyn/Subst.lhs +++ b/ghc/compiler/coreSyn/Subst.lhs @@ -32,7 +32,8 @@ module Subst ( #include "HsVersions.h" import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, CoreBndr, - CoreRules(..), CoreRule(..), emptyCoreRules, isEmptyCoreRules + CoreRules(..), CoreRule(..), + emptyCoreRules, isEmptyCoreRules, seqRules ) import CoreFVs ( exprFreeVars ) import Type ( Type(..), ThetaType, TyNote(..), @@ -284,6 +285,7 @@ subst_expr subst expr go (Var v) = case lookupSubst subst v of Just (DoneEx e') -> e' Just (ContEx env' e') -> subst_expr (setSubstEnv subst env') e' +-- NO! NO! SLPJ 14 July 99 Nothing -> case lookupInScope subst v of Just v' -> Var v' Nothing -> Var v @@ -293,6 +295,8 @@ subst_expr subst expr -- of a variable may not be right; we should replace it with the -- binder, from the in_scope set. +-- Nothing -> Var v + go (Type ty) = Type (go_ty ty) go (Con con args) = Con con (map go args) go (App fun arg) = App (go fun) (go arg) @@ -392,7 +396,7 @@ substAndCloneId subst@(Subst in_scope env) us old_id where id_ty = idType old_id id1 | noTypeSubst env || isEmptyVarSet (tyVarsOfType id_ty) = old_id - | otherwise = setIdType old_id (substTy subst id_ty) + | otherwise = setIdType old_id (substTy subst id_ty) id2 = maybeModifyIdInfo zapFragileIdInfo id1 new_id = setVarUnique id2 (uniqFromSupply us1) @@ -407,20 +411,35 @@ substAndCloneId subst@(Subst in_scope env) us old_id %************************************************************************ \begin{code} -substIdInfo :: Subst -> IdInfo -> IdInfo -substIdInfo subst info +substIdInfo :: Subst + -> IdInfo -- Get un-substituted ones from here + -> IdInfo -- Substitute it and add it to here + -> IdInfo -- To give this + -- Seq'ing on the returned IdInfo is enough to cause all the + -- substitutions to happen completely + +substIdInfo subst old_info new_info = info2 where - info1 | isEmptyCoreRules old_rules = info - | otherwise = info `setSpecInfo` substRules subst old_rules + info1 | isEmptyCoreRules old_rules = new_info + | otherwise = new_info `setSpecInfo` new_rules + -- setSpecInfo does a seq + where + new_rules = substRules subst old_rules info2 | not (workerExists old_wrkr) = info1 - | otherwise = info1 `setWorkerInfo` substWorker subst old_wrkr + | otherwise = info1 `setWorkerInfo` new_wrkr + -- setWorkerInfo does a seq + where + new_wrkr = substWorker subst old_wrkr - old_rules = specInfo info - old_wrkr = workerInfo info + old_rules = specInfo old_info + old_wrkr = workerInfo old_info substWorker :: Subst -> WorkerInfo -> WorkerInfo + -- Seq'ing on the returned WorkerInfo is enough to cause all the + -- substitutions to happen completely + substWorker subst Nothing = Nothing substWorker subst (Just w) @@ -433,10 +452,18 @@ substWorker subst (Just w) Nothing -- Ditto substRules :: Subst -> CoreRules -> CoreRules + -- Seq'ing on the returned CoreRules is enough to cause all the + -- substitutions to happen completely + +substRules subst rules + | isEmptySubst subst = rules + substRules subst (Rules rules rhs_fvs) - = Rules (map do_subst rules) - (subst_fvs (substEnv subst) rhs_fvs) + = seqRules new_rules `seq` new_rules where + new_rules = Rules (map do_subst rules) + (subst_fvs (substEnv subst) rhs_fvs) + do_subst (Rule name tpl_vars lhs_args rhs) = Rule name tpl_vars' (map (substExpr subst') lhs_args) diff --git a/ghc/compiler/cprAnalysis/CprAnalyse.lhs b/ghc/compiler/cprAnalysis/CprAnalyse.lhs index 3b2fa31..e99864f 100644 --- a/ghc/compiler/cprAnalysis/CprAnalyse.lhs +++ b/ghc/compiler/cprAnalysis/CprAnalyse.lhs @@ -15,10 +15,9 @@ import Var ( Var, Id, TyVar, idType, varName, varType ) import Id ( setIdCprInfo, getIdCprInfo, getIdUnfolding ) import IdInfo ( CprInfo(..) ) import VarEnv -import Type ( Type(..), splitFunTys, splitForAllTys, splitTyConApp_maybe, - splitAlgTyConApp_maybe ) +import Type ( Type(..), splitFunTys, splitForAllTys, splitNewType_maybe ) import TyCon ( isProductTyCon, isNewTyCon, isUnLiftedTyCon ) -import DataCon ( dataConTyCon, dataConArgTys ) +import DataCon ( dataConTyCon, splitProductType_maybe ) import Const ( Con(DataCon), isWHNFCon ) import Util ( zipEqual, zipWithEqual ) import Outputable @@ -317,23 +316,16 @@ pinCPR v e av = case av of filterAbsTuple :: (AbsVal, Type) -> AbsVal filterAbsTuple (av@(Tuple args), ty) - = case split_ty of - Nothing -> Top - Just (data_con, tycon, tycon_arg_tys, inst_con_arg_tys) -> - if isNewTyCon tycon then - ASSERT ( null $ tail inst_con_arg_tys ) - filterAbsTuple (av, head inst_con_arg_tys) - else - Tuple $ map filterAbsTuple $ zipEqual "cprFilter" args inst_con_arg_tys - where - split_ty = case splitAlgTyConApp_maybe ty of - Just (arg_tycon, tycon_arg_tys, [data_con]) -> - -- The main event: a single-constructor data type - Just (data_con, arg_tycon, tycon_arg_tys, dataConArgTys data_con tycon_arg_tys) - Just (_, _, data_cons) -> - pprPanic "cprFilter:" (text "not one constructor" $$ ppr ty) - -- hmmm, Isn't this a panic too? - Nothing -> Nothing + = case splitProductType_maybe ty of + Nothing -> WARN( True, text "filterAbsTuple" <+> ppr ty) -- Or should it be a panic? + Top + Just (tycon, _, data_con, inst_con_arg_tys) + | isNewTyCon tycon + -> ASSERT ( null $ tail inst_con_arg_tys ) + filterAbsTuple (av, head inst_con_arg_tys) + | otherwise + -> Tuple $ map filterAbsTuple $ zipEqual "cprFilter" args inst_con_arg_tys + filterAbsTuple (av, _) = av absToCprInfo :: AbsVal -> CprInfo @@ -376,23 +368,15 @@ splitTypeToFunArgAndRes ty = (tyvars, argtys, resty) -- Taken from splitFunTys in Type.lhs. Modified to keep searching through newtypes -- Should move to Type.lhs if it is doing something sensible. splitFunTysIgnoringNewTypes :: Type -> ([Type], Type) -splitFunTysIgnoringNewTypes ty = split [] ty ty +splitFunTysIgnoringNewTypes ty = split ty where - split args orig_ty (FunTy arg res) = split (arg:args) res res - split args orig_ty (NoteTy _ ty) = split args orig_ty ty - split args orig_ty ty - = case splitAlgTyConApp_maybe ty of - Just (arg_tycon, tycon_arg_tys, [data_con]) -> - let [inst_con_arg_ty] = dataConArgTys data_con tycon_arg_tys in - if (isNewTyCon arg_tycon) then - {- pprTrace "splitFunTysIgnoringNewTypes:" - (ppr arg_tycon <+> text "from type" <+> ppr inst_con_arg_ty) - -} - (split args orig_ty inst_con_arg_ty) - else - (reverse args, orig_ty) - Nothing -> (reverse args, orig_ty) - + split ty = case splitNewType_maybe res of + Nothing -> (args, res) + Just rep_ty -> (args ++ args', res') + where + (args', res') = split rep_ty + where + (args, res) = splitFunTys ty -- Is this the constructor for a product type (i.e. algebraic, single constructor) isConProdType :: Con -> Bool diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index 84631e3..ece7e71 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -27,7 +27,7 @@ import Const ( Con(..) ) import Maybes ( maybeToBool ) import PrelInfo ( packStringForCId ) import PrimOp ( PrimOp(..) ) -import DataCon ( DataCon, dataConId, dataConArgTys ) +import DataCon ( DataCon, dataConId, splitProductType_maybe ) import CallConv import Type ( isUnLiftedType, splitAlgTyConApp_maybe, mkFunTys, splitTyConApp_maybe, Type @@ -84,7 +84,7 @@ dsCCall :: FAST_STRING -- C routine to invoke -> Type -- Type of the result (a boxed-prim IO type) -> DsM CoreExpr -dsCCall label args may_gc is_asm result_ty +dsCCall lbl args may_gc is_asm result_ty = newSysLocalDs realWorldStatePrimTy `thenDs` \ old_s -> mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) -> @@ -98,7 +98,7 @@ dsCCall label args may_gc is_asm result_ty -- it at the full type, including the state argument inst_ty = mkFunTys (map coreExprType val_args) final_result_ty - the_ccall_op = CCallOp (Left label) is_asm may_gc cCallConv + the_ccall_op = CCallOp (Left lbl) is_asm may_gc cCallConv the_prim_app = mkPrimApp the_ccall_op final_args the_body = foldr ($) (res_wrapper the_prim_app) arg_wrappers @@ -134,12 +134,8 @@ unboxArg arg \body -> Case (App (Var packStringForCId) arg) prim_arg [(DEFAULT,[],body)]) - | null data_cons - -- oops: we can't see the data constructors!!! - = can'tSeeDataConsPanic "argument" arg_ty - -- Byte-arrays, both mutable and otherwise; hack warning - | is_data_type && + | is_product_type && length data_con_arg_tys == 2 && maybeToBool maybe_arg2_tycon && (arg2_tycon == byteArrayPrimTyCon || @@ -148,7 +144,7 @@ unboxArg arg = newSysLocalDs arg_ty `thenDs` \ case_bndr -> newSysLocalsDs data_con_arg_tys `thenDs` \ vars@[ixs_var, arr_cts_var] -> returnDs (Var arr_cts_var, - \ body -> Case arg case_bndr [(DataCon the_data_con,vars,body)] + \ body -> Case arg case_bndr [(DataCon data_con,vars,body)] ) -- Data types with a single constructor, which has a single, primitive-typed arg @@ -168,13 +164,10 @@ unboxArg arg maybe_boxed_prim_arg_ty = maybeBoxedPrimType arg_ty (Just (box_data_con, the_prim_arg_ty)) = maybe_boxed_prim_arg_ty - maybe_data_type = splitAlgTyConApp_maybe arg_ty - is_data_type = maybeToBool maybe_data_type - (Just (tycon, tycon_arg_tys, data_cons)) = maybe_data_type - (the_data_con : other_data_cons) = data_cons - - data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys - (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys + maybe_product_type = splitProductType_maybe arg_ty + is_product_type = maybeToBool maybe_product_type + Just (tycon, _, data_con, data_con_arg_tys) = maybe_product_type + (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys maybe_arg2_tycon = splitTyConApp_maybe data_con_arg_ty2 Just (arg2_tycon,_) = maybe_arg2_tycon @@ -193,13 +186,8 @@ boxResult :: Type -- Type of desired result CoreExpr -> CoreExpr) -- Wrapper for the ccall -- to box the result boxResult result_ty - | null data_cons - -- oops! can't see the data constructors - = can'tSeeDataConsPanic "result" result_ty - -- Data types with a single nullary constructor - | (maybeToBool maybe_data_type) && -- Data type - (null other_data_cons) && -- Just one constr + | (maybeToBool maybe_product_type) && -- Data type (null data_con_arg_tys) = newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id -> @@ -222,8 +210,7 @@ boxResult result_ty ) -- Data types with a single constructor, which has a single, primitive-typed arg - | (maybeToBool maybe_data_type) && -- Data type - (null other_data_cons) && -- Just one constr + | (maybeToBool maybe_product_type) && -- Data type not (null data_con_arg_tys) && null other_args_tys && -- Just one arg isUnLiftedType the_prim_result_ty -- of primitive type = @@ -232,7 +219,7 @@ boxResult result_ty newSysLocalDs ccall_res_type `thenDs` \ case_bndr -> let - the_result = mkConApp the_data_con (map Type tycon_arg_tys ++ [Var prim_result_id]) + the_result = mkConApp data_con (map Type tycon_arg_tys ++ [Var prim_result_id]) the_pair = mkConApp unboxedPairDataCon [Type realWorldStatePrimTy, Type result_ty, Var prim_state_id, the_result] @@ -244,52 +231,39 @@ boxResult result_ty | otherwise = pprPanic "boxResult: " (ppr result_ty) where - maybe_data_type = splitAlgTyConApp_maybe result_ty - Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type - (the_data_con : other_data_cons) = data_cons - ccall_res_type = mkUnboxedTupleTy 2 - [realWorldStatePrimTy, the_prim_result_ty] + maybe_product_type = splitProductType_maybe result_ty + Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) = maybe_product_type + (the_prim_result_ty : other_args_tys) = data_con_arg_tys - data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys - (the_prim_result_ty : other_args_tys) = data_con_arg_tys + ccall_res_type = mkUnboxedTupleTy 2 [realWorldStatePrimTy, the_prim_result_ty] -- wrap up an unboxed value. wrapUnboxedValue :: Type -> DsM (Type, Id, CoreExpr) wrapUnboxedValue ty - | null data_cons - -- oops! can't see the data constructors - = can'tSeeDataConsPanic "result" ty - -- Data types with a single constructor, which has a single, primitive-typed arg - | (maybeToBool maybe_data_type) && -- Data type - (null other_data_cons) && -- Just one constr + | (maybeToBool maybe_product_type) && -- Data type not (null data_con_arg_tys) && null other_args_tys && -- Just one arg isUnLiftedType the_prim_result_ty -- of primitive type = newSysLocalDs the_prim_result_ty `thenDs` \ prim_result_id -> let - the_result = mkConApp the_data_con (map Type tycon_arg_tys ++ [Var prim_result_id]) + the_result = mkConApp data_con (map Type tycon_arg_tys ++ [Var prim_result_id]) in returnDs (ccall_res_type, prim_result_id, the_result) -- Data types with a single nullary constructor - | (maybeToBool maybe_data_type) && -- Data type - (null other_data_cons) && -- Just one constr + | (maybeToBool maybe_product_type) && -- Data type (null data_con_arg_tys) = let unit = dataConId unitDataCon scrut_ty = mkUnboxedTupleTy 1 [realWorldStatePrimTy] in returnDs (scrut_ty, unit, mkConApp unitDataCon []) + | otherwise = pprPanic "boxResult: " (ppr ty) where - maybe_data_type = splitAlgTyConApp_maybe ty - Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type - (the_data_con : other_data_cons) = data_cons - ccall_res_type = mkUnboxedTupleTy 2 - [realWorldStatePrimTy, the_prim_result_ty] - - data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys - (the_prim_result_ty : other_args_tys) = data_con_arg_tys - + maybe_product_type = splitProductType_maybe ty + Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) = maybe_product_type + (the_prim_result_ty : other_args_tys) = data_con_arg_tys + ccall_res_type = mkUnboxedTupleTy 2 [realWorldStatePrimTy, the_prim_result_ty] \end{code} diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index a8421fd..c1a2d6e 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -309,9 +309,9 @@ dsExpr (SectionR op expr) returnDs (bindNonRec y_id y_core $ Lam x_id (mkApps core_op [Var x_id, Var y_id])) -dsExpr (CCall label args may_gc is_asm result_ty) +dsExpr (CCall lbl args may_gc is_asm result_ty) = mapDs dsExpr args `thenDs` \ core_args -> - dsCCall label core_args may_gc is_asm result_ty + dsCCall lbl core_args may_gc is_asm result_ty -- dsCCall does all the unboxification, etc. dsExpr (HsSCC cc expr) @@ -543,6 +543,7 @@ dsExpr (RecordUpdOut record_expr record_out_ty dicts rbinds) mk_alt con = newSysLocalsDs (dataConArgTys con in_inst_tys) `thenDs` \ arg_ids -> + -- This call to dataConArgTys won't work for existentials let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg (dataConFieldLabels con) arg_ids diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index b6abdbf..1abd67f 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -137,7 +137,7 @@ dsFImport nm ty may_not_gc ext_name cconv = (case ext_name of Dynamic -> getUniqueDs `thenDs` \ u -> returnDs (Right u) - ExtName fs _ -> returnDs (Left fs)) `thenDs` \ label -> + ExtName fs _ -> returnDs (Left fs)) `thenDs` \ lbl -> let val_args = Var the_state_arg : unboxed_args final_args = Type inst_ty : val_args @@ -146,7 +146,7 @@ dsFImport nm ty may_not_gc ext_name cconv = -- it at the full type, including the state argument inst_ty = mkFunTys (map coreExprType val_args) final_result_ty - the_ccall_op = CCallOp label False (not may_not_gc) cconv + the_ccall_op = CCallOp lbl False (not may_not_gc) cconv the_prim_app = mkPrimApp the_ccall_op (final_args :: [CoreArg]) diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 98a7177..455b41b 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -42,7 +42,7 @@ import Id ( idType, Id, mkWildId ) import Const ( Literal(..), Con(..) ) import TyCon ( isNewTyCon, tyConDataCons ) import DataCon ( DataCon, StrictnessMark, maybeMarkedUnboxed, dataConStrictMarks, - dataConArgTys, dataConId + dataConId, splitProductType_maybe ) import Type ( mkFunTy, isUnLiftedType, splitAlgTyConApp, unUsgTy, Type @@ -274,18 +274,19 @@ rebuildConArgs con (arg:args) stricts body | isTyVar arg rebuildConArgs con (arg:args) (str:stricts) body = rebuildConArgs con args stricts body `thenDs` \ (body', real_args) -> case maybeMarkedUnboxed str of - Just (pack_con, tys) -> - let id_tys = dataConArgTys pack_con ty_args in - newSysLocalsDs id_tys `thenDs` \ unpacked_args -> - returnDs ( - mkDsLet (NonRec arg (Con (DataCon pack_con) - (map Type ty_args ++ - map Var unpacked_args))) body', - unpacked_args ++ real_args - ) + Just (pack_con1, _) -> + case splitProductType_maybe (idType arg) of + Just (_, tycon_args, pack_con, con_arg_tys) -> + ASSERT( pack_con == pack_con1 ) + newSysLocalsDs con_arg_tys `thenDs` \ unpacked_args -> + returnDs ( + mkDsLet (NonRec arg (Con (DataCon pack_con) + (map Type tycon_args ++ + map Var unpacked_args))) body', + unpacked_args ++ real_args + ) + _ -> returnDs (body', arg:real_args) - - where ty_args = case splitAlgTyConApp (idType arg) of { (_,args,_) -> args } \end{code} %************************************************************************ diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 6c242a9..890cba9 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -28,7 +28,7 @@ import MatchCon ( matchConFamily ) import MatchLit ( matchLiterals ) import PrelInfo ( pAT_ERROR_ID ) import Type ( isUnLiftedType, splitAlgTyConApp, - Type + mkTyVarTys, Type ) import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy, addrPrimTy, wordPrimTy @@ -457,21 +457,21 @@ tidy1 v (LazyPat pat) match_result -- re-express as (ConPat ...) [directly] -tidy1 v (RecPat data_con pat_ty tvs dicts rpats) match_result +tidy1 v (RecPat data_con pat_ty ex_tvs dicts rpats) match_result | null rpats = -- Special case for C {}, which can be used for -- a constructor that isn't declared to have -- fields at all - returnDs (ConPat data_con pat_ty tvs dicts (map WildPat con_arg_tys'), match_result) + returnDs (ConPat data_con pat_ty ex_tvs dicts (map WildPat con_arg_tys'), match_result) | otherwise - = returnDs (ConPat data_con pat_ty tvs dicts pats, match_result) + = returnDs (ConPat data_con pat_ty ex_tvs dicts pats, match_result) where pats = map mk_pat tagged_arg_tys -- Boring stuff to find the arg-tys of the constructor (_, inst_tys, _) = splitAlgTyConApp pat_ty - con_arg_tys' = dataConArgTys data_con inst_tys + con_arg_tys' = dataConArgTys data_con (inst_tys ++ mkTyVarTys ex_tvs) tagged_arg_tys = con_arg_tys' `zip` (dataConFieldLabels data_con) -- mk_pat picks a WildPat of the appropriate type for absent fields, diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index caa8a6b..128c812 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -154,6 +154,7 @@ data HsExpr id pat \end{code} These constructors only appear temporarily in the parser. +The renamer translates them into the Right Thing. \begin{code} | EWildPat -- wildcard @@ -329,14 +330,18 @@ ppr_expr (ArithSeqIn info) ppr_expr (ArithSeqOut expr info) = brackets (ppr info) +ppr_expr EWildPat = char '_' +ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e +ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e + ppr_expr (CCall fun args _ is_asm result_ty) = hang (if is_asm then ptext SLIT("_casm_ ``") <> ptext fun <> ptext SLIT("''") else ptext SLIT("_ccall_") <+> ptext fun) 4 (sep (map pprParendExpr args)) -ppr_expr (HsSCC label expr) - = sep [ ptext SLIT("_scc_") <+> doubleQuotes (ptext label), pprParendExpr expr ] +ppr_expr (HsSCC lbl expr) + = sep [ ptext SLIT("_scc_") <+> doubleQuotes (ptext lbl), pprParendExpr expr ] ppr_expr (TyLam tyvars expr) = hang (hsep [ptext SLIT("/\\"), interppSP tyvars, ptext SLIT("->")]) diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index 176bf9c..1712dca 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -26,6 +26,7 @@ import TcModule ( TcResults(..), typecheckModule ) import Desugar ( deSugar ) import SimplCore ( core2core ) import CoreLint ( endPass ) +import CoreSyn ( coreBindsSize ) import CoreTidy ( tidyCorePgm ) import CoreToStg ( topCoreBindsToStg ) import StgSyn ( collectFinalStgBinders, pprStgBindings ) @@ -180,6 +181,11 @@ doIt (core_cmds, stg_cmds) let final_ids = collectFinalStgBinders (map fst stg_binds2) in + coreBindsSize tidy_binds `seq` +-- TEMP: the above call zaps some space usage allocated by the +-- simplifier, which for reasons I don't understand, persists +-- thoroughout code generation + ifaceDecls if_handle local_tycons local_classes inst_info final_ids tidy_binds imp_rule_ids >> endIface if_handle >> diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 2fec609..53a70be 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -292,7 +292,8 @@ ifaceId get_idinfo needed_ids is_rec id rhs ifaceId get_idinfo needed_ids is_rec id rhs = Just (hsep [sig_pretty, prag_pretty, char ';'], new_needed_ids) where - idinfo = get_idinfo id + core_idinfo = idInfo id + stg_idinfo = get_idinfo id ty_pretty = pprType (idType id) sig_pretty = hsep [ppr (getOccName id), dcolon, ty_pretty] @@ -309,28 +310,28 @@ ifaceId get_idinfo needed_ids is_rec id rhs ptext SLIT("##-}")] ------------ Arity -------------- - arity_pretty = ppArityInfo (arityInfo idinfo) + arity_pretty = ppArityInfo (arityInfo stg_idinfo) ------------ Caf Info -------------- - caf_pretty = ppCafInfo (cafInfo idinfo) + caf_pretty = ppCafInfo (cafInfo stg_idinfo) ------------ CPR Info -------------- - cpr_pretty = ppCprInfo (cprInfo idinfo) + cpr_pretty = ppCprInfo (cprInfo core_idinfo) ------------ Strictness -------------- - strict_info = strictnessInfo idinfo + strict_info = strictnessInfo core_idinfo bottoming_fn = isBottomingStrictness strict_info strict_pretty = ppStrictnessInfo strict_info ------------ Worker -------------- - work_info = workerInfo idinfo + work_info = workerInfo core_idinfo has_worker = workerExists work_info wrkr_pretty = ppWorkerInfo work_info Just work_id = work_info ------------ Unfolding -------------- - inline_pragma = inlinePragInfo idinfo + inline_pragma = inlinePragInfo core_idinfo dont_inline = case inline_pragma of IMustNotBeINLINEd -> True IAmALoopBreaker -> True @@ -348,7 +349,7 @@ ifaceId get_idinfo needed_ids is_rec id rhs rhs_is_small = couldBeSmallEnoughToInline (calcUnfoldingGuidance opt_UF_HiFileThreshold rhs) ------------ Specialisations -------------- - spec_info = specInfo idinfo + spec_info = specInfo core_idinfo ------------ Extra free Ids -------------- new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs index e4c1968..4c7553f 100644 --- a/ghc/compiler/nativeGen/AbsCStixGen.lhs +++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs @@ -74,17 +74,17 @@ Here we handle top-level things, like @CCodeBlock@s and -> UniqSM [StixTree] -} - gentopcode (CCodeBlock label absC) + gentopcode (CCodeBlock lbl absC) = gencode absC `thenUs` \ code -> - returnUs (StSegment TextSegment : StFunBegin label : code [StFunEnd label]) + returnUs (StSegment TextSegment : StFunBegin lbl : code [StFunEnd lbl]) - gentopcode stmt@(CStaticClosure label _ _ _) + gentopcode stmt@(CStaticClosure lbl _ _ _) = genCodeStaticClosure stmt `thenUs` \ code -> - returnUs (StSegment DataSegment : StLabel label : code []) + returnUs (StSegment DataSegment : StLabel lbl : code []) - gentopcode stmt@(CRetVector label _ _ _) + gentopcode stmt@(CRetVector lbl _ _ _) = genCodeVecTbl stmt `thenUs` \ code -> - returnUs (StSegment TextSegment : code [StLabel label]) + returnUs (StSegment TextSegment : code [StLabel lbl]) gentopcode stmt@(CRetDirect uniq absC srt liveness) = gencode absC `thenUs` \ code -> @@ -150,7 +150,7 @@ Here we handle top-level things, like @CCodeBlock@s and :: AbstractC -> UniqSM StixTreeList -} - genCodeVecTbl (CRetVector label amodes srt liveness) + genCodeVecTbl (CRetVector lbl amodes srt liveness) = genBitmapInfoTable liveness srt closure_type True `thenUs` \itbl -> returnUs (\xs -> vectbl : itbl xs) where diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs index 3871d48..abfb793 100644 --- a/ghc/compiler/nativeGen/AsmCodeGen.lhs +++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs @@ -339,8 +339,8 @@ fltFix1 locs (StAssign rep dst src) = panic "fltFix1: StAssign" fltFix1 locs (StJump tree) = StJump (fltFix1 locs tree) -fltFix1 locs (StCondJump label tree) = - StCondJump label (fltFix1 locs tree) +fltFix1 locs (StCondJump lbl tree) = + StCondJump lbl (fltFix1 locs tree) fltFix1 locs (StPrim op trees) = StPrim op (map (fltFix1 locs) trees) diff --git a/ghc/compiler/nativeGen/RegAllocInfo.lhs b/ghc/compiler/nativeGen/RegAllocInfo.lhs index 50d5709..811a39a 100644 --- a/ghc/compiler/nativeGen/RegAllocInfo.lhs +++ b/ghc/compiler/nativeGen/RegAllocInfo.lhs @@ -374,7 +374,7 @@ regUsage instr = case instr of TEST sz src dst -> usage (opToReg src ++ opToReg dst) [] CMP sz src dst -> usage (opToReg src ++ opToReg dst) [] SETCC cond op -> usage [] (opToReg op) - JXX cond label -> usage [] [] + JXX cond lbl -> usage [] [] JMP op -> usage (opToReg op) freeRegs CALL imm -> usage [] callClobberedRegs CLTD -> usage [eax] [edx] diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 5e55fd0..aecf9a9 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -350,9 +350,9 @@ rnExpr (CCall fun args may_gc is_casm fake_result_ty) returnRn (CCall fun args' may_gc is_casm fake_result_ty, fvs_args `addOneFV` cc `addOneFV` cr `addOneFV` io) -rnExpr (HsSCC label expr) +rnExpr (HsSCC lbl expr) = rnExpr expr `thenRn` \ (expr', fvs_expr) -> - returnRn (HsSCC label expr', fvs_expr) + returnRn (HsSCC lbl expr', fvs_expr) rnExpr (HsCase expr ms src_loc) = pushSrcLocRn src_loc $ @@ -430,6 +430,21 @@ rnExpr (ArithSeqIn seq) plusFVs [fvExpr1, fvExpr2, fvExpr3]) \end{code} +These three are pattern syntax appearing in expressions. +Since all the symbols are reservedops we can simply reject them. +We return a (bogus) EWildPat in each case. + +\begin{code} +rnExpr e@EWildPat = addErrRn (patSynErr e) `thenRn_` + returnRn (EWildPat, emptyFVs) + +rnExpr e@(EAsPat _ _) = addErrRn (patSynErr e) `thenRn_` + returnRn (EWildPat, emptyFVs) + +rnExpr e@(ELazyPat _) = addErrRn (patSynErr e) `thenRn_` + returnRn (EWildPat, emptyFVs) +\end{code} + %************************************************************************ %* * \subsubsection{@Rbinds@s and @Rpats@s: in record expressions} @@ -833,4 +848,8 @@ patSigErr ty $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it")) pp_op (op, fix) = hcat [ppr op, space, parens (ppr fix)] + +patSynErr e + = sep [ptext SLIT("Pattern syntax in expression context:"), + nest 4 (ppr e)] \end{code} diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index e74525d..13970ff 100644 --- a/ghc/compiler/simplCore/SetLevels.lhs +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -663,7 +663,7 @@ cloneVar NotTopLevel (lvl_env, subst_env) v lvl let subst = mkSubst emptyVarSet subst_env v' = setVarUnique v uniq - v'' = modifyIdInfo (substIdInfo subst) v' + v'' = modifyIdInfo (\info -> substIdInfo subst info info) v' subst_env' = extendSubstEnv subst_env v (DoneEx (Var v'')) lvl_env' = extendVarEnv lvl_env v lvl in @@ -677,7 +677,7 @@ cloneVars NotTopLevel (lvl_env, subst_env) vs lvl let subst = mkSubst emptyVarSet subst_env' vs' = zipWith setVarUnique vs uniqs - vs'' = map (modifyIdInfo (substIdInfo subst)) vs' + vs'' = map (modifyIdInfo (\info -> substIdInfo subst info info)) vs' subst_env' = extendSubstEnvList subst_env vs [DoneEx (Var v'') | v'' <- vs''] lvl_env' = extendVarEnvList lvl_env (vs `zip` repeat lvl) in diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs index 32d8d6b..a946da4 100644 --- a/ghc/compiler/simplCore/SimplMonad.lhs +++ b/ghc/compiler/simplCore/SimplMonad.lhs @@ -568,7 +568,6 @@ data Tick | FillInCaseDefault Id -- Case binder | BottomFound - | LeafVisit | SimplifierDone -- Ticked at each iteration of the simplifier isRuleFired (RuleFired _) = True @@ -599,7 +598,6 @@ tickToTag (CaseElim _) = 11 tickToTag (CaseIdentity _) = 12 tickToTag (FillInCaseDefault _) = 13 tickToTag BottomFound = 14 -tickToTag LeafVisit = 15 tickToTag SimplifierDone = 16 tickString :: Tick -> String @@ -619,7 +617,6 @@ tickString (CaseIdentity _) = "CaseIdentity" tickString (FillInCaseDefault _) = "FillInCaseDefault" tickString BottomFound = "BottomFound" tickString SimplifierDone = "SimplifierDone" -tickString LeafVisit = "LeafVisit" pprTickCts :: Tick -> SDoc pprTickCts (PreInlineUnconditionally v) = ppr v diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 7ce7e27..a5877bd 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -22,14 +22,14 @@ import CoreUtils ( exprIsTrivial, cheapEqExpr, coreExprType, exprIsCheap, exprGe import Subst ( substBndrs, substBndr, substIds ) import Id ( Id, idType, getIdArity, isId, idName, getInlinePragma, setInlinePragma, - getIdDemandInfo, mkId + getIdDemandInfo, mkId, idInfo ) import IdInfo ( arityLowerBound, InlinePragInfo(..), setInlinePragInfo, vanillaIdInfo ) import Maybes ( maybeToBool, catMaybes ) import Const ( Con(..) ) import Name ( isLocalName, setNameUnique ) import SimplMonad -import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, +import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType, splitTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys ) import TysPrim ( statePrimTyCon ) @@ -54,8 +54,8 @@ simplBinders bndrs thing_inside let (subst', bndrs') = substBndrs subst bndrs in - setSubst subst' $ - thing_inside bndrs' + seqBndrs bndrs' `seq` + setSubst subst' (thing_inside bndrs') simplBinder :: InBinder -> (OutBinder -> SimplM a) -> SimplM a simplBinder bndr thing_inside @@ -63,8 +63,8 @@ simplBinder bndr thing_inside let (subst', bndr') = substBndr subst bndr in - setSubst subst' $ - thing_inside bndr' + seqBndr bndr' `seq` + setSubst subst' (thing_inside bndr') -- Same semantics as simplBinders, but a little less @@ -76,8 +76,16 @@ simplIds ids thing_inside let (subst', bndrs') = substIds subst ids in - setSubst subst' $ - thing_inside bndrs' + seqBndrs bndrs' `seq` + setSubst subst' (thing_inside bndrs') + +seqBndrs [] = () +seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs + +seqBndr b | isTyVar b = b `seq` () + | otherwise = seqType (idType b) `seq` + idInfo b `seq` + () \end{code} diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index bb7fc9e..64ff7b0 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -27,10 +27,10 @@ import Id ( Id, idType, idInfo, idUnique, getIdArity, setIdArity, setIdInfo, getIdStrictness, setInlinePragma, getInlinePragma, idMustBeINLINEd, - setOneShotLambda + setOneShotLambda, maybeModifyIdInfo ) import IdInfo ( InlinePragInfo(..), OccInfo(..), StrictnessInfo(..), - ArityInfo(..), atLeastArity, arityLowerBound, unknownArity, + ArityInfo(..), atLeastArity, arityLowerBound, unknownArity, zapFragileIdInfo, specInfo, inlinePragInfo, zapLamIdInfo, setArityInfo, setInlinePragInfo, setUnfoldingInfo ) import Demand ( Demand, isStrict, wwLazy ) @@ -51,7 +51,7 @@ import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsCheap, exprIsTrivial, ) import Rules ( lookupRule ) import CostCentre ( isSubsumedCCS, currentCCS, isEmptyCC ) -import Type ( Type, mkTyVarTy, mkTyVarTys, isUnLiftedType, +import Type ( Type, mkTyVarTy, mkTyVarTys, isUnLiftedType, seqType, mkFunTy, splitFunTys, splitTyConApp_maybe, splitFunTy_maybe, funResultTy, isDictTy, isDataType, applyTy, applyTys, mkFunTys ) @@ -95,8 +95,11 @@ simplTopBinds binds top_binders = bindersOfBinds binds simpl_binds [] = returnSmpl ([], panic "simplTopBinds corner") - simpl_binds (NonRec bndr rhs : binds) = simplLazyBind TopLevel bndr bndr rhs (simpl_binds binds) - simpl_binds (Rec pairs : binds) = simplRecBind TopLevel pairs (map fst pairs) (simpl_binds binds) + simpl_binds (NonRec bndr rhs : binds) = simplLazyBind TopLevel bndr (zap bndr) rhs (simpl_binds binds) + simpl_binds (Rec pairs : binds) = simplRecBind TopLevel pairs (map (zap . fst) pairs) (simpl_binds binds) + + zap id = maybeModifyIdInfo zapFragileIdInfo id +-- TEMP simplRecBind :: TopLevelFlag -> [(InId, InExpr)] -> [OutId] @@ -174,7 +177,8 @@ simplExpr expr = getSubst `thenSmpl` \ subst -> simplExprC expr (Stop (substTy subst (coreExprType expr))) -- The type in the Stop continuation is usually not used -- It's only needed when discarding continuations after finding - -- a function that returns bottom + -- a function that returns bottom. + -- Hence the lazy substitution simplExprC :: CoreExpr -> SimplCont -> SimplM CoreExpr -- Simplify an expression, given a continuation @@ -213,13 +217,11 @@ simplExprF expr@(Con (PrimOp op) args) cont Nothing -> rebuild (Con (PrimOp op) args2) cont2 simplExprF (Con con@(DataCon _) args) cont - = freeTick LeafVisit `thenSmpl_` - simplConArgs args ( \ args' -> + = simplConArgs args ( \ args' -> rebuild (Con con args') cont) simplExprF expr@(Con con@(Literal _) args) cont = ASSERT( null args ) - freeTick LeafVisit `thenSmpl_` rebuild expr cont simplExprF (App fun arg) cont @@ -247,8 +249,8 @@ simplExprF (Type ty) cont simplExprF (Note (Coerce to from) e) cont | to == from = simplExprF e cont - | otherwise = getSubst `thenSmpl` \ subst -> - simplExprF e (CoerceIt (substTy subst to) cont) + | otherwise = simplType to `thenSmpl` \ to' -> + simplExprF e (CoerceIt to' cont) -- hack: we only distinguish subsumed cost centre stacks for the purposes of -- inlining. All other CCCSs are mapped to currentCCS. @@ -314,6 +316,7 @@ simplLam fun cont let ty' = substTy (mkSubst in_scope arg_se) ty_arg in + seqType ty' `seq` extendSubst bndr (DoneTy ty') (go body body_cont) @@ -411,7 +414,11 @@ simplConArgs (arg:args) thing_inside simplType :: InType -> SimplM OutType simplType ty = getSubst `thenSmpl` \ subst -> - returnSmpl (substTy subst ty) + let + new_ty = substTy subst ty + in + seqType new_ty `seq` + returnSmpl new_ty \end{code} @@ -533,24 +540,25 @@ completeBinding old_bndr new_bndr new_rhs thing_inside let -- We make new IdInfo for the new binder by starting from the old binder, -- doing appropriate substitutions, - old_bndr_info = idInfo old_bndr - new_bndr_info = substIdInfo subst old_bndr_info + new_bndr_info = substIdInfo subst (idInfo old_bndr) (idInfo new_bndr) `setArityInfo` ArityAtLeast (exprArity new_rhs) - -- At the *binding* site we want to zap the now-out-of-date inline - -- pragma, in case the expression is simplified a second time. - -- This has already been done in new_bndr, so we get it from there - binding_site_id = new_bndr `setIdInfo` - (new_bndr_info `setInlinePragInfo` getInlinePragma new_bndr) + -- At the *binding* site we use the new binder info + binding_site_id = new_bndr `setIdInfo` new_bndr_info - -- At the occurrence sites we want to know the unfolding, - -- We want the occurrence info of the *original*, which is already - -- in new_bndr_info + -- At the *occurrence* sites we want to know the unfolding + -- We also want the occurrence info of the *original* occ_site_id = new_bndr `setIdInfo` - (new_bndr_info `setUnfoldingInfo` mkUnfolding new_rhs) + (new_bndr_info `setUnfoldingInfo` mkUnfolding new_rhs + `setInlinePragInfo` getInlinePragma old_bndr) in - modifyInScope occ_site_id thing_inside `thenSmpl` \ stuff -> - returnSmpl (addBind (NonRec binding_site_id new_rhs) stuff) + -- These seqs force the Ids, and hence the IdInfos, and hence any + -- inner substitutions + binding_site_id `seq` + occ_site_id `seq` + + (modifyInScope occ_site_id thing_inside `thenSmpl` \ stuff -> + returnSmpl (addBind (NonRec binding_site_id new_rhs) stuff)) \end{code} @@ -672,8 +680,7 @@ splitFloats floats rhs \begin{code} simplVar var cont - = freeTick LeafVisit `thenSmpl_` - getSubst `thenSmpl` \ subst -> + = getSubst `thenSmpl` \ subst -> case lookupSubst subst var of Just (DoneEx (Var v)) -> zapSubstEnv (simplVar v cont) Just (DoneEx e) -> zapSubstEnv (simplExprF e cont) @@ -697,12 +704,17 @@ simplVar var cont in getBlackList `thenSmpl` \ black_list -> getInScope `thenSmpl` \ in_scope -> - completeCall black_list in_scope var' cont + completeCall black_list in_scope var var' cont --------------------------------------------------------- -- Dealing with a call -completeCall black_list_fn in_scope var cont +completeCall black_list_fn in_scope orig_var var cont +-- For reasons I'm not very clear about, it's important *not* to plug 'var', +-- which is replete with an inlining in its IdInfo, into the resulting expression +-- Doing so results in a significant space leak. +-- Instead we pass orig_var, which has no inlinings etc. + -- Look for rules or specialisations that match -- Do this *before* trying inlining because some functions -- have specialisations *and* are strict; we don't want to @@ -717,7 +729,7 @@ completeCall black_list_fn in_scope var cont -- thing, but perhaps we want to inline it anyway | maybeToBool maybe_inline = tick (UnfoldingDone var) `thenSmpl_` - zapSubstEnv (completeInlining var unf_template discard_inline_cont) + zapSubstEnv (completeInlining orig_var unf_template discard_inline_cont) -- The template is already simplified, so don't re-substitute. -- This is VITAL. Consider -- let x = e in @@ -730,7 +742,7 @@ completeCall black_list_fn in_scope var cont | otherwise -- Neither rule nor inlining -- Use prepareArgs to use function strictness = prepareArgs (ppr var) (idType var) (get_str var) cont $ \ args' cont' -> - rebuild (mkApps (Var var) args') cont' + rebuild (mkApps (Var orig_var) args') cont' where get_str var = case getIdStrictness var of @@ -835,6 +847,7 @@ prepareArgs pp_fun orig_fun_ty (fun_demands, result_bot) orig_cont thing_inside ty_arg' = substTy (mkSubst in_scope se) ty_arg res_ty = applyTy fun_ty ty_arg' in + seqType ty_arg' `seq` go (Type ty_arg' : acc) ds res_ty cont -- Value argument diff --git a/ghc/compiler/simplStg/StgVarInfo.lhs b/ghc/compiler/simplStg/StgVarInfo.lhs index 16f261f..f185c19 100644 --- a/ghc/compiler/simplStg/StgVarInfo.lhs +++ b/ghc/compiler/simplStg/StgVarInfo.lhs @@ -276,9 +276,9 @@ varsExpr (StgCon con args res_ty) varsAtoms args `thenLne` \ (args', args_fvs) -> returnLne (StgCon con args' res_ty, args_fvs, getFVSet args_fvs) -varsExpr (StgSCC label expr) +varsExpr (StgSCC cc expr) = varsExpr expr `thenLne` ( \ (expr2, fvs, escs) -> - returnLne (StgSCC label expr2, fvs, escs) ) + returnLne (StgSCC cc expr2, fvs, escs) ) \end{code} Cases require a little more real work. diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index cf9623f..970f04f 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -20,21 +20,21 @@ import StgSyn -- output import CoreUtils ( coreExprType ) import SimplUtils ( findDefault ) import CostCentre ( noCCS ) -import Id ( Id, mkSysLocal, idType, getIdStrictness, idUnique, isExportedId, +import Id ( Id, mkSysLocal, idType, getIdStrictness, idUnique, isExportedId, mkVanillaId, externallyVisibleId, setIdUnique, idName, getIdDemandInfo, setIdType ) import Var ( Var, varType, modifyIdInfo ) -import IdInfo ( setDemandInfo, StrictnessInfo(..) ) +import IdInfo ( setDemandInfo, StrictnessInfo(..), zapIdInfoForStg ) import UsageSPUtils ( primOpUsgTys ) import DataCon ( DataCon, dataConName, dataConId ) import Demand ( Demand, isStrict, wwStrict, wwLazy ) -import Name ( Name, nameModule, isLocallyDefinedName ) +import Name ( Name, nameModule, isLocallyDefinedName, setNameUnique ) import Module ( isDynamicModule ) import Const ( Con(..), Literal(..), isLitLitLit, conStrictness, isWHNFCon ) import VarEnv import PrimOp ( PrimOp(..), primOpUsg, primOpSig ) import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe, - UsageAnn(..), tyUsg, applyTy, mkUsgTy, repType ) + UsageAnn(..), tyUsg, applyTy, mkUsgTy, repType, seqType ) import TysPrim ( intPrimTy ) import UniqSupply -- all of it, really import Util ( lengthExceeds ) @@ -307,14 +307,17 @@ exprToRhs dem toplev (StgCon (DataCon con) args _) _ -> False exprToRhs dem _ expr - = StgRhsClosure noCCS -- No cost centre (ToDo?) - stgArgOcc -- safe + = upd `seq` + StgRhsClosure noCCS -- No cost centre (ToDo?) + stgArgOcc -- safe noSRT -- figure out later bOGUS_FVs - (if isOnceDem dem then SingleEntry else Updatable) - -- HA! Paydirt for "dem" + upd [] expr + where + upd = if isOnceDem dem then SingleEntry else Updatable + -- HA! Paydirt for "dem" isDynCon :: DataCon -> Bool isDynCon con = isDynName (dataConName con) @@ -404,7 +407,7 @@ Simple cases first \begin{code} coreExprToStgFloat env (Var var) dem - = returnUs ([], StgApp (stgLookup env var) []) + = returnUs ([], mkStgApp (stgLookup env var) []) coreExprToStgFloat env (Let bind body) dem = coreBindToStg NotTopLevel env bind `thenUs` \ (new_bind, new_env) -> @@ -455,11 +458,11 @@ coreExprToStgFloat env expr@(Lam _ _) dem case stg_body' of StgLam ty lam_bndrs lam_body -> -- If the body reduced to a lambda too, join them up - returnUs ([], StgLam expr_ty (binders' ++ lam_bndrs) lam_body) + returnUs ([], mkStgLam expr_ty (binders' ++ lam_bndrs) lam_body) other -> -- Body didn't reduce to a lambda, so return one - returnUs ([], StgLam expr_ty binders' stg_body') + returnUs ([], mkStgLam expr_ty binders' stg_body') \end{code} @@ -488,7 +491,7 @@ coreExprToStgFloat env expr@(App _ _) dem (Var fun_id, _) -> -- A function Id, so do an StgApp; it's ok if -- there are no arguments. returnUs (arg_floats, - StgApp (stgLookup env fun_id) stg_args) + mkStgApp (stgLookup env fun_id) stg_args) (non_var_fun, []) -> -- No value args, so recurse into the function ASSERT( null arg_floats ) @@ -498,7 +501,7 @@ coreExprToStgFloat env expr@(App _ _) dem newStgVar (coreExprType fun) `thenUs` \ fun_id -> coreExprToStgFloat env fun onceDem `thenUs` \ (fun_floats, stg_fun) -> returnUs (NonRecF fun_id stg_fun onceDem fun_floats : arg_floats, - StgApp fun_id stg_args) + mkStgApp fun_id stg_args) where -- Collect arguments and demands (*in reverse order*) @@ -557,6 +560,7 @@ speed. \begin{code} coreExprToStgFloat env expr@(Con con args) dem = let + expr_ty = coreExprType expr (stricts,_) = conStrictness con onces = case con of DEFAULT -> panic "coreExprToStgFloat: DEFAULT" @@ -586,7 +590,7 @@ coreExprToStgFloat env expr@(Con con args) dem _ -> returnUs con ) `thenUs` \ con' -> - returnUs (arg_floats, StgCon con' stg_atoms (coreExprType expr)) + returnUs (arg_floats, mkStgCon con' stg_atoms expr_ty) \end{code} @@ -654,7 +658,7 @@ coreExprToStgFloat env = coreExprToStgFloat env scrut (bdrDem bndr) `thenUs` \ (binds, scrut') -> newEvaldLocalId env bndr `thenUs` \ (env', bndr') -> coreExprToStg env' default_rhs dem `thenUs` \ default_rhs' -> - returnUs (binds, mkStgCase scrut' bndr' (StgPrimAlts (idType bndr) [] (StgBindDefault default_rhs'))) + returnUs (binds, mkStgCase scrut' bndr' (StgPrimAlts (idType bndr') [] (StgBindDefault default_rhs'))) where (other_alts, maybe_default) = findDefault alts Just default_rhs = maybe_default @@ -676,16 +680,17 @@ coreExprToStgFloat env (Case scrut bndr alts) dem | prim_case = default_to_stg env deflt `thenUs` \ deflt' -> mapUs (prim_alt_to_stg env) alts `thenUs` \ alts' -> - returnUs (StgPrimAlts scrut_ty alts' deflt') + returnUs (mkStgPrimAlts scrut_ty alts' deflt') | otherwise = default_to_stg env deflt `thenUs` \ deflt' -> mapUs (alg_alt_to_stg env) alts `thenUs` \ alts' -> - returnUs (StgAlgAlts scrut_ty alts' deflt') + returnUs (mkStgAlgAlts scrut_ty alts' deflt') alg_alt_to_stg env (DataCon con, bs, rhs) - = coreExprToStg env rhs dem `thenUs` \ stg_rhs -> - returnUs (con, filter isId bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs) + = newLocalIds NotTopLevel env (filter isId bs) `thenUs` \ (env', stg_bs) -> + coreExprToStg env' rhs dem `thenUs` \ stg_rhs -> + returnUs (con, stg_bs, [ True | b <- stg_bs ]{-bogus use mask-}, stg_rhs) -- NB the filter isId. Some of the binders may be -- existential type variables, which STG doesn't care about @@ -726,10 +731,12 @@ Invent a fresh @Id@: newStgVar :: Type -> UniqSM Id newStgVar ty = getUniqueUs `thenUs` \ uniq -> + seqType ty `seq` returnUs (mkSysLocal SLIT("stg") uniq ty) \end{code} \begin{code} +{- Now redundant, I believe -- we overload the demandInfo field of an Id to indicate whether the Id is definitely -- evaluated or not (i.e. whether it is a case binder). This can be used to eliminate -- some redundant cases (c.f. dataToTag# above). @@ -741,22 +748,35 @@ newEvaldLocalId env id new_env = extendVarEnv env id id' in returnUs (new_env, id') +-} +newEvaldLocalId env id = newLocalId NotTopLevel env id newLocalId TopLevel env id - = returnUs (env, id) -- Don't clone top-level binders. MkIface relies on their -- uniques staying the same, so it can snaffle IdInfo off the -- STG ids to put in interface files. + = let + name = idName id + ty = idType id + in + name `seq` + seqType ty `seq` + returnUs (env, mkVanillaId name ty) + newLocalId NotTopLevel env id = -- Local binder, give it a new unique Id. getUniqueUs `thenUs` \ uniq -> let - id' = setIdUnique id uniq - new_env = extendVarEnv env id id' + name = idName id + ty = idType id + new_id = mkVanillaId (setNameUnique name uniq) ty + new_env = extendVarEnv env id new_id in - returnUs (new_env, id') + name `seq` + seqType ty `seq` + returnUs (new_env, new_id) newLocalIds :: TopLevelFlag -> StgEnv -> [Id] -> UniqSM (StgEnv, [Id]) newLocalIds top_lev env [] @@ -768,6 +788,23 @@ newLocalIds top_lev env (b:bs) \end{code} +%************************************************************************ +%* * +\subsection{Building STG syn} +%* * +%************************************************************************ + +\begin{code} +mkStgAlgAlts ty alts deflt = seqType ty `seq` StgAlgAlts ty alts deflt +mkStgPrimAlts ty alts deflt = seqType ty `seq` StgPrimAlts ty alts deflt +mkStgCon con args ty = seqType ty `seq` StgCon con args ty +mkStgLam ty bndrs body = seqType ty `seq` StgLam ty bndrs body + +mkStgApp :: Id -> [StgArg] -> StgExpr +mkStgApp fn args = fn `seq` StgApp fn args + -- Force the lookup +\end{code} + \begin{code} -- Stg doesn't have a lambda *expression*, deStgLam (StgLam ty bndrs body) = mkStgLamExpr ty bndrs body @@ -776,7 +813,7 @@ deStgLam expr = returnUs expr mkStgLamExpr ty bndrs body = ASSERT( not (null bndrs) ) newStgVar ty `thenUs` \ fn -> - returnUs (StgLet (StgNonRec fn lam_closure) (StgApp fn [])) + returnUs (StgLet (StgNonRec fn lam_closure) (mkStgApp fn [])) where lam_closure = StgRhsClosure noCCS stgArgOcc diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs index 631218a..11ca944 100644 --- a/ghc/compiler/stgSyn/StgLint.lhs +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -224,6 +224,7 @@ lintAlgAlt scrut_ty (con, args, _, rhs) Just (tycon, tys_applied, cons) -> let arg_tys = dataConArgTys con tys_applied + -- This almost certainly does not work for existential constructors in checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `thenL_` checkL (length arg_tys == length args) (mkAlgAltMsg3 con args) diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs index 74155cf..8dc7331 100644 --- a/ghc/compiler/stranal/SaAbsInt.lhs +++ b/ghc/compiler/stranal/SaAbsInt.lhs @@ -21,7 +21,7 @@ import CoreUnfold ( Unfolding, maybeUnfoldingTemplate ) import PrimOp ( primOpStrictness ) import Id ( Id, idType, getIdStrictness, getIdUnfolding ) import Const ( Con(..) ) -import DataCon ( dataConTyCon, dataConArgTys ) +import DataCon ( dataConTyCon, splitProductType_maybe ) import IdInfo ( StrictnessInfo(..) ) import Demand ( Demand(..), wwPrim, wwStrict, wwEnum, wwUnpackData, wwUnpackNew ) @@ -714,25 +714,27 @@ findRecDemand str_fn abs_fn ty else -- It's strict (or we're pretending it is)! - case (splitAlgTyConApp_maybe ty) of + case splitProductType_maybe ty of - Nothing -> wwStrict + Nothing -> wwStrict -- Could have a test for wwEnum, but + -- we don't exploit it yet, so don't bother - Just (tycon,tycon_arg_tys,[data_con]) | isProductTyCon tycon -> - -- Non-recursive, single constructor case - let - cmpnt_tys = dataConArgTys data_con tycon_arg_tys - prod_len = length cmpnt_tys - in - - if isNewTyCon tycon then -- A newtype! - ASSERT( null (tail cmpnt_tys) ) + Just (tycon,_,data_con,cmpnt_tys) -- Non-recursive, single constructor case + | isNewTyCon tycon -- A newtype! + -> ASSERT( null (tail cmpnt_tys) ) let demand = findRecDemand str_fn abs_fn (head cmpnt_tys) in wwUnpackNew demand - else -- A data type! - let + + | null compt_strict_infos -- A nullary data type + -> wwStrict + + | otherwise -- Some other data type + -> wwUnpackData compt_strict_infos + + where + prod_len = length cmpnt_tys compt_strict_infos = [ findRecDemand (\ cmpnt_val -> @@ -743,21 +745,7 @@ findRecDemand str_fn abs_fn ty ) cmpnt_ty | (cmpnt_ty, i) <- cmpnt_tys `zip` [1..] ] - in - if null compt_strict_infos then - if isEnumerationTyCon tycon then wwEnum else wwStrict - else - wwUnpackData compt_strict_infos - - Just (tycon,_,_) -> - -- Multi-constr data types, *or* an abstract data - -- types, *or* things we don't have a way of conveying - -- the info over module boundaries (class ops, - -- superdict sels, dfns). - if isEnumerationTyCon tycon then - wwEnum - else - wwStrict + where is_numeric_type ty = case (splitAlgTyConApp_maybe ty) of -- NB: duplicates stuff done above diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index 4eefd47..c739cc9 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -19,7 +19,7 @@ import Id ( Id, idType, mkSysLocal, getIdDemandInfo, setIdDemandInfo, ) import IdInfo ( CprInfo(..), noCprInfo, vanillaIdInfo ) import Const ( Con(..), DataCon ) -import DataCon ( dataConArgTys ) +import DataCon ( splitProductType_maybe ) import Demand ( Demand(..) ) import PrelInfo ( realWorldPrimId, aBSENT_ERROR_ID ) import TysPrim ( realWorldStatePrimTy ) @@ -27,7 +27,7 @@ import TysWiredIn ( unboxedTupleCon, unboxedTupleTyCon ) import Type ( isUnLiftedType, mkTyVarTys, mkTyVarTy, mkFunTys, splitForAllTys, splitFunTys, splitFunTysN, splitAlgTyConApp_maybe, splitAlgTyConApp, - mkTyConApp, newTypeRep, isNewType, + mkTyConApp, splitNewType_maybe, Type ) import TyCon ( isNewTyCon, @@ -312,16 +312,10 @@ where R' is the representation type for R. \begin{code} mkWWcoerce body_ty - | not (isNewType body_ty) - = (id, id) - - | otherwise - = (wrap_fn . mkNote (Coerce body_ty rep_ty), - mkNote (Coerce rep_ty body_ty) . work_fn) - where - (tycon, args, _) = splitAlgTyConApp body_ty - rep_ty = newTypeRep tycon args - (wrap_fn, work_fn) = mkWWcoerce rep_ty + = case splitNewType_maybe body_ty of + Nothing -> (id, id) + Just rep_ty -> (mkNote (Coerce body_ty rep_ty), + mkNote (Coerce rep_ty body_ty)) \end{code} @@ -396,21 +390,7 @@ mk_ww (arg : ds) mk_unpk_case new_or_data arg unpk_args data_con arg_tycon . wrap_fn, work_fn . mk_pk_let new_or_data arg data_con tycon_arg_tys unpk_args) where - inst_con_arg_tys = dataConArgTys data_con tycon_arg_tys - (arg_tycon, tycon_arg_tys, data_con) - = case (splitAlgTyConApp_maybe (idType arg)) of - - Just (arg_tycon, tycon_arg_tys, [data_con]) -> - -- The main event: a single-constructor data type - (arg_tycon, tycon_arg_tys, data_con) - - Just (_, _, data_cons) -> - pprPanic "mk_ww_arg_processing:" - (text "not one constr (interface files not consistent/up to date?)" - $$ (ppr arg <+> ppr (idType arg))) - - Nothing -> - panic "mk_ww_arg_processing: not datatype" + (arg_tycon, tycon_arg_tys, data_con, inst_con_arg_tys) = splitProductType "mk_ww" (idType arg) -- Other cases other_demand -> @@ -512,7 +492,7 @@ mk_cpr_case (ty, cpr_info@(CPRInfo ci_args)) in returnUs (id_id, new_tup, new_exp_case) where - (data_con, tycon, tycon_arg_tys, inst_con_arg_tys) = splitType "mk_cpr_case" ty + (tycon, tycon_arg_tys, data_con, inst_con_arg_tys) = splitProductType "mk_cpr_case" ty from_type = head inst_con_arg_tys -- if coerced from a function 'look through' to find result type target_of_from_type = (snd.splitFunTys.snd.splitForAllTys) from_type @@ -570,29 +550,16 @@ mk_cpr_let (ty, cpr_info@(CPRInfo ci_args)) in returnUs (id_id, new_tup, new_exp) where - (data_con, tycon, tycon_arg_tys, inst_con_arg_tys) = splitType "mk_cpr_let" ty + (tycon, tycon_arg_tys, data_con, inst_con_arg_tys) = splitProductType "mk_cpr_let" ty from_type = head inst_con_arg_tys -- if coerced from a function 'look through' to find result type target_of_from_type = (snd.splitFunTys.snd.splitForAllTys) from_type -splitType :: String -> Type -> (DataCon, TyCon, [Type], [Type]) -splitType fname ty = (data_con, tycon, tycon_arg_tys, dataConArgTys data_con tycon_arg_tys) - where - (data_con, tycon, tycon_arg_tys) - = case (splitAlgTyConApp_maybe ty) of - Just (arg_tycon, tycon_arg_tys, [data_con]) -> - -- The main event: a single-constructor data type - (data_con, arg_tycon, tycon_arg_tys) - - Just (_, _, data_cons) -> - pprPanic (fname ++ ":") - (text "not one constr (interface files not consistent/up to date?)" - $$ ppr ty) - - Nothing -> - pprPanic (fname ++ ":") - (text "not a datatype" $$ ppr ty) +splitProductType :: String -> Type -> (TyCon, [Type], DataCon, [Type]) +splitProductType fname ty = case splitProductType_maybe ty of + Just stuff -> stuff + Nothing -> pprPanic (fname ++ ": not a product") (ppr ty) \end{code} diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index b9b308b..4fb993e 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -33,7 +33,7 @@ import HsTypes ( HsTyVar, getTyVarName ) import Id ( mkUserLocal, isDataConId_maybe ) import MkId ( mkSpecPragmaId ) import Var ( TyVar, Id, setVarName, - idType, setIdInfo, idInfo, tyVarKind + idType, lazySetIdInfo, idInfo, tyVarKind ) import TcType ( TcType, TcTyVar, TcTyVarSet, TcThetaType, tcInstTyVars, zonkTcTyVars, @@ -396,7 +396,7 @@ tcAddImportedIdInfo unf_env id -- have explicit local definitions, so we get a black hole! = id | otherwise - = id `setIdInfo` new_info + = id `lazySetIdInfo` new_info -- The Id must be returned without a data dependency on maybe_id where new_info = -- pprTrace "tcAdd" (ppr id) $ diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index a27b3b0..b9960e6 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -377,9 +377,9 @@ tcMonoExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty \end{code} \begin{code} -tcMonoExpr (HsSCC label expr) res_ty +tcMonoExpr (HsSCC lbl expr) res_ty = tcMonoExpr expr res_ty `thenTc` \ (expr', lie) -> - returnTc (HsSCC label expr', lie) + returnTc (HsSCC lbl expr', lie) tcMonoExpr (HsLet binds expr) res_ty = tcBindsAndThen @@ -982,7 +982,7 @@ Errors and contexts Mini-utils: \begin{code} pp_nest_hang :: String -> SDoc -> SDoc -pp_nest_hang label stuff = nest 2 (hang (text label) 4 stuff) +pp_nest_hang lbl stuff = nest 2 (hang (text lbl) 4 stuff) \end{code} Boring and alphabetical: diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 41e44c5..98c4a90 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -41,7 +41,7 @@ import HsSyn -- oodles of it -- others: import Id ( idName, idType, setIdType, omitIfaceSigForId, Id ) -import DataCon ( DataCon, dataConArgTys ) +import DataCon ( DataCon, splitProductType_maybe ) import TcEnv ( tcLookupValueMaybe, tcExtendGlobalValEnv, tcGetValueEnv, ValueEnv, TcId, tcInstId ) @@ -138,13 +138,11 @@ DsCCall.lhs. \begin{code} maybeBoxedPrimType :: Type -> Maybe (DataCon, Type) maybeBoxedPrimType ty - = case splitAlgTyConApp_maybe ty of -- Data type, - Just (tycon, tys_applied, [data_con]) | isDataTyCon tycon -- with exactly one constructor - -> case (dataConArgTys data_con tys_applied) of - [data_con_arg_ty] -- Applied to exactly one type, - | isUnLiftedType data_con_arg_ty -- which is primitive - -> Just (data_con, data_con_arg_ty) - other_cases -> Nothing + = case splitProductType_maybe ty of -- Product data type + Just (tycon, tys_applied, data_con, [data_con_arg_ty]) -- constr has one arg + | isUnLiftedType data_con_arg_ty -- which is primitive + -> Just (data_con, data_con_arg_ty) + other_cases -> Nothing \end{code} @@ -453,9 +451,9 @@ zonkExpr (CCall fun args may_gc is_casm result_ty) zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty -> returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty) -zonkExpr (HsSCC label expr) +zonkExpr (HsSCC lbl expr) = zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (HsSCC label new_expr) + returnNF_Tc (HsSCC lbl new_expr) zonkExpr (TyLam tyvars expr) = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars -> diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 2f14a7b..f615dec 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -39,7 +39,7 @@ import Bag ( emptyBag, unitBag, unionBags, unionManyBags, import CmdLineOpts ( opt_GlasgowExts, opt_AllowUndecidableInstances ) import Class ( classBigSig, Class ) import Var ( idName, idType, Id, TyVar ) -import DataCon ( isNullaryDataCon, dataConArgTys, dataConId ) +import DataCon ( isNullaryDataCon, splitProductType_maybe, dataConId ) import Maybes ( maybeToBool, catMaybes, expectJust ) import MkId ( mkDictFunId ) import Module ( ModuleName ) @@ -564,16 +564,13 @@ ccallable_type ty = isUnLiftedType ty || -- Allow CCallable Int# etc ty == stringTy || byte_arr_thing where - byte_arr_thing = case splitAlgTyConApp_maybe ty of - Just (tycon, ty_args, [data_con]) | isDataTyCon tycon -> - length data_con_arg_tys == 2 && + byte_arr_thing = case splitProductType_maybe ty of + Just (tycon, ty_args, data_con, [data_con_arg_ty1, data_con_arg_ty2]) -> maybeToBool maybe_arg2_tycon && (arg2_tycon == byteArrayPrimTyCon || arg2_tycon == mutableByteArrayPrimTyCon) where - data_con_arg_tys = dataConArgTys data_con ty_args - (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys - maybe_arg2_tycon = splitTyConApp_maybe data_con_arg_ty2 + maybe_arg2_tycon = splitTyConApp_maybe data_con_arg_ty2 Just (arg2_tycon,_) = maybe_arg2_tycon other -> False diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 49cf2bc..28eaddf 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -273,10 +273,10 @@ isDataTyCon other = False isNewTyCon (AlgTyCon {algTyConFlavour = NewType}) = True isNewTyCon other = False --- A "product" tycon is non-recursive and has one constructor, +-- A "product" tycon is non-recursive and has one constructor, and is *not* an unboxed tuple -- whether DataType or NewType isProductTyCon (AlgTyCon {dataCons = [c], algTyConRec = NonRecursive}) = True -isProductTyCon (TupleTyCon {}) = True +isProductTyCon (TupleTyCon { tyConBoxed = boxed }) = boxed isProductTyCon other = False isSynTyCon (SynTyCon {}) = True diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index d778277..93f2ff6 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -33,7 +33,7 @@ module Type ( splitAlgTyConApp_maybe, splitAlgTyConApp, mkDictTy, splitDictTy_maybe, isDictTy, - mkSynTy, isSynTy, deNoteType, repType, newTypeRep, + mkSynTy, isSynTy, deNoteType, repType, splitNewType_maybe, mkUsgTy, isUsgTy{- dont use -}, isNotUsgTy, splitUsgTy, unUsgTy, tyUsg, @@ -57,7 +57,11 @@ module Type ( tidyType, tidyTypes, tidyOpenType, tidyOpenTypes, tidyTyVar, tidyTyVars, - tidyTopType + tidyTopType, + + -- Seq + seqType, seqTypes + ) where #include "HsVersions.h" @@ -97,7 +101,7 @@ import PrimRep ( PrimRep(..), isFollowableRep ) import Unique -- quite a few *Keys import Util ( thenCmp, mapAccumL, seqList, ($!) ) import Outputable - +import UniqSet ( sizeUniqSet ) -- Should come via VarSet \end{code} %************************************************************************ @@ -543,6 +547,7 @@ isDictTy other = False mkSynTy syn_tycon tys = ASSERT( isSynTyCon syn_tycon ) ASSERT( isNotUsgTy body ) + ASSERT( length tyvars == length tys ) NoteTy (SynNote (TyConApp syn_tycon tys)) (substTy (mkTyVarSubst tyvars tys) body) where @@ -587,13 +592,24 @@ interested in newtypes anymore. repType :: Type -> Type repType (NoteTy _ ty) = repType ty repType (ForAllTy _ ty) = repType ty -repType (TyConApp tc tys) | isNewTyCon tc = repType (newTypeRep tc tys) +repType (TyConApp tc tys) | isNewTyCon tc = repType (new_type_rep tc tys) repType other_ty = other_ty -newTypeRep :: TyCon -> [Type] -> Type +splitNewType_maybe :: Type -> Maybe Type +-- Find the representation of a newtype, if it is one +splitNewType_maybe (NoteTy _ ty) = splitNewType_maybe ty +splitNewType_maybe (TyConApp tc tys) | isNewTyCon tc = case splitNewType_maybe rep_ty of + Just rep_ty' -> Just rep_ty' + Nothing -> Just rep_ty + where + rep_ty = new_type_rep tc tys + +splitNewType_maybe other = Nothing + +new_type_rep :: TyCon -> [Type] -> Type -- The representation type for (T t1 .. tn), where T is a newtype -- Looks through one layer only -newTypeRep tc tys +new_type_rep tc tys = ASSERT( isNewTyCon tc ) case splitFunTy_maybe (applyTys (dataConType (head (tyConDataCons tc))) tys) of Just (rep_ty, _) -> rep_ty @@ -1068,3 +1084,28 @@ cmpTy ty1 ty2 \end{code} +%************************************************************************ +%* * +\subsection{Sequencing on types +%* * +%************************************************************************ + +\begin{code} +seqType :: Type -> () +seqType (TyVarTy tv) = tv `seq` () +seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 +seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2 +seqType (NoteTy note t2) = seqNote note `seq` seqType t2 +seqType (TyConApp tc tys) = tc `seq` seqTypes tys +seqType (ForAllTy tv ty) = tv `seq` seqType ty + +seqTypes :: [Type] -> () +seqTypes [] = () +seqTypes (ty:tys) = seqType ty `seq` seqTypes tys + +seqNote :: TyNote -> () +seqNote (SynNote ty) = seqType ty +seqNote (FTVNote set) = sizeUniqSet set `seq` () +seqNote (UsgNote usg) = usg `seq` () +\end{code} + diff --git a/ghc/compiler/utils/Digraph.lhs b/ghc/compiler/utils/Digraph.lhs index b904fff..3196e6e 100644 --- a/ghc/compiler/utils/Digraph.lhs +++ b/ghc/compiler/utils/Digraph.lhs @@ -377,13 +377,13 @@ path g v w = w `elem` (reachable g v) \begin{code} bcc :: Graph -> Forest [Vertex] -bcc g = (concat . map bicomps . map (label g dnum)) forest +bcc g = (concat . map bicomps . map (do_label g dnum)) forest where forest = dff g dnum = preArr (bounds g) forest -label :: Graph -> Table Int -> Tree Vertex -> Tree (Vertex,Int,Int) -label g dnum (Node v ts) = Node (v,dnum!v,lv) us - where us = map (label g dnum) ts +do_label :: Graph -> Table Int -> Tree Vertex -> Tree (Vertex,Int,Int) +do_label g dnum (Node v ts) = Node (v,dnum!v,lv) us + where us = map (do_label g dnum) ts lv = minimum ([dnum!v] ++ [dnum!w | w <- g!v] ++ [lu | Node (u,du,lu) xs <- us]) diff --git a/ghc/compiler/utils/StringBuffer.lhs b/ghc/compiler/utils/StringBuffer.lhs index 2b22939..f70500a 100644 --- a/ghc/compiler/utils/StringBuffer.lhs +++ b/ghc/compiler/utils/StringBuffer.lhs @@ -212,7 +212,10 @@ slurpFileExpandTabs fname = do trySlurp :: Handle -> Int -> Addr -> IO (Addr, Int) trySlurp handle sz_i chunk = -#if __GLASGOW_HASKELL__ >= 303 +#if __GLASGOW_HASKELL__ == 303 + wantReadableHandle "hGetChar" handle >>= \ handle_ -> + let fo = haFO__ handle_ in +#elif __GLASGOW_HASKELL__ > 303 wantReadableHandle "hGetChar" handle $ \ handle_ -> let fo = haFO__ handle_ in #else @@ -276,7 +279,7 @@ reAllocMem :: Addr -> Int -> IO Addr reAllocMem ptr sz = do chunk <- _ccall_ realloc ptr sz if chunk == nullAddr -#if __GLASGOW_HASKELL__ < 303 +#ifndef __HASKELL98__ then fail (userError "reAllocMem") #else then fail "reAllocMem" -- 1.7.10.4