import StgSyn ( SRT(..) )
import BitSet ( intBS )
import Outputable
+import GlaExts
import Util ( nOfThem )
import ST
pprMagicId (VanillaReg pk n)
= hcat [ pprVanillaReg n, char '.',
pprUnionTag pk ]
-pprMagicId (FloatReg n) = (<>) (ptext SLIT("F")) (int IBOX(n))
-pprMagicId (DoubleReg n) = (<>) (ptext SLIT("D")) (int IBOX(n))
-pprMagicId (LongReg _ n) = (<>) (ptext SLIT("L")) (int IBOX(n))
+pprMagicId (FloatReg n) = ptext SLIT("F") <> int (I# n)
+pprMagicId (DoubleReg n) = ptext SLIT("D") <> int (I# n)
+pprMagicId (LongReg _ n) = ptext SLIT("L") <> int (I# n)
pprMagicId Sp = ptext SLIT("Sp")
pprMagicId Su = ptext SLIT("Su")
pprMagicId SpLim = ptext SLIT("SpLim")
pprMagicId CurCostCentre = ptext SLIT("CCCS")
pprMagicId VoidReg = panic "pprMagicId:VoidReg!"
-pprVanillaReg :: FastInt -> SDoc
-pprVanillaReg n = (<>) (char 'R') (int IBOX(n))
+pprVanillaReg :: Int# -> SDoc
+pprVanillaReg n = char 'R' <> int (I# n)
pprUnionTag :: PrimRep -> SDoc
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgClosure.lhs,v 1.41 2000/07/14 08:14:53 simonpj Exp $
+% $Id: CgClosure.lhs,v 1.42 2000/10/24 08:40:09 simonpj Exp $
%
\section[CgClosure]{Code generation for closures}
import Name ( nameOccName )
import OccName ( occNameFS )
-
+import FastTypes ( iBox )
+
getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)"
\end{code}
getSpRelOffset 0 `thenFC` \ (SpRel sp) ->
let
- off = I# sp
+ off = iBox sp
rel_arg = mkIntCLit off
in
ASSERT(off /= 0)
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgHeapery.lhs,v 1.23 2000/07/26 14:48:16 simonmar Exp $
+% $Id: CgHeapery.lhs,v 1.24 2000/10/24 08:40:10 simonpj Exp $
%
\section[CgHeapery]{Heap management functions}
tag_assts
free_reg = case length regs + 1 of
- IBOX(x) -> CReg (VanillaReg PtrRep x)
+ I# x -> CReg (VanillaReg PtrRep x)
all_pointers = all pointer regs
pointer (VanillaReg rep _) = isFollowableRep rep
tag_assts
-}
-- this will cover all cases for x86
- [VanillaReg rep ILIT(1)]
+ [VanillaReg rep 1#]
| isFollowableRep rep ->
CCheck HP_CHK_UT_ALT
[mkIntCLit words_required, mkIntCLit 1, mkIntCLit 0,
- CReg (VanillaReg RetRep ILIT(2)),
+ CReg (VanillaReg RetRep 2#),
CLbl (mkReturnInfoLabel ret_addr) RetRep]
tag_assts
| otherwise ->
CCheck HP_CHK_UT_ALT
[mkIntCLit words_required, mkIntCLit 0, mkIntCLit 1,
- CReg (VanillaReg RetRep ILIT(2)),
+ CReg (VanillaReg RetRep 2#),
CLbl (mkReturnInfoLabel ret_addr) RetRep]
tag_assts
in
CCheck HP_CHK_GEN
[mkIntCLit words_required,
- mkIntCLit (IBOX(word2Int# liveness)),
+ mkIntCLit (I# (word2Int# liveness)),
-- HP_CHK_GEN needs a direct return address,
-- not an info table (might be different if
-- we're not assembly-mangling/tail-jumping etc.)
-- We need this case because the closure in Node won't return
-- directly when we enter it (it could be a function), so the
-- heap check code needs to push a seq frame on top of the stack.
- [VanillaReg rep ILIT(1)]
+ [VanillaReg rep 1#]
| rep == PtrRep
&& is_fun ->
CCheck HP_CHK_SEQ_NP
AbsCNop
-- R1 is lifted (the common case)
- [VanillaReg rep ILIT(1)]
+ [VanillaReg rep 1#]
| rep == PtrRep ->
CCheck HP_CHK_NP
[mkIntCLit words_required, mkIntCLit 1{-regs live-}]
CCheck HP_CHK_UNBX_R1 [mkIntCLit words_required] AbsCNop
-- FloatReg1
- [FloatReg ILIT(1)] ->
+ [FloatReg 1#] ->
CCheck HP_CHK_F1 [mkIntCLit words_required] AbsCNop
-- DblReg1
- [DoubleReg ILIT(1)] ->
+ [DoubleReg 1#] ->
CCheck HP_CHK_D1 [mkIntCLit words_required] AbsCNop
-- LngReg1
- [LongReg _ ILIT(1)] ->
+ [LongReg _ 1#] ->
CCheck HP_CHK_L1 [mkIntCLit words_required] AbsCNop
#ifdef DEBUG
where
liveness_mask = mkRegLiveness regs
reschedule_code = absC (CMacroStmt GRAN_RESCHEDULE [
- mkIntCLit (IBOX(word2Int# liveness_mask)),
+ mkIntCLit (I# (word2Int# liveness_mask)),
mkIntCLit (if node_reqd then 1 else 0)])
--HWL: generate GRAN_FETCH macro for GrAnSim
liveness_mask = mkRegLiveness regs
yield_code =
absC (CMacroStmt GRAN_YIELD
- [mkIntCLit (IBOX(word2Int# liveness_mask))])
+ [mkIntCLit (I# (word2Int# liveness_mask))])
\end{code}
\begin{code}
#include "HsVersions.h"
-import CmdLineOpts ( opt_D_dump_simpl, opt_D_verbose_core2core, opt_UsageSPOn )
+import CmdLineOpts ( DynFlags, DynFlag(..), opt_UsageSPOn, dopt )
import CoreSyn
import CoreUnfold ( noUnfolding )
import CoreLint ( beginPass, endPass )
import OccName ( initTidyOccEnv, tidyOccName )
import Type ( tidyTopType, tidyType, tidyTypes, tidyTyVar, tidyTyVars )
import Module ( Module )
-import UniqSupply ( UniqSupply )
+import UniqSupply ( mkSplitUniqSupply )
import Unique ( Uniquable(..) )
import SrcLoc ( noSrcLoc )
import Util ( mapAccumL )
from the uniques for local thunks etc.]
\begin{code}
-tidyCorePgm :: UniqSupply -> Module -> [CoreBind] -> RuleBase
+tidyCorePgm :: DynFlags -> Module -> [CoreBind] -> RuleBase
-> IO ([CoreBind], [ProtoCoreRule])
-tidyCorePgm us module_name binds_in rulebase_in
+tidyCorePgm dflags module_name binds_in rulebase_in
= do
- beginPass "Tidy Core"
+ us <- mkSplitUniqSupply 'u'
+
+ beginPass dflags "Tidy Core"
binds_in1 <- if opt_UsageSPOn
then _scc_ "CoreUsageSPInf"
- doUsageSPInf us binds_in rulebase_in
+ doUsageSPInf dflags us binds_in rulebase_in
else return binds_in
let (tidy_env1, binds_out) = mapAccumL (tidyBind (Just module_name))
init_tidy_env binds_in1
rules_out = tidyProtoRules tidy_env1 (mk_local_protos rulebase_in)
- endPass "Tidy Core" (opt_D_dump_simpl || opt_D_verbose_core2core) binds_out
+ endPass dflags "Tidy Core" (dopt Opt_D_dump_simpl dflags ||
+ dopt Opt_D_verbose_core2core dflags)
+ binds_out
+
return (binds_out, rules_out)
where
-- We also make sure to avoid any exported binders. Consider
import Type ( unUsgTy, repType,
splitTyConApp_maybe, splitFunTys, splitForAllTys,
Type, mkFunTys, mkForAllTys, mkTyConApp,
- mkTyVarTy, mkFunTy, splitAppTy, applyTy, funResultTy
- )
-import PrimOp ( PrimOp(..), CCall(..),
- CCallTarget(..), dynamicTarget )
-import TysWiredIn ( unitTy, addrTy, stablePtrTyCon,
- addrDataCon
+ mkFunTy, splitAppTy, applyTy, funResultTy
)
+import PrimOp ( CCall(..), CCallTarget(..), dynamicTarget )
+import TysWiredIn ( unitTy, addrTy, stablePtrTyCon )
import TysPrim ( addrPrimTy )
-import PrelNames ( Uniquable(..), hasKey,
- ioTyConKey, deRefStablePtrName, returnIOIdKey,
- bindIOName,
- returnIOName, makeStablePtrName
+import PrelNames ( hasKey, ioTyConKey, deRefStablePtrName,
+ bindIOName, returnIOName, makeStablePtrName
)
import Outputable
import UniqSupply ( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply,
UniqSM, UniqSupply )
import Unique ( Unique )
-import UniqFM ( lookupWithDefaultUFM_Directly )
import Util ( zipWithEqual )
import Name ( Name, lookupNameEnv )
import HscTypes ( HomeSymbolTable, PersistentCompilerState(..),
#include "HsVersions.h"
-import CmdLineOpts ( DynFlag(..), DynFlags, dopt )
+import CmdLineOpts ( DynFlag(..), dopt )
import HsSyn
import TcHsSyn ( TypecheckedPat, TypecheckedMatch )
import DsHsSyn ( outPatType )
mkSplitUniqSupply 'd' >>= \ ds_uniqs -> -- desugarer
mkSplitUniqSupply 'r' >>= \ ru_uniqs -> -- rules
mkSplitUniqSupply 'c' >>= \ c2s_uniqs -> -- core-to-stg
- mkSplitUniqSupply 'u' >>= \ tidy_uniqs -> -- tidy up
mkSplitUniqSupply 'g' >>= \ st_uniqs -> -- stg-to-stg passes
mkSplitUniqSupply 'n' >>= \ ncg_uniqs -> -- native-code generator
core2core core_cmds desugared rules >>= \ (simplified, orphan_rules) ->
-- Do the final tidy-up
- tidyCorePgm tidy_uniqs this_mod
+ tidyCorePgm this_mod
simplified orphan_rules >>= \ (tidy_binds, tidy_orphan_rules) ->
-- Run the occurrence analyser one last time, so that
ModDetails(..), ModIface(..), GlobalSymbolTable,
HomeSymbolTable, PackageSymbolTable,
- HomeIfaceTable, PackageIfaceTable,
+ HomeIfaceTable, PackageIfaceTable,
+ lookupTable,
IfaceDecls(..),
TypeEnv, extendTypeEnv, lookupTypeEnv,
- lookupFixityEnv,
-
WhetherHasOrphans, ImportVersion, WhatsImported(..),
PersistentRenamerState(..), IsBootInterface, Avails, DeclsMap,
IfaceInsts, IfaceRules, GatedDecl,
import FiniteMap ( FiniteMap, emptyFM, addToFM, lookupFM, foldFM )
import Bag ( Bag )
+import Maybes ( seqMaybe )
import UniqFM ( UniqFM )
import Outputable
import SrcLoc ( SrcLoc, isGoodSrcLoc )
mi_version :: VersionInfo, -- Module version number
mi_orphan :: WhetherHasOrphans, -- Whether this module has orphans
- mi_usages :: [ImportVersion Name], -- Usages; kept sorted
+ mi_usages :: [ImportVersion Name], -- Usages; kept sorted so that it's easy
+ -- to decide whether to write a new iface file
+ -- (changing usages doesn't affect the version of
+ -- this module)
mi_exports :: Avails, -- What it exports
-- Kept sorted by (mod,occ),
Simple lookups in the symbol table.
\begin{code}
-lookupFixityEnv :: IfaceTable -> Name -> Maybe Fixity
-lookupFixityEnv tbl name
- = case lookupModuleEnv tbl (nameModule name) of
- Nothing -> Nothing
- Just details -> lookupNameEnv (mi_fixities details) name
+lookupTable :: ModuleEnv a -> ModuleEnv a -> Name -> Maybe a
+-- We often have two Symbol- or IfaceTables, and want to do a lookup
+lookupTable ht pt name
+ = lookupModuleEnv ht mod `seqMaybe` lookupModuleEnv pt mod
+ where
+ mod = nameModule name
\end{code}
{-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.42 2000/10/24 07:35:01 simonpj Exp $
+$Id: Parser.y,v 1.43 2000/10/24 08:40:10 simonpj Exp $
Haskell grammar.
| srcloc 'data' ctype '=' constrs deriving
{% checkDataHeader $3 `thenP` \(cs,c,ts) ->
returnP (RdrHsDecl (TyClD
- (mkTyData DataType cs c ts (reverse $5) (length $5) $6
- NoDataPragmas $1))) }
+ (mkTyData DataType cs c ts (reverse $5) (length $5) $6 $1))) }
| srcloc 'newtype' ctype '=' newconstr deriving
{% checkDataHeader $3 `thenP` \(cs,c,ts) ->
returnP (RdrHsDecl (TyClD
- (mkTyData NewType cs c ts [$5] 1 $6
- NoDataPragmas $1))) }
+ (mkTyData NewType cs c ts [$5] 1 $6 $1))) }
| srcloc 'class' ctype fds where
{% checkDataHeader $3 `thenP` \(cs,c,ts) ->
(binds,sigs) = cvMonoBindsAndSigs cvClassOpSig (groupBindings $5)
in
returnP (RdrHsDecl (TyClD
- (mkClassDecl cs c ts $4 sigs binds
- NoClassPragmas $1))) }
+ (mkClassDecl cs c ts $4 sigs binds $1))) }
| srcloc 'instance' inst_type where
{ let (binds,sigs)
qdata_name : data_name { $1 }
| qdata_fs { mkSysQual dataName $1 }
-qdata_names :: { [RdrName] }
-qdata_names : { [] }
- | qdata_name qdata_names { $1 : $2 }
-
var_or_data_name :: { RdrName }
: var_name { $1 }
| data_name { $1 }
--------------------------------------------------------------------------
id_info :: { [HsIdInfo RdrName] }
- : { [] }
+ : id_info_item { [$1] }
| id_info_item id_info { $1 : $2 }
id_info_item :: { HsIdInfo RdrName }
-> HomeIfaceTable -> HomeSymbolTable
-> PersistentCompilerState
-> Module -> RdrNameHsModule
- -> IO (PersistentCompilerState, Maybe ModIface)
- -- The mi_decls in the ModIface include
- -- ones imported from packages too
+ -> IO (PersistentCompilerState, Maybe (ModIface, [RenamedHsDecl]))
renameModule dflags finder hit hst old_pcs this_module
this_mod@(HsModule _ _ _ _ _ _ loc)
case maybe_stuff of {
Nothing -> -- Everything is up to date; no need to recompile further
rnDump [] [] `thenRn` \ dump_action ->
- returnRn (Nothing, [], dump_action) ;
+ returnRn (Nothing, dump_action) ;
Just (gbl_env, local_gbl_env, export_avails, global_avail_env) ->
tryLoadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d (Ifaces, Maybe Message)
-- Returns (Just err) if an error happened
- -- Guarantees to return with iImpModInfo m --> (... Just cts)
- -- (If the load fails, we plug in a vanilla placeholder
+ -- Guarantees to return with iImpModInfo m --> (..., True)
+ -- (If the load fails, we plug in a vanilla placeholder)
tryLoadInterface doc_str mod_name from
- = getIfacesRn `thenRn` \ ifaces ->
+ = getHomeIfaceTableRn `thenRn` \ hit ->
+ getIfacesRn `thenRn` \ ifaces ->
+
+ -- Check whether we have it already in the home package
+ case lookupModuleEnvByName hit mod_name of {
+ Just _ -> returnRn (ifaces, Nothing) ; -- In the home package
+ Nothing ->
+
let
mod_map = iImpModInfo ifaces
mod_info = lookupFM mod_map mod_name
in
setIfacesRn new_ifaces `thenRn_`
returnRn (new_ifaces, Nothing)
- }}
+ }}}
-----------------------------------------------------
-- Adding module dependencies from the
-- right away (after all, it's possible that nothing from B will be used).
-- When we come across a use of 'f', we need to know its fixity, and it's then,
-- and only then, that we load B.hi. That is what's happening here.
- = getHomeIfaceTableRn `thenRn` \ hst ->
- case lookupFixityEnv hst name of {
- Just fixity -> returnRn fixity ;
- Nothing ->
-
+ = getHomeIfaceTableRn `thenRn` \ hit ->
loadHomeInterface doc name `thenRn` \ ifaces ->
- returnRn (lookupFixityEnv (iPIT ifaces) name `orElse` defaultFixity)
- }
+ case lookupTable hit (iPIT ifaces) name of
+ Just iface -> returnRn (lookupNameEnv (mi_fixities iface) name `orElse` defaultFixity)
+ Nothing -> returnRn defaultFixity
where
doc = ptext SLIT("Checking fixity for") <+> ppr name
\end{code}
)
import UniqSupply -- all of it, really
import BasicTypes ( TopLevelFlag(..), isNotTopLevel )
-import CmdLineOpts ( opt_D_verbose_stg2stg )
import UniqSet ( emptyUniqSet )
import Maybes
import Outputable
\begin{code}
bOGUS_LVs :: StgLiveVars
-bOGUS_LVs | opt_D_verbose_stg2stg = emptyUniqSet
- | otherwise =panic "bOGUS_LVs"
+bOGUS_LVs = emptyUniqSet
bOGUS_FVs :: [Id]
-bOGUS_FVs | opt_D_verbose_stg2stg = []
- | otherwise = panic "bOGUS_FVs"
+bOGUS_FVs = []
\end{code}
\begin{code}
renameSourceCode, thenRn, mapRn, returnRn )
import HscTypes ( DFunId, GlobalSymbolTable, PersistentRenamerState )
+import BasicTypes ( Fixity )
import Bag ( Bag, emptyBag, unionBags, listToBag )
import Class ( classKey, Class )
import ErrUtils ( dumpIfSet_dyn, Message )
import Module ( Module )
import Name ( Name, isLocallyDefined, getSrcLoc, NamedThing(..) )
import RdrName ( RdrName )
---import RnMonad ( FixityEnv )
import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings,
tyConTheta, maybeTyConSingleCon, isDataTyCon,
iBinds = binds,
iLoc = getSrcLoc dfun, iPrags = [] }
where
- (tyvars, theta, tau, clas, tys) = splitDFunTy (idType dfun)
+ (tyvars, theta, clas, tys) = splitDFunTy (idType dfun)
rn_meths meths = rnMethodBinds [] meths `thenRn` \ (meths', _) -> returnRn meths'
-- Ignore the free vars returned
UfInlineCall -> returnTc (Note InlineCall expr')
UfInlineMe -> returnTc (Note InlineMe expr')
UfSCC cc -> returnTc (Note (SCC cc) expr')
-
-tcCoreNote (UfSCC cc) = returnTc (SCC cc)
-tcCoreNote UfInlineCall = returnTc InlineCall
\end{code}
\begin{code}
import CmdLineOpts ( DynFlag(..), dopt )
-import HsSyn ( HsDecl(..), InstDecl(..), TyClDecl(..),
- MonoBinds(..), HsExpr(..), HsLit(..), Sig(..),
+import HsSyn ( HsDecl(..), InstDecl(..), TyClDecl(..), InPat(..),
+ MonoBinds(..), HsExpr(..), HsLit(..), Sig(..), Match(..),
andMonoBindList, collectMonoBinders, isClassDecl
)
import HsTypes ( HsType (..), HsTyVarBndr(..), toHsTyVar )
-import HsPat ( InPat (..) )
-import HsMatches ( Match (..) )
-import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl,
- extractHsTyVars )
+import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl, RenamedMonoBinds,
+ RenamedTyClDecl, RenamedHsType,
+ extractHsTyVars, maybeGenericMatch
+ )
import TcHsSyn ( TcMonoBinds, mkHsConApp )
import TcBinds ( tcSpecSigs )
import TcClassDcl ( tcMethodBind, badMethodErr )
plusNameEnv_C, nameEnvElts )
import FiniteMap ( mapFM )
import SrcLoc ( SrcLoc )
-import RnHsSyn -- ( RenamedMonoBinds )
import VarSet ( varSetElems )
import UniqFM ( mapUFM )
import Unique ( Uniquable(..) )
-import BasicTypes ( NewOrData(..) )
+import BasicTypes ( NewOrData(..), Fixity )
import ErrUtils ( dumpIfSet_dyn )
import ListSetOps ( Assoc, emptyAssoc, plusAssoc_C, mapAssoc,
assocElts, extendAssoc_C,
import ErrUtils ( printErrorsAndWarnings, dumpIfSet_dyn )
import Id ( idType, idName, idUnfolding )
import Module ( Module, moduleName, plusModuleEnv )
-import Name ( nameOccName, isLocallyDefined, isGlobalName,
- toRdrName, nameEnvElts, emptyNameEnv
+import Name ( Name, nameOccName, isLocallyDefined, isGlobalName,
+ toRdrName, nameEnvElts, emptyNameEnv, lookupNameEnv
)
import TyCon ( TyCon, isDataTyCon, tyConName, tyConGenInfo )
import OccName ( isSysOcc )
import Class ( Class )
import PrelNames ( mAIN_Name, mainName )
import UniqSupply ( UniqSupply )
-import Maybes ( maybeToBool )
+import Maybes ( maybeToBool, thenMaybe )
import Util
-import BasicTypes ( EP(..) )
+import BasicTypes ( EP(..), Fixity )
import Bag ( Bag, isEmptyBag )
import Outputable
-import HscTypes ( PersistentCompilerState(..), HomeSymbolTable,
- PackageSymbolTable, DFunId,
- TypeEnv, extendTypeEnv,
+import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, HomeIfaceTable,
+ PackageSymbolTable, PackageIfaceTable, DFunId, ModIface(..),
+ TypeEnv, extendTypeEnv, lookupTable,
TyThing(..), groupTyThings )
import FiniteMap ( FiniteMap, delFromFM, lookupWithDefaultFM )
\end{code}
-> tcModule pcs hst get_fixity this_mod decls unf_env)
get_fixity :: Name -> Maybe Fixity
- get_fixity nm
- = case lookupFixityEnv hit nm of
- Just f -> Just f
- Nothing -> lookupFixityEnv pit nm
+ get_fixity nm = lookupTable hit pit nm `thenMaybe` \ iface ->
+ lookupNameEnv (mi_fixities iface) nm
\end{code}
The internal monster:
)
import TcEnv ( tcExtendTyVarEnv,
tcLookupTyCon, tcLookupClass, tcLookupGlobalId,
- TyThing(..), TyThingDetails(..)
+ TyThingDetails(..)
)
import TcMonad
expectJust,
maybeToBool,
- failMaB,
- failMaybe,
- seqMaybe,
- returnMaB,
- returnMaybe,
- thenMaB,
- catMaybes
+ thenMaybe, seqMaybe, returnMaybe, failMaybe, catMaybes,
+
+ thenMaB, returnMaB, failMaB
+
) where
#include "HsVersions.h"
seqMaybe (Just x) _ = Just x
seqMaybe Nothing my = my
+thenMaybe :: Maybe a -> (a -> Maybe b) -> Maybe b
+thenMaybe ma mb = case ma of
+ Just x -> mb x
+ Nothing -> Nothing
+
returnMaybe :: a -> Maybe a
returnMaybe = Just
projects / ghc-hetmet.git / commitdiff