endif
@echo "cEnableWin32DLLs = \"$(EnableWin32DLLs)\"" >> $(CONFIG_HS)
@echo "cCONTEXT_DIFF = \"$(CONTEXT_DIFF)\"" >> $(CONFIG_HS)
- @echo "cHaveLibGmp = \"$(HaveLibGmp)\"" >> $(CONFIG_HS)
@echo "cUSER_WAY_NAMES = \"$(USER_WAY_NAMES)\"" >> $(CONFIG_HS)
@echo "cUSER_WAY_OPTS = \"$(USER_WAY_OPTS)\"" >> $(CONFIG_HS)
@echo "cDEFAULT_TMPDIR = \"$(DEFAULT_TMPDIR)\"" >> $(CONFIG_HS)
-- Construction
mkRdrUnqual, mkRdrQual,
- mkUnqual, mkVarUnqual, mkQual, mkOrig, mkIfaceOrig,
+ mkUnqual, mkVarUnqual, mkQual, mkOrig,
nameRdrName, getRdrName,
- qualifyRdrName, unqualifyRdrName,
mkDerivedRdrName,
- dummyRdrVarName, dummyRdrTcName,
-- Destruction
rdrNameModule, rdrNameOcc, setRdrNameSpace,
isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName,
-- Printing; instance Outputable RdrName
- pprUnqualRdrName,
-- LocalRdrEnv
LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv,
-- GlobalRdrElt, Provenance, ImportSpec
GlobalRdrElt(..), Provenance(..), ImportSpec(..),
- isLocalGRE, unQualOK, hasQual,
+ isLocalGRE, unQualOK,
pprNameProvenance
) where
mkOrig :: ModuleName -> OccName -> RdrName
mkOrig mod occ = Orig mod occ
-mkIfaceOrig :: NameSpace -> EncodedFS -> EncodedFS -> RdrName
-mkIfaceOrig ns m n = Orig (mkSysModuleNameFS m) (mkSysOccFS ns n)
-
---------------
mkDerivedRdrName :: Name -> (OccName -> OccName) -> (RdrName)
mkDerivedRdrName parent mk_occ
-- unique is still there for debug printing, particularly
-- of Types (which are converted to IfaceTypes before printing)
-qualifyRdrName :: ModuleName -> RdrName -> RdrName
- -- Sets the module name of a RdrName, even if it has one already
-qualifyRdrName mod rn = Qual mod (rdrNameOcc rn)
-
-unqualifyRdrName :: RdrName -> RdrName
-unqualifyRdrName rdr_name = Unqual (rdrNameOcc rdr_name)
-
nukeExact :: Name -> RdrName
nukeExact n
| isExternalName n = Orig (nameModuleName n) (nameOccName n)
\end{code}
\begin{code}
- -- This guy is used by the reader when HsSyn has a slot for
- -- an implicit name that's going to be filled in by
- -- the renamer. We can't just put "error..." because
- -- we sometimes want to print out stuff after reading but
- -- before renaming
-dummyRdrVarName = Unqual (mkVarOcc FSLIT("V-DUMMY"))
-dummyRdrTcName = Unqual (mkOccFS tcName FSLIT("TC-DUMMY"))
-\end{code}
-
-
-\begin{code}
isRdrDataCon rn = isDataOcc (rdrNameOcc rn)
isRdrTyVar rn = isTvOcc (rdrNameOcc rn)
isRdrTc rn = isTcOcc (rdrNameOcc rn)
| isTvOcc (rdrNameOcc n) = char '@' <+> ppr n
| otherwise = ppr n
-pprUnqualRdrName rdr_name = ppr (rdrNameOcc rdr_name)
-
instance Eq RdrName where
(Exact n1) == (Exact n2) = n1==n2
-- Convert exact to orig
module Unique (
Unique, Uniquable(..), hasKey,
- pprUnique, pprUnique10,
+ pprUnique,
mkUnique, -- Used in UniqSupply
mkUniqueGrimily, -- Used in UniqSupply only!
getKey, getKey#, -- Used in Var, UniqFM, Name only!
- unpkUnique,
incrUnique, -- Used for renumbering
deriveUnique, -- Ditto
newTagUnique, -- Used in CgCase
initTyVarUnique,
- initTidyUniques,
isTupleKey,
mkPreludeTyConUnique, mkPreludeClassUnique,
mkPArrDataConUnique,
- mkBuiltinUnique, builtinUniques,
- mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3
+ mkBuiltinUnique,
+ mkPseudoUnique3
) where
#include "HsVersions.h"
We do sometimes make strings with @Uniques@ in them:
\begin{code}
-pprUnique, pprUnique10 :: Unique -> SDoc
-
+pprUnique :: Unique -> SDoc
pprUnique uniq
= case unpkUnique uniq of
(tag, u) -> finish_ppr tag u (iToBase62 u)
+#ifdef UNUSED
+pprUnique10 :: Unique -> SDoc
pprUnique10 uniq -- in base-10, dudes
= case unpkUnique uniq of
(tag, u) -> finish_ppr tag u (int u)
+#endif
finish_ppr 't' u pp_u | u < 26
= -- Special case to make v common tyvars, t1, t2, ...
initTyVarUnique :: Unique
initTyVarUnique = mkUnique 't' 0
-initTidyUniques :: (Unique, Unique) -- Global and local
-initTidyUniques = (mkUnique 'g' 0, mkUnique 'x' 0)
-
mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
mkBuiltinUnique :: Int -> Unique
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgClosure.lhs,v 1.61 2003/10/30 16:01:52 simonpj Exp $
+% $Id: CgClosure.lhs,v 1.62 2003/11/17 14:23:31 simonmar Exp $
%
\section[CgClosure]{Code generation for closures}
\begin{code}
module CgClosure ( cgTopRhsClosure,
cgStdRhsClosure,
- cgRhsClosure,
- closureCodeBody ) where
+ cgRhsClosure,
+ ) where
#include "HsVersions.h"
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: ClosureInfo.lhs,v 1.60 2003/10/30 16:01:52 simonpj Exp $
+% $Id: ClosureInfo.lhs,v 1.61 2003/11/17 14:23:31 simonmar Exp $
%
\section[ClosureInfo]{Data structures which describe closures}
mkClosureLFInfo, mkConLFInfo, mkSelectorLFInfo,
mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
- UpdateFlag,
closureSize, closureNonHdrSize,
closureGoodStuffSize, closurePtrsSize,
closureLFInfo, closureSMRep, closureUpdReqd,
closureSingleEntry, closureReEntrant, closureSemiTag,
closureFunInfo, isStandardFormThunk,
- GenStgArg,
isToplevClosure,
closureTypeDescr, -- profiling
-- -> IO (CmState, Maybe HValue)
cmGetModInfo, -- :: CmState -> (ModuleGraph, HomePackageTable)
- findModuleLinkable_maybe, -- Exported to InteractiveUI
cmSetDFlags,
cmGetBindings, -- :: CmState -> [TyThing]
cmGetPrintUnqual, -- :: CmState -> PrintUnqualified
-
- sandboxIO -- Should be somewhere else
#endif
)
where
\begin{code}
module CoreUtils (
-- Construction
- mkNote, mkInlineMe, mkSCC, mkCoerce, mkCoerce2,
+ mkInlineMe, mkSCC, mkCoerce, mkCoerce2,
bindNonRec, needsCaseBinding,
mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
-- Taking expressions apart
- findDefault, findAlt, hasDefault,
+ findDefault, findAlt,
-- Properties of expressions
- exprType, coreAltsType,
- exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap,
+ exprType,
+ exprIsDupable, exprIsTrivial, exprIsCheap,
exprIsValue,exprOkForSpeculation, exprIsBig,
exprIsConApp_maybe,
rhsIsStatic,
mkNote removes redundant coercions, and SCCs where possible
\begin{code}
+#ifdef UNUSED
mkNote :: Note -> CoreExpr -> CoreExpr
mkNote (Coerce to_ty from_ty) expr = mkCoerce2 to_ty from_ty expr
mkNote (SCC cc) expr = mkSCC cc expr
mkNote InlineMe expr = mkInlineMe expr
mkNote note expr = Note note expr
+#endif
-- Slide InlineCall in around the function
-- No longer necessary I think (SLPJ Apr 99)
This makes it easy to find, though it makes matching marginally harder.
\begin{code}
-hasDefault :: [CoreAlt] -> Bool
-hasDefault ((DEFAULT,_,_) : alts) = True
-hasDefault _ = False
-
findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
findDefault alts = (alts, Nothing)
%
\begin{code}
-module PprExternalCore where
+module PprExternalCore () where
import Pretty
import ExternalCore
{-# OPTIONS -optc-DNON_POSIX_SOURCE -#include "Linker.h" #-}
-module Linker ( HValue, initDynLinker, showLinkerState,
+module Linker ( HValue, showLinkerState,
linkExpr, unload, extendLinkEnv,
linkPackages,
) where
tcIfaceTyVar, tcIfaceDataCon, tcIfaceLclId,
-- Name-cache stuff
- allocateGlobalBinder, extendOrigNameCache, initNameCache
+ allocateGlobalBinder, initNameCache
) where
#include "HsVersions.h"
\begin{code}
module LoadIface (
- loadHomeInterface, loadInterface, loadSysInterface,
+ loadHomeInterface, loadInterface,
loadSrcInterface, loadOrphanModules,
readIface, -- Used when reading the module's old interface
predInstGates, ifaceInstGates, ifaceStats,
-- Manipulating DynFlags
defaultDynFlags, -- DynFlags
- defaultHscLang, -- HscLang
dopt, -- DynFlag -> DynFlags -> Bool
dopt_set, dopt_unset, -- DynFlags -> DynFlag -> DynFlags
dopt_CoreToDo, -- DynFlags -> [CoreToDo]
restoreDynFlags, -- IO DynFlags
-- sets of warning opts
- standardWarnings,
minusWOpts,
minusWallOpts,
-- Output style options
- opt_PprStyle_NoPrags,
- opt_PprStyle_RawTypes,
opt_PprUserLength,
opt_PprStyle_Debug,
opt_AutoSccsOnAllToplevs,
opt_AutoSccsOnExportedToplevs,
opt_AutoSccsOnIndividualCafs,
- opt_AutoSccsOnDicts,
opt_SccProfilingOn,
opt_DoTickyProfiling,
-- language opts
- opt_AllStrict,
opt_DictsStrict,
opt_MaxContextReductionDepth,
opt_IrrefutableTuples,
- opt_NumbersStrict,
opt_Parallel,
opt_SMP,
opt_RuntimeTypes,
-- optimisation opts
opt_NoMethodSharing,
- opt_DoSemiTagging,
opt_LiberateCaseThreshold,
opt_CprOff,
opt_RulesOff,
opt_UF_FunAppDiscount,
opt_UF_KeenessFactor,
opt_UF_UpdateInPlace,
- opt_UF_CheapOp,
opt_UF_DearOp,
-- misc opts
opt_GranMacros,
opt_HiVersion,
opt_HistorySize,
- opt_NoHiCheck,
opt_OmitBlackHoling,
- opt_NoPruneDecls,
opt_Static,
opt_Unregisterised,
opt_EmitExternalCore
\begin{code}
-- debugging opts
-opt_PprStyle_NoPrags = lookUp FSLIT("-dppr-noprags")
opt_PprStyle_Debug = lookUp FSLIT("-dppr-debug")
-opt_PprStyle_RawTypes = lookUp FSLIT("-dppr-rawtypes")
opt_PprUserLength = lookup_def_int "-dppr-user-length" 5 --ToDo: give this a name
-- profiling opts
opt_AutoSccsOnAllToplevs = lookUp FSLIT("-fauto-sccs-on-all-toplevs")
opt_AutoSccsOnExportedToplevs = lookUp FSLIT("-fauto-sccs-on-exported-toplevs")
opt_AutoSccsOnIndividualCafs = lookUp FSLIT("-fauto-sccs-on-individual-cafs")
-opt_AutoSccsOnDicts = lookUp FSLIT("-fauto-sccs-on-dicts")
opt_SccProfilingOn = lookUp FSLIT("-fscc-profiling")
opt_DoTickyProfiling = lookUp FSLIT("-fticky-ticky")
opt_DictsStrict = lookUp FSLIT("-fdicts-strict")
opt_IrrefutableTuples = lookUp FSLIT("-firrefutable-tuples")
opt_MaxContextReductionDepth = lookup_def_int "-fcontext-stack" mAX_CONTEXT_REDUCTION_DEPTH
-opt_NumbersStrict = lookUp FSLIT("-fnumbers-strict")
opt_Parallel = lookUp FSLIT("-fparallel")
opt_SMP = lookUp FSLIT("-fsmp")
opt_Flatten = lookUp FSLIT("-fflatten")
-- optimisation opts
opt_NoMethodSharing = lookUp FSLIT("-fno-method-sharing")
-opt_DoSemiTagging = lookUp FSLIT("-fsemi-tagging")
opt_CprOff = lookUp FSLIT("-fcpr-off")
opt_RulesOff = lookUp FSLIT("-frules-off")
-- Switch off CPR analysis in the new demand analyser
opt_GranMacros = lookUp FSLIT("-fgransim")
opt_HiVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Int
opt_HistorySize = lookup_def_int "-fhistory-size" 20
-opt_NoHiCheck = lookUp FSLIT("-fno-hi-version-check")
opt_OmitBlackHoling = lookUp FSLIT("-dno-black-holing")
opt_RuntimeTypes = lookUp FSLIT("-fruntime-types")
opt_UF_KeenessFactor = lookup_def_float "-funfolding-keeness-factor" (1.5::Float)
opt_UF_UpdateInPlace = lookUp FSLIT("-funfolding-update-in-place")
-opt_UF_CheapOp = ( 1 :: Int) -- Only one instruction; and the args are charged for
opt_UF_DearOp = ( 4 :: Int)
-opt_NoPruneDecls = lookUp FSLIT("-fno-prune-decls")
opt_Static = lookUp FSLIT("-static")
opt_Unregisterised = lookUp FSLIT("-funregisterised")
opt_EmitExternalCore = lookUp FSLIT("-fext-core")
"fall-strict",
"fdicts-strict",
"firrefutable-tuples",
- "fnumbers-strict",
"fparallel",
"fsmp",
"fflatten",
-----------------------------------------------------------------------------
--- $Id: DriverMkDepend.hs,v 1.30 2003/07/18 13:18:07 simonmar Exp $
+-- $Id: DriverMkDepend.hs,v 1.31 2003/11/17 14:23:38 simonmar Exp $
--
-- GHC Driver
--
--
-----------------------------------------------------------------------------
-module DriverMkDepend where
+module DriverMkDepend (
+ doMkDependHSPhase, beginMkDependHS, endMkDependHS
+ ) where
#include "HsVersions.h"
module Lexer (
Token(..), Token__(..), lexer, mkPState, showPFailed,
P(..), ParseResult(..), setSrcLocFor, getSrcLoc,
- failMsgP, failLocMsgP, srcParseFail,
+ failLocMsgP, srcParseFail,
popContext, pushCurrentContext,
) where
\begin{code}
module PrimOp (
PrimOp(..), allThePrimOps,
- primOpType, primOpSig, primOpArity,
+ primOpType, primOpSig,
primOpTag, maxPrimOpTag, primOpOcc,
- commutableOp,
-
primOpOutOfLine, primOpNeedsWrapper,
primOpOkForSpeculation, primOpIsCheap, primOpIsDupable,
- primOpHasSideEffects,
getPrimOpResultInfo, PrimOpResultInfo(..)
) where
\end{code}
\begin{code}
-primOpArity :: PrimOp -> Arity
-primOpArity op
- = case (primOpInfo op) of
- Monadic occ ty -> 1
- Dyadic occ ty -> 2
- Compare occ ty -> 2
- GenPrimOp occ tyvars arg_tys res_ty -> length arg_tys
-
primOpType :: PrimOp -> Type -- you may want to use primOpSig instead
primOpType op
= case (primOpInfo op) of
\begin{code}
module Inst (
- LIE, emptyLIE, unitLIE, plusLIE, consLIE,
- plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE,
showLIE,
Inst,
mkClass, classTyVars, classArity,
classKey, className, classSelIds, classTyCon,
- classBigSig, classExtraBigSig, classTvsFds, classSCTheta,
- classHasFDs
+ classBigSig, classExtraBigSig, classTvsFds, classSCTheta
) where
#include "HsVersions.h"
classSCTheta = sc_theta, classSCSels = sc_sels,
classOpStuff = op_stuff})
= (tyvars, fundeps, sc_theta, sc_sels, op_stuff)
-
-classHasFDs :: Class -> Bool
-classHasFDs (Class {classFunDeps = fundeps}) = notNull fundeps
\end{code}
module InstEnv (
DFunId, InstEnv,
- emptyInstEnv, extendInstEnv, pprInstEnv,
+ emptyInstEnv, extendInstEnv,
lookupInstEnv,
classInstEnv, simpleDFunClassTyCon, checkFunDeps
) where
ins_tv_set = mkVarSet ins_tvs
ins_item = (ins_tv_set, ins_tys, dfun_id)
+#ifdef UNUSED
pprInstEnv :: InstEnv -> SDoc
pprInstEnv env
= vcat [ brackets (pprWithCommas ppr (varSetElems tyvars)) <+>
| cls_inst_env <- eltsUFM env
, (tyvars, tys, dfun) <- cls_inst_env
]
-
+#endif
simpleDFunClassTyCon :: DFunId -> (Class, TyCon)
simpleDFunClassTyCon dfun
\begin{code}
module FastMutInt(
FastMutInt, newFastMutInt,
- readFastMutInt, writeFastMutInt,
- incFastMutInt, incFastMutIntBy
+ readFastMutInt, writeFastMutInt
) where
#include "MachDeps.h"
writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s ->
case writeIntArray# arr 0# i s of { s ->
(# s, () #) }
-
-incFastMutInt :: FastMutInt -> IO Int -- Returns original value
-incFastMutInt (FastMutInt arr) = IO $ \s ->
- case readIntArray# arr 0# s of { (# s, i #) ->
- case writeIntArray# arr 0# (i +# 1#) s of { s ->
- (# s, I# i #) } }
-
-incFastMutIntBy :: FastMutInt -> Int -> IO Int -- Returns original value
-incFastMutIntBy (FastMutInt arr) (I# n) = IO $ \s ->
- case readIntArray# arr 0# s of { (# s, i #) ->
- case writeIntArray# arr 0# (i +# n) s of { s ->
- (# s, I# i #) } }
\end{code}
#endif
{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
module PrimPacked (
- Ptr(..), nullPtr, writeCharOffPtr, plusAddr#,
- BA(..), MBA(..),
+ Ptr(..), nullPtr, plusAddr#,
+ BA(..),
packString, -- :: String -> (Int, BA)
unpackNBytesBA, -- :: BA -> Int -> [Char]
strLength, -- :: Ptr CChar -> Int
copyPrefixStr, -- :: Addr# -> Int -> BA
- copySubStr, -- :: Addr# -> Int -> Int -> BA
copySubStrBA, -- :: BA -> Int -> Int -> BA
eqStrPrefix, -- :: Addr# -> ByteArray# -> Int# -> Bool
- eqCharStrPrefix, -- :: Addr# -> Addr# -> Int# -> Bool
eqStrPrefixBA, -- :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
- eqCharStrPrefixBA, -- :: Addr# -> ByteArray# -> Int# -> Int# -> Bool
) where
-- This #define suppresses the "import FastString" that
plusAddr# :: Addr# -> Int# -> Addr#
plusAddr# a# i# = int2Addr# (addr2Int# a# +# i#)
#endif
-
--- more compatibility: in 5.00+ we would use the Storable class for this,
--- but 4.08 doesn't have it.
-writeCharOffPtr (Ptr a#) (I# i#) (C# c#) = IO $ \s# ->
- case writeCharOffAddr# a# i# c# s# of { s# -> (# s#, () #) }
\end{code}
Wrapper types for bytearrays
(and positive lengths, thank you).
\begin{code}
+#ifdef UNUSED
copySubStr :: Addr# -> Int -> Int -> BA
copySubStr a# (I# start#) length =
copyPrefixStr (a# `plusAddr#` start#) length
+#endif
copySubStrBA :: BA -> Int -> Int -> BA
copySubStrBA (BA barr#) (I# start#) len@(I# length#) = ba
x <- memcmp_ba a# barr# (I# len#)
return (x == 0)
--- unused???
+#ifdef UNUSED
eqCharStrPrefix :: Addr# -> Addr# -> Int# -> Bool
eqCharStrPrefix a1# a2# len# =
unsafePerformIO $ do
x <- memcmp a1# a2# (I# len#)
return (x == 0)
+#endif
eqStrPrefixBA :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
eqStrPrefixBA b1# b2# start# len# =
x <- memcmp_baoff_ba b2# (I# start#) b1# (I# len#)
return (x == 0)
+#ifdef UNUSED
eqCharStrPrefixBA :: Addr# -> ByteArray# -> Int# -> Int# -> Bool
eqCharStrPrefixBA a# b2# start# len# =
unsafePerformIO $ do
x <- memcmp_baoff b2# (I# start#) a# (I# len#)
return (x == 0)
+#endif
\end{code}
\begin{code}
prevChar, -- :: StringBuffer -> Char -> Char
lookAhead, -- :: StringBuffer -> Int -> Char
atEnd, -- :: StringBuffer -> Bool
- difference, -- :: StringBuffer -> StringBuffer -> Int
-- * Moving
stepOn, stepOnBy,
where
off = c# +# i#
-difference :: StringBuffer -> StringBuffer -> Int
-difference (StringBuffer _ _ c1#) (StringBuffer _ _ c2#) = I# (c2# -# c1#)
-
-- -----------------------------------------------------------------------------
-- Moving
projects / ghc-hetmet.git / commitdiff