+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 ..)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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
# -----------------------------------------------------------------------------
-# $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
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"'
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}
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}
data TopLevelFlag
= TopLevel
| NotTopLevel
+
+isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool
+
+isNotTopLevel NotTopLevel = True
+isNotTopLevel TopLevel = False
+
+isTopLevel TopLevel = True
+isTopLevel NotTopLevel = False
\end{code}
%************************************************************************
\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}
Con(..),
conType, conPrimRep,
conOkForApp, conOkForAlt, isWHNFCon, isDataCon,
- conIsTrivial, conIsCheap,
+ conIsTrivial, conIsCheap, conIsDupable, conStrictness,
+ conOkForSpeculation,
DataCon, PrimOp, -- For completeness
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
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
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}
_interface_ DataCon 1
_exports_
-DataCon DataCon ;
+DataCon DataCon dataConType ;
_declarations_
1 data DataCon ;
+1 dataConType _:_ DataCon -> Type.Type ;;
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
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 )
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
showsPrec p con = showsPrecSDoc p (ppr con)
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Consruction}
+%* *
+%************************************************************************
+
\begin{code}
mkDataCon :: Name
-> [StrictnessMark] -> [FieldLabel]
-- 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)
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}
Demand(..),
wwLazy, wwStrict, wwUnpackData, wwUnpackNew, wwPrim, wwEnum,
- isStrict, isLazy,
+ isStrict, isLazy, isPrim,
pprDemands
) where
isStrict WwEnum = True
isStrict WwPrim = True
isStrict _ = False
+
+isPrim :: Demand -> Bool
+isPrim WwPrim = True
+isPrim other = False
\end{code}
\begin{code}
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,
-- 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,
#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 )
%* *
%************************************************************************
-\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...
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}
%************************************************************************
%* *
%************************************************************************
\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}
getIdArity id = arityInfo (idInfo id)
setIdArity :: Id -> ArityInfo -> Id
-setIdArity id arity = modifyIdInfo id (arity `setArityInfo`)
+setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id
---------------------------------
-- STRICTNESS
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
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
getIdUnfolding id = unfoldingInfo (idInfo id)
setIdUnfolding :: Id -> Unfolding -> Id
-setIdUnfolding id unfolding = modifyIdInfo id (unfolding `setUnfoldingInfo`)
+setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) 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
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
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
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}
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}
module IdInfo (
IdInfo, -- Abstract
- noIdInfo,
+ vanillaIdInfo, mkIdInfo,
+
+ -- Flavour
+ IdFlavour(..), flavourInfo,
+ setNoDiscardInfo, zapSpecPragInfo, copyIdInfo,
+ ppFlavourInfo,
-- Arity
ArityInfo(..),
inlinePragInfo, setInlinePragInfo, notInsideLambda,
-- Specialisation
- IdSpecEnv, specInfo, setSpecInfo,
+ specInfo, setSpecInfo,
-- Update
UpdateInfo, UpdateSpec,
-- 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.
\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@}
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
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).
-- 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@}
%* *
%************************************************************************
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@}
_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 ;;
__interface MkId 1 0 where
-__export MkId mkDataConId ;
+__export MkId mkDataConId mkPrimitiveId ;
1 mkDataConId :: DataCon.DataCon -> Var.Id ;
+1 mkPrimitiveId :: PrimOp.PrimOp -> Var.Id ;
+
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 )
%************************************************************************
%* *
+\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
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
* 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
= 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
\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
[data_id] = mkTemplateLocals [data_ty]
sel_rhs = mkLams tyvars $ Lam data_id $
Note (Coerce rhs_ty data_ty) (Var data_id)
-
\end{code}
%* *
%************************************************************************
-\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.
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
%* *
%************************************************************************
-
\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
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}
-
%************************************************************************
%* *
= 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
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}
+
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}
%* *
%************************************************************************
-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,
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}
+
Name, -- Abstract
mkLocalName, mkImportedLocalName, mkSysLocalName,
mkTopName,
- mkDerivedName, mkGlobalName,
+ mkDerivedName, mkGlobalName, mkKnownKeyGlobal,
mkWiredInIdName, mkWiredInTyConName,
maybeWiredInIdName, maybeWiredInTyConName,
isWiredInName,
tidyTopName,
nameOccName, nameModule, setNameOcc, nameRdrName, setNameModule,
- isExportedName, nameSrcLoc,
+ isUserExportedName, nameSrcLoc,
isLocallyDefinedName,
isSystemName, isLocalName, isGlobalName, isExternallyVisibleName,
-- Class NamedThing and overloaded friends
NamedThing(..),
- isExported,
getSrcLoc, isLocallyDefined, getOccString
) where
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 )
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 }
\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)
nameModule :: Name -> Module
nameSrcLoc :: Name -> SrcLoc
isLocallyDefinedName :: Name -> Bool
-isExportedName :: Name -> Bool
+isUserExportedName :: Name -> Bool
isWiredInName :: Name -> Bool
isLocalName :: Name -> Bool
isGlobalName :: Name -> Bool
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
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
-- 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
\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)
NameSet,
emptyNameSet, unitNameSet, mkNameSet, unionNameSets, unionManyNameSets,
minusNameSet, elemNameSet, nameSetToList, addOneToNameSet, addListToNameSet,
- delFromNameSet, delListFromNameSet, isEmptyNameSet,
+ delFromNameSet, delListFromNameSet, isEmptyNameSet, foldNameSet
) where
#include "HsVersions.h"
isEmptyNameSet :: NameSet -> Bool
delFromNameSet :: NameSet -> Name -> NameSet
delListFromNameSet :: NameSet -> [Name] -> NameSet
+foldNameSet :: (Name -> b -> b) -> b -> NameSet -> b
isEmptyNameSet = isEmptyUniqSet
emptyNameSet = emptyUniqSet
elemNameSet = elementOfUniqSet
nameSetToList = uniqSetToList
delFromNameSet = delOneFromUniqSet
+foldNameSet = foldUniqSet
delListFromNameSet set ns = foldl delFromNameSet set ns
\end{code}
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}
data RdrName = RdrName Qual OccName
data Qual = Unqual
- | Qual Module
+ | Qual ModuleName -- The (encoded) module name
\end{code}
%************************************************************************
\begin{code}
-rdrNameModule :: RdrName -> Module
+rdrNameModule :: RdrName -> ModuleName
rdrNameModule (RdrName (Qual m) _) = m
rdrNameOcc :: RdrName -> OccName
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)
-- 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}
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 }
recSelErrIdKey,
recUpdErrorIdKey,
returnMClassOpKey,
+ runSTRepIdKey,
showClassKey,
ioTyConKey,
ioDataConKey,
{-# 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)
\begin{code}
assertIdKey = mkPreludeMiscIdUnique 121
+runSTRepIdKey = mkPreludeMiscIdUnique 122
\end{code}
\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
-- 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,
}
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
, varType = kind
, varDetails = TyVar
#ifdef DEBUG
- , varInfo = pprPanic "mkTyVar" (ppr name)
+ , varInfo = pprPanic "looking at IdInfo of a tyvar" (ppr name)
#endif
}
idType = varType
idUnique = varUnique
idInfo = varInfo
-idDetails = varDetails
setIdUnique :: Id -> Unique -> Id
setIdUnique = setVarUnique
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
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
%************************************************************************
%* *
+\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}
%* *
%************************************************************************
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,
#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}
-- (==) 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
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}
%
% (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 $
%
%********************************************************
%* *
\begin{code}
module CgCase ( cgCase, saveVolatileVarsAndRegs,
- restoreCurrentCostCentre, freeCostCentreSlot,
- splitTyConAppThroughNewTypes ) where
+ restoreCurrentCostCentre, freeCostCentreSlot
+ ) where
#include "HsVersions.h"
import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
getAmodeRep, nonemptyAbsC
)
-import CoreSyn ( isDeadBinder )
import CgUpdate ( reserveSeqFrame )
import CgBindery ( getVolatileRegs, getArgAmodes, getArgAmode,
bindNewToReg, bindNewToTemp,
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 )
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
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}
(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.
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
= 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}
%
% (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}
import CgMonad
import AbsCSyn
import StgSyn
-import BasicTypes ( TopLevelFlag(..) )
import AbsCUtils ( mkAbstractCs, getAmodeRep )
import CgBindery ( getCAddrMode, getArgAmodes,
import Const ( Con(..), Literal(..), isLitLitLit )
import PrelInfo ( maybeCharLikeCon, maybeIntLikeCon )
import PrimRep ( PrimRep(..) )
-import BasicTypes ( TopLevelFlag(..) )
import Util
import Panic ( assertPanic, trace )
\end{code}
import PrimRep ( getPrimRepSize, PrimRep(..) )
import TyCon ( tyConDataCons, isEnumerationTyCon, TyCon )
import Type ( typePrimRep, Type )
-import BasicTypes ( TopLevelFlag(..) )
import Outputable
\end{code}
\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
%
% (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 $
%
%********************************************************
%* *
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 )
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(..) )
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
%
% (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}
StackUsage, HeapUsage,
- profCtrC,
+ profCtrC, cgPanic,
costCentresC, moduleName,
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 )
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)
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}
%
% (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}
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}
= 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
-> 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
-> 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
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
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}
%************************************************************************
projects / ghc-hetmet.git / commitdiff