Commit ef5b4b14 authored by simonmar's avatar simonmar

[project @ 2004-11-26 16:19:45 by simonmar]

Further integration with the new package story.  GHC now supports
pretty much everything in the package proposal.

  - GHC now works in terms of PackageIds (<pkg>-<version>) rather than
    just package names.  You can still specify package names without
    versions on the command line, as long as the name is unambiguous.

  - GHC understands hidden/exposed modules in a package, and will refuse
    to import a hidden module.  Also, the hidden/eposed status of packages
    is taken into account.

  - I had to remove the old package syntax from ghc-pkg, backwards
    compatibility isn't really practical.

  - All the package.conf.in files have been rewritten in the new syntax,
    and contain a complete list of modules in the package.  I've set all
    the versions to 1.0 for now - please check your package(s) and fix the
    version number & other info appropriately.

  - New options:

	-hide-package P    sets the expose flag on package P to False
	-ignore-package P  unregisters P for this compilation

	For comparison, -package P sets the expose flag on package P
        to True, and also causes P to be linked in eagerly.

        -package-name is no longer officially supported.  Unofficially, it's
	a synonym for -ignore-package, which has more or less the same effect
	as -package-name used to.

	Note that a package may be hidden and yet still be linked into
	the program, by virtue of being a dependency of some other package.
	To completely remove a package from the compiler's internal database,
        use -ignore-package.

	The compiler will complain if any two packages in the
        transitive closure of exposed packages contain the same
        module.

	You *must* use -ignore-package P when compiling modules for
        package P, if package P (or an older version of P) is already
        registered.  The compiler will helpfully complain if you don't.
	The fptools build system does this.

   - Note: the Cabal library won't work yet.  It still thinks GHC uses
     the old package config syntax.

