From: simonpj Date: Tue, 18 May 1999 15:03:51 +0000 (+0000) Subject: [project @ 1999-05-18 15:03:33 by simonpj] X-Git-Tag: Approximately_9120_patches~6202 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=506fa77d392191e46c12b2c19387ff5b0888f6a2;p=ghc-hetmet.git [project @ 1999-05-18 15:03:33 by simonpj] RULES-NOTES --- diff --git a/ghc/compiler/DEPEND-NOTES b/ghc/compiler/DEPEND-NOTES index c1b64f3..2c0f82a 100644 --- a/ghc/compiler/DEPEND-NOTES +++ b/ghc/compiler/DEPEND-NOTES @@ -1,3 +1,15 @@ +add types/InstEnv, InstEnv.hi-boot +add coreSyn/CoreRules.* +add coreSyn/CoreTidy.lhs +add coreSyn/CoreFVs.lhs +remove coreSyn/FreeVars.lhs +add coreSyn/Subst.* +remove simplCore/MagicUFs.* + +remove specialise/SpecEnv.* + + + ToDo ~~~~ * Test effect of eta-expanding past (case x of ..) @@ -62,45 +74,43 @@ ToDo ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Name/Var/Type group is a bit complicated. Here's the deal +Things in brackets are what the module *uses*. +A 'loop' indicates a use from a module compiled later - Name, PrimRep, FieldLabel (uses Type.Type) + Name, PrimRep, FieldLabel (loop Type.Type) then - Var (uses Const.Con, IdInfo.IdInfo, Type.GenType, Type.Kind) + Var (loop Const.Con, loop IdInfo.IdInfo, + loop Type.GenType, loop Type.Kind) then - VarEnv, VarSet + VarEnv, VarSet, ThinAir then - Class (uses TyCon.TyCon, Type.Type, SpecEnv.SpecEnv) + Class (loop TyCon.TyCon, loop Type.Type, loop InstEnv.InstEnv) then - TyCon (uses Type.Type, Type.Kind, DataCon.DataCon) + TyCon (loop Type.Type, loop Type.Kind, loop DataCon.DataCon) then - Type (uses [DataCon.DataCon]) + Type (loop DataCon.DataCon, loop Subst.substTy) then - DataCon, TysPrim, Unify, SpecEnv, PprType + DataCon, TysPrim, Unify, PprType then - IdInfo, TysWiredIn (uses DataCon.mkDataCon, [MkId.mkDataConId]) + InstEnv (Unify) then - PrimOp (uses PprType, TysWiredIn) + IdInfo (loop CoreRules.CoreRules) + TysWiredIn (DataCon.mkDataCon, loop MkId.mkDataConId) then - Const (needs PrimOp, [TysWiredIn.stringTy]) + PrimOp (PprType, TysWiredIn, IdInfo.StrictnessInfo) then - Id (needs Const.Con(..)), CoreSyn + Const (PrimOp.PrimOp, TysWiredIn.stringTy) then - CoreUtils, OccurAnal + Id (Const.Con(..)), CoreSyn then - CoreUnfold (uses OccurAnal) + CoreUtils (loop PprCore.pprCoreExpr), CoreFVs +then + OccurAnal (ThinAir.noRepStrs -- an awkward dependency) then - MkId (uses CoreUnfold) - - -PrimOp uses TysWiredIn - + CoreUnfold (loop OccurAnal.globalOccurAnalyse) +then + Rules (Unfolding), Subst (Unfolding, CoreFVs), CoreTidy (noUnfolding) +then + MkId (CoreUnfold.mkUnfolding, Subst) -Add -~~~ -basicTypes/DataCon.lhs -basicTypes/DataCon.hi-boot -Remove -~~~~~~ -specialise/SpecUtils.lhs -basicTypes/IdUtils.lhs diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index 63c090f..21bd8a1 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Makefile,v 1.57 1999/05/14 11:23:47 simonm Exp $ +# $Id: Makefile,v 1.58 1999/05/18 15:03:34 simonpj Exp $ TOP = .. include $(TOP)/mk/boilerplate.mk @@ -182,6 +182,7 @@ parser/U_literal_HC_OPTS = -fvia-C '-\#include"hspincl.h"' parser/U_match_HC_OPTS = -fvia-C '-\#include"hspincl.h"' parser/U_maybe_HC_OPTS = -fvia-C '-\#include"hspincl.h"' parser/U_qid_HC_OPTS = -fvia-C '-\#include"hspincl.h"' +parser/U_rulevar_HC_OPTS = -fvia-C '-\#include"hspincl.h"' parser/U_tree_HC_OPTS = -H12m -fvia-C '-\#include"hspincl.h"' parser/U_ttype_HC_OPTS = -fvia-C '-\#include"hspincl.h"' diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs index 5625103..39daeec 100644 --- a/ghc/compiler/basicTypes/BasicTypes.lhs +++ b/ghc/compiler/basicTypes/BasicTypes.lhs @@ -16,14 +16,14 @@ types that module BasicTypes( Version, Arity, Unused, unused, - Fixity(..), FixityDirection(..), StrictnessMark(..), - NewOrData(..), TopLevelFlag(..), RecFlag(..) + Fixity(..), FixityDirection(..), defaultFixity, + NewOrData(..), + RecFlag(..), isRec, isNonRec, + TopLevelFlag(..), isTopLevel, isNotTopLevel ) where #include "HsVersions.h" -import {-# SOURCE #-} DataCon ( DataCon ) -import {-# SOURCE #-} Type ( Type ) import Outputable \end{code} @@ -86,6 +86,9 @@ instance Outputable FixityDirection where instance Eq Fixity where -- Used to determine if two fixities conflict (Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2 + + +defaultFixity = Fixity 9 InfixL \end{code} @@ -113,6 +116,14 @@ data NewOrData data TopLevelFlag = TopLevel | NotTopLevel + +isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool + +isNotTopLevel NotTopLevel = True +isNotTopLevel TopLevel = False + +isTopLevel TopLevel = True +isTopLevel NotTopLevel = False \end{code} %************************************************************************ @@ -124,16 +135,12 @@ data TopLevelFlag \begin{code} data RecFlag = Recursive | NonRecursive -\end{code} -%************************************************************************ -%* * -\subsection{Strictness indication} -%* * -%************************************************************************ +isRec :: RecFlag -> Bool +isRec Recursive = True +isRec NonRecursive = False -\begin{code} -data StrictnessMark = MarkedStrict - | MarkedUnboxed DataCon [Type] - | NotMarkedStrict +isNonRec :: RecFlag -> Bool +isNonRec Recursive = False +isNonRec NonRecursive = True \end{code} diff --git a/ghc/compiler/basicTypes/Const.lhs b/ghc/compiler/basicTypes/Const.lhs index 1a48d0c..ae4219d 100644 --- a/ghc/compiler/basicTypes/Const.lhs +++ b/ghc/compiler/basicTypes/Const.lhs @@ -8,7 +8,8 @@ module Const ( Con(..), conType, conPrimRep, conOkForApp, conOkForAlt, isWHNFCon, isDataCon, - conIsTrivial, conIsCheap, + conIsTrivial, conIsCheap, conIsDupable, conStrictness, + conOkForSpeculation, DataCon, PrimOp, -- For completeness @@ -26,12 +27,14 @@ module Const ( import TysPrim ( charPrimTy, addrPrimTy, floatPrimTy, doublePrimTy, intPrimTy, wordPrimTy, int64PrimTy, word64PrimTy ) -import PrimOp ( PrimOp, primOpType, primOpIsCheap ) +import PrimOp ( PrimOp, primOpType, primOpIsDupable, + primOpIsCheap, primOpStrictness, primOpOkForSpeculation ) import PrimRep ( PrimRep(..) ) -import DataCon ( DataCon, dataConType, dataConTyCon, isNullaryDataCon ) +import DataCon ( DataCon, dataConType, dataConTyCon, isNullaryDataCon, dataConRepStrictness ) import TyCon ( isNewTyCon ) import Type ( Type, typePrimRep ) import PprType ( pprParendType ) +import Demand ( Demand ) import CStrings ( stringToC, charToC, charToEasyHaskell ) import Outputable @@ -74,6 +77,11 @@ conType (DataCon dc) = dataConType dc conType (Literal lit) = literalType lit conType (PrimOp op) = primOpType op +conStrictness :: Con -> ([Demand], Bool) +conStrictness (DataCon dc) = (dataConRepStrictness dc, False) +conStrictness (PrimOp op) = primOpStrictness op +conStrictness (Literal lit) = ([], False) + conPrimRep :: Con -> PrimRep -- Only data valued constants conPrimRep (DataCon dc) = ASSERT( isNullaryDataCon dc) PtrRep conPrimRep (Literal lit) = literalPrimRep lit @@ -113,6 +121,18 @@ conIsTrivial con = True conIsCheap (Literal lit) = not (isNoRepLit lit) conIsCheap (DataCon con) = True conIsCheap (PrimOp op) = primOpIsCheap op + +-- conIsDupable is true for constants whose applications we are willing +-- to duplicate in different case branches; i.e no issue about loss of +-- work, just space +conIsDupable (Literal lit) = not (isNoRepLit lit) +conIsDupable (DataCon con) = True +conIsDupable (PrimOp op) = primOpIsDupable op + +-- Similarly conOkForSpeculation +conOkForSpeculation (Literal lit) = True +conOkForSpeculation (DataCon con) = True +conOkForSpeculation (PrimOp op) = primOpOkForSpeculation op \end{code} diff --git a/ghc/compiler/basicTypes/DataCon.hi-boot b/ghc/compiler/basicTypes/DataCon.hi-boot index 3761c8f..511160d 100644 --- a/ghc/compiler/basicTypes/DataCon.hi-boot +++ b/ghc/compiler/basicTypes/DataCon.hi-boot @@ -1,5 +1,6 @@ _interface_ DataCon 1 _exports_ -DataCon DataCon ; +DataCon DataCon dataConType ; _declarations_ 1 data DataCon ; +1 dataConType _:_ DataCon -> Type.Type ;; diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs index 0ecb8e0..d916dcb 100644 --- a/ghc/compiler/basicTypes/DataCon.lhs +++ b/ghc/compiler/basicTypes/DataCon.lhs @@ -11,18 +11,23 @@ module DataCon ( dataConType, dataConSig, dataConName, dataConTag, dataConOrigArgTys, dataConArgTys, dataConRawArgTys, dataConTyCon, dataConFieldLabels, dataConStrictMarks, dataConSourceArity, - dataConNumFields, dataConNumInstArgs, dataConId, + dataConNumFields, dataConNumInstArgs, dataConId, dataConRepStrictness, isNullaryDataCon, isTupleCon, isUnboxedTupleCon, - isExistentialDataCon + isExistentialDataCon, + + StrictnessMark(..), -- Representation visible to MkId only + markedStrict, notMarkedStrict, markedUnboxed, maybeMarkedUnboxed ) where #include "HsVersions.h" +import {-# SOURCE #-} Subst( substTy, mkTyVarSubst ) + import CmdLineOpts ( opt_DictsStrict ) import TysPrim import Type ( Type, ThetaType, TauType, mkSigmaTy, mkFunTys, mkTyConApp, - mkTyVarTys, mkDictTy, substTy, + mkTyVarTys, mkDictTy, splitAlgTyConApp_maybe ) import PprType @@ -31,9 +36,9 @@ import TyCon ( TyCon, tyConDataCons, isDataTyCon, import Class ( classTyCon ) import Name ( Name, NamedThing(..), nameUnique, isLocallyDefinedName ) import Var ( TyVar, Id ) -import VarEnv import FieldLabel ( FieldLabel ) -import BasicTypes ( StrictnessMark(..), Arity ) +import BasicTypes ( Arity ) +import Demand ( Demand, wwStrict, wwLazy ) import Outputable import Unique ( Unique, Uniquable(..) ) import CmdLineOpts ( opt_UnboxStrictFields ) @@ -136,6 +141,32 @@ but the rep type is Actually, the unboxed part isn't implemented yet! +%************************************************************************ +%* * +\subsection{Strictness indication} +%* * +%************************************************************************ + +\begin{code} +data StrictnessMark = MarkedStrict + | MarkedUnboxed DataCon [Type] + | NotMarkedStrict + +markedStrict = MarkedStrict +notMarkedStrict = NotMarkedStrict +markedUnboxed = MarkedUnboxed (panic "markedUnboxed1") (panic "markedUnboxed2") + +maybeMarkedUnboxed (MarkedUnboxed dc tys) = Just (dc,tys) +maybeMarkedUnboxed other = Nothing +\end{code} + + +%************************************************************************ +%* * +\subsection{Instances} +%* * +%************************************************************************ + \begin{code} instance Eq DataCon where a == b = getUnique a == getUnique b @@ -161,6 +192,13 @@ instance Show DataCon where showsPrec p con = showsPrecSDoc p (ppr con) \end{code} + +%************************************************************************ +%* * +\subsection{Consruction} +%* * +%************************************************************************ + \begin{code} mkDataCon :: Name -> [StrictnessMark] -> [FieldLabel] @@ -307,6 +345,17 @@ dataConSourceArity :: DataCon -> Arity -- Source-level arity of the data constructor dataConSourceArity dc = length (dcOrigArgTys dc) +dataConRepStrictness :: DataCon -> [Demand] + -- Give the demands on the arguments of a + -- Core constructor application (Con dc args) +dataConRepStrictness dc + = go (dcRealStricts dc) + where + go [] = [] + go (MarkedStrict : ss) = wwStrict : go ss + go (NotMarkedStrict : ss) = wwLazy : go ss + go (MarkedUnboxed con _ : ss) = go (dcRealStricts con ++ ss) + dataConSig :: DataCon -> ([TyVar], ThetaType, [TyVar], ThetaType, [TauType], TyCon) @@ -325,12 +374,12 @@ dataConArgTys, dataConOrigArgTys :: DataCon dataConArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars, dcExTyVars = ex_tyvars, dcExTheta = ex_theta}) inst_tys - = map (substTy (zipVarEnv (tyvars ++ ex_tyvars) 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 (zipVarEnv (tyvars ++ ex_tyvars) inst_tys)) + = map (substTy (mkTyVarSubst (tyvars ++ ex_tyvars) inst_tys)) ([mkDictTy cls tys | (cls,tys) <- ex_theta] ++ arg_tys) \end{code} diff --git a/ghc/compiler/basicTypes/Demand.lhs b/ghc/compiler/basicTypes/Demand.lhs index f034216..7a4dbfe 100644 --- a/ghc/compiler/basicTypes/Demand.lhs +++ b/ghc/compiler/basicTypes/Demand.lhs @@ -8,7 +8,7 @@ module Demand( Demand(..), wwLazy, wwStrict, wwUnpackData, wwUnpackNew, wwPrim, wwEnum, - isStrict, isLazy, + isStrict, isLazy, isPrim, pprDemands ) where @@ -80,6 +80,10 @@ isStrict WwStrict = True isStrict WwEnum = True isStrict WwPrim = True isStrict _ = False + +isPrim :: Demand -> Bool +isPrim WwPrim = True +isPrim other = False \end{code} \begin{code} diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 6dec041..75e27aa 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -8,16 +8,17 @@ module Id ( Id, DictId, -- Simple construction - mkVanillaId, mkImportedId, mkSysLocal, mkUserLocal, - mkTemplateLocals, mkTemplateLocal, mkWildId, mkUserId, + mkId, mkVanillaId, mkSysLocal, mkUserLocal, + mkTemplateLocals, mkWildId, mkTemplateLocal, -- Taking an Id apart - idName, idType, idUnique, idInfo, idDetails, + idName, idType, idUnique, idInfo, idPrimRep, isId, recordSelectorFieldLabel, -- Modifying an Id - setIdName, setIdUnique, setIdType, setIdInfo, + setIdName, setIdUnique, setIdType, setIdNoDiscard, + setIdInfo, modifyIdInfo, maybeModifyIdInfo, -- Predicates omitIfaceSigForId, @@ -26,14 +27,12 @@ module Id ( -- Inline pragma stuff getInlinePragma, setInlinePragma, modifyInlinePragma, - idWantsToBeINLINEd, idMustBeINLINEd, idMustNotBeINLINEd, - isSpecPragmaId, - + idMustBeINLINEd, idMustNotBeINLINEd, - isRecordSelector, + isSpecPragmaId, isRecordSelector, isPrimitiveId_maybe, isDataConId_maybe, - isConstantId, - isBottomingId, idAppIsBottom, + isConstantId, isBottomingId, idAppIsBottom, + isExportedId, isUserExportedId, -- IdInfo stuff setIdUnfolding, @@ -61,20 +60,22 @@ module Id ( #include "HsVersions.h" import {-# SOURCE #-} CoreUnfold ( Unfolding ) +import {-# SOURCE #-} CoreSyn ( CoreRules ) -import Var ( Id, DictId, VarDetails(..), - isId, mkId, - idName, idType, idUnique, idInfo, idDetails, - setIdName, setVarType, setIdUnique, setIdInfo, modifyIdInfo, +import Var ( Id, DictId, + isId, mkIdVar, + idName, idType, idUnique, idInfo, + setIdName, setVarType, setIdUnique, + setIdInfo, modifyIdInfo, maybeModifyIdInfo, externallyVisibleId ) import VarSet import Type ( Type, tyVarsOfType, typePrimRep, addFreeTyVars ) import IdInfo -import Demand ( Demand ) +import Demand ( Demand, isStrict, wwLazy ) import Name ( Name, OccName, mkSysLocalName, mkLocalName, - isWiredInName + isWiredInName, isUserExportedName ) import Const ( Con(..) ) import PrimRep ( PrimRep ) @@ -106,15 +107,22 @@ infixl 1 `setIdUnfolding`, %* * %************************************************************************ -\begin{code} -mkVanillaId :: Name -> Type -> Id -mkVanillaId name ty = mkId name (addFreeTyVars ty) VanillaId noIdInfo +Absolutely all Ids are made by mkId. It + a) Pins free-tyvar-info onto the Id's type, + where it can easily be found. + b) Ensures that exported Ids are -mkImportedId :: Name -> Type -> IdInfo -> Id -mkImportedId name ty info = mkId name (addFreeTyVars ty) VanillaId info +\begin{code} +mkId :: Name -> Type -> IdInfo -> Id +mkId name ty info = mkIdVar name (addFreeTyVars ty) info' + where + info' | isUserExportedName name = setNoDiscardInfo info + | otherwise = info +\end{code} -mkUserId :: Name -> Type -> Id -mkUserId name ty = mkVanillaId name ty +\begin{code} +mkVanillaId :: Name -> Type -> Id +mkVanillaId name ty = mkId name ty vanillaIdInfo -- SysLocal: for an Id being created by the compiler out of thin air... -- UserLocal: an Id with a name the user might recognize... @@ -163,27 +171,6 @@ idPrimRep :: Id -> PrimRep idPrimRep id = typePrimRep (idType id) \end{code} -omitIfaceSigForId tells whether an Id's info is implied by other declarations, -so we don't need to put its signature in an interface file, even if it's mentioned -in some other interface unfolding. - -\begin{code} -omitIfaceSigForId :: Id -> Bool -omitIfaceSigForId id - | isWiredInName (idName id) - = True - - | otherwise - = case idDetails id of - RecordSelId _ -> True -- Includes dictionary selectors - ConstantId _ -> True - -- ConstantIds are implied by their type or class decl; - -- remember that all type and class decls appear in the interface file. - -- The dfun id must *not* be omitted, because it carries version info for - -- the instance decl - - other -> False -- Don't omit! -\end{code} %************************************************************************ %* * @@ -192,28 +179,75 @@ omitIfaceSigForId id %************************************************************************ \begin{code} +idFlavour :: Id -> IdFlavour +idFlavour id = flavourInfo (idInfo id) + +setIdNoDiscard :: Id -> Id +setIdNoDiscard id -- Make an Id into a NoDiscardId, unless it is already + = modifyIdInfo setNoDiscardInfo id + recordSelectorFieldLabel :: Id -> FieldLabel -recordSelectorFieldLabel id = case idDetails id of +recordSelectorFieldLabel id = case idFlavour id of RecordSelId lbl -> lbl -isRecordSelector id = case idDetails id of +isRecordSelector id = case idFlavour id of RecordSelId lbl -> True other -> False -isPrimitiveId_maybe id = case idDetails id of +isPrimitiveId_maybe id = case idFlavour id of ConstantId (PrimOp op) -> Just op other -> Nothing -isDataConId_maybe id = case idDetails id of +isDataConId_maybe id = case idFlavour id of ConstantId (DataCon con) -> Just con other -> Nothing -isConstantId id = case idDetails id of +isConstantId id = case idFlavour id of ConstantId _ -> True other -> False + +isSpecPragmaId id = case idFlavour id of + SpecPragmaId -> True + other -> False + +-- Don't drop a binding for an exported Id, +-- if it otherwise looks dead. +isExportedId :: Id -> Bool +isExportedId id = case idFlavour id of + VanillaId -> False + other -> True -- All the others are no-discard + +-- Say if an Id was exported by the user +-- Implies isExportedId (see mkId above) +isUserExportedId :: Id -> Bool +isUserExportedId id = isUserExportedName (idName id) \end{code} +omitIfaceSigForId tells whether an Id's info is implied by other declarations, +so we don't need to put its signature in an interface file, even if it's mentioned +in some other interface unfolding. + +\begin{code} +omitIfaceSigForId :: Id -> Bool +omitIfaceSigForId id + | isWiredInName (idName id) + = True + + | otherwise + = case idFlavour id of + RecordSelId _ -> True -- Includes dictionary selectors + ConstantId _ -> True + -- ConstantIds are implied by their type or class decl; + -- remember that all type and class decls appear in the interface file. + -- The dfun id must *not* be omitted, because it carries version info for + -- the instance decl + + other -> False -- Don't omit! +\end{code} + + + %************************************************************************ %* * \subsection{IdInfo stuff} @@ -227,7 +261,7 @@ getIdArity :: Id -> ArityInfo getIdArity id = arityInfo (idInfo id) setIdArity :: Id -> ArityInfo -> Id -setIdArity id arity = modifyIdInfo id (arity `setArityInfo`) +setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id --------------------------------- -- STRICTNESS @@ -235,7 +269,7 @@ getIdStrictness :: Id -> StrictnessInfo getIdStrictness id = strictnessInfo (idInfo id) setIdStrictness :: Id -> StrictnessInfo -> Id -setIdStrictness id strict_info = modifyIdInfo id (strict_info `setStrictnessInfo`) +setIdStrictness id strict_info = modifyIdInfo (`setStrictnessInfo` strict_info) id -- isBottomingId returns true if an application to n args would diverge isBottomingId :: Id -> Bool @@ -250,7 +284,7 @@ getIdWorkerInfo :: Id -> WorkerInfo getIdWorkerInfo id = workerInfo (idInfo id) setIdWorkerInfo :: Id -> WorkerInfo -> Id -setIdWorkerInfo id work_info = modifyIdInfo id (work_info `setWorkerInfo`) +setIdWorkerInfo id work_info = modifyIdInfo (`setWorkerInfo` work_info) id --------------------------------- -- UNFOLDING @@ -258,7 +292,7 @@ getIdUnfolding :: Id -> Unfolding getIdUnfolding id = unfoldingInfo (idInfo id) setIdUnfolding :: Id -> Unfolding -> Id -setIdUnfolding id unfolding = modifyIdInfo id (unfolding `setUnfoldingInfo`) +setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id --------------------------------- -- DEMAND @@ -266,7 +300,7 @@ getIdDemandInfo :: Id -> Demand getIdDemandInfo id = demandInfo (idInfo id) setIdDemandInfo :: Id -> Demand -> Id -setIdDemandInfo id demand_info = modifyIdInfo id (demand_info `setDemandInfo`) +setIdDemandInfo id demand_info = modifyIdInfo (`setDemandInfo` demand_info) id --------------------------------- -- UPDATE INFO @@ -274,15 +308,15 @@ getIdUpdateInfo :: Id -> UpdateInfo getIdUpdateInfo id = updateInfo (idInfo id) setIdUpdateInfo :: Id -> UpdateInfo -> Id -setIdUpdateInfo id upd_info = modifyIdInfo id (upd_info `setUpdateInfo`) +setIdUpdateInfo id upd_info = modifyIdInfo (`setUpdateInfo` upd_info) id --------------------------------- -- SPECIALISATION -getIdSpecialisation :: Id -> IdSpecEnv +getIdSpecialisation :: Id -> CoreRules getIdSpecialisation id = specInfo (idInfo id) -setIdSpecialisation :: Id -> IdSpecEnv -> Id -setIdSpecialisation id spec_info = modifyIdInfo id (spec_info `setSpecInfo`) +setIdSpecialisation :: Id -> CoreRules -> Id +setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id --------------------------------- -- CAF INFO @@ -290,7 +324,7 @@ getIdCafInfo :: Id -> CafInfo getIdCafInfo id = cafInfo (idInfo id) setIdCafInfo :: Id -> CafInfo -> Id -setIdCafInfo id caf_info = modifyIdInfo id (caf_info `setCafInfo`) +setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id --------------------------------- -- CPR INFO @@ -298,8 +332,7 @@ getIdCprInfo :: Id -> CprInfo getIdCprInfo id = cprInfo (idInfo id) setIdCprInfo :: Id -> CprInfo -> Id -setIdCprInfo id cpr_info = modifyIdInfo id (cpr_info `setCprInfo`) - +setIdCprInfo id cpr_info = modifyIdInfo (`setCprInfo` cpr_info) id \end{code} @@ -313,28 +346,17 @@ getInlinePragma :: Id -> InlinePragInfo getInlinePragma id = inlinePragInfo (idInfo id) setInlinePragma :: Id -> InlinePragInfo -> Id -setInlinePragma id prag = modifyIdInfo id (setInlinePragInfo prag) +setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id modifyInlinePragma :: Id -> (InlinePragInfo -> InlinePragInfo) -> Id -modifyInlinePragma id fn = modifyIdInfo id (\info -> setInlinePragInfo (fn (inlinePragInfo info)) info) - -idWantsToBeINLINEd :: Id -> Bool -idWantsToBeINLINEd id = case getInlinePragma id of - IWantToBeINLINEd -> True - IMustBeINLINEd -> True - other -> False +modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id idMustNotBeINLINEd id = case getInlinePragma id of IMustNotBeINLINEd -> True - IAmASpecPragmaId -> True IAmALoopBreaker -> True other -> False idMustBeINLINEd id = case getInlinePragma id of IMustBeINLINEd -> True other -> False - -isSpecPragmaId id = case getInlinePragma id of - IAmASpecPragmaId -> True - other -> False \end{code} diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 892dd20..83f932d 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -10,7 +10,12 @@ Haskell. [WDP 94/11]) module IdInfo ( IdInfo, -- Abstract - noIdInfo, + vanillaIdInfo, mkIdInfo, + + -- Flavour + IdFlavour(..), flavourInfo, + setNoDiscardInfo, zapSpecPragInfo, copyIdInfo, + ppFlavourInfo, -- Arity ArityInfo(..), @@ -39,7 +44,7 @@ module IdInfo ( inlinePragInfo, setInlinePragInfo, notInsideLambda, -- Specialisation - IdSpecEnv, specInfo, setSpecInfo, + specInfo, setSpecInfo, -- Update UpdateInfo, UpdateSpec, @@ -51,30 +56,48 @@ module IdInfo ( -- Constructed Product Result Info CprInfo(..), cprInfo, setCprInfo, ppCprInfo, noCprInfo, + -- Zapping + zapLamIdInfo, zapFragileIdInfo, + -- Lambda-bound variable info - LBVarInfo(..), lbvarInfo, setLBVarInfo, noLBVarInfo, + LBVarInfo(..), lbvarInfo, setLBVarInfo, noLBVarInfo ) where #include "HsVersions.h" -import {-# SOURCE #-} CoreUnfold ( Unfolding, noUnfolding ) -import {-# SOURCE #-} CoreSyn ( CoreExpr ) +import {-# SOURCE #-} CoreUnfold ( Unfolding, noUnfolding, hasUnfolding ) +import {-# SOURCE #-} CoreSyn ( CoreExpr, CoreRules, emptyCoreRules, isEmptyCoreRules ) +import {-# SOURCE #-} Const ( Con ) import Var ( Id ) -import SpecEnv ( SpecEnv, emptySpecEnv ) -import Demand ( Demand, isLazy, wwLazy, pprDemands ) +import FieldLabel ( FieldLabel ) +import Demand ( Demand, isStrict, isLazy, wwLazy, pprDemands ) import Type ( UsageAnn ) import Outputable - import Maybe ( isJust ) +infixl 1 `setUpdateInfo`, + `setDemandInfo`, + `setStrictnessInfo`, + `setSpecInfo`, + `setArityInfo`, + `setInlinePragInfo`, + `setUnfoldingInfo`, + `setCprInfo`, + `setWorkerInfo`, + `setCafInfo` + -- infixl so you can say (id `set` a `set` b) \end{code} An @IdInfo@ gives {\em optional} information about an @Id@. If present it never lies, but it may not be present, in which case there is always a conservative assumption which can be made. + There is one exception: the 'flavour' is *not* optional. + You must not discard it. + It used to be in Var.lhs, but that seems unclean. + Two @Id@s may have different info even though they have the same @Unique@ (and are hence the same @Id@); for example, one might lack the properties attached to the other. @@ -87,53 +110,138 @@ case. KSW 1999-04). \begin{code} data IdInfo = IdInfo { - arityInfo :: ArityInfo, -- Its arity - demandInfo :: Demand, -- Whether or not it is definitely demanded - specInfo :: IdSpecEnv, -- Specialisations of this function which exist - strictnessInfo :: StrictnessInfo, -- Strictness properties - workerInfo :: WorkerInfo, -- Pointer to Worker Function - unfoldingInfo :: Unfolding, -- Its unfolding - updateInfo :: UpdateInfo, -- Which args should be updated - cafInfo :: CafInfo, - cprInfo :: CprInfo, -- Function always constructs a product result - lbvarInfo :: LBVarInfo, -- Info about a lambda-bound variable - inlinePragInfo :: !InlinePragInfo -- Inline pragmas + flavourInfo :: IdFlavour, -- NOT OPTIONAL + arityInfo :: ArityInfo, -- Its arity + demandInfo :: Demand, -- Whether or not it is definitely demanded + specInfo :: CoreRules, -- Specialisations of this function which exist + strictnessInfo :: StrictnessInfo, -- Strictness properties + workerInfo :: WorkerInfo, -- Pointer to Worker Function + unfoldingInfo :: Unfolding, -- Its unfolding + updateInfo :: UpdateInfo, -- Which args should be updated + cafInfo :: CafInfo, + cprInfo :: CprInfo, -- Function always constructs a product result + lbvarInfo :: LBVarInfo, -- Info about a lambda-bound variable + inlinePragInfo :: !InlinePragInfo -- Inline pragmas } \end{code} Setters \begin{code} -setUpdateInfo ud info = info { updateInfo = ud } -setDemandInfo dd info = info { demandInfo = dd } -setStrictnessInfo st info = info { strictnessInfo = st } -setWorkerInfo wk info = info { workerInfo = wk } -setSpecInfo sp info = info { specInfo = sp } -setArityInfo ar info = info { arityInfo = ar } -setInlinePragInfo pr info = info { inlinePragInfo = pr } -setUnfoldingInfo uf info = info { unfoldingInfo = uf } -setCafInfo cf info = info { cafInfo = cf } -setCprInfo cp info = info { cprInfo = cp } -setLBVarInfo lb info = info { lbvarInfo = lb } +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 } + +setNoDiscardInfo info = case flavourInfo info of + VanillaId -> info { flavourInfo = NoDiscardId } + other -> info +zapSpecPragInfo info = case flavourInfo info of + SpecPragmaId -> info { flavourInfo = VanillaId } + other -> info + +copyIdInfo :: IdInfo -- From + -> IdInfo -- To + -> IdInfo -- To updated with stuff from From; except flavour unchanged +-- copyIdInfo is used when shorting out a top-level binding +-- f_local = BIG +-- f = f_local +-- where f is exported. We are going to swizzle it around to +-- f = BIG +-- f_local = f +-- but we must be careful to combine their IdInfos right. +-- The fact that things can go wrong here is a bad sign, but I can't see +-- how to make it 'patently right', so copyIdInfo is derived (pretty much) by trial and error +-- +-- Here 'from' is f_local, 'to' is f. + +copyIdInfo from to = from { flavourInfo = flavourInfo to, + specInfo = specInfo to + } + -- It's important to propagate the inline pragmas from bndr + -- to exportd_id. Ditto strictness etc. This "bites" when we use an INLNE pragma: + -- {-# INLINE f #-} + -- f x = (x,x) + -- + -- This becomes (where the "*" means INLINE prag) + -- + -- M.f = /\a -> let mf* = \x -> (x,x) in mf + -- + -- Now the mf floats out and we end up with the trivial binding + -- + -- mf* = /\a -> \x -> (x,x) + -- M.f = mf + -- + -- Now, when we short out the M.f = mf binding we must preserve the inline + -- pragma on the mf binding. + -- + -- On the other hand, transformation rules may be attached to the + -- 'to' Id, and we want to preserve them. \end{code} \begin{code} -noIdInfo = IdInfo { - arityInfo = UnknownArity, - demandInfo = wwLazy, - specInfo = emptySpecEnv, - strictnessInfo = NoStrictnessInfo, - workerInfo = noWorkerInfo, - unfoldingInfo = noUnfolding, - updateInfo = NoUpdateInfo, - cafInfo = MayHaveCafRefs, - cprInfo = NoCPRInfo, - lbvarInfo = NoLBVarInfo, - inlinePragInfo = NoInlinePragInfo +vanillaIdInfo :: IdInfo +vanillaIdInfo = mkIdInfo VanillaId + +mkIdInfo :: IdFlavour -> IdInfo +mkIdInfo flv = IdInfo { + flavourInfo = flv, + arityInfo = UnknownArity, + demandInfo = wwLazy, + specInfo = emptyCoreRules, + workerInfo = Nothing, + strictnessInfo = NoStrictnessInfo, + unfoldingInfo = noUnfolding, + updateInfo = NoUpdateInfo, + cafInfo = MayHaveCafRefs, + cprInfo = NoCPRInfo, + lbvarInfo = NoLBVarInfo, + inlinePragInfo = NoInlinePragInfo } \end{code} + +%************************************************************************ +%* * +\subsection{Flavour} +%* * +%************************************************************************ + +\begin{code} +data IdFlavour + = VanillaId -- Most Ids are like this + | ConstantId Con -- The Id for a constant (data constructor or primop) + | RecordSelId FieldLabel -- The Id for a record selector + | SpecPragmaId -- Don't discard these + | NoDiscardId -- Don't discard these either + +ppFlavourInfo :: IdFlavour -> SDoc +ppFlavourInfo VanillaId = empty +ppFlavourInfo (ConstantId _) = ptext SLIT("[Constr]") +ppFlavourInfo (RecordSelId _) = ptext SLIT("[RecSel]") +ppFlavourInfo SpecPragmaId = ptext SLIT("[SpecPrag]") +ppFlavourInfo NoDiscardId = ptext SLIT("[NoDiscard]") +\end{code} + +The @SpecPragmaId@ exists only to make Ids that are +on the *LHS* of bindings created by SPECIALISE pragmas; +eg: s = f Int d +The SpecPragmaId is never itself mentioned; it +exists solely so that the specialiser will find +the call to f, and make specialised version of it. +The SpecPragmaId binding is discarded by the specialiser +when it gathers up overloaded calls. +Meanwhile, it is not discarded as dead code. + + %************************************************************************ %* * \subsection[arity-IdInfo]{Arity info about an @Id@} @@ -175,9 +283,6 @@ ppArityInfo (ArityAtLeast arity) = hsep [ptext SLIT("__AL"), int arity] data InlinePragInfo = NoInlinePragInfo - | IAmASpecPragmaId -- Used for spec-pragma Ids; don't discard or inline - - | IWantToBeINLINEd -- User INLINE pragma | IMustNotBeINLINEd -- User NOINLINE pragma | IAmALoopBreaker -- Used by the occurrence analyser to mark loop-breakers @@ -202,35 +307,19 @@ data InlinePragInfo instance Outputable InlinePragInfo where ppr NoInlinePragInfo = empty ppr IMustBeINLINEd = ptext SLIT("__UU") - ppr IWantToBeINLINEd = ptext SLIT("__U") ppr IMustNotBeINLINEd = ptext SLIT("__Unot") ppr IAmALoopBreaker = ptext SLIT("__Ux") ppr IAmDead = ptext SLIT("__Ud") ppr (ICanSafelyBeINLINEd InsideLam _) = ptext SLIT("__Ul") ppr (ICanSafelyBeINLINEd _ _) = ptext SLIT("__Us") - ppr IAmASpecPragmaId = ptext SLIT("__US") instance Show InlinePragInfo where showsPrec p prag = showsPrecSDoc p (ppr prag) \end{code} -The @IMustNotBeDiscarded@ exists only to make Ids that are -on the *LHS* of bindings created by SPECIALISE pragmas; -eg: s = f Int d -The SpecPragmaId is never itself mentioned; it -exists solely so that the specialiser will find -the call to f, and make specialised version of it. -The SpecPragmaId binding is discarded by the specialiser -when it gathers up overloaded calls. -Meanwhile, it is not discarded as dead code. - \begin{code} data OccInfo - = StrictOcc -- Occurs syntactically strictly; - -- i.e. in a function position or case scrutinee - - | LazyOcc -- Not syntactically strict (*even* that of a strict function) - -- or in a case branch where there's more than one alternative + = NotInsideLam | InsideLam -- Inside a non-linear lambda (that is, a lambda which -- is sure to be instantiated only once). @@ -238,57 +327,17 @@ data OccInfo -- dangerous because it might duplicate work. instance Outputable OccInfo where - ppr StrictOcc = text "s" - ppr LazyOcc = empty - ppr InsideLam = text "l" + ppr NotInsideLam = empty + ppr InsideLam = text "l" notInsideLambda :: OccInfo -> Bool -notInsideLambda StrictOcc = True -notInsideLambda LazyOcc = True -notInsideLambda InsideLam = False +notInsideLambda NotInsideLam = True +notInsideLambda InsideLam = False \end{code} %************************************************************************ %* * -\subsection[specialisation-IdInfo]{Specialisation info about an @Id@} -%* * -%************************************************************************ - -A @IdSpecEnv@ holds details of an @Id@'s specialisations. - -\begin{code} -type IdSpecEnv = SpecEnv CoreExpr -\end{code} - -For example, if \tr{f}'s @SpecEnv@ contains the mapping: -\begin{verbatim} - [List a, b] ===> (\d -> f' a b) -\end{verbatim} -then when we find an application of f to matching types, we simply replace -it by the matching RHS: -\begin{verbatim} - f (List Int) Bool ===> (\d -> f' Int Bool) -\end{verbatim} -All the stuff about how many dictionaries to discard, and what types -to apply the specialised function to, are handled by the fact that the -SpecEnv contains a template for the result of the specialisation. - -There is one more exciting case, which is dealt with in exactly the same -way. If the specialised value is unboxed then it is lifted at its -definition site and unlifted at its uses. For example: - - pi :: forall a. Num a => a - -might have a specialisation - - [Int#] ===> (case pi' of Lift pi# -> pi#) - -where pi' :: Lift Int# is the specialised version of pi. - - -%************************************************************************ -%* * \subsection[strictness-IdInfo]{Strictness info about an @Id@} %* * %************************************************************************ @@ -432,6 +481,86 @@ ppCafInfo NoCafRefs = ptext SLIT("__C") ppCafInfo MayHaveCafRefs = empty \end{code} + +%************************************************************************ +%* * +\subsection[CAF-IdInfo]{CAF-related information} +%* * +%************************************************************************ + +zapFragileIdInfo is used when cloning binders, mainly in the +simplifier. We must forget about used-once information because that +isn't necessarily correct in the transformed program. +Also forget specialisations and unfoldings because they would need +substitution to be correct. (They get pinned back on separately.) + +\begin{code} +zapFragileIdInfo :: IdInfo -> Maybe IdInfo +zapFragileIdInfo info@(IdInfo {inlinePragInfo = inline_prag, + specInfo = rules, + unfoldingInfo = unfolding}) + | not is_fragile_inline_prag + -- We must forget about whether it was marked safe-to-inline, + -- because that isn't necessarily true in the simplified expression. + -- This is important because expressions may be re-simplified + + && isEmptyCoreRules rules + -- Specialisations would need substituting. They get pinned + -- back on separately. + + && not (hasUnfolding unfolding) + -- This is very important; occasionally a let-bound binder is used + -- as a binder in some lambda, in which case its unfolding is utterly + -- bogus. Also the unfolding uses old binders so if we left it we'd + -- have to substitute it. Much better simply to give the Id a new + -- unfolding each time, which is what the simplifier does. + = Nothing + + | otherwise + = Just (info {inlinePragInfo = safe_inline_prag, + specInfo = emptyCoreRules, + unfoldingInfo = noUnfolding}) + + where + is_fragile_inline_prag = case inline_prag of + ICanSafelyBeINLINEd _ _ -> True + +-- We used to say the dead-ness was fragile, but I don't +-- see why it is. Furthermore, deadness is a pain to lose; +-- see Simplify.mkDupableCont (Select ...) +-- IAmDead -> True + + other -> False + + -- Be careful not to destroy real 'pragma' info + safe_inline_prag | is_fragile_inline_prag = NoInlinePragInfo + | otherwise = inline_prag +\end{code} + + +@zapLamIdInfo@ is used for lambda binders that turn out to to be +part of an unsaturated lambda + +\begin{code} +zapLamIdInfo :: IdInfo -> Maybe IdInfo +zapLamIdInfo info@(IdInfo {inlinePragInfo = inline_prag, demandInfo = demand}) + | is_safe_inline_prag && not (isStrict demand) + = Nothing + | otherwise + = Just (info {inlinePragInfo = safe_inline_prag, + demandInfo = wwLazy}) + where + is_safe_inline_prag = case inline_prag of + ICanSafelyBeINLINEd dup_danger nalts -> notInsideLambda dup_danger + other -> True + + safe_inline_prag = case inline_prag of + ICanSafelyBeINLINEd _ nalts + -> ICanSafelyBeINLINEd InsideLam nalts + other -> inline_prag +\end{code} + + %************************************************************************ %* * \subsection[cpr-IdInfo]{Constructed Product Result info about an @Id@} diff --git a/ghc/compiler/basicTypes/MkId.hi-boot b/ghc/compiler/basicTypes/MkId.hi-boot index 09a7f14..1069e9e 100644 --- a/ghc/compiler/basicTypes/MkId.hi-boot +++ b/ghc/compiler/basicTypes/MkId.hi-boot @@ -1,5 +1,6 @@ _interface_ MkId 1 _exports_ -MkId mkDataConId ; +MkId mkDataConId mkPrimitiveId ; _declarations_ -1 mkDataConId _:_ DataCon.DataCon -> Var.Id ;; +1 mkDataConId _:_ DataCon.DataCon -> Var.Id ;; +1 mkPrimitiveId _:_ PrimOp.PrimOp -> Var.Id ;; diff --git a/ghc/compiler/basicTypes/MkId.hi-boot-5 b/ghc/compiler/basicTypes/MkId.hi-boot-5 index 6dd3a40..10a40e8 100644 --- a/ghc/compiler/basicTypes/MkId.hi-boot-5 +++ b/ghc/compiler/basicTypes/MkId.hi-boot-5 @@ -1,3 +1,5 @@ __interface MkId 1 0 where -__export MkId mkDataConId ; +__export MkId mkDataConId mkPrimitiveId ; 1 mkDataConId :: DataCon.DataCon -> Var.Id ; +1 mkPrimitiveId :: PrimOp.PrimOp -> Var.Id ; + diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index af3dc38..d13463e 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -16,55 +16,71 @@ module MkId ( mkSpecPragmaId, mkWorkerId, mkDictFunId, mkDefaultMethodId, - mkMethodSelId, mkSuperDictSelId, + mkDictSelId, mkDataConId, mkRecordSelId, mkNewTySelId, - mkPrimitiveId + mkPrimitiveId, + + -- And some particular Ids; see below for why they are wired in + wiredInIds, + unsafeCoerceId, realWorldPrimId, + eRROR_ID, rEC_SEL_ERROR_ID, pAT_ERROR_ID, rEC_CON_ERROR_ID, + rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID, + nO_METHOD_BINDING_ERROR_ID, aBSENT_ERROR_ID, pAR_ERROR_ID ) where #include "HsVersions.h" -import {-# SOURCE #-} CoreUnfold ( mkUnfolding ) -import TysWiredIn ( boolTy ) +import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy, + intPrimTy, realWorldStatePrimTy + ) +import TysWiredIn ( boolTy, charTy, mkListTy ) +import PrelMods ( pREL_ERR, pREL_GHC ) import Type ( Type, ThetaType, mkDictTy, mkTyConApp, mkTyVarTys, mkFunTys, mkFunTy, mkSigmaTy, - mkForAllTys, isUnLiftedType, substTopTheta, - splitSigmaTy, splitFunTy_maybe, splitAlgTyConApp, unUsgTy, + isUnLiftedType, mkForAllTys, mkTyVarTy, + splitSigmaTy, splitFunTy_maybe, splitAlgTyConApp, + splitFunTys, splitForAllTys, unUsgTy, + mkUsgTy, UsageAnn(..) ) +import Module ( Module ) +import CoreUnfold ( mkUnfolding ) +import Subst ( mkTopTyVarSubst, substTheta ) import TyCon ( TyCon, isNewTyCon, tyConDataCons, isDataTyCon ) import Class ( Class, classBigSig, classTyCon ) -import Var ( Id, TyVar, VarDetails(..), mkId ) +import Var ( Id, TyVar ) import VarEnv ( zipVarEnv ) import Const ( Con(..) ) -import Name ( mkDerivedName, mkWiredInIdName, +import Name ( mkDerivedName, mkWiredInIdName, mkLocalName, mkWorkerOcc, mkSuperDictSelOcc, Name, NamedThing(..), ) -import PrimOp ( PrimOp, primOpSig, primOpOcc, primOpUniq ) -import DataCon ( DataCon, dataConStrictMarks, dataConFieldLabels, +import OccName ( mkSrcVarOcc ) +import PrimOp ( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName ) +import Demand ( wwStrict ) +import DataCon ( DataCon, StrictnessMark(..), dataConStrictMarks, dataConFieldLabels, dataConArgTys, dataConSig, dataConRawArgTys ) -import Id ( idType, - mkUserLocal, mkVanillaId, mkTemplateLocals, +import Id ( idType, mkId, + mkVanillaId, mkTemplateLocals, mkTemplateLocal, setInlinePragma ) -import IdInfo ( noIdInfo, - exactArity, setUnfoldingInfo, +import IdInfo ( vanillaIdInfo, mkIdInfo, + exactArity, setUnfoldingInfo, setCafInfo, setArityInfo, setInlinePragInfo, - InlinePragInfo(..), IdInfo + mkStrictnessInfo, setStrictnessInfo, + IdFlavour(..), InlinePragInfo(..), CafInfo(..), IdInfo ) import FieldLabel ( FieldLabel, FieldLabelTag, mkFieldLabel, fieldLabelName, firstFieldLabelTag, allFieldLabelTags ) import CoreSyn -import PrelVals ( rEC_SEL_ERROR_ID ) -import PrelMods ( pREL_GHC ) import Maybes -import BasicTypes ( Arity, StrictnessMark(..) ) -import Unique ( Unique ) +import BasicTypes ( Arity ) +import Unique import Maybe ( isJust ) import Outputable import Util ( assoc ) @@ -74,13 +90,46 @@ import List ( nub ) %************************************************************************ %* * +\subsection{Wired in Ids} +%* * +%************************************************************************ + +\begin{code} +wiredInIds + = [ -- These error-y things are wired in because we don't yet have + -- a way to express in an interface file that the result type variable + -- is 'open'; that is can be unified with an unboxed type + -- + -- [The interface file format now carry such information, but there's + -- no way yet of expressing at the definition site for these error-reporting + -- functions that they have an 'open' result type. -- sof 1/99] + + aBSENT_ERROR_ID + , eRROR_ID + , iRREFUT_PAT_ERROR_ID + , nON_EXHAUSTIVE_GUARDS_ERROR_ID + , nO_METHOD_BINDING_ERROR_ID + , pAR_ERROR_ID + , pAT_ERROR_ID + , rEC_CON_ERROR_ID + , rEC_UPD_ERROR_ID + + -- These two can't be defined in Haskell + , realWorldPrimId + , unsafeCoerceId + , getTagId + ] +\end{code} + +%************************************************************************ +%* * \subsection{Easy ones} %* * %************************************************************************ \begin{code} mkSpecPragmaId occ uniq ty loc - = mkUserLocal occ uniq ty loc `setInlinePragma` IAmASpecPragmaId + = mkId (mkLocalName uniq occ loc) ty (mkIdInfo SpecPragmaId) -- Maybe a SysLocal? But then we'd lose the location mkDefaultMethodId dm_name rec_c ty @@ -101,7 +150,6 @@ mkDataConId :: DataCon -> Id mkDataConId data_con = mkId (getName data_con) id_ty - (ConstantId (DataCon data_con)) (dataConInfo data_con) where (tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon) = dataConSig data_con @@ -129,21 +177,29 @@ Notice that * We have to check that we can construct Data dictionaries for the types a and Int. Once we've done that we can throw d1 away too. -* We use (case p of ...) to evaluate p, rather than "seq" because +* We use (case p of q -> ...) to evaluate p, rather than "seq" because all that matters is that the arguments are evaluated. "seq" is very careful to preserve evaluation order, which we don't need to be here. + You might think that we could simply give constructors some strictness + info, like PrimOps, and let CoreToStg do the let-to-case transformation. + But we don't do that because in the case of primops and functions strictness + is a *property* not a *requirement*. In the case of constructors we need to + do something active to evaluate the argument. + + Making an explicit case expression allows the simplifier to eliminate + it in the (common) case where the constructor arg is already evaluated. + \begin{code} dataConInfo :: DataCon -> IdInfo dataConInfo data_con - = setInlinePragInfo IMustBeINLINEd $ -- Always inline constructors - setArityInfo (exactArity (n_dicts + n_ex_dicts + n_id_args)) $ - setUnfoldingInfo unfolding $ - noIdInfo + = mkIdInfo (ConstantId (DataCon data_con)) + `setArityInfo` exactArity (n_dicts + n_ex_dicts + n_id_args) + `setUnfoldingInfo` unfolding where - unfolding = mkUnfolding con_rhs + unfolding = mkUnfolding (Note InlineMe con_rhs) (tyvars, theta, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con @@ -226,12 +282,12 @@ mkRecordSelId field_label selector_ty = ASSERT( null theta && isDataTyCon tycon ) sel_id where - sel_id = mkId (fieldLabelName field_label) selector_ty - (RecordSelId field_label) info + sel_id = mkId (fieldLabelName field_label) selector_ty info - info = exactArity 1 `setArityInfo` ( - unfolding `setUnfoldingInfo` - noIdInfo) + info = mkIdInfo (RecordSelId field_label) + `setArityInfo` exactArity 1 + `setUnfoldingInfo` unfolding + -- ToDo: consider adding further IdInfo unfolding = mkUnfolding sel_rhs @@ -278,12 +334,13 @@ Possibly overkill to do it this way: \begin{code} mkNewTySelId field_label selector_ty = sel_id where - sel_id = mkId (fieldLabelName field_label) selector_ty - (RecordSelId field_label) info + sel_id = mkId (fieldLabelName field_label) selector_ty info + - info = exactArity 1 `setArityInfo` ( - unfolding `setUnfoldingInfo` - noIdInfo) + info = mkIdInfo (RecordSelId field_label) + `setArityInfo` exactArity 1 + `setUnfoldingInfo` unfolding + -- ToDo: consider adding further IdInfo unfolding = mkUnfolding sel_rhs @@ -297,7 +354,6 @@ mkNewTySelId field_label selector_ty = sel_id [data_id] = mkTemplateLocals [data_ty] sel_rhs = mkLams tyvars $ Lam data_id $ Note (Coerce rhs_ty data_ty) (Var data_id) - \end{code} @@ -307,25 +363,6 @@ mkNewTySelId field_label selector_ty = sel_id %* * %************************************************************************ -\begin{code} -mkSuperDictSelId :: Unique -> Class -> FieldLabelTag -> Type -> Id - -- The FieldLabelTag says which superclass is selected - -- So, for - -- class (C a, C b) => Foo a b where ... - -- we get superclass selectors - -- Foo_sc1, Foo_sc2 - -mkSuperDictSelId uniq clas index ty - = mkDictSelId name clas ty - where - name = mkDerivedName (mkSuperDictSelOcc index) (getName clas) uniq - - -- For method selectors the clean thing to do is - -- to give the method selector the same name as the class op itself. -mkMethodSelId name clas ty - = mkDictSelId name clas ty -\end{code} - Selecting a field for a dictionary. If there is just one field, then there's nothing to do. @@ -333,15 +370,15 @@ there's nothing to do. mkDictSelId name clas ty = sel_id where - sel_id = mkId name ty (RecordSelId field_lbl) info + sel_id = mkId name ty info field_lbl = mkFieldLabel name ty tag tag = assoc "MkId.mkDictSelId" ((sc_sel_ids ++ op_sel_ids) `zip` allFieldLabelTags) sel_id - info = setInlinePragInfo IMustBeINLINEd $ - setUnfoldingInfo unfolding noIdInfo - -- The always-inline thing means we don't need any other IdInfo - -- We need "Must" inline because we don't create any bindigs for - -- the selectors. + info = mkIdInfo (RecordSelId field_lbl) + `setUnfoldingInfo` unfolding + + -- We no longer use 'must-inline' on record selectors. They'll + -- inline like crazy if they scrutinise a constructor unfolding = mkUnfolding rhs @@ -370,25 +407,23 @@ mkDictSelId name clas ty %* * %************************************************************************ - \begin{code} mkPrimitiveId :: PrimOp -> Id mkPrimitiveId prim_op = id where - occ_name = primOpOcc prim_op - key = primOpUniq prim_op (tyvars,arg_tys,res_ty) = primOpSig prim_op - ty = mkForAllTys tyvars (mkFunTys arg_tys res_ty) - name = mkWiredInIdName key pREL_GHC occ_name id - id = mkId name ty (ConstantId (PrimOp prim_op)) info + ty = mkForAllTys tyvars (mkFunTys arg_tys res_ty) + name = mkPrimOpIdName prim_op id + id = mkId name ty info - info = setUnfoldingInfo unfolding $ - setInlinePragInfo IMustBeINLINEd $ + info = mkIdInfo (ConstantId (PrimOp prim_op)) + `setUnfoldingInfo` unfolding + `setInlinePragInfo` IMustBeINLINEd -- The pragma @IMustBeINLINEd@ says that this Id absolutely -- must be inlined. It's only used for primitives, -- because we don't want to make a closure for each of them. - noIdInfo + unfolding = mkUnfolding rhs @@ -397,14 +432,6 @@ mkPrimitiveId prim_op mkPrimApp prim_op (map Type (mkTyVarTys tyvars) ++ map Var args) \end{code} -\end{code} - -\begin{code} -dyadic_fun_ty ty = mkFunTys [ty, ty] ty -monadic_fun_ty ty = ty `mkFunTy` ty -compare_fun_ty ty = mkFunTys [ty, ty] boolTy -\end{code} - %************************************************************************ %* * @@ -424,7 +451,7 @@ mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta = mkVanillaId dfun_name dfun_ty where (class_tyvars, sc_theta, _, _, _) = classBigSig clas - sc_theta' = substTopTheta (zipVarEnv class_tyvars inst_tys) sc_theta + sc_theta' = substTheta (mkTopTyVarSubst class_tyvars inst_tys) sc_theta dfun_theta = case inst_decl_theta of [] -> [] -- If inst_decl_theta is empty, then we don't @@ -443,3 +470,164 @@ mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys) \end{code} + + +%************************************************************************ +%* * +\subsection{Un-definable} +%* * +%************************************************************************ + +These two can't be defined in Haskell. + +unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that +just gets expanded into a type coercion wherever it occurs. Hence we +add it as a built-in Id with an unfolding here. + +The type variables we use here are "open" type variables: this means +they can unify with both unlifted and lifted types. Hence we provide +another gun with which to shoot yourself in the foot. + +\begin{code} +unsafeCoerceId + = pcMiscPrelId unsafeCoerceIdKey pREL_GHC SLIT("unsafeCoerce#") ty info + where + info = vanillaIdInfo + `setUnfoldingInfo` mkUnfolding rhs + `setInlinePragInfo` IMustBeINLINEd + + + ty = mkForAllTys [openAlphaTyVar,openBetaTyVar] + (mkFunTy openAlphaTy openBetaTy) + [x] = mkTemplateLocals [openAlphaTy] + rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $ + Note (Coerce openBetaTy openAlphaTy) (Var x) +\end{code} + + +@getTag#@ is another function which can't be defined in Haskell. It needs to +evaluate its argument and call the dataToTag# primitive. + +\begin{code} +getTagId + = pcMiscPrelId getTagIdKey pREL_GHC SLIT("getTag#") ty info + where + info = vanillaIdInfo + `setUnfoldingInfo` mkUnfolding rhs + `setInlinePragInfo` IMustBeINLINEd + -- We don't provide a defn for this; you must inline it + + ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy intPrimTy) + [x,y] = mkTemplateLocals [alphaTy,alphaTy] + rhs = mkLams [alphaTyVar,x] $ + Case (Var x) y [ (DEFAULT, [], + Con (PrimOp DataToTagOp) [Type alphaTy, Var y]) ] +\end{code} + +@realWorld#@ used to be a magic literal, \tr{void#}. If things get +nasty as-is, change it back to a literal (@Literal@). + +\begin{code} +realWorldPrimId -- :: State# RealWorld + = pcMiscPrelId realWorldPrimIdKey pREL_GHC SLIT("realWorld#") + realWorldStatePrimTy + noCafIdInfo +\end{code} + + +%************************************************************************ +%* * +\subsection[PrelVals-error-related]{@error@ and friends; @trace@} +%* * +%************************************************************************ + +GHC randomly injects these into the code. + +@patError@ is just a version of @error@ for pattern-matching +failures. It knows various ``codes'' which expand to longer +strings---this saves space! + +@absentErr@ is a thing we put in for ``absent'' arguments. They jolly +well shouldn't be yanked on, but if one is, then you will get a +friendly message from @absentErr@ (rather than a totally random +crash). + +@parError@ is a special version of @error@ which the compiler does +not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@ +templates, but we don't ever expect to generate code for it. + +\begin{code} +eRROR_ID + = pc_bottoming_Id errorIdKey pREL_ERR SLIT("error") errorTy +rEC_SEL_ERROR_ID + = generic_ERROR_ID recSelErrIdKey SLIT("patError") +pAT_ERROR_ID + = generic_ERROR_ID patErrorIdKey SLIT("patError") +rEC_CON_ERROR_ID + = generic_ERROR_ID recConErrorIdKey SLIT("recConError") +rEC_UPD_ERROR_ID + = generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError") +iRREFUT_PAT_ERROR_ID + = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError") +nON_EXHAUSTIVE_GUARDS_ERROR_ID + = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError") +nO_METHOD_BINDING_ERROR_ID + = generic_ERROR_ID noMethodBindingErrorIdKey SLIT("noMethodBindingError") + +aBSENT_ERROR_ID + = pc_bottoming_Id absentErrorIdKey pREL_ERR SLIT("absentErr") + (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) + +pAR_ERROR_ID + = pcMiscPrelId parErrorIdKey pREL_ERR SLIT("parError") + (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noCafIdInfo + +\end{code} + + +%************************************************************************ +%* * +\subsection{Utilities} +%* * +%************************************************************************ + +\begin{code} +pcMiscPrelId :: Unique{-IdKey-} -> Module -> FAST_STRING -> Type -> IdInfo -> Id +pcMiscPrelId key mod str ty info + = let + name = mkWiredInIdName key mod (mkSrcVarOcc str) imp + imp = mkId name ty info -- the usual case... + in + imp + -- We lie and say the thing is imported; otherwise, we get into + -- a mess with dependency analysis; e.g., core2stg may heave in + -- random calls to GHCbase.unpackPS__. If GHCbase is the module + -- being compiled, then it's just a matter of luck if the definition + -- will be in "the right place" to be in scope. + +pc_bottoming_Id key mod name ty + = pcMiscPrelId key mod name ty bottoming_info + where + bottoming_info = noCafIdInfo + `setStrictnessInfo` mkStrictnessInfo ([wwStrict], True) + + -- these "bottom" out, no matter what their arguments + +generic_ERROR_ID u n = pc_bottoming_Id u pREL_ERR n errorTy + +-- Very useful... +noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs + +(openAlphaTyVar:openBetaTyVar:_) = openAlphaTyVars +openAlphaTy = mkTyVarTy openAlphaTyVar +openBetaTy = mkTyVarTy openBetaTyVar + +errorTy :: Type +errorTy = mkUsgTy UsMany $ + mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkUsgTy UsOnce (mkListTy charTy)] + (mkUsgTy UsMany openAlphaTy)) + -- Notice the openAlphaTyVar. It says that "error" can be applied + -- to unboxed as well as boxed types. This is OK because it never + -- returns, so the return type is irrelevant. +\end{code} + diff --git a/ghc/compiler/basicTypes/Module.lhs b/ghc/compiler/basicTypes/Module.lhs index 2e6f46c..4320bc3 100644 --- a/ghc/compiler/basicTypes/Module.lhs +++ b/ghc/compiler/basicTypes/Module.lhs @@ -9,43 +9,54 @@ Representing modules and their flavours. module Module ( Module -- abstract, instance of Eq, Ord, Outputable + , ModuleName + + , moduleNameString -- :: ModuleName -> EncodedString + , moduleNameUserString -- :: ModuleName -> UserString + , moduleString -- :: Module -> EncodedString , moduleUserString -- :: Module -> UserString - , moduleIfaceFlavour -- :: Module -> IfaceFlavour - , moduleFS -- :: Module -> EncodedFS + , moduleName -- :: Module -> ModuleName - , mkBootModule -- :: Module -> Module - , setModuleFlavour -- :: IfaceFlavour -> Module -> Module + , mkVanillaModule -- :: ModuleName -> Module + , mkThisModule -- :: ModuleName -> Module + , mkPrelModule -- :: UserString -> Module - , mkDynamicModule -- :: Module -> Module , isDynamicModule -- :: Module -> Bool + , isLibModule , mkSrcModule - , mkPrelModule -- :: UserString -> Module - , mkSrcModuleFS -- :: UserFS -> Module - , mkSysModuleFS -- :: EncodedFS -> IfaceFlavour -> Module - , mkImportModuleFS -- :: UserFS -> IfaceFlavour -> Module + , mkSrcModuleFS -- :: UserFS -> ModuleName + , mkSysModuleFS -- :: EncodedFS -> ModuleName - , pprModule - , pprModuleSep - , pprModuleBoot + , pprModule, pprModuleName - -- IfaceFlavour - , IfaceFlavour - , hiFile - , hiBootFile -- :: IfaceFlavour - , mkDynFlavour -- :: Bool -> IfaceFlavour -> IfaceFlavour + -- DllFlavour + , DllFlavour, dll, notDll + + -- ModFlavour + , ModFlavour, libMod, userMod - , bootFlavour -- :: IfaceFlavour -> Bool + -- Where to find a .hi file + , WhereFrom(..), SearchPath, mkSearchPath + , ModuleHiMap, mkModuleHiMaps ) where #include "HsVersions.h" import OccName import Outputable -import CmdLineOpts ( opt_Static, opt_CompilingPrelude ) - +import FiniteMap +import CmdLineOpts ( opt_Static, opt_CompilingPrelude, opt_WarnHiShadows ) +import Constants ( interfaceFileFormatVersion ) +import Maybes ( seqMaybe ) +import Maybe ( fromMaybe ) +import Directory ( doesFileExist ) +import DirUtils ( getDirectoryContents ) +import List ( intersperse ) +import Monad ( foldM ) +import IO ( hPutStrLn, stderr, isDoesNotExistError ) \end{code} @@ -55,23 +66,6 @@ import CmdLineOpts ( opt_Static, opt_CompilingPrelude ) %* * %************************************************************************ -The IfaceFlavour type is used mainly in an imported Name's Provenance -to say whether the name comes from a regular .hi file, or whether it comes -from a hand-written .hi-boot file. This is important, because it has to be -propagated. Suppose - - C.hs imports B - B.hs imports A - A.hs imports C {-# SOURCE -#} ( f ) - -Then in A.hi we may mention C.f, in an inlining. When compiling B we *must not* -read C.f's details from C.hi, even if the latter happens to exist from an earlier -compilation run. So we use the name "C!f" in A.hi, and when looking for an interface -file with details of C!f we look in C.hi-boot. The "!" stuff is recorded in the -IfaceFlavour in the Module of C.f in A. - -Not particularly beautiful, but it works. - A further twist to the tale is the support for dynamically linked libraries under Win32. Here, dealing with the use of global variables that's residing in a DLL requires special handling at the point of use (there's an extra level of indirection, @@ -84,124 +78,308 @@ The logic for how an interface file is marked as corresponding to a module that' hiding in a DLL is explained elsewhere (ToDo: give renamer href here.) \begin{code} -data IfaceFlavour = HiFile -- The thing comes from a standard interface file - -- or from the source file itself - | HiBootFile -- ... or from a handwritten "hi-boot" interface file - - | HiDllFile -- The thing comes from a standard interface file, but - -- it's corresponding object code is residing in a DLL. - -- (see above.) - deriving( Eq ) - -hiFile = HiFile -hiDllFile = HiDllFile -hiBootFile = HiBootFile - --- badly named, isn't clear whether the boolean deals with --- the 'bootedness' or the 'DLLedness'. ToDo: improve. -mkDynFlavour :: Bool{-is really dyn?-} -> IfaceFlavour -> IfaceFlavour -mkDynFlavour True HiFile = HiDllFile -mkDynFlavour _ x = x - -instance Text IfaceFlavour where -- Just used in debug prints of lex tokens - showsPrec n HiBootFile s = "!" ++ s - showsPrec n HiFile s = s - showsPrec n HiDllFile s = s - -bootFlavour :: IfaceFlavour -> Bool -bootFlavour HiBootFile = True -bootFlavour HiFile = False -bootFlavour HiDllFile = False +data DllFlavour = NotDll -- Ordinary module + | Dll -- The module's object code lives in a DLL. + deriving( Eq ) + +dll = Dll +notDll = NotDll + +instance Text DllFlavour where -- Just used in debug prints of lex tokens + showsPrec n NotDll s = s + showsPrec n Dll s = "dll " ++ s \end{code} %************************************************************************ %* * -\subsection[Module]{The name of a module} +\subsection{System/user module} %* * %************************************************************************ +We also track whether an imported module is from a 'system-ish' place. In this case +we don't record the fact that this module depends on it, nor usages of things +inside it. + \begin{code} -data Module = Module - EncodedFS - IfaceFlavour +data ModFlavour = LibMod -- A library-ish module + | UserMod -- Not library-ish + +libMod = LibMod +userMod = UserMod +\end{code} + + +%************************************************************************ +%* * +\subsection{Where from} +%* * +%************************************************************************ + +The @WhereFrom@ type controls where the renamer looks for an interface file + +\begin{code} +data WhereFrom = ImportByUser -- Ordinary user import: look for M.hi + | ImportByUserSource -- User {- SOURCE -}: look for M.hi-boot + | ImportBySystem -- Non user import. Look for M.hi if M is in + -- the module this module depends on, or is a system-ish module; + -- M.hi-boot otherwise + +instance Outputable WhereFrom where + ppr ImportByUser = empty + ppr ImportByUserSource = ptext SLIT("{- SOURCE -}") + ppr ImportBySystem = ptext SLIT("{- SYSTEM IMPORT -}") +\end{code} + + +%************************************************************************ +%* * +\subsection{The name of a module} +%* * +%************************************************************************ + +\begin{code} +type ModuleName = EncodedFS -- Haskell module names can include the quote character ', -- so the module names have the z-encoding applied to them + +type ModuleNameSet = FiniteMap ModuleName +elemModuleNameSet s x = elemFM s x +moduleNameSetElems s = eltsFM s + + +pprModuleName :: ModuleName -> SDoc +pprModuleName nm = pprEncodedFS nm + +moduleNameString :: ModuleName -> EncodedString +moduleNameString mod = _UNPK_ mod + +moduleNameUserString :: ModuleName -> UserString +moduleNameUserString mod = decode (_UNPK_ mod) + +mkSrcModule :: UserString -> ModuleName +mkSrcModule s = _PK_ (encode s) + +mkSrcModuleFS :: UserFS -> ModuleName +mkSrcModuleFS s = encodeFS s + +mkSysModuleFS :: EncodedFS -> ModuleName +mkSysModuleFS s = s +\end{code} + +\begin{code} +data Module = Module + ModuleName + ModFlavour + DllFlavour \end{code} \begin{code} instance Outputable Module where ppr = pprModule --- Ignore the IfaceFlavour when comparing modules instance Eq Module where - (Module m1 _) == (Module m2 _) = m1 == m2 + (Module m1 _ _) == (Module m2 _ _) = m1 == m2 instance Ord Module where - (Module m1 _) `compare` (Module m2 _) = m1 `compare` m2 + (Module m1 _ _) `compare` (Module m2 _ _) = m1 `compare` m2 \end{code} \begin{code} pprModule :: Module -> SDoc -pprModule (Module mod _) = pprEncodedFS mod - -pprModuleSep, pprModuleBoot :: Module -> SDoc -pprModuleSep (Module mod HiFile) = dot -pprModuleSep (Module mod HiDllFile) = dot -pprModuleSep (Module mod HiBootFile) = char '!' - -pprModuleBoot (Module mod HiFile) = empty -pprModuleBoot (Module mod HiDllFile) = empty -pprModuleBoot (Module mod HiBootFile) = char '!' +pprModule (Module mod _ _) = pprEncodedFS mod \end{code} \begin{code} -mkSrcModule :: UserString -> Module -mkSrcModule s = Module (_PK_ (encode s)) HiFile +mkModule = Module + +mkVanillaModule :: ModuleName -> Module +mkVanillaModule name = Module name UserMod NotDll + +mkThisModule :: ModuleName -> Module -- The module being comiled +mkThisModule name = Module name UserMod NotDll -- ToDo: correct Dll flag? -mkPrelModule :: UserString -> Module -mkPrelModule s = Module (_PK_ (encode s)) ilk +mkPrelModule :: ModuleName -> Module +mkPrelModule name = Module name sys dll where - ilk - | opt_Static || opt_CompilingPrelude = HiFile - | otherwise = HiDllFile + sys | opt_CompilingPrelude = UserMod + | otherwise = LibMod -mkSrcModuleFS :: UserFS -> Module -mkSrcModuleFS s = Module (encodeFS s) HiFile + dll | opt_Static || opt_CompilingPrelude = NotDll + | otherwise = Dll -mkImportModuleFS :: UserFS -> IfaceFlavour -> Module -mkImportModuleFS s hif = Module (encodeFS s) hif +moduleString :: Module -> EncodedString +moduleString (Module mod _ _) = _UNPK_ mod + +moduleName :: Module -> ModuleName +moduleName (Module mod _ _) = mod -mkSysModuleFS :: EncodedFS -> IfaceFlavour -> Module -mkSysModuleFS s hif = Module s hif +moduleUserString :: Module -> UserString +moduleUserString (Module mod _ _) = moduleNameUserString mod +\end{code} -mkBootModule :: Module -> Module -mkBootModule (Module s _) = Module s HiBootFile +\begin{code} +isDynamicModule :: Module -> Bool +isDynamicModule (Module _ _ Dll) = True +isDynamicModule _ = False -mkDynamicModule :: Module -> Module -mkDynamicModule (Module s HiFile) = Module s HiDllFile -mkDynamicModule m = m +isLibModule :: Module -> Bool +isLibModule (Module _ LibMod _) = True +isLibModule _ = False +\end{code} -setModuleFlavour :: IfaceFlavour -> Module -> Module -setModuleFlavour hif (Module n _) = Module n hif -moduleString :: Module -> EncodedString -moduleString (Module mod _) = _UNPK_ mod +%************************************************************************ +%* * +\subsection{Finding modules in the file system +%* * +%************************************************************************ -moduleFS :: Module -> EncodedFS -moduleFS (Module mod _) = mod +\begin{code} +type ModuleHiMap = FiniteMap ModuleName (String, Module) + -- Mapping from module name to + -- * the file path of its corresponding interface file, + -- * the Module, decorated with it's properties +\end{code} -moduleUserString :: Module -> UserString -moduleUserString (Module mod _) = decode (_UNPK_ mod) +(We allege that) it is quicker to build up a mapping from module names +to the paths to their corresponding interface files once, than to search +along the import part every time we slurp in a new module (which we +do quite a lot of.) -moduleIfaceFlavour :: Module -> IfaceFlavour -moduleIfaceFlavour (Module _ hif) = hif +\begin{code} +type SearchPath = [(String,String)] -- List of (directory,suffix) pairs to search + -- for interface files. + +mkModuleHiMaps :: SearchPath -> IO (ModuleHiMap, ModuleHiMap) +mkModuleHiMaps dirs = foldM (getAllFilesMatching dirs) (env,env) dirs + where + env = emptyFM + +{- A pseudo file, currently "dLL_ifs.hi", + signals that the interface files + contained in a particular directory have got their + corresponding object codes stashed away in a DLL + + This stuff is only needed to deal with Win32 DLLs, + and conceivably we conditionally compile in support + for handling it. (ToDo?) +-} +dir_contain_dll_his = "dLL_ifs.hi" + +getAllFilesMatching :: SearchPath + -> (ModuleHiMap, ModuleHiMap) + -> (FilePath, String) + -> IO (ModuleHiMap, ModuleHiMap) +getAllFilesMatching dirs hims (dir_path, suffix) = ( do + -- fpaths entries do not have dir_path prepended + fpaths <- getDirectoryContents dir_path + is_dll <- catch + (if opt_Static || dir_path == "." then + return NotDll + else + do exists <- doesFileExist (dir_path ++ '/': dir_contain_dll_his) + return (if exists then Dll else NotDll) + ) + (\ _ {-don't care-} -> return NotDll) + return (foldl (addModules is_dll) hims fpaths) + ) -- soft failure + `catch` + (\ err -> do + hPutStrLn stderr + ("Import path element `" ++ dir_path ++ + if (isDoesNotExistError err) then + "' does not exist, ignoring." + else + "' couldn't read, ignoring.") + + return hims + ) + where + + -- Dreadfully crude. We want a better way to distinguish + -- "library-ish" modules. + is_sys | head dir_path == '/' = LibMod + | otherwise = UserMod + + xiffus = reverse dotted_suffix + dotted_suffix = case suffix of + [] -> [] + ('.':xs) -> suffix + ls -> '.':ls + + hi_boot_version_xiffus = + reverse (show interfaceFileFormatVersion) ++ '-':hi_boot_xiffus + hi_boot_xiffus = "toob-ih." -- .hi-boot reversed! + + addModules is_dll his@(hi_env, hib_env) filename = fromMaybe his $ + FMAP add_hi (go xiffus rev_fname) `seqMaybe` + FMAP add_vhib (go hi_boot_version_xiffus rev_fname) `seqMaybe` + FMAP add_hib (go hi_boot_xiffus rev_fname) + where + rev_fname = reverse filename + path = dir_path ++ '/':filename + + mk_module mod_nm = Module mod_nm is_sys is_dll + add_hi mod_nm = (addToFM_C addNewOne hi_env mod_nm (path, mk_module mod_nm), hib_env) + add_vhib mod_nm = (hi_env, addToFM_C overrideNew hib_env mod_nm (path, mk_module mod_nm)) + add_hib mod_nm = (hi_env, addToFM_C addNewOne hib_env mod_nm (path, mk_module mod_nm)) + + + -- go prefix (prefix ++ stuff) == Just (reverse stuff) + go [] xs = Just (_PK_ (reverse xs)) + go _ [] = Nothing + go (x:xs) (y:ys) | x == y = go xs ys + | otherwise = Nothing + + addNewOne | opt_WarnHiShadows = conflict + | otherwise = stickWithOld + + stickWithOld old new = old + overrideNew old new = new + + conflict (old_path,mod) (new_path,_) + | old_path /= new_path = + pprTrace "Warning: " (text "Identically named interface files present on the import path, " $$ + text (show old_path) <+> text "shadows" $$ + text (show new_path) $$ + text "on the import path: " <+> + text (concat (intersperse ":" (map fst dirs)))) + (old_path,mod) + | otherwise = (old_path,mod) -- don't warn about innocous shadowings. \end{code} + +%********************************************************* +%* * +\subsection{Making a search path} +%* * +%********************************************************* + +@mkSearchPath@ takes a string consisting of a colon-separated list +of directories and corresponding suffixes, and turns it into a list +of (directory, suffix) pairs. For example: + +\begin{verbatim} + mkSearchPath "foo%.hi:.%.p_hi:baz%.mc_hi" + = [("foo",".hi"),( ".", ".p_hi"), ("baz",".mc_hi")] +\begin{verbatim} + \begin{code} -isDynamicModule :: Module -> Bool -isDynamicModule (Module _ HiDllFile) = True -isDynamicModule _ = False +mkSearchPath :: Maybe String -> SearchPath +mkSearchPath Nothing = [(".",".hi")] -- ToDo: default should be to look in + -- the directory the module we're compiling + -- lives. +mkSearchPath (Just s) = go s + where + go "" = [] + go s = + case span (/= '%') s of + (dir,'%':rs) -> + case span (/= ':') rs of + (hisuf,_:rest) -> (dir,hisuf):go rest + (hisuf,[]) -> [(dir,hisuf)] \end{code} + diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 9c1fee1..0bd95d2 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -12,7 +12,7 @@ module Name ( Name, -- Abstract mkLocalName, mkImportedLocalName, mkSysLocalName, mkTopName, - mkDerivedName, mkGlobalName, + mkDerivedName, mkGlobalName, mkKnownKeyGlobal, mkWiredInIdName, mkWiredInTyConName, maybeWiredInIdName, maybeWiredInTyConName, isWiredInName, @@ -21,7 +21,7 @@ module Name ( tidyTopName, nameOccName, nameModule, setNameOcc, nameRdrName, setNameModule, - isExportedName, nameSrcLoc, + isUserExportedName, nameSrcLoc, isLocallyDefinedName, isSystemName, isLocalName, isGlobalName, isExternallyVisibleName, @@ -34,7 +34,6 @@ module Name ( -- Class NamedThing and overloaded friends NamedThing(..), - isExported, getSrcLoc, isLocallyDefined, getOccString ) where @@ -44,8 +43,8 @@ import {-# SOURCE #-} Var ( Id, setIdName ) import {-# SOURCE #-} TyCon ( TyCon, setTyConName ) import OccName -- All of it -import Module -import RdrName ( RdrName, mkRdrQual, mkRdrUnqual ) +import Module ( Module, moduleName, pprModule, mkVanillaModule ) +import RdrName ( RdrName, mkRdrQual, mkRdrUnqual, rdrNameOcc, rdrNameModule ) import CmdLineOpts ( opt_PprStyle_NoPrags, opt_OmitInterfacePragmas, opt_EnsureSplittableC ) import SrcLoc ( noSrcLoc, mkBuiltinSrcLoc, SrcLoc ) @@ -109,6 +108,12 @@ mkGlobalName uniq mod occ prov = Name { n_uniq = uniq, n_sort = Global mod, n_occ = occ, n_prov = prov } +mkKnownKeyGlobal :: (RdrName, Unique) -> Name +mkKnownKeyGlobal (rdr_name, uniq) + = mkGlobalName uniq (mkVanillaModule (rdrNameModule rdr_name)) + (rdrNameOcc rdr_name) + systemProvenance + mkSysLocalName :: Unique -> FAST_STRING -> Name mkSysLocalName uniq fs = Name { n_uniq = uniq, n_sort = Local, n_occ = mkSrcVarOcc fs, n_prov = SystemProv } @@ -213,9 +218,7 @@ are exported. But also: \begin{code} tidyTopName :: Module -> TidyOccEnv -> Name -> (TidyOccEnv, Name) tidyTopName mod env name - | isExported name = (env, name) -- Don't fiddle with an exported name - -- It should be in the TidyOccEnv already - | otherwise = (env', name') + = (env', name') where (env', occ') = tidyOccName env (n_occ name) @@ -365,7 +368,7 @@ nameOccName :: Name -> OccName nameModule :: Name -> Module nameSrcLoc :: Name -> SrcLoc isLocallyDefinedName :: Name -> Bool -isExportedName :: Name -> Bool +isUserExportedName :: Name -> Bool isWiredInName :: Name -> Bool isLocalName :: Name -> Bool isGlobalName :: Name -> Bool @@ -387,16 +390,16 @@ nameSortModule (WiredInTyCon mod _) = mod nameRdrName :: Name -> RdrName nameRdrName (Name { n_sort = Local, n_occ = occ }) = mkRdrUnqual occ -nameRdrName (Name { n_sort = sort, n_occ = occ }) = mkRdrQual (nameSortModule sort) occ +nameRdrName (Name { n_sort = sort, n_occ = occ }) = mkRdrQual (moduleName (nameSortModule sort)) occ -isExportedName (Name { n_prov = LocalDef _ Exported }) = True -isExportedName other = False +isUserExportedName (Name { n_prov = LocalDef _ Exported }) = True +isUserExportedName other = False nameSrcLoc name = provSrcLoc (n_prov name) provSrcLoc (LocalDef loc _) = loc provSrcLoc (NonLocalDef (UserImport _ loc _) _) = loc -provSrcLoc SystemProv = noSrcLoc +provSrcLoc other = noSrcLoc isLocallyDefinedName (Name {n_sort = Local}) = True -- Local (might have SystemProv) isLocallyDefinedName (Name {n_prov = LocalDef _ _}) = True -- Global, but defined here @@ -517,7 +520,7 @@ pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ, n_prov = prov}) pp_mod_dot sty = case prov of - SystemProv -> pp_qual mod pp_sep user_sty + SystemProv -> pp_qual mod user_sty -- Hack alert! Omit the qualifier on SystemProv things in user style -- I claim such SystemProv things will also be WiredIn things. -- We can't get the omit flag right @@ -525,24 +528,20 @@ pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ, n_prov = prov}) -- and hope that leaving it out isn't too consfusing. -- (e.g. if the programmer hides Bool and redefines it. If so, use -dppr-debug.) - LocalDef _ _ -> pp_qual mod dot (user_sty || iface_sty) + LocalDef _ _ -> pp_qual mod (user_sty || iface_sty) NonLocalDef (UserImport imp_mod _ _) omit - | user_sty -> pp_qual imp_mod pp_sep omit - | otherwise -> pp_qual mod pp_sep False - NonLocalDef ImplicitImport omit -> pp_qual mod pp_sep (user_sty && omit) + | user_sty -> pp_qual imp_mod omit + | otherwise -> pp_qual mod False + NonLocalDef ImplicitImport omit -> pp_qual mod (user_sty && omit) where user_sty = userStyle sty iface_sty = ifaceStyle sty - pp_qual mod sep omit_qual + pp_qual mod omit_qual | omit_qual = empty - | otherwise = pprModule mod <> sep + | otherwise = pprModule mod <> dot - pp_sep | bootFlavour (moduleIfaceFlavour mod) = text "!" -- M!t indicates a name imported - -- from a .hi-boot interface - | otherwise = dot -- Vanilla case - pp_global_debug sty uniq prov | debugStyle sty = hcat [text "{-", pprUnique uniq, prov_p prov, text "-}"] | otherwise = empty @@ -576,10 +575,8 @@ class NamedThing a where \begin{code} getSrcLoc :: NamedThing a => a -> SrcLoc isLocallyDefined :: NamedThing a => a -> Bool -isExported :: NamedThing a => a -> Bool getOccString :: NamedThing a => a -> String -isExported = isExportedName . getName getSrcLoc = nameSrcLoc . getName isLocallyDefined = isLocallyDefinedName . getName getOccString x = occNameString (getOccName x) diff --git a/ghc/compiler/basicTypes/NameSet.lhs b/ghc/compiler/basicTypes/NameSet.lhs index 0f857db..1c9d02b 100644 --- a/ghc/compiler/basicTypes/NameSet.lhs +++ b/ghc/compiler/basicTypes/NameSet.lhs @@ -9,7 +9,7 @@ module NameSet ( NameSet, emptyNameSet, unitNameSet, mkNameSet, unionNameSets, unionManyNameSets, minusNameSet, elemNameSet, nameSetToList, addOneToNameSet, addListToNameSet, - delFromNameSet, delListFromNameSet, isEmptyNameSet, + delFromNameSet, delListFromNameSet, isEmptyNameSet, foldNameSet ) where #include "HsVersions.h" @@ -40,6 +40,7 @@ nameSetToList :: NameSet -> [Name] isEmptyNameSet :: NameSet -> Bool delFromNameSet :: NameSet -> Name -> NameSet delListFromNameSet :: NameSet -> [Name] -> NameSet +foldNameSet :: (Name -> b -> b) -> b -> NameSet -> b isEmptyNameSet = isEmptyUniqSet emptyNameSet = emptyUniqSet @@ -53,6 +54,7 @@ minusNameSet = minusUniqSet elemNameSet = elementOfUniqSet nameSetToList = uniqSetToList delFromNameSet = delOneFromUniqSet +foldNameSet = foldUniqSet delListFromNameSet set ns = foldl delFromNameSet set ns \end{code} diff --git a/ghc/compiler/basicTypes/RdrName.lhs b/ghc/compiler/basicTypes/RdrName.lhs index 838df14..3e5f52e 100644 --- a/ghc/compiler/basicTypes/RdrName.lhs +++ b/ghc/compiler/basicTypes/RdrName.lhs @@ -28,10 +28,9 @@ import OccName ( NameSpace, tcName, mkSrcOccFS, mkSrcVarOcc, isDataOcc, isTvOcc ) -import Module ( Module, IfaceFlavour, mkSysModuleFS, - mkSrcModuleFS, pprModuleSep +import Module ( ModuleName, + mkSysModuleFS, mkSrcModuleFS ) -import PrelMods ( pRELUDE ) import Outputable import Util ( thenCmp ) \end{code} @@ -47,7 +46,7 @@ import Util ( thenCmp ) data RdrName = RdrName Qual OccName data Qual = Unqual - | Qual Module + | Qual ModuleName -- The (encoded) module name \end{code} @@ -58,7 +57,7 @@ data Qual = Unqual %************************************************************************ \begin{code} -rdrNameModule :: RdrName -> Module +rdrNameModule :: RdrName -> ModuleName rdrNameModule (RdrName (Qual m) _) = m rdrNameOcc :: RdrName -> OccName @@ -70,13 +69,13 @@ rdrNameOcc (RdrName _ occ) = occ mkRdrUnqual :: OccName -> RdrName mkRdrUnqual occ = RdrName Unqual occ -mkRdrQual :: Module -> OccName -> RdrName +mkRdrQual :: ModuleName -> OccName -> RdrName mkRdrQual mod occ = RdrName (Qual mod) occ -- These two are used when parsing source files -- They do encode the module and occurrence names mkSrcUnqual :: NameSpace -> FAST_STRING -> RdrName -mkSrcUnqual sp n = RdrName Unqual (mkSrcOccFS sp n) +mkSrcUnqual sp n = RdrName Unqual (mkSrcOccFS sp n) mkSrcQual :: NameSpace -> FAST_STRING -> FAST_STRING -> RdrName mkSrcQual sp m n = RdrName (Qual (mkSrcModuleFS m)) (mkSrcOccFS sp n) @@ -84,15 +83,15 @@ mkSrcQual sp m n = RdrName (Qual (mkSrcModuleFS m)) (mkSrcOccFS sp n) -- These two are used when parsing interface files -- They do not encode the module and occurrence name mkSysUnqual :: NameSpace -> FAST_STRING -> RdrName -mkSysUnqual sp n = RdrName Unqual (mkSysOccFS sp n) +mkSysUnqual sp n = RdrName Unqual (mkSysOccFS sp n) -mkSysQual :: NameSpace -> (FAST_STRING, FAST_STRING, IfaceFlavour) -> RdrName -mkSysQual sp (m,n,hif) = RdrName (Qual (mkSysModuleFS m hif)) (mkSysOccFS sp n) +mkSysQual :: NameSpace -> (FAST_STRING, FAST_STRING) -> RdrName +mkSysQual sp (m,n) = RdrName (Qual (mkSysModuleFS m)) (mkSysOccFS sp n) -mkPreludeQual :: NameSpace -> Module -> FAST_STRING -> RdrName +mkPreludeQual :: NameSpace -> ModuleName -> FAST_STRING -> RdrName mkPreludeQual sp mod n = RdrName (Qual mod) (mkSrcOccFS sp n) -qualifyRdrName :: Module -> RdrName -> RdrName +qualifyRdrName :: ModuleName -> RdrName -> RdrName qualifyRdrName mod (RdrName Unqual occ) = RdrName (Qual mod) occ qualifyRdrName mod rdr_name = rdr_name \end{code} @@ -130,7 +129,7 @@ instance Outputable RdrName where ppr (RdrName qual occ) = pp_qual qual <> ppr occ where pp_qual Unqual = empty - pp_qual (Qual mod) = ppr mod <> pprModuleSep mod + pp_qual (Qual mod) = ppr mod <> dot instance Eq RdrName where a == b = case (a `compare` b) of { EQ -> True; _ -> False } diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index 81e137d..ae87ce2 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -152,6 +152,7 @@ module Unique ( recSelErrIdKey, recUpdErrorIdKey, returnMClassOpKey, + runSTRepIdKey, showClassKey, ioTyConKey, ioDataConKey, @@ -241,7 +242,9 @@ mkUniqueGrimily x = MkUnique x {-# INLINE getKey #-} getKey (MkUnique x) = x -incrUnique (MkUnique i) = MkUnique (i +# 1#) +incrUnique (MkUnique i) = MkUnique (i +# 100#) +-- Bump the unique by a lot, to get it out of the neighbourhood +-- of its friends -- pop the Char in the top 8 bits of the Unique(Supply) @@ -640,4 +643,5 @@ mapIdKey = mkPreludeMiscIdUnique 120 \begin{code} assertIdKey = mkPreludeMiscIdUnique 121 +runSTRepIdKey = mkPreludeMiscIdUnique 122 \end{code} diff --git a/ghc/compiler/basicTypes/Var.lhs b/ghc/compiler/basicTypes/Var.lhs index cacde2b..4d5be70 100644 --- a/ghc/compiler/basicTypes/Var.lhs +++ b/ghc/compiler/basicTypes/Var.lhs @@ -5,10 +5,9 @@ \begin{code} module Var ( - Var, IdOrTyVar, -- Abstract - VarDetails(..), -- Concrete - varName, varUnique, varDetails, varInfo, varType, - setVarName, setVarUnique, setVarType, setVarOcc, + Var, IdOrTyVar, VarDetails, -- Abstract + varName, varUnique, varInfo, varType, + setVarName, setVarUnique, setVarType, setVarOcc, -- TyVars @@ -26,18 +25,16 @@ module Var ( -- Ids Id, DictId, - idDetails, idName, idType, idUnique, idInfo, modifyIdInfo, + idName, idType, idUnique, idInfo, modifyIdInfo, maybeModifyIdInfo, setIdName, setIdUnique, setIdInfo, - mkId, isId, externallyVisibleId + mkIdVar, isId, externallyVisibleId ) where #include "HsVersions.h" import {-# SOURCE #-} Type( Type, Kind ) import {-# SOURCE #-} IdInfo( IdInfo ) -import {-# SOURCE #-} Const( Con ) -import FieldLabel ( FieldLabel ) import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey ) import Name ( Name, OccName, NamedThing(..), setNameUnique, setNameOcc, nameUnique, @@ -78,9 +75,7 @@ data Var } data VarDetails - = VanillaId -- Most Ids are like this - | ConstantId Con -- The Id for a constant (data constructor or primop) - | RecordSelId FieldLabel -- The Id for a record selector + = AnId | TyVar | MutTyVar (IORef (Maybe Type)) -- Used during unification; Bool -- True <=> this is a type signature variable, which @@ -164,7 +159,7 @@ mkTyVar name kind = Var { varName = name , varType = kind , varDetails = TyVar #ifdef DEBUG - , varInfo = pprPanic "mkTyVar" (ppr name) + , varInfo = pprPanic "looking at IdInfo of a tyvar" (ppr name) #endif } @@ -264,7 +259,6 @@ idName = varName idType = varType idUnique = varUnique idInfo = varInfo -idDetails = varDetails setIdUnique :: Id -> Unique -> Id setIdUnique = setVarUnique @@ -275,24 +269,27 @@ setIdName = setVarName setIdInfo :: Id -> IdInfo -> Id setIdInfo var info = var {varInfo = info} -modifyIdInfo :: Id -> (IdInfo -> IdInfo) -> Id -modifyIdInfo var@(Var {varInfo = info}) fn = var {varInfo = fn info} +modifyIdInfo :: (IdInfo -> IdInfo) -> Id -> Id +modifyIdInfo fn var@(Var {varInfo = info}) = var {varInfo = fn info} + +-- maybeModifyIdInfo tries to avoid unnecesary thrashing +maybeModifyIdInfo :: (IdInfo -> Maybe IdInfo) -> Id -> Id +maybeModifyIdInfo fn var@(Var {varInfo = info}) = case fn info of + Nothing -> var + Just new_info -> var {varInfo = new_info} \end{code} \begin{code} -mkId :: Name -> Type -> VarDetails -> IdInfo -> Id -mkId name ty details info +mkIdVar :: Name -> Type -> IdInfo -> Id +mkIdVar name ty info = Var {varName = name, realUnique = getKey (nameUnique name), varType = ty, - varDetails = details, varInfo = info} + varDetails = AnId, varInfo = info} \end{code} \begin{code} isId :: Var -> Bool -isId (Var {varDetails = details}) = case details of - VanillaId -> True - ConstantId _ -> True - RecordSelId _ -> True - other -> False +isId (Var {varDetails = AnId}) = True +isId other = False \end{code} @externallyVisibleId@: is it true that another module might be diff --git a/ghc/compiler/basicTypes/VarEnv.lhs b/ghc/compiler/basicTypes/VarEnv.lhs index db389ef..0b3d921 100644 --- a/ghc/compiler/basicTypes/VarEnv.lhs +++ b/ghc/compiler/basicTypes/VarEnv.lhs @@ -16,11 +16,20 @@ module VarEnv ( modifyVarEnv, modifyVarEnv_Directly, isEmptyVarEnv, foldVarEnv, - TidyEnv, emptyTidyEnv + -- TidyEnvs + TidyEnv, emptyTidyEnv, + + -- SubstEnvs + SubstEnv, TyVarSubstEnv, SubstResult(..), emptySubstEnv, + mkSubstEnv, lookupSubstEnv, extendSubstEnv, extendSubstEnvList, + delSubstEnv, noTypeSubst, isEmptySubstEnv ) where #include "HsVersions.h" +import {-# SOURCE #-} CoreSyn( CoreExpr ) +import {-# SOURCE #-} Type( Type ) + import OccName ( TidyOccEnv, emptyTidyOccEnv ) import Var ( Var, Id, IdOrTyVar ) import UniqFM @@ -45,6 +54,55 @@ emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv) %************************************************************************ %* * +\subsection{Substitution environments} +%* * +%************************************************************************ + +\begin{code} + +noTys :: SubstResult -> Bool -> Bool +noTys (DoneTy ty) no_tys = False +noTys other no_tys = no_tys + +data SubstEnv = SE (VarEnv SubstResult) + Bool -- True => definitely no type substitutions in the env + +noTypeSubst :: SubstEnv -> Bool +noTypeSubst (SE _ nt) = nt + +type TyVarSubstEnv = SubstEnv -- of the form (DoneTy ty) *only* + +data SubstResult + = DoneEx CoreExpr -- Completed term + | DoneTy Type -- Completed type + | ContEx SubstEnv CoreExpr -- A suspended substitution + +emptySubstEnv :: SubstEnv +emptySubstEnv = SE emptyVarEnv True + +isEmptySubstEnv :: SubstEnv -> Bool +isEmptySubstEnv (SE s _) = isEmptyVarEnv s + +lookupSubstEnv :: SubstEnv -> Var -> Maybe SubstResult +lookupSubstEnv (SE s _) v = lookupVarEnv s v + +extendSubstEnv :: SubstEnv -> Var -> SubstResult -> SubstEnv +extendSubstEnv (SE s nt) v r = SE (extendVarEnv s v r) (noTys r nt) + +mkSubstEnv :: [IdOrTyVar] -> [SubstResult] -> SubstEnv +mkSubstEnv bs vs = extendSubstEnvList emptySubstEnv bs vs + +extendSubstEnvList :: SubstEnv -> [IdOrTyVar] -> [SubstResult] -> SubstEnv +extendSubstEnvList env [] [] = env +extendSubstEnvList (SE env nt) (b:bs) (r:rs) = extendSubstEnvList (SE (extendVarEnv env b r) (noTys r nt)) bs rs + +delSubstEnv :: SubstEnv -> IdOrTyVar -> SubstEnv +delSubstEnv (SE s nt) v = SE (delVarEnv s v) nt +\end{code} + + +%************************************************************************ +%* * \subsection{@VarEnv@s} %* * %************************************************************************ diff --git a/ghc/compiler/basicTypes/VarSet.lhs b/ghc/compiler/basicTypes/VarSet.lhs index 9091dfe..fb5b6cf 100644 --- a/ghc/compiler/basicTypes/VarSet.lhs +++ b/ghc/compiler/basicTypes/VarSet.lhs @@ -8,10 +8,10 @@ module VarSet ( VarSet, IdSet, TyVarSet, IdOrTyVarSet, emptyVarSet, unitVarSet, mkVarSet, extendVarSet, - elemVarSet, varSetElems, + elemVarSet, varSetElems, subVarSet, unionVarSet, unionVarSets, intersectVarSet, intersectsVarSet, - isEmptyVarSet, delVarSet, + isEmptyVarSet, delVarSet, delVarSetByKey, minusVarSet, foldVarSet, filterVarSet, lookupVarSet, mapVarSet, @@ -20,9 +20,11 @@ module VarSet ( #include "HsVersions.h" +import CmdLineOpts ( opt_PprStyle_Debug ) import Var ( Var, Id, TyVar, IdOrTyVar, setVarUnique ) -import Unique ( Uniquable(..), incrUnique ) +import Unique ( Unique, Uniquable(..), incrUnique ) import UniqSet +import UniqFM ( delFromUFM_Directly ) import Outputable \end{code} @@ -57,6 +59,9 @@ lookupVarSet :: VarSet -> Var -> Maybe Var -- (==) to the argument, but not the same as mapVarSet :: (Var -> Var) -> VarSet -> VarSet filterVarSet :: (Var -> Bool) -> VarSet -> VarSet +subVarSet :: VarSet -> VarSet -> Bool + +delVarSetByKey :: VarSet -> Unique -> VarSet emptyVarSet = emptyUniqSet unitVarSet = unitUniqSet @@ -75,15 +80,24 @@ foldVarSet = foldUniqSet lookupVarSet = lookupUniqSet mapVarSet = mapUniqSet 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} uniqAway :: VarSet -> Var -> Var -- Give the Var a new unique, different to any in the VarSet uniqAway set var + | not (var `elemVarSet` set) = var -- Nothing to do + + | otherwise = try 1 (incrUnique (getUnique var)) where try n uniq | uniq `elemUniqSet_Directly` set = try ((n+1)::Int) (incrUnique uniq) - | otherwise = {- pprTrace "uniqAway:" (ppr n <+> text "tries") -} - setVarUnique var uniq +#ifdef DEBUG + | opt_PprStyle_Debug && n > 3 + = pprTrace "uniqAway:" (ppr n <+> text "tries" <+> ppr var) + setVarUnique var uniq +#endif + | otherwise = setVarUnique var uniq \end{code} diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index aa09d5d..b02e248 100644 --- a/ghc/compiler/codeGen/CgCase.lhs +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgCase.lhs,v 1.28 1999/05/13 17:30:55 simonm Exp $ +% $Id: CgCase.lhs,v 1.29 1999/05/18 15:03:46 simonpj Exp $ % %******************************************************** %* * @@ -11,8 +11,8 @@ \begin{code} module CgCase ( cgCase, saveVolatileVarsAndRegs, - restoreCurrentCostCentre, freeCostCentreSlot, - splitTyConAppThroughNewTypes ) where + restoreCurrentCostCentre, freeCostCentreSlot + ) where #include "HsVersions.h" @@ -25,7 +25,6 @@ import AbsCSyn import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch, getAmodeRep, nonemptyAbsC ) -import CoreSyn ( isDeadBinder ) import CgUpdate ( reserveSeqFrame ) import CgBindery ( getVolatileRegs, getArgAmodes, getArgAmode, bindNewToReg, bindNewToTemp, @@ -51,6 +50,7 @@ import CLabel ( CLabel, mkVecTblLabel, mkReturnPtLabel, import ClosureInfo ( mkLFArgument ) import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros ) import CostCentre ( CostCentre ) +import CoreSyn ( isDeadBinder ) import Id ( Id, idPrimRep ) import DataCon ( DataCon, dataConTag, fIRST_TAG, ConTag, isUnboxedTupleCon, dataConType ) @@ -63,8 +63,7 @@ import TyCon ( TyCon, isEnumerationTyCon, isUnboxedTupleTyCon, isNewTyCon, isAlgTyCon, isFunTyCon, isPrimTyCon, tyConDataCons, tyConFamilySize ) import Type ( Type, typePrimRep, splitAlgTyConApp, - splitTyConApp_maybe, - splitFunTys, applyTys ) + splitTyConApp_maybe, splitRepTyConApp_maybe ) import Unique ( Unique, Uniquable(..), mkBuiltinUnique ) import Maybes ( maybeToBool ) import Util @@ -238,10 +237,8 @@ cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt two bindings pointing at the same stack locn doesn't work (it confuses nukeDeadBindings). Hence, use a new temp. -} - (if (isDeadBinder bndr) - then nopC - else bindNewToTemp bndr `thenFC` \deflt_amode -> - absC (CAssign deflt_amode amode)) `thenC` + bindNewToTemp bndr `thenFC` \deflt_amode -> + absC (CAssign deflt_amode amode) `thenC` cgPrimAlts NoGC amode alts deflt [] \end{code} @@ -448,9 +445,7 @@ cgEvalAlts cc_slot bndr srt alts (StgAlgAlts ty alts deflt) -> -- bind the default binder (it covers all the alternatives) - (if (isDeadBinder bndr) - then nopC - else bindNewToReg bndr node mkLFArgument) `thenC` + bindNewToReg bndr node mkLFArgument `thenC` -- Generate sequel info for use downstream -- At the moment, we only do it if the type is vector-returnable. @@ -757,9 +752,7 @@ cgPrimEvalAlts bndr ty alts deflt cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs = -- first bind the default if necessary - (if isDeadBinder bndr - then nopC - else bindNewPrimToAmode bndr scrutinee) `thenC` + bindNewPrimToAmode bndr scrutinee `thenC` cgPrimAlts gc_flag scrutinee alts deflt regs cgPrimAlts gc_flag scrutinee alts deflt regs @@ -988,41 +981,14 @@ possibleHeapCheck NoGC _ _ tags lbl code = code \end{code} -splitTyConAppThroughNewTypes is like splitTyConApp_maybe except -that it looks through newtypes in addition to synonyms. It's -useful in the back end where we're not interested in newtypes -anymore. - -Sometimes, we've thrown away the constructors during pruning in the -renamer. In these cases, we emit a warning and fall back to using a -SEQ_FRAME to evaluate the case scrutinee. - \begin{code} getScrutineeTyCon :: Type -> Maybe TyCon getScrutineeTyCon ty = - case (splitTyConAppThroughNewTypes ty) of + case splitRepTyConApp_maybe ty of Nothing -> Nothing Just (tc,_) -> if isFunTyCon tc then Nothing else -- not interested in funs if isPrimTyCon tc then Just tc else -- return primitive tycons -- otherwise (algebraic tycons) check the no. of constructors - case (tyConFamilySize tc) of - 0 -> pprTrace "Warning" (hcat [ - text "constructors for ", - ppr tc, - text " not available.\n\tUse -fno-prune-tydecls to fix." - ]) Nothing - _ -> Just tc - -splitTyConAppThroughNewTypes :: Type -> Maybe (TyCon, [Type]) -splitTyConAppThroughNewTypes ty - = case splitTyConApp_maybe ty of - Just (tc, tys) - | isNewTyCon tc -> splitTyConAppThroughNewTypes ty - | otherwise -> Just (tc, tys) - where - ([ty], _) = splitFunTys (applyTys (dataConType (head (tyConDataCons tc))) tys) - - other -> Nothing - + Just tc \end{code} diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index edcb089..7d532ba 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.30 1999/05/13 17:30:56 simonm Exp $ +% $Id: CgClosure.lhs,v 1.31 1999/05/18 15:03:47 simonpj Exp $ % \section[CgClosure]{Code generation for closures} @@ -22,7 +22,6 @@ import {-# SOURCE #-} CgExpr ( cgExpr ) import CgMonad import AbsCSyn import StgSyn -import BasicTypes ( TopLevelFlag(..) ) import AbsCUtils ( mkAbstractCs, getAmodeRep ) import CgBindery ( getCAddrMode, getArgAmodes, diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index 35dcdc2..6be1371 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -50,7 +50,6 @@ import Module ( isDynamicModule ) import Const ( Con(..), Literal(..), isLitLitLit ) import PrelInfo ( maybeCharLikeCon, maybeIntLikeCon ) import PrimRep ( PrimRep(..) ) -import BasicTypes ( TopLevelFlag(..) ) import Util import Panic ( assertPanic, trace ) \end{code} diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs index 99d286e..6b75ee5 100644 --- a/ghc/compiler/codeGen/CgConTbls.lhs +++ b/ghc/compiler/codeGen/CgConTbls.lhs @@ -26,7 +26,6 @@ import Name ( getOccString ) import PrimRep ( getPrimRepSize, PrimRep(..) ) import TyCon ( tyConDataCons, isEnumerationTyCon, TyCon ) import Type ( typePrimRep, Type ) -import BasicTypes ( TopLevelFlag(..) ) import Outputable \end{code} @@ -72,15 +71,10 @@ closures predeclared. \begin{code} genStaticConBits :: CompilationInfo -- global info about the compilation -> [TyCon] -- tycons to generate - -> FiniteMap TyCon [(Bool, [Maybe Type])] - -- tycon specialisation info -> AbstractC -- output -genStaticConBits comp_info gen_tycons tycon_specs - = ASSERT( null (fmToList tycon_specs) ) - -- We don't do specialised type constructors any more - - -- for each type constructor: +genStaticConBits comp_info gen_tycons + = -- for each type constructor: -- grab all its data constructors; -- for each one, generate an info table -- for each specialised type constructor diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index 5c4cd9b..4490a81 100644 --- a/ghc/compiler/codeGen/CgExpr.lhs +++ b/ghc/compiler/codeGen/CgExpr.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgExpr.lhs,v 1.24 1999/05/07 13:44:00 simonm Exp $ +% $Id: CgExpr.lhs,v 1.25 1999/05/18 15:03:49 simonpj Exp $ % %******************************************************** %* * @@ -24,8 +24,7 @@ import CLabel ( mkClosureTblLabel ) import SMRep ( fixedHdrSize ) import CgBindery ( getArgAmodes, getArgAmode, CgIdInfo, nukeDeadBindings) import CgCase ( cgCase, saveVolatileVarsAndRegs, - restoreCurrentCostCentre, freeCostCentreSlot, - splitTyConAppThroughNewTypes ) + restoreCurrentCostCentre, freeCostCentreSlot ) import CgClosure ( cgRhsClosure, cgStdRhsClosure ) import CgCon ( buildDynCon, cgReturnDataCon ) import CgLetNoEscape ( cgLetNoEscapeClosure ) @@ -48,7 +47,7 @@ import PrimOp ( primOpOutOfLine, import PrimRep ( getPrimRepSize, PrimRep(..), isFollowableRep ) import TyCon ( maybeTyConSingleCon, isUnboxedTupleTyCon, isEnumerationTyCon ) -import Type ( Type, typePrimRep, splitTyConApp_maybe ) +import Type ( Type, typePrimRep, splitTyConApp_maybe, splitRepTyConApp_maybe ) import Maybes ( assocMaybe, maybeToBool ) import Unique ( mkBuiltinUnique ) import BasicTypes ( TopLevelFlag(..), RecFlag(..) ) @@ -463,7 +462,7 @@ primRetUnboxedTuple op args res_ty allocate some temporaries for the return values. -} let - (tc,ty_args) = case splitTyConAppThroughNewTypes res_ty of + (tc,ty_args) = case splitRepTyConApp_maybe res_ty of Nothing -> pprPanic "primRetUnboxedTuple" (ppr res_ty) Just pr -> pr prim_reps = map typePrimRep ty_args diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs index dea30bf..06a9a52 100644 --- a/ghc/compiler/codeGen/CgMonad.lhs +++ b/ghc/compiler/codeGen/CgMonad.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgMonad.lhs,v 1.19 1999/05/13 17:30:57 simonm Exp $ +% $Id: CgMonad.lhs,v 1.20 1999/05/18 15:03:49 simonpj Exp $ % \section[CgMonad]{The code generation monad} @@ -29,7 +29,7 @@ module CgMonad ( StackUsage, HeapUsage, - profCtrC, + profCtrC, cgPanic, costCentresC, moduleName, @@ -49,7 +49,7 @@ import {-# SOURCE #-} CgUsages ( getSpRelOffset ) import AbsCSyn import AbsCUtils ( mkAbsCStmts ) import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling ) -import CLabel ( CLabel, mkUpdInfoLabel ) +import CLabel ( CLabel, mkUpdInfoLabel, pprCLabel ) import Module ( Module ) import DataCon ( ConTag ) import Id ( Id ) @@ -177,7 +177,7 @@ sequelToAmode (OnStack virt_sp_offset) sequelToAmode UpdateCode = returnFC (CLbl mkUpdInfoLabel RetRep) sequelToAmode (CaseAlts amode _) = returnFC amode -sequelToAmode (SeqFrame _ _) = panic "sequelToAmode: SeqFrame" +sequelToAmode (SeqFrame _ _) = cgPanic (text "sequelToAmode: SeqFrame") type CgStksAndHeapUsage -- stacks and heap usage information = (StackUsage, HeapUsage) @@ -608,13 +608,17 @@ lookupBindC name info_down@(MkCgInfoDown _ static_binds srt _) case (lookupVarEnv static_binds name) of Just this -> this Nothing - -> pprPanic "lookupBindC:no info!\n" - (vcat [ - hsep [ptext SLIT("for:"), ppr name], - ptext SLIT("(probably: data dependencies broken by an optimisation pass)"), + -> cgPanic (text "lookupBindC: no info for" <+> ppr name) info_down state + +cgPanic :: SDoc -> CgInfoDownwards -> CgState -> a +cgPanic doc info_down@(MkCgInfoDown _ static_binds srt _) + state@(MkCgState absC local_binds usage) + = pprPanic "cgPanic" + (vcat [doc, ptext SLIT("static binds for:"), vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv static_binds ], ptext SLIT("local binds for:"), - vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv local_binds ] + vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv local_binds ], + ptext SLIT("SRT label") <+> pprCLabel srt ]) \end{code} diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index 986bfd2..3b7b5a1 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: ClosureInfo.lhs,v 1.37 1999/05/11 16:44:02 keithw Exp $ +% $Id: ClosureInfo.lhs,v 1.38 1999/05/18 15:03:50 simonpj Exp $ % \section[ClosureInfo]{Data structures which describe closures} @@ -88,7 +88,7 @@ import PprType ( getTyDescription ) import PrimRep ( getPrimRepSize, separateByPtrFollowness, PrimRep ) import SMRep -- all of it import Type ( isUnLiftedType, Type ) -import BasicTypes ( TopLevelFlag(..) ) +import BasicTypes ( TopLevelFlag(..), isNotTopLevel, isTopLevel ) import Util ( mapAccumL ) import Outputable \end{code} @@ -543,7 +543,7 @@ nodeMustPointToIt lf_info = case lf_info of LFReEntrant ty top arity no_fvs _ _ -> returnFC ( not no_fvs || -- Certainly if it has fvs we need to point to it - case top of { TopLevel -> False; _ -> True } + isNotTopLevel top -- If it is not top level we will point to it -- We can have a \r closure with no_fvs which -- is not top level as special case cgRhsClosure @@ -835,7 +835,7 @@ staticClosureRequired -> Bool staticClosureRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _) (LFReEntrant _ top_level _ _ _ _) -- It's a function - = ASSERT( case top_level of { TopLevel -> True; other -> False } ) + = ASSERT( isTopLevel top_level ) -- Assumption: it's a top-level, no-free-var binding arg_occ -- There's an argument occurrence || unsat_occ -- There's an unsaturated call @@ -865,7 +865,7 @@ funInfoTableRequired -> Bool funInfoTableRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _) (LFReEntrant _ top_level _ _ _ _) - = (case top_level of { NotTopLevel -> True; TopLevel -> False }) + = isNotTopLevel top_level || arg_occ -- There's an argument occurrence || unsat_occ -- There's an unsaturated call || isExternallyVisibleName binder diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index c6d94f4..35e18cb 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -24,73 +24,90 @@ import CgMonad import AbsCSyn import CLabel ( CLabel, mkSRTLabel, mkClosureLabel ) -import AbsCUtils ( mkAbstractCs, mkAbsCStmts ) +import PprAbsC ( dumpRealC ) +import AbsCUtils ( mkAbstractCs, mkAbsCStmts, flattenAbsC ) import CgBindery ( CgIdInfo ) import CgClosure ( cgTopRhsClosure ) import CgCon ( cgTopRhsCon ) import CgConTbls ( genStaticConBits ) import ClosureInfo ( mkClosureLFInfo ) import CmdLineOpts ( opt_SccProfilingOn, opt_EnsureSplittableC, - opt_SccGroup + opt_D_dump_absC, opt_SccGroup ) import CostCentre ( CostCentre, CostCentreStack ) import FiniteMap ( FiniteMap ) import Id ( Id, idName ) -import Module ( Module, moduleString ) +import Module ( Module, moduleString, ModuleName, moduleNameString ) import PrimRep ( getPrimRepSize, PrimRep(..) ) import Type ( Type ) -import TyCon ( TyCon ) +import TyCon ( TyCon, isDataTyCon ) +import Class ( Class, classTyCon ) import BasicTypes ( TopLevelFlag(..) ) +import UniqSupply ( mkSplitUniqSupply ) +import ErrUtils ( dumpIfSet ) import Util import Panic ( assertPanic ) \end{code} \begin{code} -codeGen :: Module -- module name - -> ([CostCentre], -- local cost-centres needing declaring/registering + + +codeGen :: Module -- Module name + -> [ModuleName] -- Import names + -> ([CostCentre], -- Local cost-centres needing declaring/registering [CostCentre], -- "extern" cost-centres needing declaring - [CostCentreStack]) -- pre-defined "singleton" cost centre stacks - -> [Module] -- import names - -> [TyCon] -- tycons with data constructors to convert - -> FiniteMap TyCon [(Bool, [Maybe Type])] - -- tycon specialisation info - -> [(StgBinding,[Id])] -- bindings to convert, with SRTs - -> AbstractC -- output - -codeGen mod_name (local_CCs, extern_CCs, singleton_CCSs) - import_names gen_tycons tycon_specs stg_pgm - = let - maybe_split = if opt_EnsureSplittableC - then CSplitMarker - else AbsCNop - cinfo = MkCompInfo mod_name + [CostCentreStack]) -- Pre-defined "singleton" cost centre stacks + -> [TyCon] -> [Class] -- Local tycons and classes + -> [(StgBinding,[Id])] -- Bindings to convert, with SRTs + -> IO AbstractC -- Output + +codeGen mod_name imported_modules cost_centre_info + tycons classes stg_binds + = mkSplitUniqSupply 'f' >>= \ fl_uniqs -> -- absC flattener + let + datatype_stuff = genStaticConBits cinfo data_tycons + code_stuff = initC cinfo (cgTopBindings maybe_split stg_binds) + cost_centre_stuff = mkCostCentreStuff mod_name imported_modules cost_centre_info + + abstractC = mkAbstractCs [ cost_centre_stuff, + datatype_stuff, + code_stuff ] + + flat_abstractC = flattenAbsC fl_uniqs abstractC in - let - module_code = mkAbstractCs [ - genStaticConBits cinfo gen_tycons tycon_specs, - initC cinfo (cgTopBindings maybe_split stg_pgm) ] - - -- Cost-centre profiling: - -- Besides the usual stuff, we must produce: - -- - -- * Declarations for the cost-centres defined in this module; - -- * Code to participate in "registering" all the cost-centres - -- in the program (done at startup time when the pgm is run). - -- - -- (The local cost-centres involved in this are passed - -- into the code-generator, as are the imported-modules' names.) - -- - -- - cost_centre_stuff - | not opt_SccProfilingOn = AbsCNop - | otherwise = mkAbstractCs ( + dumpIfSet opt_D_dump_absC "Abstract C" (dumpRealC abstractC) >> + return flat_abstractC + + where + data_tycons = filter isDataTyCon (tycons ++ map classTyCon classes) + -- Generate info tables for the data constrs arising + -- from class decls as well + + maybe_split = if opt_EnsureSplittableC + then CSplitMarker + else AbsCNop + cinfo = MkCompInfo mod_name +\end{code} + +Cost-centre profiling: +Besides the usual stuff, we must produce: + +* Declarations for the cost-centres defined in this module; +* Code to participate in "registering" all the cost-centres + in the program (done at startup time when the pgm is run). + +(The local cost-centres involved in this are passed +into the code-generator, as are the imported-modules' names.) + +\begin{code} +mkCostCentreStuff mod_name import_names (local_CCs, extern_CCs, singleton_CCSs) + | not opt_SccProfilingOn = AbsCNop + | otherwise = mkAbstractCs ( map (CCostCentreDecl True) local_CCs ++ map (CCostCentreDecl False) extern_CCs ++ map CCostCentreStackDecl singleton_CCSs ++ mkCcRegister local_CCs singleton_CCSs import_names - ) - in - mkAbstractCs [ cost_centre_stuff, module_code ] + ) where mkCcRegister ccs cc_stacks import_names @@ -117,7 +134,7 @@ codeGen mod_name (local_CCs, extern_CCs, singleton_CCSs) mk_import_register import_name = CCallProfCCMacro SLIT("REGISTER_IMPORT") - [CLitLit (_PK_ ("_reg" ++ moduleString import_name)) AddrRep] + [CLitLit (_PK_ ("_reg" ++ moduleNameString import_name)) AddrRep] \end{code} %************************************************************************