From: Jose Pedro Magalhaes Date: Thu, 5 May 2011 06:11:52 +0000 (+0200) Subject: Merge branch 'master' of http://darcs.haskell.org/ghc into ghc-generics X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=ea94a66d93047a9b0cd4532645eb1e9be04888e1;hp=ffabe3acb2d30be0c8e89e139f5bca7a1eb900f6 Merge branch 'master' of darcs.haskell.org/ghc into ghc-generics Fixed conflicts: compiler/iface/IfaceSyn.lhs compiler/typecheck/TcSMonad.lhs --- diff --git a/Makefile b/Makefile index 1a23e2e..0929f28 100644 --- a/Makefile +++ b/Makefile @@ -45,7 +45,7 @@ endif include mk/custom-settings.mk # No need to update makefiles for these targets: -REALGOALS=$(filter-out binary-dist binary-dist-prep bootstrapping-files framework-pkg clean clean_% distclean maintainer-clean show help install-docs test fulltest,$(MAKECMDGOALS)) +REALGOALS=$(filter-out binary-dist binary-dist-prep bootstrapping-files framework-pkg clean clean_% distclean maintainer-clean show help test fulltest,$(MAKECMDGOALS)) # configure touches certain files even if they haven't changed. This # can mean a lot of unnecessary recompilation after a re-configure, so @@ -102,12 +102,6 @@ framework-pkg: $(MAKE) -C distrib/MacOS $@ endif -# install-docs is a historical target that isn't supported in GHC 6.12. See #3662. -install-docs: - @echo "The install-docs target is not supported in GHC 6.12.1 and later." - @echo "'make install' now installs everything, including documentation." - @exit 1 - # If the user says 'make A B', then we don't want to invoke two # instances of the rule above in parallel: .NOTPARALLEL: diff --git a/aclocal.m4 b/aclocal.m4 index 7433873..c7aba3e 100644 --- a/aclocal.m4 +++ b/aclocal.m4 @@ -1031,18 +1031,6 @@ AC_SUBST([FopCmd]) ])# FP_PROG_FOP -# FP_PROG_HSTAGS -# ---------------- -# Sets the output variable HstagsCmd to the full Haskell tags program path. -# HstagsCmd is empty if no such program could be found. -AC_DEFUN([FP_PROG_HSTAGS], -[AC_PATH_PROG([HstagsCmd], [hasktags]) -if test -z "$HstagsCmd"; then - AC_MSG_WARN([cannot find hasktags in your PATH, you will not be able to build the tags]) -fi -])# FP_PROG_HSTAGS - - # FP_PROG_GHC_PKG # ---------------- # Try to find a ghc-pkg matching the ghc mentioned in the environment variable diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs index bca185f..13810da 100644 --- a/compiler/basicTypes/Var.lhs +++ b/compiler/basicTypes/Var.lhs @@ -137,8 +137,7 @@ data Var -- Identical to the Unique in the name, -- cached here for speed varType :: Kind, -- ^ The type or kind of the 'Var' in question - isCoercionVar :: Bool - } + isCoercionVar :: Bool } | TcTyVar { -- Used only during type inference -- Used for kind variables during diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs index 41d5240..c5e0118 100644 --- a/compiler/deSugar/Check.lhs +++ b/compiler/deSugar/Check.lhs @@ -110,8 +110,7 @@ type EqnSet = UniqSet EqnNo check :: [EquationInfo] -> ([ExhaustivePat], [EquationInfo]) -- Second result is the shadowed equations -- if there are view patterns, just give up - don't know what the function is -check qs = pprTrace "check" (ppr tidy_qs) $ - (untidy_warns, shadowed_eqns) +check qs = (untidy_warns, shadowed_eqns) where tidy_qs = map tidy_eqn qs (warns, used_nos) = check' ([1..] `zip` tidy_qs) diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index ea1ace8..dcf2177 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -5,34 +5,34 @@ \begin{code} module IfaceSyn ( - module IfaceType, -- Re-export all this + module IfaceType, - IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..), - IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..), - IfaceBinding(..), IfaceConAlt(..), - IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..), - IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, - IfaceInst(..), IfaceFamInst(..), + IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..), + IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..), + IfaceBinding(..), IfaceConAlt(..), + IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..), + IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, + IfaceInst(..), IfaceFamInst(..), - -- Misc + -- Misc ifaceDeclSubBndrs, visibleIfConDecls, -- Free Names freeNamesIfDecl, freeNamesIfRule, - -- Pretty printing - pprIfaceExpr, pprIfaceDeclHead + -- Pretty printing + pprIfaceExpr, pprIfaceDeclHead ) where #include "HsVersions.h" import IfaceType import CoreSyn( DFunArg, dfunArgExprs ) -import PprCore() -- Printing DFunArgs +import PprCore() -- Printing DFunArgs import Demand import Annotations import Class -import NameSet +import NameSet import Name import CostCentre import Literal @@ -48,66 +48,67 @@ infixl 3 &&& %************************************************************************ -%* * - Data type declarations -%* * +%* * + Data type declarations +%* * %************************************************************************ \begin{code} -data IfaceDecl - = IfaceId { ifName :: OccName, - ifType :: IfaceType, - ifIdDetails :: IfaceIdDetails, - ifIdInfo :: IfaceIdInfo } - - | IfaceData { ifName :: OccName, -- Type constructor - ifTyVars :: [IfaceTvBndr], -- Type variables - ifCtxt :: IfaceContext, -- The "stupid theta" - ifCons :: IfaceConDecls, -- Includes new/data info - ifRec :: RecFlag, -- Recursive or not? - ifGadtSyntax :: Bool, -- True <=> declared using - -- GADT syntax +data IfaceDecl + = IfaceId { ifName :: OccName, + ifType :: IfaceType, + ifIdDetails :: IfaceIdDetails, + ifIdInfo :: IfaceIdInfo } + + | IfaceData { ifName :: OccName, -- Type constructor + ifTyVars :: [IfaceTvBndr], -- Type variables + ifCtxt :: IfaceContext, -- The "stupid theta" + ifCons :: IfaceConDecls, -- Includes new/data info + ifRec :: RecFlag, -- Recursive or not? + ifGadtSyntax :: Bool, -- True <=> declared using + -- GADT syntax ifFamInst :: Maybe (IfaceTyCon, [IfaceType]) -- Just <=> instance of family - -- Invariant: + -- Invariant: -- ifCons /= IfOpenDataTyCon -- for family instances } - | IfaceSyn { ifName :: OccName, -- Type constructor - ifTyVars :: [IfaceTvBndr], -- Type variables - ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of the tycon) - ifSynRhs :: Maybe IfaceType, -- Just rhs for an ordinary synonyn - -- Nothing for an open family + | IfaceSyn { ifName :: OccName, -- Type constructor + ifTyVars :: [IfaceTvBndr], -- Type variables + ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of the tycon) + ifSynRhs :: Maybe IfaceType, -- Just rhs for an ordinary synonyn + -- Nothing for an open family ifFamInst :: Maybe (IfaceTyCon, [IfaceType]) -- Just <=> instance of family -- Invariant: ifOpenSyn == False -- for family instances } - | IfaceClass { ifCtxt :: IfaceContext, -- Context... - ifName :: OccName, -- Name of the class - ifTyVars :: [IfaceTvBndr], -- Type variables - ifFDs :: [FunDep FastString], -- Functional dependencies - ifATs :: [IfaceDecl], -- Associated type families - ifSigs :: [IfaceClassOp], -- Method signatures - ifRec :: RecFlag -- Is newtype/datatype associated with the class recursive? + | IfaceClass { ifCtxt :: IfaceContext, -- Context... + ifName :: OccName, -- Name of the class + ifTyVars :: [IfaceTvBndr], -- Type variables + ifFDs :: [FunDep FastString], -- Functional dependencies + ifATs :: [IfaceDecl], -- Associated type families + ifSigs :: [IfaceClassOp], -- Method signatures + ifRec :: RecFlag -- Is newtype/datatype associated + -- with the class recursive? } | IfaceForeign { ifName :: OccName, -- Needs expanding when we move -- beyond .NET - ifExtName :: Maybe FastString } + ifExtName :: Maybe FastString } data IfaceClassOp = IfaceClassOp OccName DefMethSpec IfaceType - -- Nothing => no default method - -- Just False => ordinary polymorphic default method - -- Just True => generic default method + -- Nothing => no default method + -- Just False => ordinary polymorphic default method + -- Just True => generic default method data IfaceConDecls - = IfAbstractTyCon -- No info - | IfOpenDataTyCon -- Open data family - | IfDataTyCon [IfaceConDecl] -- data type decls - | IfNewTyCon IfaceConDecl -- newtype decls + = IfAbstractTyCon -- No info + | IfOpenDataTyCon -- Open data family + | IfDataTyCon [IfaceConDecl] -- data type decls + | IfNewTyCon IfaceConDecl -- newtype decls visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] visibleIfConDecls IfAbstractTyCon = [] @@ -115,49 +116,49 @@ visibleIfConDecls IfOpenDataTyCon = [] visibleIfConDecls (IfDataTyCon cs) = cs visibleIfConDecls (IfNewTyCon c) = [c] -data IfaceConDecl +data IfaceConDecl = IfCon { - ifConOcc :: OccName, -- Constructor name - ifConWrapper :: Bool, -- True <=> has a wrapper - ifConInfix :: Bool, -- True <=> declared infix - ifConUnivTvs :: [IfaceTvBndr], -- Universal tyvars - ifConExTvs :: [IfaceTvBndr], -- Existential tyvars - ifConEqSpec :: [(OccName,IfaceType)], -- Equality contraints - ifConCtxt :: IfaceContext, -- Non-stupid context - ifConArgTys :: [IfaceType], -- Arg types - ifConFields :: [OccName], -- ...ditto... (field labels) - ifConStricts :: [HsBang]} -- Empty (meaning all lazy), - -- or 1-1 corresp with arg tys - -data IfaceInst - = IfaceInst { ifInstCls :: IfExtName, -- See comments with - ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance - ifDFun :: IfExtName, -- The dfun - ifOFlag :: OverlapFlag, -- Overlap flag - ifInstOrph :: Maybe OccName } -- See Note [Orphans] - -- There's always a separate IfaceDecl for the DFun, which gives - -- its IdInfo with its full type and version number. - -- The instance declarations taken together have a version number, - -- and we don't want that to wobble gratuitously - -- If this instance decl is *used*, we'll record a usage on the dfun; - -- and if the head does not change it won't be used if it wasn't before + ifConOcc :: OccName, -- Constructor name + ifConWrapper :: Bool, -- True <=> has a wrapper + ifConInfix :: Bool, -- True <=> declared infix + ifConUnivTvs :: [IfaceTvBndr], -- Universal tyvars + ifConExTvs :: [IfaceTvBndr], -- Existential tyvars + ifConEqSpec :: [(OccName,IfaceType)], -- Equality contraints + ifConCtxt :: IfaceContext, -- Non-stupid context + ifConArgTys :: [IfaceType], -- Arg types + ifConFields :: [OccName], -- ...ditto... (field labels) + ifConStricts :: [HsBang]} -- Empty (meaning all lazy), + -- or 1-1 corresp with arg tys + +data IfaceInst + = IfaceInst { ifInstCls :: IfExtName, -- See comments with + ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance + ifDFun :: IfExtName, -- The dfun + ifOFlag :: OverlapFlag, -- Overlap flag + ifInstOrph :: Maybe OccName } -- See Note [Orphans] + -- There's always a separate IfaceDecl for the DFun, which gives + -- its IdInfo with its full type and version number. + -- The instance declarations taken together have a version number, + -- and we don't want that to wobble gratuitously + -- If this instance decl is *used*, we'll record a usage on the dfun; + -- and if the head does not change it won't be used if it wasn't before data IfaceFamInst = IfaceFamInst { ifFamInstFam :: IfExtName -- Family tycon - , ifFamInstTys :: [Maybe IfaceTyCon] -- Rough match types - , ifFamInstTyCon :: IfaceTyCon -- Instance decl - } + , ifFamInstTys :: [Maybe IfaceTyCon] -- Rough match types + , ifFamInstTyCon :: IfaceTyCon -- Instance decl + } data IfaceRule - = IfaceRule { - ifRuleName :: RuleName, - ifActivation :: Activation, - ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars - ifRuleHead :: IfExtName, -- Head of lhs - ifRuleArgs :: [IfaceExpr], -- Args of LHS - ifRuleRhs :: IfaceExpr, - ifRuleAuto :: Bool, - ifRuleOrph :: Maybe OccName -- Just like IfaceInst + = IfaceRule { + ifRuleName :: RuleName, + ifActivation :: Activation, + ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars + ifRuleHead :: IfExtName, -- Head of lhs + ifRuleArgs :: [IfaceExpr], -- Args of LHS + ifRuleRhs :: IfaceExpr, + ifRuleAuto :: Bool, + ifRuleOrph :: Maybe OccName -- Just like IfaceInst } data IfaceAnnotation @@ -179,80 +180,80 @@ data IfaceIdDetails | IfDFunId Int -- Number of silent args data IfaceIdInfo - = NoInfo -- When writing interface file without -O - | HasInfo [IfaceInfoItem] -- Has info, and here it is + = NoInfo -- When writing interface file without -O + | HasInfo [IfaceInfoItem] -- Has info, and here it is -- Here's a tricky case: -- * Compile with -O module A, and B which imports A.f -- * Change function f in A, and recompile without -O -- * When we read in old A.hi we read in its IdInfo (as a thunk) --- (In earlier GHCs we used to drop IdInfo immediately on reading, --- but we do not do that now. Instead it's discarded when the --- ModIface is read into the various decl pools.) +-- (In earlier GHCs we used to drop IdInfo immediately on reading, +-- but we do not do that now. Instead it's discarded when the +-- ModIface is read into the various decl pools.) -- * The version comparsion sees that new (=NoInfo) differs from old (=HasInfo *) --- and so gives a new version. +-- and so gives a new version. data IfaceInfoItem - = HsArity Arity + = HsArity Arity | HsStrictness StrictSig | HsInline InlinePragma - | HsUnfold Bool -- True <=> isNonRuleLoopBreaker is true - IfaceUnfolding -- See Note [Expose recursive functions] + | HsUnfold Bool -- True <=> isNonRuleLoopBreaker is true + IfaceUnfolding -- See Note [Expose recursive functions] | HsNoCafRefs -- NB: Specialisations and rules come in separately and are -- only later attached to the Id. Partial reason: some are orphans. -data IfaceUnfolding +data IfaceUnfolding = IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding -- Possibly could eliminate the Bool here, the information -- is also in the InlinePragma. - | IfCompulsory IfaceExpr -- Only used for default methods, in fact + | IfCompulsory IfaceExpr -- Only used for default methods, in fact | IfInlineRule Arity -- INLINE pragmas - Bool -- OK to inline even if *un*-saturated - Bool -- OK to inline even if context is boring - IfaceExpr + Bool -- OK to inline even if *un*-saturated + Bool -- OK to inline even if context is boring + IfaceExpr - | IfExtWrapper Arity IfExtName -- NB: sometimes we need a IfExtName (not just IfLclName) - | IfLclWrapper Arity IfLclName -- because the worker can simplify to a function in - -- another module. + | IfExtWrapper Arity IfExtName -- NB: sometimes we need a IfExtName (not just IfLclName) + | IfLclWrapper Arity IfLclName -- because the worker can simplify to a function in + -- another module. | IfDFunUnfold [DFunArg IfaceExpr] -------------------------------- data IfaceExpr - = IfaceLcl IfLclName + = IfaceLcl IfLclName | IfaceExt IfExtName | IfaceType IfaceType - | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted - | IfaceLam IfaceBndr IfaceExpr - | IfaceApp IfaceExpr IfaceExpr - | IfaceCase IfaceExpr IfLclName IfaceType [IfaceAlt] - | IfaceLet IfaceBinding IfaceExpr - | IfaceNote IfaceNote IfaceExpr + | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted + | IfaceLam IfaceBndr IfaceExpr + | IfaceApp IfaceExpr IfaceExpr + | IfaceCase IfaceExpr IfLclName IfaceType [IfaceAlt] + | IfaceLet IfaceBinding IfaceExpr + | IfaceNote IfaceNote IfaceExpr | IfaceCast IfaceExpr IfaceCoercion - | IfaceLit Literal - | IfaceFCall ForeignCall IfaceType + | IfaceLit Literal + | IfaceFCall ForeignCall IfaceType | IfaceTick Module Int data IfaceNote = IfaceSCC CostCentre | IfaceCoreNote String type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr) - -- Note: IfLclName, not IfaceBndr (and same with the case binder) - -- We reconstruct the kind/type of the thing from the context - -- thus saving bulk in interface files + -- Note: IfLclName, not IfaceBndr (and same with the case binder) + -- We reconstruct the kind/type of the thing from the context + -- thus saving bulk in interface files data IfaceConAlt = IfaceDefault - | IfaceDataAlt IfExtName - | IfaceTupleAlt Boxity - | IfaceLitAlt Literal + | IfaceDataAlt IfExtName + | IfaceTupleAlt Boxity + | IfaceLitAlt Literal data IfaceBinding - = IfaceNonRec IfaceLetBndr IfaceExpr - | IfaceRec [(IfaceLetBndr, IfaceExpr)] + = IfaceNonRec IfaceLetBndr IfaceExpr + | IfaceRec [(IfaceLetBndr, IfaceExpr)] -- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too -- It's used for *non-top-level* let/rec binders @@ -291,9 +292,9 @@ complicate the situation though. Consider and suppose we are compiling module X: module X where - import M - data T = ... - instance C Int T where ... + import M + data T = ... + instance C Int T where ... This instance is an orphan, because when compiling a third module Y we might get a constraint (C Int v), and we'd want to improve v to T. So @@ -307,7 +308,7 @@ More precisely, an instance is an orphan iff If there are fundeps, then for every fundep, at least one of the names free in a *non-determined* part of the instance head is - defined in this module. + defined in this module. (Note that these conditions hold trivially if the class is locally defined.) @@ -334,10 +335,10 @@ a functionally-dependent part of the instance decl. E.g. and suppose we are compiling module X: module X where - import M - data S = ... - data T = ... - instance C S T where ... + import M + data S = ... + data T = ... + instance C S T where ... If we base the instance verion on T, I'm worried that changing S to S' would change T's version, but not S or S'. But an importing module might @@ -348,8 +349,8 @@ and it seems deeply obscure, so I'm going to leave it for now. Note [Versioning of rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~ -A rule that is not an orphan has an ifRuleOrph field of (Just n), where -n appears on the LHS of the rule; any change in the rule changes the version of n. +A rule that is not an orphan has an ifRuleOrph field of (Just n), where n +appears on the LHS of the rule; any change in the rule changes the version of n. \begin{code} @@ -372,7 +373,7 @@ ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon} = [] ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, ifCons = IfNewTyCon ( IfCon { ifConOcc = con_occ }), - ifFamInst = famInst}) + ifFamInst = famInst}) = -- implicit coerion and (possibly) family instance coercion (mkNewTyCoOcc tc_occ) : (famInstCo famInst tc_occ) ++ -- data constructor and worker (newtypes don't have a wrapper) @@ -380,8 +381,8 @@ ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, - ifCons = IfDataTyCon cons, - ifFamInst = famInst}) + ifCons = IfDataTyCon cons, + ifFamInst = famInst}) = -- (possibly) family instance coercion; -- there is no implicit coercion for non-newtypes famInstCo famInst tc_occ @@ -390,20 +391,20 @@ ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, ++ concatMap dc_occs cons where dc_occs con_decl - | has_wrapper = [con_occ, work_occ, wrap_occ] - | otherwise = [con_occ, work_occ] - where - con_occ = ifConOcc con_decl -- DataCon namespace - wrap_occ = mkDataConWrapperOcc con_occ -- Id namespace - work_occ = mkDataConWorkerOcc con_occ -- Id namespace - has_wrapper = ifConWrapper con_decl -- This is the reason for - -- having the ifConWrapper field! - -ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, - ifSigs = sigs, ifATs = ats }) + | has_wrapper = [con_occ, work_occ, wrap_occ] + | otherwise = [con_occ, work_occ] + where + con_occ = ifConOcc con_decl -- DataCon namespace + wrap_occ = mkDataConWrapperOcc con_occ -- Id namespace + work_occ = mkDataConWorkerOcc con_occ -- Id namespace + has_wrapper = ifConWrapper con_decl -- This is the reason for + -- having the ifConWrapper field! + +ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, + ifSigs = sigs, ifATs = ats }) = -- dictionary datatype: -- type constructor - tc_occ : + tc_occ : -- (possibly) newtype coercion co_occs ++ -- data constructor (DataCon namespace) @@ -420,14 +421,14 @@ ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, n_ctxt = length sc_ctxt n_sigs = length sigs tc_occ = mkClassTyConOcc cls_occ - dc_occ = mkClassDataConOcc cls_occ + dc_occ = mkClassDataConOcc cls_occ co_occs | is_newtype = [mkNewTyCoOcc tc_occ] - | otherwise = [] + | otherwise = [] dcww_occ = mkDataConWorkerOcc dc_occ - is_newtype = n_sigs + n_ctxt == 1 -- Sigh + is_newtype = n_sigs + n_ctxt == 1 -- Sigh ifaceDeclSubBndrs (IfaceSyn {ifName = tc_occ, - ifFamInst = famInst}) + ifFamInst = famInst}) = famInstCo famInst tc_occ ifaceDeclSubBndrs _ = [] @@ -443,46 +444,46 @@ instance Outputable IfaceDecl where ppr = pprIfaceDecl pprIfaceDecl :: IfaceDecl -> SDoc -pprIfaceDecl (IfaceId {ifName = var, ifType = ty, +pprIfaceDecl (IfaceId {ifName = var, ifType = ty, ifIdDetails = details, ifIdInfo = info}) - = sep [ ppr var <+> dcolon <+> ppr ty, - nest 2 (ppr details), - nest 2 (ppr info) ] + = sep [ ppr var <+> dcolon <+> ppr ty, + nest 2 (ppr details), + nest 2 (ppr info) ] pprIfaceDecl (IfaceForeign {ifName = tycon}) = hsep [ptext (sLit "foreign import type dotnet"), ppr tycon] -pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, - ifSynRhs = Just mono_ty, +pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, + ifSynRhs = Just mono_ty, ifFamInst = mbFamInst}) = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars) 4 (vcat [equals <+> ppr mono_ty, pprFamily mbFamInst]) -pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, - ifSynRhs = Nothing, ifSynKind = kind }) +pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, + ifSynRhs = Nothing, ifSynKind = kind }) = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars) 4 (dcolon <+> ppr kind) pprIfaceDecl (IfaceData {ifName = tycon, ifCtxt = context, - ifTyVars = tyvars, ifCons = condecls, - ifRec = isrec, ifFamInst = mbFamInst}) + ifTyVars = tyvars, ifCons = condecls, + ifRec = isrec, ifFamInst = mbFamInst}) = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) 4 (vcat [pprRec isrec, pp_condecls tycon condecls, - pprFamily mbFamInst]) + pprFamily mbFamInst]) where pp_nd = case condecls of - IfAbstractTyCon -> ptext (sLit "data") - IfOpenDataTyCon -> ptext (sLit "data family") - IfDataTyCon _ -> ptext (sLit "data") - IfNewTyCon _ -> ptext (sLit "newtype") - -pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, - ifFDs = fds, ifATs = ats, ifSigs = sigs, - ifRec = isrec}) + IfAbstractTyCon -> ptext (sLit "data") + IfOpenDataTyCon -> ptext (sLit "data family") + IfDataTyCon _ -> ptext (sLit "data") + IfNewTyCon _ -> ptext (sLit "newtype") + +pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, + ifFDs = fds, ifATs = ats, ifSigs = sigs, + ifRec = isrec}) = hang (ptext (sLit "class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds) 4 (vcat [pprRec isrec, - sep (map ppr ats), - sep (map ppr sigs)]) + sep (map ppr ats), + sep (map ppr sigs)]) pprRec :: RecFlag -> SDoc pprRec isrec = ptext (sLit "RecFlag") <+> ppr isrec @@ -496,68 +497,68 @@ instance Outputable IfaceClassOp where pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc pprIfaceDeclHead context thing tyvars - = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing), - pprIfaceTvBndrs tyvars] + = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing), + pprIfaceTvBndrs tyvars] pp_condecls :: OccName -> IfaceConDecls -> SDoc pp_condecls _ IfAbstractTyCon = ptext (sLit "{- abstract -}") pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c pp_condecls _ IfOpenDataTyCon = empty pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |")) - (map (pprIfaceConDecl tc) cs)) + (map (pprIfaceConDecl tc) cs)) pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc pprIfaceConDecl tc - (IfCon { ifConOcc = name, ifConInfix = is_infix, ifConWrapper = has_wrap, - ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs, - ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys, - ifConStricts = strs, ifConFields = fields }) + (IfCon { ifConOcc = name, ifConInfix = is_infix, ifConWrapper = has_wrap, + ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs, + ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys, + ifConStricts = strs, ifConFields = fields }) = sep [main_payload, - if is_infix then ptext (sLit "Infix") else empty, - if has_wrap then ptext (sLit "HasWrapper") else empty, - ppUnless (null strs) $ - nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr_bang strs)), - ppUnless (null fields) $ - nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))] + if is_infix then ptext (sLit "Infix") else empty, + if has_wrap then ptext (sLit "HasWrapper") else empty, + ppUnless (null strs) $ + nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr_bang strs)), + ppUnless (null fields) $ + nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))] where - ppr_bang HsNoBang = char '_' -- Want to see these + ppr_bang HsNoBang = char '_' -- Want to see these ppr_bang bang = ppr bang - - main_payload = ppr name <+> dcolon <+> - pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau - eq_ctxt = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty) - | (tv,ty) <- eq_spec] + main_payload = ppr name <+> dcolon <+> + pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau - -- A bit gruesome this, but we can't form the full con_tau, and ppr it, - -- because we don't have a Name for the tycon, only an OccName + eq_ctxt = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty) + | (tv,ty) <- eq_spec] + + -- A bit gruesome this, but we can't form the full con_tau, and ppr it, + -- because we don't have a Name for the tycon, only an OccName pp_tau = case map pprParendIfaceType arg_tys ++ [pp_res_ty] of - (t:ts) -> fsep (t : map (arrow <+>) ts) - [] -> panic "pp_con_taus" + (t:ts) -> fsep (t : map (arrow <+>) ts) + [] -> panic "pp_con_taus" pp_res_ty = ppr tc <+> fsep [ppr tv | (tv,_) <- univ_tvs] instance Outputable IfaceRule where ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, - ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs }) + ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs }) = sep [hsep [doubleQuotes (ftext name), ppr act, - ptext (sLit "forall") <+> pprIfaceBndrs bndrs], - nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args), - ptext (sLit "=") <+> ppr rhs]) + ptext (sLit "forall") <+> pprIfaceBndrs bndrs], + nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args), + ptext (sLit "=") <+> ppr rhs]) ] instance Outputable IfaceInst where - ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag, - ifInstCls = cls, ifInstTys = mb_tcs}) - = hang (ptext (sLit "instance") <+> ppr flag - <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs)) + ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag, + ifInstCls = cls, ifInstTys = mb_tcs}) + = hang (ptext (sLit "instance") <+> ppr flag + <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs)) 2 (equals <+> ppr dfun_id) instance Outputable IfaceFamInst where ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs, - ifFamInstTyCon = tycon_id}) - = hang (ptext (sLit "family instance") <+> - ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs)) + ifFamInstTyCon = tycon_id}) + = hang (ptext (sLit "family instance") <+> + ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs)) 2 (equals <+> ppr tycon_id) ppr_rough :: Maybe IfaceTyCon -> SDoc @@ -575,9 +576,11 @@ instance Outputable IfaceExpr where pprParendIfaceExpr :: IfaceExpr -> SDoc pprParendIfaceExpr = pprIfaceExpr parens +-- | Pretty Print an IfaceExpre +-- +-- The first argument should be a function that adds parens in context that need +-- an atomic value (e.g. function args) pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc - -- The function adds parens in context that need - -- an atomic value (e.g. function args) pprIfaceExpr _ (IfaceLcl v) = ppr v pprIfaceExpr _ (IfaceExt v) = ppr v @@ -589,100 +592,107 @@ pprIfaceExpr _ (IfaceType ty) = char '@' <+> pprParendIfaceType ty pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app []) pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (interpp'SP as) -pprIfaceExpr add_par e@(IfaceLam _ _) +pprIfaceExpr add_par i@(IfaceLam _ _) = add_par (sep [char '\\' <+> sep (map ppr bndrs) <+> arrow, - pprIfaceExpr noParens body]) - where - (bndrs,body) = collect [] e + pprIfaceExpr noParens body]) + where + (bndrs,body) = collect [] i collect bs (IfaceLam b e) = collect (b:bs) e collect bs e = (reverse bs, e) pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)]) = add_par (sep [ptext (sLit "case") <+> char '@' <+> pprParendIfaceType ty - <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") - <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow, - pprIfaceExpr noParens rhs <+> char '}']) + <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") + <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow, + pprIfaceExpr noParens rhs <+> char '}']) pprIfaceExpr add_par (IfaceCase scrut bndr ty alts) = add_par (sep [ptext (sLit "case") <+> char '@' <+> pprParendIfaceType ty - <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") - <+> ppr bndr <+> char '{', - nest 2 (sep (map ppr_alt alts)) <+> char '}']) + <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") + <+> ppr bndr <+> char '{', + nest 2 (sep (map ppr_alt alts)) <+> char '}']) pprIfaceExpr _ (IfaceCast expr co) = sep [pprParendIfaceExpr expr, - nest 2 (ptext (sLit "`cast`")), - pprParendIfaceType co] + nest 2 (ptext (sLit "`cast`")), + pprParendIfaceType co] pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body) - = add_par (sep [ptext (sLit "let {"), - nest 2 (ppr_bind (b, rhs)), - ptext (sLit "} in"), - pprIfaceExpr noParens body]) + = add_par (sep [ptext (sLit "let {"), + nest 2 (ppr_bind (b, rhs)), + ptext (sLit "} in"), + pprIfaceExpr noParens body]) pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body) = add_par (sep [ptext (sLit "letrec {"), - nest 2 (sep (map ppr_bind pairs)), - ptext (sLit "} in"), - pprIfaceExpr noParens body]) + nest 2 (sep (map ppr_bind pairs)), + ptext (sLit "} in"), + pprIfaceExpr noParens body]) -pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprParendIfaceExpr body) +pprIfaceExpr add_par (IfaceNote note body) = add_par $ ppr note + <+> pprParendIfaceExpr body ppr_alt :: (IfaceConAlt, [IfLclName], IfaceExpr) -> SDoc -ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs, - arrow <+> pprIfaceExpr noParens rhs] +ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs, + arrow <+> pprIfaceExpr noParens rhs] ppr_con_bs :: IfaceConAlt -> [IfLclName] -> SDoc ppr_con_bs (IfaceTupleAlt tup_con) bs = tupleParens tup_con (interpp'SP bs) -ppr_con_bs con bs = ppr con <+> hsep (map ppr bs) - +ppr_con_bs con bs = ppr con <+> hsep (map ppr bs) + ppr_bind :: (IfaceLetBndr, IfaceExpr) -> SDoc -ppr_bind (IfLetBndr b ty info, rhs) +ppr_bind (IfLetBndr b ty info, rhs) = sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr info), - equals <+> pprIfaceExpr noParens rhs] + equals <+> pprIfaceExpr noParens rhs] ------------------ pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc -pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprParendIfaceExpr arg) : args) -pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args) +pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun $ + nest 2 (pprParendIfaceExpr arg) : args +pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args) ------------------ instance Outputable IfaceNote where ppr (IfaceSCC cc) = pprCostCentreCore cc - ppr (IfaceCoreNote s) = ptext (sLit "__core_note") <+> pprHsString (mkFastString s) + ppr (IfaceCoreNote s) = ptext (sLit "__core_note") + <+> pprHsString (mkFastString s) instance Outputable IfaceConAlt where ppr IfaceDefault = text "DEFAULT" ppr (IfaceLitAlt l) = ppr l ppr (IfaceDataAlt d) = ppr d - ppr (IfaceTupleAlt _) = panic "ppr IfaceConAlt" + ppr (IfaceTupleAlt _) = panic "ppr IfaceConAlt" -- IfaceTupleAlt is handled by the case-alternative printer ------------------ instance Outputable IfaceIdDetails where - ppr IfVanillaId = empty + ppr IfVanillaId = empty ppr (IfRecSelId tc b) = ptext (sLit "RecSel") <+> ppr tc - <+> if b then ptext (sLit "") else empty + <+> if b then ptext (sLit "") else empty ppr (IfDFunId ns) = ptext (sLit "DFunId") <> brackets (int ns) instance Outputable IfaceIdInfo where ppr NoInfo = empty - ppr (HasInfo is) = ptext (sLit "{-") <+> pprWithCommas ppr is <+> ptext (sLit "-}") + ppr (HasInfo is) = ptext (sLit "{-") <+> pprWithCommas ppr is + <+> ptext (sLit "-}") instance Outputable IfaceInfoItem where - ppr (HsUnfold lb unf) = ptext (sLit "Unfolding") <> ppWhen lb (ptext (sLit "(loop-breaker)")) + ppr (HsUnfold lb unf) = ptext (sLit "Unfolding") + <> ppWhen lb (ptext (sLit "(loop-breaker)")) <> colon <+> ppr unf ppr (HsInline prag) = ptext (sLit "Inline:") <+> ppr prag ppr (HsArity arity) = ptext (sLit "Arity:") <+> int arity ppr (HsStrictness str) = ptext (sLit "Strictness:") <+> pprIfaceStrictSig str - ppr HsNoCafRefs = ptext (sLit "HasNoCafRefs") + ppr HsNoCafRefs = ptext (sLit "HasNoCafRefs") instance Outputable IfaceUnfolding where ppr (IfCompulsory e) = ptext (sLit "") <+> parens (ppr e) - ppr (IfCoreUnfold s e) = (if s then ptext (sLit "") else empty) <+> parens (ppr e) - ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule") <+> ppr (a,uok,bok), - pprParendIfaceExpr e] + ppr (IfCoreUnfold s e) = (if s then ptext (sLit "") else empty) + <+> parens (ppr e) + ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule") + <+> ppr (a,uok,bok), + pprParendIfaceExpr e] ppr (IfLclWrapper a wkr) = ptext (sLit "Worker(lcl):") <+> ppr wkr <+> parens (ptext (sLit "arity") <+> int a) ppr (IfExtWrapper a wkr) = ptext (sLit "Worker(ext0:") <+> ppr wkr @@ -691,7 +701,7 @@ instance Outputable IfaceUnfolding where <+> brackets (pprWithCommas ppr ns) -- ----------------------------------------------------------------------------- --- Finding the Names in IfaceSyn +-- | Finding the Names in IfaceSyn -- This is used for dependency analysis in MkIface, so that we -- fingerprint a declaration before the things that depend on it. It @@ -701,11 +711,11 @@ instance Outputable IfaceUnfolding where -- fingerprinting the instance, so DFuns are not dependencies. freeNamesIfDecl :: IfaceDecl -> NameSet -freeNamesIfDecl (IfaceId _s t d i) = +freeNamesIfDecl (IfaceId _s t d i) = freeNamesIfType t &&& freeNamesIfIdInfo i &&& freeNamesIfIdDetails d -freeNamesIfDecl IfaceForeign{} = +freeNamesIfDecl IfaceForeign{} = emptyNameSet freeNamesIfDecl d@IfaceData{} = freeNamesIfTvBndrs (ifTyVars d) &&& @@ -732,7 +742,7 @@ freeNamesIfSynRhs (Just ty) = freeNamesIfType ty freeNamesIfSynRhs Nothing = emptyNameSet freeNamesIfTcFam :: Maybe (IfaceTyCon, [IfaceType]) -> NameSet -freeNamesIfTcFam (Just (tc,tys)) = +freeNamesIfTcFam (Just (tc,tys)) = freeNamesIfTc tc &&& fnList freeNamesIfType tys freeNamesIfTcFam Nothing = emptyNameSet @@ -752,15 +762,15 @@ freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c freeNamesIfConDecls _ = emptyNameSet freeNamesIfConDecl :: IfaceConDecl -> NameSet -freeNamesIfConDecl c = +freeNamesIfConDecl c = freeNamesIfTvBndrs (ifConUnivTvs c) &&& freeNamesIfTvBndrs (ifConExTvs c) &&& - freeNamesIfContext (ifConCtxt c) &&& + freeNamesIfContext (ifConCtxt c) &&& fnList freeNamesIfType (ifConArgTys c) &&& fnList freeNamesIfType (map snd (ifConEqSpec c)) -- equality constraints freeNamesIfPredType :: IfacePredType -> NameSet -freeNamesIfPredType (IfaceClassP cl tys) = +freeNamesIfPredType (IfaceClassP cl tys) = unitNameSet cl &&& fnList freeNamesIfType tys freeNamesIfPredType (IfaceIParam _n ty) = freeNamesIfType ty @@ -771,7 +781,7 @@ freeNamesIfType :: IfaceType -> NameSet freeNamesIfType (IfaceTyVar _) = emptyNameSet freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfType t freeNamesIfType (IfacePredTy st) = freeNamesIfPredType st -freeNamesIfType (IfaceTyConApp tc ts) = +freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& fnList freeNamesIfType ts freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfTvBndr tv &&& freeNamesIfType t @@ -786,7 +796,7 @@ freeNamesIfBndr (IfaceTvBndr b) = freeNamesIfTvBndr b freeNamesIfLetBndr :: IfaceLetBndr -> NameSet -- Remember IfaceLetBndr is used only for *nested* bindings --- The IdInfo can contain an unfolding (in the case of +-- The IdInfo can contain an unfolding (in the case of -- local INLINE pragmas), so look there too freeNamesIfLetBndr (IfLetBndr _name ty info) = freeNamesIfType ty &&& freeNamesIfIdInfo info @@ -799,7 +809,7 @@ freeNamesIfIdBndr :: IfaceIdBndr -> NameSet freeNamesIfIdBndr = freeNamesIfTvBndr freeNamesIfIdInfo :: IfaceIdInfo -> NameSet -freeNamesIfIdInfo NoInfo = emptyNameSet +freeNamesIfIdInfo NoInfo = emptyNameSet freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i freeNamesItem :: IfaceInfoItem -> NameSet @@ -815,17 +825,17 @@ freeNamesIfUnfold (IfLclWrapper {}) = emptyNameSet freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr (dfunArgExprs vs) freeNamesIfExpr :: IfaceExpr -> NameSet -freeNamesIfExpr (IfaceExt v) = unitNameSet v +freeNamesIfExpr (IfaceExt v) = unitNameSet v freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as freeNamesIfExpr (IfaceLam b body) = freeNamesIfBndr b &&& freeNamesIfExpr body freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfType co -freeNamesIfExpr (IfaceNote _n r) = freeNamesIfExpr r +freeNamesIfExpr (IfaceNote _n r) = freeNamesIfExpr r freeNamesIfExpr (IfaceCase s _ ty alts) - = freeNamesIfExpr s + = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts &&& freeNamesIfType ty where @@ -833,10 +843,10 @@ freeNamesIfExpr (IfaceCase s _ ty alts) -- Depend on the data constructors. Just one will do! -- Note [Tracking data constructors] - fn_cons [] = emptyNameSet - fn_cons ((IfaceDefault ,_,_) : alts) = fn_cons alts - fn_cons ((IfaceDataAlt con,_,_) : _ ) = unitNameSet con - fn_cons (_ : _ ) = emptyNameSet + fn_cons [] = emptyNameSet + fn_cons ((IfaceDefault ,_,_) : xs) = fn_cons xs + fn_cons ((IfaceDataAlt con,_,_) : _ ) = unitNameSet con + fn_cons (_ : _ ) = emptyNameSet freeNamesIfExpr (IfaceLet (IfaceNonRec bndr rhs) body) = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs &&& freeNamesIfExpr body @@ -871,18 +881,18 @@ fnList f = foldr (&&&) emptyNameSet . map f Note [Tracking data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a case expression +In a case expression case e of { C a -> ...; ... } You might think that we don't need to include the datacon C -in the free names, because its type will probably show up in +in the free names, because its type will probably show up in the free names of 'e'. But in rare circumstances this may not happen. Here's the one that bit me: - module DynFlags where + module DynFlags where import {-# SOURCE #-} Packages( PackageState ) data DynFlags = DF ... PackageState ... - module Packages where + module Packages where import DynFlags data PackageState = PS ... lookupModule (df :: DynFlags) @@ -893,3 +903,4 @@ not happen. Here's the one that bit me: Now, lookupModule depends on DynFlags, but the transitive dependency on the *locally-defined* type PackageState is not visible. We need to take account of the use of the data constructor PS in the pattern match. + diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs index 911592b..9f25c08 100644 --- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -122,34 +122,25 @@ pprInfoTable env count lbl stat then Outputable.panic "LlvmCodeGen.Ppr: invalid info table!" else (pprLlvmData ([ldata'], ltypes), llvmUsed) + -- | We generate labels for info tables by converting them to the same label -- as for the entry code but adding this string as a suffix. iTableSuf :: String iTableSuf = "_itable" --- | Create an appropriate section declaration for subsection of text --- WARNING: This technique could fail as gas documentation says it only --- supports up to 8192 subsections per section. Inspection of the source --- code and some test programs seem to suggest it supports more than this --- so we are hoping it does. +-- | Create a specially crafted section declaration that encodes the order this +-- section should be in the final object code. +-- +-- The LlvmMangler.llvmFixupAsm pass over the assembly produced by LLVM uses +-- this section declaration to do its processing. mkLayoutSection :: Int -> LMSection mkLayoutSection n - -- On OSX we can't use the GNU Assembler, we must use the OSX assembler, which - -- doesn't support subsections. So we post process the assembly code, this - -- section specifier will be replaced with '.text' by the mangler. - = Just (fsLit $ infoSection ++ show n -#if darwin_TARGET_OS - ) -#else - ++ "#") -#endif + = Just (fsLit $ infoSection ++ show n) --- | The section we are putting info tables and their entry code into + +-- | The section we are putting info tables and their entry code into, should +-- be unique since we process the assembly pattern matching this. infoSection :: String -#if darwin_TARGET_OS -infoSection = "__STRIP,__me" -#else -infoSection = ".text; .text " -#endif +infoSection = "X98A__STRIP,__me" diff --git a/compiler/llvmGen/LlvmMangler.hs b/compiler/llvmGen/LlvmMangler.hs index ac187e0..591ef81 100644 --- a/compiler/llvmGen/LlvmMangler.hs +++ b/compiler/llvmGen/LlvmMangler.hs @@ -1,17 +1,21 @@ +{-# OPTIONS -fno-warn-unused-binds #-} -- ----------------------------------------------------------------------------- -- | GHC LLVM Mangler -- -- This script processes the assembly produced by LLVM, rearranging the code --- so that an info table appears before its corresponding function. We also --- use it to fix up the stack alignment, which needs to be 16 byte aligned --- but always ends up off by 4 bytes because GHC sets it to the 'wrong' --- starting value in the RTS. +-- so that an info table appears before its corresponding function. -- --- We only need this for Mac OS X, other targets don't use it. +-- On OSX we also use it to fix up the stack alignment, which needs to be 16 +-- byte aligned but always ends up off by word bytes because GHC sets it to +-- the 'wrong' starting value in the RTS. -- module LlvmMangler ( llvmFixupAsm ) where +#include "HsVersions.h" + +import LlvmCodeGen.Ppr ( infoSection ) + import Control.Exception import qualified Data.ByteString.Char8 as B import Data.Char @@ -19,18 +23,25 @@ import qualified Data.IntMap as I import System.IO -- Magic Strings -infoSec, newInfoSec, newLine, spInst, jmpInst :: B.ByteString -infoSec = B.pack "\t.section\t__STRIP,__me" +secStmt, infoSec, newInfoSec, newLine, spInst, jmpInst :: B.ByteString +secStmt = B.pack "\t.section\t" +infoSec = B.pack infoSection newInfoSec = B.pack "\n\t.text" newLine = B.pack "\n" -spInst = B.pack ", %esp\n" jmpInst = B.pack "\n\tjmp" -infoLen, spFix, labelStart :: Int -infoLen = B.length infoSec -spFix = 4 +infoLen, labelStart, spFix :: Int +infoLen = B.length infoSec labelStart = B.length jmpInst +#if x86_64_TARGET_ARCH +spInst = B.pack ", %rsp\n" +spFix = 8 +#else +spInst = B.pack ", %esp\n" +spFix = 4 +#endif + -- Search Predicates eolPred, dollarPred, commaPred :: Char -> Bool eolPred = ((==) '\n') @@ -50,25 +61,30 @@ llvmFixupAsm f1 f2 = do {- | Here we process the assembly file one function and data - defenition at a time. When a function is encountered that + definition at a time. When a function is encountered that should have a info table we store it in a map. Otherwise we print it. When an info table is found we retrieve its function from the map and print them both. For all functions we fix up the stack alignment. We also - fix up the section defenition for functions and info tables. + fix up the section definition for functions and info tables. -} fixTables :: Handle -> Handle -> I.IntMap B.ByteString -> IO () fixTables r w m = do f <- getFun r B.empty if B.null f then return () - else let fun = fixupStack f B.empty - (a,b) = B.breakSubstring infoSec fun - (x,c) = B.break eolPred b - fun' = a `B.append` newInfoSec `B.append` c - n = readInt $ B.drop infoLen x - (bs, m') | B.null b = ([fun], m) + else let fun = fixupStack f B.empty + (a,b) = B.breakSubstring infoSec fun + (a',s) = B.breakEnd eolPred a + -- We search for the section header in two parts as it makes + -- us portable across OS types and LLVM version types since + -- section names are wrapped differently. + secHdr = secStmt `B.isPrefixOf` s + (x,c) = B.break eolPred b + fun' = a' `B.append` newInfoSec `B.append` c + n = readInt $ B.takeWhile isDigit $ B.drop infoLen x + (bs, m') | B.null b || not secHdr = ([fun], m) | even n = ([], I.insert n fun' m) | otherwise = case I.lookup (n+1) m of Just xf' -> ([fun',xf'], m) @@ -88,7 +104,7 @@ getFun r f = do Mac OS X requires that the stack be 16 byte aligned when making a function call (only really required though when making a call that will pass through the dynamic linker). The alignment isn't correctly generated by LLVM as - LLVM rightly assumes that the stack wil be aligned to 16n + 12 on entry + LLVM rightly assumes that the stack will be aligned to 16n + 12 on entry (since the function call was 16 byte aligned and the return address should have been pushed, so sub 4). GHC though since it always uses jumps keeps the stack 16 byte aligned on both function calls and function entry. @@ -96,6 +112,11 @@ getFun r f = do We correct the alignment here. -} fixupStack :: B.ByteString -> B.ByteString -> B.ByteString + +#if !darwin_TARGET_OS +fixupStack = const + +#else fixupStack f f' | B.null f' = let -- fixup sub op (a, c) = B.breakSubstring spInst f @@ -124,10 +145,11 @@ fixupStack f f' = then fixupStack b $ f' `B.append` a `B.append` l else fixupStack b $ f' `B.append` a' `B.append` num `B.append` x `B.append` l +#endif --- | read an int or error +-- | Read an int or error readInt :: B.ByteString -> Int readInt str | B.all isDigit str = (read . B.unpack) str - | otherwise = error $ "LLvmMangler Cannot read" ++ show str - ++ "as it's not an Int" + | otherwise = error $ "LLvmMangler Cannot read " ++ show str + ++ " as it's not an Int" diff --git a/compiler/main/DriverPhases.hs b/compiler/main/DriverPhases.hs index f6a9738..4702682 100644 --- a/compiler/main/DriverPhases.hs +++ b/compiler/main/DriverPhases.hs @@ -143,11 +143,7 @@ nextPhase (Hsc _) = HCc nextPhase SplitMangle = As nextPhase As = SplitAs nextPhase LlvmOpt = LlvmLlc -#if darwin_TARGET_OS nextPhase LlvmLlc = LlvmMangle -#else -nextPhase LlvmLlc = As -#endif nextPhase LlvmMangle = As nextPhase SplitAs = MergeStub nextPhase Ccpp = As diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 03e3cf6..a832034 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -1307,22 +1307,18 @@ runPhase LlvmOpt input_fn dflags -- fix up some pretty big deficiencies in the code we generate llvmOpts = ["-mem2reg", "-O1", "-O2"] - ----------------------------------------------------------------------------- -- LlvmLlc phase runPhase LlvmLlc input_fn dflags = do let lc_opts = getOpts dflags opt_lc - let opt_lvl = max 0 (min 2 $ optLevel dflags) - let nphase = if cTargetOS == OSX - then LlvmMangle - else As - let rmodel | opt_PIC = "pic" + opt_lvl = max 0 (min 2 $ optLevel dflags) + rmodel | opt_PIC = "pic" | not opt_Static = "dynamic-no-pic" | otherwise = "static" - output_fn <- phaseOutputFilename nphase + output_fn <- phaseOutputFilename LlvmMangle io $ SysTools.runLlvmLlc dflags ([ SysTools.Option (llvmOpts !! opt_lvl), @@ -1331,13 +1327,13 @@ runPhase LlvmLlc input_fn dflags SysTools.Option "-o", SysTools.FileOption "" output_fn] ++ map SysTools.Option lc_opts) - return (nphase, output_fn) + return (LlvmMangle, output_fn) where + -- Bug in LLVM at O3 on OSX. llvmOpts = if cTargetOS == OSX then ["-O1", "-O2", "-O2"] else ["-O1", "-O2", "-O3"] - ----------------------------------------------------------------------------- -- LlvmMangle phase diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 3a10e02..3960717 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -1105,12 +1105,13 @@ parseDynamicFlags_ dflags0 args pkg_flags = do when (not (null errs)) $ ghcError $ errorsToGhcException errs let (pic_warns, dflags2) - | not (cTargetArch == X86_64 && cTargetOS == Linux) && + | not (cTargetArch == X86_64 && (cTargetOS == Linux || cTargetOS == OSX)) && (not opt_Static || opt_PIC) && hscTarget dflags1 == HscLlvm - = ([L noSrcSpan $ "Warning: -fllvm is incompatible with -fPIC and -" - ++ "dynamic on this platform;\n" - ++ " using " ++ showHscTargetFlag defaultObjectTarget ++ " instead"], + = ([L noSrcSpan $ "Warning: -fllvm is incompatible with -fPIC and " + ++ "-dynamic on this platform;\n" + ++ " using " + ++ showHscTargetFlag defaultObjectTarget ++ " instead"], dflags1{ hscTarget = defaultObjectTarget }) | otherwise = ([], dflags1) diff --git a/compiler/main/GhcMonad.hs b/compiler/main/GhcMonad.hs index 711259c..4c72f14 100644 --- a/compiler/main/GhcMonad.hs +++ b/compiler/main/GhcMonad.hs @@ -15,11 +15,11 @@ module GhcMonad ( reflectGhc, reifyGhc, getSessionDynFlags, liftIO, - Session(..), withSession, modifySession, withTempSession, + Session(..), withSession, modifySession, withTempSession, -- ** Warnings logWarnings, printException, printExceptionAndWarnings, - WarnErrLogger, defaultWarnErrLogger + WarnErrLogger, defaultWarnErrLogger ) where import MonadUtils diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 97a6514..436cfa6 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -238,7 +238,7 @@ initSysTools mbMinusB ld_prog = gcc_prog ld_args = gcc_args - -- figure out llvm location. (TODO: Acutally implement). + -- We just assume on command line ; let lc_prog = "llc" lo_prog = "opt" diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index b3458db..46eef67 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -841,9 +841,24 @@ rnParallelStmts ctxt segs thing_inside lookupStmtName :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars) -- Like lookupSyntaxName, but ListComp/PArrComp are never rebindable -lookupStmtName ListComp n = return (HsVar n, emptyFVs) -lookupStmtName PArrComp n = return (HsVar n, emptyFVs) -lookupStmtName _ n = lookupSyntaxName n +-- Neither is ArrowExpr, which has its own desugarer in DsArrows +lookupStmtName ctxt n + = case ctxt of + ListComp -> not_rebindable + PArrComp -> not_rebindable + ArrowExpr -> not_rebindable + PatGuard {} -> not_rebindable + + DoExpr -> rebindable + MDoExpr -> rebindable + MonadComp -> rebindable + GhciStmt -> rebindable -- I suppose? + + ParStmtCtxt c -> lookupStmtName c n -- Look inside to + TransStmtCtxt c -> lookupStmtName c n -- the parent context + where + rebindable = lookupSyntaxName n + not_rebindable = return (HsVar n, emptyFVs) \end{code} Note [Renaming parallel Stmts] diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 4573082..414c63a 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -102,6 +102,7 @@ import FastString import HsBinds -- for TcEvBinds stuff import Id +import StaticFlags( opt_PprStyle_Debug ) import TcRnTypes #ifdef DEBUG import Control.Monad( when ) diff --git a/configure.ac b/configure.ac index 4e9b548..67d6b57 100644 --- a/configure.ac +++ b/configure.ac @@ -632,8 +632,6 @@ FP_CHECK_DOCBOOK_DTD FP_DOCBOOK_XSL FP_PROG_DBLATEX -FP_PROG_HSTAGS - dnl ** check for ghc-pkg command FP_PROG_GHC_PKG diff --git a/ghc.spec.in b/ghc.spec.in index c8eab26..2a70043 100644 --- a/ghc.spec.in +++ b/ghc.spec.in @@ -177,7 +177,6 @@ fi %{_prefix}/bin/ghci %{_prefix}/bin/ghci-%{version} %{_prefix}/bin/ghcprof -%{_prefix}/bin/hasktags %{_prefix}/bin/hp2ps %{_prefix}/bin/hpc %{_prefix}/bin/hsc2hs-ghc diff --git a/mk/config.mk.in b/mk/config.mk.in index 8796ad4..3749bce 100644 --- a/mk/config.mk.in +++ b/mk/config.mk.in @@ -774,8 +774,6 @@ ALEX_VERSION = @AlexVersion@ # SRC_ALEX_OPTS = -g -HSTAGS = @HstagsCmd@ - # Should we build haddock docs? HADDOCK_DOCS = YES # And HsColour the sources? diff --git a/utils/Makefile b/utils/Makefile index 881d7d5..e522c32 100644 --- a/utils/Makefile +++ b/utils/Makefile @@ -60,7 +60,7 @@ endif WITH_BOOTSTRAPPING_COMPILER = installPackage ghc-pkg hsc2hs hpc -WITH_STAGE2 = installPackage ghc-pkg hasktags runghc hpc pwd haddock +WITH_STAGE2 = installPackage ghc-pkg runghc hpc pwd haddock ifneq "$(NO_INSTALL_HSC2HS)" "YES" WITH_STAGE2 += hsc2hs endif