Internal changes/cleanups:

   - The ModuleName type has gone away.  Modules are now just (a
     newtype of) FastStrings, and don't contain any package information.
     All the package-related knowledge is in DynFlags, which is passed
     down to where it is needed.

   - DynFlags manipulation has been cleaned up somewhat: there are no
     global variables holding DynFlags any more, instead the DynFlags
     are passed around properly.

   - There are a few less global variables in GHC.  Lots more are
     scheduled for removal.

   - -i is now a dynamic flag, as are all the package-related flags (but
     using them in {-# OPTIONS #-} is Officially Not Recommended).

   - make -j now appears to work under fptools/libraries/.  Probably
     wouldn't take much to get it working for a whole build.
parent 1f8b341a
......@@ -522,6 +522,7 @@ endif
# from mkDependHS.
SRC_MKDEPENDHS_OPTS += \
-optdep--exclude-module=Compat.RawSystem \
-optdep--exclude-module=Compat.Directory \
-optdep--exclude-module=Data.Version \
-optdep--exclude-module=Distribution.Package \
-optdep--exclude-module=Distribution.InstalledPackageInfo \
......
__interface Module 1 0 where
__export Module ModuleName ;
1 data ModuleName ;
__export Module Module ;
1 data Module ;
module Module where
data ModuleName
data Module
This diff is collapsed.
......@@ -17,16 +17,16 @@ module Name (
mkExternalName, mkWiredInName,
nameUnique, setNameUnique,
nameOccName, nameModule, nameModule_maybe, nameModuleName,
nameOccName, nameModule, nameModule_maybe,
setNameOcc,
hashName, localiseName,
nameSrcLoc, nameParent, nameParent_maybe,
isSystemName, isInternalName, isExternalName,
isTyVarName, isDllName, isWiredInName, isBuiltInSyntax,
isTyVarName, isWiredInName, isBuiltInSyntax,
wiredInNameTyThing_maybe,
nameIsLocalOrFrom, isHomePackageName,
nameIsLocalOrFrom,
-- Class NamedThing and overloaded friends
NamedThing(..),
......@@ -38,8 +38,7 @@ module Name (
import {-# SOURCE #-} TypeRep( TyThing )
import OccName -- All of it
import Module ( Module, ModuleName, moduleName, isHomeModule )
import CmdLineOpts ( opt_Static )
import Module ( Module )
import SrcLoc ( noSrcLoc, wiredInSrcLoc, SrcLoc )
import Unique ( Unique, Uniquable(..), getKey, pprUnique )
import Maybes ( orElse )
......@@ -120,7 +119,6 @@ All built-in syntax is for wired-in things.
nameUnique :: Name -> Unique
nameOccName :: Name -> OccName
nameModule :: Name -> Module
nameModuleName :: Name -> ModuleName
nameSrcLoc :: Name -> SrcLoc
nameUnique name = n_uniq name
......@@ -133,7 +131,6 @@ nameIsLocalOrFrom :: Module -> Name -> Bool
isInternalName :: Name -> Bool
isExternalName :: Name -> Bool
isSystemName :: Name -> Bool
isHomePackageName :: Name -> Bool
isWiredInName :: Name -> Bool
isWiredInName (Name {n_sort = WiredIn _ _ _ _}) = True
......@@ -163,8 +160,6 @@ nameParent name = case nameParent_maybe name of
Nothing -> name
nameModule name = nameModule_maybe name `orElse` pprPanic "nameModule" (ppr name)
nameModuleName name = moduleName (nameModule name)
nameModule_maybe (Name { n_sort = External mod _}) = Just mod
nameModule_maybe (Name { n_sort = WiredIn mod _ _ _}) = Just mod
nameModule_maybe name = Nothing
......@@ -173,13 +168,6 @@ nameIsLocalOrFrom from name
| isExternalName name = from == nameModule name
| otherwise = True
isHomePackageName name
| isExternalName name = isHomeModule (nameModule name)
| otherwise = True -- Internal and system names
isDllName :: Name -> Bool -- Does this name refer to something in a different DLL?
isDllName nm = not opt_Static && not (isHomePackageName nm)
isTyVarName :: Name -> Bool
isTyVarName name = isTvOcc (nameOccName name)
......@@ -326,20 +314,18 @@ pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ})
Internal -> pprInternal sty uniq occ
pprExternal sty uniq mod occ is_wired is_builtin
| codeStyle sty = ppr mod_name <> char '_' <> ppr_occ_name occ
| codeStyle sty = ppr mod <> char '_' <> ppr_occ_name occ
-- In code style, always qualify
-- ToDo: maybe we could print all wired-in things unqualified
-- in code style, to reduce symbol table bloat?
| debugStyle sty = ppr mod_name <> dot <> ppr_occ_name occ
| debugStyle sty = ppr mod <> dot <> ppr_occ_name occ
<> braces (hsep [if is_wired then ptext SLIT("(w)") else empty,
text (briefOccNameFlavour occ),
pprUnique uniq])
| BuiltInSyntax <- is_builtin = ppr_occ_name occ
-- never qualify builtin syntax
| unqualStyle sty mod_name occ = ppr_occ_name occ
| otherwise = ppr mod_name <> dot <> ppr_occ_name occ
where
mod_name = moduleName mod
| unqualStyle sty mod occ = ppr_occ_name occ
| otherwise = ppr mod <> dot <> ppr_occ_name occ
pprInternal sty uniq occ
| codeStyle sty = pprUnique uniq
......
......@@ -47,8 +47,8 @@ import OccName ( NameSpace, varName,
elemOccEnv, plusOccEnv_C, extendOccEnv_C, foldOccEnv,
occEnvElts
)
import Module ( ModuleName, mkModuleNameFS )
import Name ( Name, NamedThing(getName), nameModuleName, nameParent_maybe,
import Module ( Module, mkModuleFS )
import Name ( Name, NamedThing(getName), nameModule, nameParent_maybe,
nameOccName, isExternalName, nameSrcLoc )
import SrcLoc ( isGoodSrcLoc, SrcSpan )
import Outputable
......@@ -67,13 +67,13 @@ data RdrName
= Unqual OccName
-- Used for ordinary, unqualified occurrences
| Qual ModuleName OccName
| Qual Module OccName
-- A qualified name written by the user in
-- *source* code. The module isn't necessarily
-- the module where the thing is defined;
-- just the one from which it is imported
| Orig ModuleName OccName
| Orig Module OccName
-- An original name; the module is the *defining* module.
-- This is used when GHC generates code that will be fed
-- into the renamer (e.g. from deriving clauses), but where
......@@ -97,10 +97,10 @@ data RdrName
%************************************************************************
\begin{code}
rdrNameModule :: RdrName -> ModuleName
rdrNameModule :: RdrName -> Module
rdrNameModule (Qual m _) = m
rdrNameModule (Orig m _) = m
rdrNameModule (Exact n) = nameModuleName n
rdrNameModule (Exact n) = nameModule n
rdrNameModule (Unqual n) = pprPanic "rdrNameModule" (ppr n)
rdrNameOcc :: RdrName -> OccName
......@@ -121,7 +121,7 @@ setRdrNameSpace :: RdrName -> NameSpace -> RdrName
setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ)
setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ)
setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ)
setRdrNameSpace (Exact n) ns = Orig (nameModuleName n)
setRdrNameSpace (Exact n) ns = Orig (nameModule n)
(setOccNameSpace ns (nameOccName n))
\end{code}
......@@ -130,16 +130,16 @@ setRdrNameSpace (Exact n) ns = Orig (nameModuleName n)
mkRdrUnqual :: OccName -> RdrName
mkRdrUnqual occ = Unqual occ
mkRdrQual :: ModuleName -> OccName -> RdrName
mkRdrQual :: Module -> OccName -> RdrName
mkRdrQual mod occ = Qual mod occ
mkOrig :: ModuleName -> OccName -> RdrName
mkOrig :: Module -> OccName -> RdrName
mkOrig mod occ = Orig mod occ
---------------
mkDerivedRdrName :: Name -> (OccName -> OccName) -> (RdrName)
mkDerivedRdrName parent mk_occ
= mkOrig (nameModuleName parent) (mk_occ (nameOccName parent))
= mkOrig (nameModule parent) (mk_occ (nameOccName parent))
---------------
-- These two are used when parsing source files
......@@ -151,7 +151,7 @@ mkVarUnqual :: UserFS -> RdrName
mkVarUnqual n = Unqual (mkOccFS varName n)
mkQual :: NameSpace -> (UserFS, UserFS) -> RdrName
mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccFS sp n)
mkQual sp (m, n) = Qual (mkModuleFS m) (mkOccFS sp n)
getRdrName :: NamedThing thing => thing -> RdrName
getRdrName name = nameRdrName (getName name)
......@@ -164,7 +164,7 @@ nameRdrName name = Exact name
nukeExact :: Name -> RdrName
nukeExact n
| isExternalName n = Orig (nameModuleName n) (nameOccName n)
| isExternalName n = Orig (nameModule n) (nameOccName n)
| otherwise = Unqual (nameOccName n)
\end{code}
......@@ -368,7 +368,7 @@ unQualOK :: GlobalRdrElt -> Bool
unQualOK (GRE {gre_prov = LocalDef _}) = True
unQualOK (GRE {gre_prov = Imported is _}) = not (all is_qual is)
hasQual :: ModuleName -> GlobalRdrElt -> Bool
hasQual :: Module -> GlobalRdrElt -> Bool
-- A qualified version of this thing is in scope
hasQual mod (GRE {gre_prov = LocalDef m}) = m == mod
hasQual mod (GRE {gre_prov = Imported is _}) = any ((== mod) . is_as) is
......@@ -411,7 +411,7 @@ The "provenance" of something says how it came to be in scope.
\begin{code}
data Provenance
= LocalDef -- Defined locally
ModuleName
Module
| Imported -- Imported
[ImportSpec] -- INVARIANT: non-empty
......@@ -429,10 +429,10 @@ data ImportSpec -- Describes a particular import declaration
-- Shared among all the Provenaces for a particular
-- import declaration
= ImportSpec {
is_mod :: ModuleName, -- 'import Muggle'
is_mod :: Module, -- 'import Muggle'
-- Note the Muggle may well not be
-- the defining module for this thing!
is_as :: ModuleName, -- 'as M' (or 'Muggle' if there is no 'as' clause)
is_as :: Module, -- 'as M' (or 'Muggle' if there is no 'as' clause)
is_qual :: Bool, -- True <=> qualified (only)
is_loc :: SrcSpan } -- Location of import statment
......
This diff is collapsed.
......@@ -25,11 +25,11 @@ import CostCentre ( dontCareCCS )
import Cmm
import PprCmm
import CmmUtils ( mkIntCLit, mkLblExpr )
import CmmUtils ( mkIntCLit )
import CmmLex
import CLabel
import MachOp
import SMRep ( tablesNextToCode, fixedHdrSize, CgRep(..) )
import SMRep ( fixedHdrSize, CgRep(..) )
import Lexer
import ForeignCall ( CCallConv(..) )
......@@ -872,7 +872,7 @@ parseCmmFile dflags filename = do
case unP cmmParse init_state of
PFailed span err -> do printError span err; return Nothing
POk _ code -> do
cmm <- initC no_module (getCmm (unEC code initEnv [] >> return ()))
cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ()))
dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms [cmm])
return (Just cmm)
where
......
......@@ -236,7 +236,12 @@ getCgIdInfo id
Nothing ->
-- Should be imported; make up a CgIdInfo for it
if isExternalName name then
let
name = idName id
in
if isExternalName name then do
dflags <- getDynFlags
let ext_lbl = CmmLit (CmmLabel (mkClosureLabel dflags name))
return (stableIdInfo id ext_lbl (mkLFImported id))
else
if isVoidArg (idCgRep id) then
......@@ -246,9 +251,7 @@ getCgIdInfo id
-- Bug
cgLookupPanic id
}}}}
where
name = idName id
ext_lbl = CmmLit (CmmLabel (mkClosureLabel name))
cgLookupPanic :: Id -> FCode a
cgLookupPanic id
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgCase.lhs,v 1.71 2004/09/30 10:35:36 simonpj Exp $
% $Id: CgCase.lhs,v 1.72 2004/11/26 16:19:59 simonmar Exp $
%
%********************************************************
%* *
......@@ -336,9 +336,10 @@ cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts
-- Bind the default binder if necessary
-- (avoiding it avoids the assignment)
-- The deadness info is set by StgVarInfo
; dflags <- getDynFlags
; whenC (not (isDeadBinder bndr))
(do { tmp_reg <- bindNewToTemp bndr
; stmtC (CmmAssign tmp_reg (tagToClosure tycon tag_amode)) })
; stmtC (CmmAssign tmp_reg (tagToClosure dflags tycon tag_amode)) })
-- Compile the alts
; (branches, mb_deflt) <- cgAlgAlts NoGC Nothing{-cc_slot-}
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgClosure.lhs,v 1.64 2004/09/30 10:35:39 simonpj Exp $
% $Id: CgClosure.lhs,v 1.65 2004/11/26 16:20:03 simonmar Exp $
%
\section[CgClosure]{Code generation for closures}
......@@ -40,8 +40,7 @@ import MachOp ( MachHint(..) )
import Cmm
import CmmUtils ( CmmStmts, mkStmts, oneStmt, plusStmts, noStmts,
mkLblExpr )
import CLabel ( mkRtsDataLabel, mkClosureLabel, mkRednCountsLabel,
mkSlowEntryLabel, mkIndStaticInfoLabel )
import CLabel
import StgSyn
import CmdLineOpts ( opt_DoTickyProfiling )
import CostCentre
......@@ -83,7 +82,7 @@ cgTopRhsClosure id ccs binder_info srt upd_flag args body = do
; mod_name <- moduleName
; let descr = closureDescription mod_name name
closure_info = mkClosureInfo True id lf_info 0 0 srt_info descr
closure_label = mkClosureLabel name
closure_label = mkLocalClosureLabel name
cg_id_info = stableIdInfo id (mkLblExpr closure_label) lf_info
closure_rep = mkStaticClosureFields closure_info ccs True []
......@@ -366,7 +365,7 @@ mkSlowEntryCode cl_info reg_args
stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset)
stk_adj_push = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset))
jump_to_entry = CmmJump (mkLblExpr (enterIdLabel name)) []
jump_to_entry = CmmJump (mkLblExpr (enterLocalIdLabel name)) []
\end{code}
......
......@@ -35,7 +35,7 @@ import CgTailCall ( performReturn, emitKnownConReturnCode, returnUnboxedTuple )
import CgProf ( mkCCostCentreStack, ldvEnter, curCCS )
import CgTicky
import CgInfoTbls ( emitClosureCodeAndInfoTable, dataConTagZ )
import CLabel ( mkClosureLabel, mkRtsDataLabel, mkClosureTblLabel )
import CLabel
import ClosureInfo ( mkConLFInfo, mkLFArgument )
import CmmUtils ( mkLblExpr )
import Cmm
......@@ -70,17 +70,20 @@ cgTopRhsCon :: Id -- Name of thing bound to this RHS
-> [StgArg] -- Args
-> FCode (Id, CgIdInfo)
cgTopRhsCon id con args
= ASSERT( not (isDllConApp con args) )
ASSERT( args `lengthIs` dataConRepArity con )
do { -- LAY IT OUT
= do {
; dflags <- getDynFlags
; ASSERT( not (isDllConApp dflags con args) ) return ()
; ASSERT( args `lengthIs` dataConRepArity con ) return ()
-- LAY IT OUT
; amodes <- getArgAmodes args
; let
name = idName id
lf_info = mkConLFInfo con
closure_label = mkClosureLabel name
closure_label = mkClosureLabel dflags name
caffy = any stgArgHasCafRefs args
(closure_info, amodes_w_offsets) = layOutStaticConstr con amodes
(closure_info, amodes_w_offsets) = layOutStaticConstr dflags con amodes
closure_rep = mkStaticClosureFields
closure_info
dontCareCCS -- Because it's static data
......@@ -137,8 +140,9 @@ at all.
\begin{code}
buildDynCon binder cc con []
= returnFC (stableIdInfo binder
(mkLblExpr (mkClosureLabel (dataConName con)))
= do dflags <- getDynFlags
returnFC (stableIdInfo binder
(mkLblExpr (mkClosureLabel dflags (dataConName con)))
(mkConLFInfo con))
\end{code}
......@@ -191,11 +195,15 @@ Now the general case.
\begin{code}
buildDynCon binder ccs con args
= do { hp_off <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
= do {
; dflags <- getDynFlags
; let
(closure_info, amodes_w_offsets) = layOutDynConstr dflags con args
; hp_off <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
; returnFC (heapIdInfo binder hp_off lf_info) }
where
lf_info = mkConLFInfo con
(closure_info, amodes_w_offsets) = layOutDynConstr con args
use_cc -- cost-centre to stick in the object
| currentOrSubsumedCCS ccs = curCCS
......@@ -220,11 +228,13 @@ found a $con$.
\begin{code}
bindConArgs :: DataCon -> [Id] -> Code
bindConArgs con args
= ASSERT(not (isUnboxedTupleCon con))
mapCs bind_arg args_w_offsets
where
bind_arg (arg, offset) = bindNewToNode arg offset (mkLFArgument arg)
(_, args_w_offsets) = layOutDynConstr con (addIdReps args)
= do dflags <- getDynFlags
let
bind_arg (arg, offset) = bindNewToNode arg offset (mkLFArgument arg)
(_, args_w_offsets) = layOutDynConstr dflags con (addIdReps args)
--
ASSERT(not (isUnboxedTupleCon con)) return ()
mapCs bind_arg args_w_offsets
\end{code}
Unboxed tuples are handled slightly differently - the object is
......@@ -385,9 +395,9 @@ cgTyCon tycon
-- to (say) PrelBase_$wTrue_closure, which is defined in code_stuff
; extra <-
if isEnumerationTyCon tycon then do
tbl <- getCmm (emitRODataLits (mkClosureTblLabel
tbl <- getCmm (emitRODataLits (mkLocalClosureTableLabel
(tyConName tycon))
[ CmmLabel (mkClosureLabel (dataConName con))
[ CmmLabel (mkLocalClosureLabel (dataConName con))
| con <- tyConDataCons tycon])
return [tbl]
else
......@@ -404,32 +414,41 @@ static closure, for a constructor.
cgDataCon :: DataCon -> Code
cgDataCon data_con
= do { -- Don't need any dynamic closure code for zero-arity constructors
whenC (not (isNullaryRepDataCon data_con))
dflags <- getDynFlags
; let
-- To allow the debuggers, interpreters, etc to cope with
-- static data structures (ie those built at compile
-- time), we take care that info-table contains the
-- information we need.
(static_cl_info, _) =
layOutStaticConstr dflags data_con arg_reps
(dyn_cl_info, arg_things) =
layOutDynConstr dflags data_con arg_reps
emit_info cl_info ticky_code
= do { code_blks <- getCgStmts the_code
; emitClosureCodeAndInfoTable cl_info [] code_blks }
where
the_code = do { ticky_code
; ldvEnter (CmmReg nodeReg)
; body_code }
arg_reps :: [(CgRep, Type)]
arg_reps = [(typeCgRep ty, ty) | ty <- dataConRepArgTys data_con]
body_code = do {
-- NB: We don't set CC when entering data (WDP 94/06)
tickyReturnOldCon (length arg_things)
; performReturn (emitKnownConReturnCode data_con) }
-- noStmts: Ptr to thing already in Node
; whenC (not (isNullaryRepDataCon data_con))
(emit_info dyn_cl_info tickyEnterDynCon)
-- Dynamic-Closure first, to reduce forward references
; emit_info static_cl_info tickyEnterStaticCon }
where
emit_info cl_info ticky_code
= do { code_blks <- getCgStmts the_code
; emitClosureCodeAndInfoTable cl_info [] code_blks }
where
the_code = do { ticky_code
; ldvEnter (CmmReg nodeReg)
; body_code }
arg_reps :: [(CgRep, Type)]
arg_reps = [(typeCgRep ty, ty) | ty <- dataConRepArgTys data_con]
-- To allow the debuggers, interpreters, etc to cope with static
-- data structures (ie those built at compile time), we take care that
-- info-table contains the information we need.
(static_cl_info, _) = layOutStaticConstr data_con arg_reps
(dyn_cl_info, arg_things) = layOutDynConstr data_con arg_reps
body_code = do { -- NB: We don't set CC when entering data (WDP 94/06)
tickyReturnOldCon (length arg_things)
; performReturn (emitKnownConReturnCode data_con) }
-- noStmts: Ptr to thing already in Node
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgExpr.lhs,v 1.60 2004/09/30 10:35:43 simonpj Exp $
% $Id: CgExpr.lhs,v 1.61 2004/11/26 16:20:07 simonmar Exp $
%
%********************************************************
%* *
......@@ -152,7 +152,8 @@ cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty)
do { (_,amode) <- getArgAmode arg
; amode' <- assignTemp amode -- We're going to use it twice,
-- so save in a temp if non-trivial
; stmtC (CmmAssign nodeReg (tagToClosure tycon amode'))
; dflags <- getDynFlags
; stmtC (CmmAssign nodeReg (tagToClosure dflags tycon amode'))
; performReturn (emitAlgReturnCode tycon amode') }
where
-- If you're reading this code in the attempt to figure
......@@ -184,8 +185,9 @@ cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty)
| ReturnsAlg tycon <- result_info, isEnumerationTyCon tycon
-- c.f. cgExpr (...TagToEnumOp...)
= do tag_reg <- newTemp wordRep
dflags <- getDynFlags
cgPrimOp [tag_reg] primop args emptyVarSet
stmtC (CmmAssign nodeReg (tagToClosure tycon (CmmReg tag_reg)))
stmtC (CmmAssign nodeReg (tagToClosure dflags tycon (CmmReg tag_reg)))
performReturn (emitAlgReturnCode tycon (CmmReg tag_reg))
where
result_info = getPrimOpResultInfo primop
......@@ -280,7 +282,8 @@ cgRhs name (StgRhsCon maybe_cc con args)
; returnFC (name, idinfo) }
cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
= mkRhsClosure name cc bi srt fvs upd_flag args body
= do dflags <- getDynFlags
mkRhsClosure dflags name cc bi srt fvs upd_flag args body
\end{code}
mkRhsClosure looks for two special forms of the right-hand side:
......@@ -303,7 +306,7 @@ form:
\begin{code}
mkRhsClosure bndr cc bi srt
mkRhsClosure dflags bndr cc bi srt
[the_fv] -- Just one free var
upd_flag -- Updatable thunk
[] -- A thunk
......@@ -323,9 +326,10 @@ mkRhsClosure bndr cc bi srt
-- will evaluate to.
cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
where
lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag)
(_, params_w_offsets) = layOutDynConstr con (addIdReps params)
-- Just want the layout
lf_info = mkSelectorLFInfo bndr offset_into_int
(isUpdatable upd_flag)
(_, params_w_offsets) = layOutDynConstr dflags con (addIdReps params)
-- Just want the layout
maybe_offset = assocMaybe params_w_offsets selectee
Just the_offset = maybe_offset
offset_into_int = the_offset - fixedHdrSize
......@@ -348,7 +352,7 @@ We only generate an Ap thunk if all the free variables are pointers,
for semi-obvious reasons.
\begin{code}
mkRhsClosure bndr cc bi srt
mkRhsClosure dflags bndr cc bi srt
fvs
upd_flag
[] -- No args; a thunk
......@@ -373,7 +377,7 @@ mkRhsClosure bndr cc bi srt
The default case
~~~~~~~~~~~~~~~~
\begin{code}
mkRhsClosure bndr cc bi srt fvs upd_flag args body
mkRhsClosure dflags bndr cc bi srt fvs upd_flag args body
= cgRhsClosure bndr cc bi srt fvs upd_flag args body
\end{code}
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgHeapery.lhs,v 1.41 2004/09/30 10:35:45 simonpj Exp $
% $Id: CgHeapery.lhs,v 1.42 2004/11/26 16:20:09 simonmar Exp $
%
\section[CgHeapery]{Heap management functions}
......@@ -54,6 +54,7 @@ import TyCon ( tyConPrimRep )
import CostCentre ( CostCentreStack )
import Util ( mapAccumL, filterOut )
import Constants ( wORD_SIZE )
import CmdLineOpts ( DynFlags )
import Outputable
import GLAEXTS
......@@ -125,7 +126,8 @@ getHpRelOffset virtual_offset
\begin{code}
layOutDynConstr, layOutStaticConstr
:: DataCon
:: DynFlags
-> DataCon
-> [(CgRep,a)]
-> (ClosureInfo,
[(a,VirtualHpOffset)])
......@@ -133,8 +135,8 @@ layOutDynConstr, layOutStaticConstr
layOutDynConstr = layOutConstr False
layOutStaticConstr = layOutConstr True
layOutConstr is_static data_con args
= (mkConInfo is_static data_con tot_wds ptr_wds,
layOutConstr is_static dflags data_con args
= (mkConInfo dflags is_static data_con tot_wds ptr_wds,
things_w_offsets)
where
(tot_wds, -- #ptr_wds + #nonptr_wds
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgMonad.lhs,v 1.41 2004/09/10 14:53:47 simonmar Exp $
% $Id: CgMonad.lhs,v 1.42 2004/11/26 16:20:10 simonmar Exp $
%
\section[CgMonad]{The code generation monad}
......@@ -47,7 +47,7 @@ module CgMonad (
Sequel(..), -- ToDo: unabstract?
-- ideally we wouldn't export these, but some other modules access internal state
getState, setState, getInfoDown,
getState, setState, getInfoDown, getDynFlags,
-- more localised access to monad state
getStkUsage, setStkUsage,
......@@ -61,6 +61,7 @@ module CgMonad (
import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds )
import CmdLineOpts ( DynFlags )
import Cmm
import CmmUtils ( CmmStmts, isNopStmt )
import CLabel
......@@ -75,6 +76,8 @@ import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupp
import FastString
import Outputable
import Control.Monad ( liftM )
infixr 9 `thenC` -- Right-associative!
infixr 9 `thenFC`
\end{code}
......@@ -92,6 +95,7 @@ along.
\begin{code}
data CgInfoDownwards -- information only passed *downwards* by the monad
= MkCgInfoDown {
cgd_dflags :: DynFlags,
cgd_mod :: Module, -- Module being compiled
cgd_statics :: CgBindings, -- [Id -> info] : static environment
cgd_srt :: CLabel, -- label of the current SRT
......@@ -99,9 +103,10 @@ data CgInfoDownwards -- information only passed *downwards* by the monad
cgd_eob :: EndOfBlockInfo -- Info for stuff to do at end of basic block:
}
initCgInfoDown :: Module -> CgInfoDownwards
initCgInfoDown mod
= MkCgInfoDown { cgd_mod = mod,
initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
initCgInfoDown dflags mod
= MkCgInfoDown { cgd_dflags = dflags,
cgd_mod = mod,
cgd_statics = emptyVarEnv,
cgd_srt = error "initC: srt",
cgd_ticky = mkTopTickyCtrLabel,
......@@ -370,11 +375,11 @@ instance Monad FCode where
The Abstract~C is not in the environment so as to improve strictness.
\begin{code}
initC :: Module -> FCode a -> IO a
initC :: DynFlags -> Module -> FCode a -> IO a
initC mod (FCode code)
initC dflags mod (FCode code)
= do { uniqs <- mkSplitUniqSupply 'c'
; case code (initCgInfoDown mod) (initCgState uniqs) of
; case code (initCgInfoDown dflags mod) (initCgState uniqs) of
(res, _) -> return res
}
......@@ -499,6 +504,9 @@ newUnique = do
getInfoDown :: FCode CgInfoDownwards
getInfoDown = FCode $ \info_down state -> (info_down,state)
getDynFlags :: FCode DynFlags
getDynFlags = liftM cgd_dflags getInfoDown
withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
......@@ -646,7 +654,7 @@ forkEvalHelp :: EndOfBlockInfo -- For the body
a) -- Result of the FCode
-- A disturbingly complicated function
forkEvalHelp body_eob_info env_code body_code
= do { info_down@(MkCgInfoDown cg_info statics srt ticky _) <- getInfoDown
= do { info_down <- getInfoDown
; us <- newUniqSupply
; state <- getState
; let { info_down_for_body = info_down {cgd_eob = body_eob_info}
......
......@@ -43,7 +43,7 @@ import MachOp
import CmmUtils ( zeroCLit, mkIntCLit, mkLblExpr )
import CLabel ( mkCCLabel, mkCCSLabel, mkRtsDataLabel )
import Module ( moduleNameUserString )
import Module ( moduleUserString )
import Id ( Id )
import CostCentre
import StgSyn ( GenStgExpr(..), StgExpr )
......@@ -291,7 +291,7 @@ emitCostCentreDecl
-> Code
emitCostCentreDecl cc = do
{ label <- mkStringCLit (costCentreUserName cc)
; modl <- mkStringCLit (moduleNameUserString (cc_mod cc))
; modl <- mkStringCLit (moduleUserString (cc_mod cc))
; let
lits = [ zero, -- StgInt ccID,
label, -- char *label,
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgTailCall.lhs,v 1.40 2004/09/30 10:35:50 simonpj Exp $
% $Id: CgTailCall.lhs,v 1.41 2004/11/26 16:20:12 simonmar Exp $
%
%********************************************************
%* *
......@@ -118,8 +118,9 @@ performTailCall fun_info arg_amodes pending_assts
opt_node_asst | nodeMustPointToIt lf_info = node_asst
| otherwise = noStmts
; EndOfBlockInfo sp _ <- getEndOfBlockInfo
; dflags <- getDynFlags
; case (getCallMethod fun_name lf_info (length arg_amodes)) of
; case (getCallMethod dflags fun_name lf_info (length arg_amodes)) of