Commit 0171936c authored by simonmar's avatar simonmar

[project @ 2002-03-04 17:01:26 by simonmar]

Binary Interface Files - stage 1
--------------------------------

This commit changes the default interface file format from text to
binary, in order to improve compilation performace.

To view an interface file, use 'ghc --show-iface Foo.hi'.

utils/Binary.hs is the basic Binary I/O library, based on the nhc98
binary I/O library but much stripped-down and working in terms of
bytes rather than bits, and with some special features for GHC: it
remembers which Module is being emitted to avoid dumping too many
qualified names, and it keeps track of a "dictionary" of FastStrings
so that we don't dump the same FastString more than once into the
binary file.  I'll make a generic version of this for the libraries at
some point.

main/BinIface.hs contains most of the Binary instances.  Some
instances are in the same module as the data type (RdrName, Name,
OccName in particular).  Most instances were generated using a
modified version of DrIFT, which I'll commit later.  However, editing
them by hand isn't hard (certainly easier than modifying
ParseIface.y).

The first thing in a binary interface is the interface version, so
nice error messages will be generated if the binary format changes and
you still have old interfaces lying around.  The version also now
includes the "way" as an extra sanity check.

Other changes
-------------

I don't like the way FastStrings contain both hashed strings (with
O(1) comparison) and literal C strings (with O(n) comparison).  So as
a first step to separating these I made serveral "literal" type
strings into hashed strings.  SLIT() still generates a literal, and
now FSLIT() generates a hashed string.  With DEBUG on, you'll get a
warning if you try to compare any SLIT()s with anything, and the
compiler will fall over if you try to dump any literal C strings into
an interface file (usually indicating a use of SLIT() which should be
FSLIT()).

mkSysLocal no longer re-encodes its FastString argument each time it
is called.

I also fixed the -pgm options so that the argument can now optionally
be separted from the option.

Bugfix: PrelNames declared Names for several comparison primops, eg.
eqCharName, eqIntName etc. but these had different uniques from the
real primop names.  I've moved these to PrimOps and defined them using
mkPrimOpIdName instead, and deleted some for which we don't have real
primops (Manuel: please check that things still work for you after
this change).
parent 6561aa4e
......@@ -49,6 +49,7 @@ import qualified FastString
# define USE_FAST_STRINGS 1
# define FAST_STRING FastString.FastString
# define SLIT(x) (FastString.mkFastCharString# (x#))
# define FSLIT(x) (FastString.mkFastString# (x#))
# define _NULL_ FastString.nullFastString
# define _NIL_ (FastString.mkFastString "")
# define _CONS_ FastString.consFS
......
# -----------------------------------------------------------------------------
# $Id: Makefile,v 1.212 2002/02/14 08:23:25 sof Exp $
# $Id: Makefile,v 1.213 2002/03/04 17:01:27 simonmar Exp $
TOP = ..
......@@ -362,6 +362,14 @@ else
INSTALL_PROGS += $(HS_PROG)
endif
# ----------------------------------------------------------------------------
# profiling.
rename/Rename_HC_OPTS += -auto-all
rename/RnEnv_HC_OPTS += -auto-all
rename/RnHiFiles_HC_OPTS += -auto-all
rename/RnSource_HC_OPTS += -auto-all
#-----------------------------------------------------------------------------
# clean
......
......@@ -104,7 +104,7 @@ import Name ( Name, OccName,
mkSysLocalName, mkLocalName,
getOccName, getSrcLoc
)
import OccName ( UserFS, mkWorkerOcc )
import OccName ( EncodedFS, UserFS, mkWorkerOcc )
import PrimRep ( PrimRep )
import TysPrim ( statePrimTyCon )
import FieldLabel ( FieldLabel )
......@@ -160,9 +160,11 @@ mkLocalId name ty = mkLocalIdWithInfo 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...
mkUserLocal :: OccName -> Unique -> Type -> SrcLoc -> Id
mkSysLocal :: UserFS -> Unique -> Type -> Id
mkSysLocal :: EncodedFS -> Unique -> Type -> Id
mkVanillaGlobal :: Name -> Type -> IdInfo -> Id
-- for SysLocal, we assume the base name is already encoded, to avoid
-- re-encoding the same string over and over again.
mkSysLocal fs uniq ty = mkLocalId (mkSysLocalName uniq fs) ty
mkUserLocal occ uniq ty loc = mkLocalId (mkLocalName uniq occ loc) ty
mkVanillaGlobal = mkGlobalId VanillaGlobal
......@@ -175,7 +177,7 @@ instantiated before use.
\begin{code}
-- "Wild Id" typically used when you need a binder that you don't expect to use
mkWildId :: Type -> Id
mkWildId ty = mkSysLocal SLIT("wild") (mkBuiltinUnique 1) ty
mkWildId ty = mkSysLocal FSLIT("wild") (mkBuiltinUnique 1) ty
mkWorkerId :: Unique -> Id -> Type -> Id
-- A worker gets a local name. CoreTidy will globalise it if necessary.
......@@ -193,7 +195,7 @@ mkTemplateLocalsNum :: Int -> [Type] -> [Id]
mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys
mkTemplateLocal :: Int -> Type -> Id
mkTemplateLocal i ty = mkSysLocal SLIT("tpl") (mkBuiltinUnique i) ty
mkTemplateLocal i ty = mkSysLocal FSLIT("tpl") (mkBuiltinUnique i) ty
\end{code}
......
......@@ -36,6 +36,7 @@ import CStrings ( pprFSInCStyle )
import Outputable
import FastTypes
import Binary
import Util ( thenCmp )
import Ratio ( numerator )
......@@ -122,6 +123,60 @@ data Literal
| MachLitLit FAST_STRING Type -- Type might be Addr# or Int# etc
\end{code}
Binary instance: must do this manually, because we don't want the type
arg of MachLitLit involved.
\begin{code}
instance Binary Literal where
put_ bh (MachChar aa) = do putByte bh 0; put_ bh aa
put_ bh (MachStr ab) = do putByte bh 1; put_ bh ab
put_ bh (MachAddr ac) = do putByte bh 2; put_ bh ac
put_ bh (MachInt ad) = do putByte bh 3; put_ bh ad
put_ bh (MachInt64 ae) = do putByte bh 4; put_ bh ae
put_ bh (MachWord af) = do putByte bh 5; put_ bh af
put_ bh (MachWord64 ag) = do putByte bh 6; put_ bh ag
put_ bh (MachFloat ah) = do putByte bh 7; put_ bh ah
put_ bh (MachDouble ai) = do putByte bh 8; put_ bh ai
put_ bh (MachLabel aj) = do putByte bh 9; put_ bh aj
put_ bh (MachLitLit ak _) = do putByte bh 10; put_ bh ak
get bh = do
h <- getByte bh
case h of
0 -> do
aa <- get bh
return (MachChar aa)
1 -> do
ab <- get bh
return (MachStr ab)
2 -> do
ac <- get bh
return (MachAddr ac)
3 -> do
ad <- get bh
return (MachInt ad)
4 -> do
ae <- get bh
return (MachInt64 ae)
5 -> do
af <- get bh
return (MachWord af)
6 -> do
ag <- get bh
return (MachWord64 ag)
7 -> do
ah <- get bh
return (MachFloat ah)
8 -> do
ai <- get bh
return (MachDouble ai)
9 -> do
aj <- get bh
return (MachLabel aj)
10 -> do
ak <- get bh
return (MachLitLit ak (error "MachLitLit: no type"))
\end{code}
\begin{code}
instance Outputable Literal where
ppr lit = pprLit lit
......
......@@ -547,7 +547,7 @@ rebuildConArgs (arg:args) (str:stricts) us
(_, tycon_args, pack_con, con_arg_tys)
= splitProductType "rebuildConArgs" arg_ty
unpacked_args = zipWith (mkSysLocal SLIT("rb")) us con_arg_tys
unpacked_args = zipWith (mkSysLocal FSLIT("rb")) us con_arg_tys
(binds, args') = rebuildConArgs args stricts (dropList con_arg_tys us)
con_app = mkConApp pack_con (map Type tycon_args ++ map Var unpacked_args)
in
......@@ -787,7 +787,7 @@ another gun with which to shoot yourself in the foot.
\begin{code}
-- unsafeCoerce# :: forall a b. a -> b
unsafeCoerceId
= pcMiscPrelId unsafeCoerceIdKey pREL_GHC SLIT("unsafeCoerce#") ty info
= pcMiscPrelId unsafeCoerceIdKey pREL_GHC FSLIT("unsafeCoerce#") ty info
where
info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
......@@ -802,13 +802,13 @@ unsafeCoerceId
-- The reason is is here is because we don't provide
-- a way to write this literal in Haskell.
nullAddrId
= pcMiscPrelId nullAddrIdKey pREL_GHC SLIT("nullAddr#") addrPrimTy info
= pcMiscPrelId nullAddrIdKey pREL_GHC FSLIT("nullAddr#") addrPrimTy info
where
info = noCafNoTyGenIdInfo `setUnfoldingInfo`
mkCompulsoryUnfolding (Lit nullAddrLit)
seqId
= pcMiscPrelId seqIdKey pREL_GHC SLIT("seq") ty info
= pcMiscPrelId seqIdKey pREL_GHC FSLIT("seq") ty info
where
info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
......@@ -824,7 +824,7 @@ evaluate its argument and call the dataToTag# primitive.
\begin{code}
getTagId
= pcMiscPrelId getTagIdKey pREL_GHC SLIT("getTag#") ty info
= pcMiscPrelId getTagIdKey pREL_GHC FSLIT("getTag#") ty info
where
info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
-- We don't provide a defn for this; you must inline it
......@@ -849,7 +849,7 @@ This comes up in strictness analysis
\begin{code}
realWorldPrimId -- :: State# RealWorld
= pcMiscPrelId realWorldPrimIdKey pREL_GHC SLIT("realWorld#")
= pcMiscPrelId realWorldPrimIdKey pREL_GHC FSLIT("realWorld#")
realWorldStatePrimTy
(noCafNoTyGenIdInfo `setUnfoldingInfo` mkOtherCon [])
-- The mkOtherCon makes it look that realWorld# is evaluated
......@@ -858,7 +858,7 @@ realWorldPrimId -- :: State# RealWorld
-- to be inlined
voidArgId -- :: State# RealWorld
= mkSysLocal SLIT("void") voidArgIdKey realWorldStatePrimTy
= mkSysLocal FSLIT("void") voidArgIdKey realWorldStatePrimTy
\end{code}
......@@ -885,31 +885,31 @@ 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
= pc_bottoming_Id errorIdKey pREL_ERR FSLIT("error") errorTy
eRROR_CSTRING_ID
= pc_bottoming_Id errorCStringIdKey pREL_ERR SLIT("errorCString")
= pc_bottoming_Id errorCStringIdKey pREL_ERR FSLIT("errorCString")
(mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy))
pAT_ERROR_ID
= generic_ERROR_ID patErrorIdKey SLIT("patError")
= generic_ERROR_ID patErrorIdKey FSLIT("patError")
rEC_SEL_ERROR_ID
= generic_ERROR_ID recSelErrIdKey SLIT("recSelError")
= generic_ERROR_ID recSelErrIdKey FSLIT("recSelError")
rEC_CON_ERROR_ID
= generic_ERROR_ID recConErrorIdKey SLIT("recConError")
= generic_ERROR_ID recConErrorIdKey FSLIT("recConError")
rEC_UPD_ERROR_ID
= generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError")
= generic_ERROR_ID recUpdErrorIdKey FSLIT("recUpdError")
iRREFUT_PAT_ERROR_ID
= generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError")
= generic_ERROR_ID irrefutPatErrorIdKey FSLIT("irrefutPatError")
nON_EXHAUSTIVE_GUARDS_ERROR_ID
= generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError")
= generic_ERROR_ID nonExhaustiveGuardsErrorIdKey FSLIT("nonExhaustiveGuardsError")
nO_METHOD_BINDING_ERROR_ID
= generic_ERROR_ID noMethodBindingErrorIdKey SLIT("noMethodBindingError")
= generic_ERROR_ID noMethodBindingErrorIdKey FSLIT("noMethodBindingError")
aBSENT_ERROR_ID
= pc_bottoming_Id absentErrorIdKey pREL_ERR SLIT("absentErr")
= pc_bottoming_Id absentErrorIdKey pREL_ERR FSLIT("absentErr")
(mkSigmaTy [openAlphaTyVar] [] openAlphaTy)
pAR_ERROR_ID
= pcMiscPrelId parErrorIdKey pREL_ERR SLIT("parError")
= pcMiscPrelId parErrorIdKey pREL_ERR FSLIT("parError")
(mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noCafNoTyGenIdInfo
\end{code}
......
__interface Module 1 0 where
__export Module Module ;
1 data Module ;
__interface Module 1 0 where
__export Module Module ;
1 data Module ;
......@@ -92,6 +92,7 @@ import FastString ( FastString )
import Unique ( Uniquable(..) )
import UniqFM
import UniqSet
import Binary
\end{code}
......@@ -117,6 +118,10 @@ renamer href here.)
\begin{code}
data Module = Module ModuleName !PackageInfo
instance Binary Module where
put_ bh (Module m p) = put_ bh m
get bh = do m <- get bh; return (Module m DunnoYet)
data PackageInfo
= ThisPackage -- A module from the same package
-- as the one being compiled
......@@ -131,12 +136,12 @@ data PackageInfo
type PackageName = FastString -- No encoding at all
preludePackage :: PackageName
preludePackage = SLIT("std")
preludePackage = FSLIT("std")
packageInfoPackage :: PackageInfo -> PackageName
packageInfoPackage ThisPackage = opt_InPackage
packageInfoPackage DunnoYet = SLIT("<?>")
packageInfoPackage AnotherPackage = SLIT("<pkg>")
packageInfoPackage DunnoYet = FSLIT("<?>")
packageInfoPackage AnotherPackage = FSLIT("<pkg>")
instance Outputable PackageInfo where
-- Just used in debug prints of lex tokens and in debug modde
......@@ -180,6 +185,10 @@ newtype ModuleName = ModuleName EncodedFS
-- Haskell module names can include the quote character ',
-- so the module names have the z-encoding applied to them
instance Binary ModuleName where
put_ bh (ModuleName m) = put_ bh m
get bh = do m <- get bh; return (ModuleName m)
instance Uniquable ModuleName where
getUnique (ModuleName nm) = getUnique nm
......
......@@ -35,11 +35,13 @@ module Name (
import OccName -- All of it
import Module ( Module, moduleName, mkVanillaModule, isHomeModule )
import RdrName ( RdrName, mkRdrOrig, mkRdrUnqual, rdrNameOcc, rdrNameModule )
import RdrName ( RdrName, mkRdrOrig, mkRdrUnqual, rdrNameOcc,
rdrNameModule, mkRdrQual )
import CmdLineOpts ( opt_Static )
import SrcLoc ( builtinSrcLoc, noSrcLoc, SrcLoc )
import Unique ( Unique, Uniquable(..), u2i, pprUnique )
import FastTypes
import Binary
import Outputable
\end{code}
......@@ -180,7 +182,7 @@ mkKnownKeyGlobal rdr_name uniq
mkWiredInName :: Module -> OccName -> Unique -> Name
mkWiredInName mod occ uniq = mkGlobalName uniq mod occ builtinSrcLoc
mkSysLocalName :: Unique -> UserFS -> Name
mkSysLocalName :: Unique -> EncodedFS -> Name
mkSysLocalName uniq fs = Name { n_uniq = uniq, n_sort = System,
n_occ = mkVarOcc fs, n_loc = noSrcLoc }
......@@ -267,6 +269,26 @@ instance NamedThing Name where
getName n = n
\end{code}
%************************************************************************
%* *
\subsection{Binary output}
%* *
%************************************************************************
\begin{code}
instance Binary Name where
-- we must print these as RdrNames, because that's how they will be read in
put_ bh Name {n_sort = sort, n_uniq = uniq, n_occ = occ} =
case sort of
Global mod
| this_mod == mod -> put_ bh (mkRdrUnqual occ)
| otherwise -> put_ bh (mkRdrOrig (moduleName mod) occ)
where (this_mod,_,_,_) = getUserData bh
_ -> do
put_ bh (mkRdrUnqual occ)
get bh = error "can't Binary.get a Name"
\end{code}
%************************************************************************
%* *
......
{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
......@@ -14,7 +15,8 @@ module OccName (
OccName, -- Abstract, instance of Outputable
pprOccName,
mkOccFS, mkSysOcc, mkSysOccFS, mkFCallOcc, mkVarOcc, mkKindOccFS,
mkOccFS, mkSysOcc, mkSysOccFS, mkFCallOcc, mkKindOccFS,
mkVarOcc, mkVarOccEncoded,
mkSuperDictSelOcc, mkDFunOcc, mkForeignExportOcc,
mkDictOcc, mkIPOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc,
mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc,
......@@ -45,6 +47,8 @@ import Util ( thenCmp )
import Unique ( Unique )
import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, elemFM )
import Outputable
import Binary
import GlaExts
\end{code}
......@@ -89,6 +93,7 @@ data NameSpace = VarName -- Variables
| TcClsName -- Type constructors and classes; Haskell has them
-- in the same name space for now.
deriving( Eq, Ord )
{-! derive: Binary !-}
-- Though type constructors and classes are in the same name space now,
-- the NameSpace type is abstract, so we can easily separate them later
......@@ -119,6 +124,7 @@ nameSpaceString TcClsName = "Type constructor or class"
data OccName = OccName
NameSpace
EncodedFS
{-! derive : Binary !-}
\end{code}
......@@ -188,6 +194,9 @@ mkOccFS occ_sp fs = mkSysOccFS occ_sp (encodeFS fs)
mkVarOcc :: UserFS -> OccName
mkVarOcc fs = mkSysOccFS varName (encodeFS fs)
mkVarOccEncoded :: EncodedFS -> OccName
mkVarOccEncoded fs = mkSysOccFS varName fs
\end{code}
......@@ -613,9 +622,9 @@ isLexSym cs = isLexConSym cs || isLexVarSym cs
-------------
isLexConId cs -- Prefix type or data constructors
| _NULL_ cs = False -- e.g. "Foo", "[]", "(,)"
| cs == SLIT("[]") = True
| otherwise = startsConId (_HEAD_ cs)
| _NULL_ cs = False -- e.g. "Foo", "[]", "(,)"
| cs == FSLIT("[]") = True
| otherwise = startsConId (_HEAD_ cs)
isLexVarId cs -- Ordinary prefix identifiers
| _NULL_ cs = False -- e.g. "x", "_x"
......@@ -623,7 +632,7 @@ isLexVarId cs -- Ordinary prefix identifiers
isLexConSym cs -- Infix type or data constructors
| _NULL_ cs = False -- e.g. ":-:", ":", "->"
| cs == SLIT("->") = True
| cs == FSLIT("->") = True
| otherwise = startsConSym (_HEAD_ cs)
isLexVarSym cs -- Infix identifiers
......@@ -645,3 +654,34 @@ isUpperISO (C# c#) = c# `geChar#` '\xc0'# && c# `leChar#` '\xde'# && c# `neCh
isLowerISO (C# c#) = c# `geChar#` '\xdf'# && c# `leChar#` '\xff'# && c# `neChar#` '\xf7'#
--0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
\end{code}
\begin{code}
{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
instance Binary NameSpace where
put_ bh VarName = do
putByte bh 0
put_ bh DataName = do
putByte bh 1
put_ bh TvName = do
putByte bh 2
put_ bh TcClsName = do
putByte bh 3
get bh = do
h <- getByte bh
case h of
0 -> do return VarName
1 -> do return DataName
2 -> do return TvName
_ -> do return TcClsName
instance Binary OccName where
put_ bh (OccName aa ab) = do
put_ bh aa
put_ bh ab
get bh = do
aa <- get bh
ab <- get bh
return (OccName aa ab)
-- Imported from other files :-
\end{code}
{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
......@@ -40,6 +41,7 @@ import Module ( ModuleName,
)
import FiniteMap
import Outputable
import Binary
import Util ( thenCmp )
\end{code}
......@@ -52,16 +54,20 @@ import Util ( thenCmp )
\begin{code}
data RdrName = RdrName Qual OccName
{-! derive: Binary !-}
data Qual = Unqual
data Qual
= Unqual
| Qual ModuleName -- 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
| Qual ModuleName -- 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 -- This is an *original* name; the module is the place
-- where the thing was defined
{-! derive: Binary !-}
| Orig ModuleName -- This is an *original* name; the module is the place
-- where the thing was defined
\end{code}
......@@ -126,8 +132,8 @@ mkRdrNameWkr (RdrName qual occ) = RdrName qual (mkWorkerOcc occ)
-- the renamer. We can't just put "error..." because
-- we sometimes want to print out stuff after reading but
-- before renaming
dummyRdrVarName = RdrName Unqual (mkVarOcc SLIT("V-DUMMY"))
dummyRdrTcName = RdrName Unqual (mkOccFS tcName SLIT("TC-DUMMY"))
dummyRdrVarName = RdrName Unqual (mkVarOcc FSLIT("V-DUMMY"))
dummyRdrTcName = RdrName Unqual (mkOccFS tcName FSLIT("TC-DUMMY"))
\end{code}
......@@ -214,3 +220,35 @@ rdrEnvToList = fmToList
elemRdrEnv = elemFM
foldRdrEnv = foldFM
\end{code}
\begin{code}
{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
instance Binary RdrName where
put_ bh (RdrName aa ab) = do
put_ bh aa
put_ bh ab
get bh = do
aa <- get bh
ab <- get bh
return (RdrName aa ab)
instance Binary Qual where
put_ bh Unqual = do
putByte bh 0
put_ bh (Qual aa) = do
putByte bh 1
put_ bh aa
put_ bh (Orig ab) = do
putByte bh 2
put_ bh ab
get bh = do
h <- getByte bh
case h of
0 -> do return Unqual
1 -> do aa <- get bh
return (Qual aa)
_ -> do ab <- get bh
return (Orig ab)
-- Imported from other files :-
\end{code}
......@@ -195,7 +195,7 @@ mkSysTyVar uniq kind = Var { varName = name
, varInfo = pprPanic "mkSysTyVar" (ppr name)
}
where
name = mkSysLocalName uniq SLIT("t")
name = mkSysLocalName uniq FSLIT("t")
newMutTyVar :: Name -> Kind -> TyVarDetails -> IO TyVar
newMutTyVar name kind details
......
......@@ -764,5 +764,5 @@ newVar :: Type -> UniqSM Id
newVar ty
= seqType ty `seq`
getUniqueUs `thenUs` \ uniq ->
returnUs (mkSysLocal SLIT("sat") uniq ty)
returnUs (mkSysLocal FSLIT("sat") uniq ty)
\end{code}
......@@ -863,7 +863,7 @@ eta_expand n us expr ty
case splitFunTy_maybe ty of {
Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
where
arg1 = mkSysLocal SLIT("eta") uniq arg_ty
arg1 = mkSysLocal FSLIT("eta") uniq arg_ty
(uniq:us2) = us
; Nothing ->
......
......@@ -28,6 +28,7 @@ import Name ( mkGlobalName, nameModule, nameOccName, getOccString,
mkForeignExportOcc, isLocalName,
NamedThing(..),
)
import OccName ( encodeFS )
import Type ( repType, eqType )
import TcType ( Type, mkFunTys, mkForAllTys, mkTyConApp,
mkFunTy, applyTy,
......@@ -200,7 +201,7 @@ dsFCall mod_Name fn_id fcall
worker_ty = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
the_ccall_app = mkFCall ccall_uniq fcall val_args ccall_result_ty
work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app)
work_id = mkSysLocal SLIT("$wccall") work_uniq worker_ty
work_id = mkSysLocal (encodeFS SLIT("$wccall")) work_uniq worker_ty
-- Build the wrapper
work_app = mkApps (mkVarApps (Var work_id) tvs) val_args
......
......@@ -139,13 +139,13 @@ it easier to read debugging output.
newSysLocalDs, newFailLocalDs :: Type -> DsM Id
newSysLocalDs ty dflags us genv loc mod warns
= case uniqFromSupply us of { assigned_uniq ->
(mkSysLocal SLIT("ds") assigned_uniq ty, warns) }
(mkSysLocal FSLIT("ds") assigned_uniq ty, warns) }
newSysLocalsDs tys = mapDs newSysLocalDs tys
newFailLocalDs ty dflags us genv loc mod warns
= case uniqFromSupply us of { assigned_uniq ->
(mkSysLocal SLIT("fail") assigned_uniq ty, warns) }
(mkSysLocal FSLIT("fail") assigned_uniq ty, warns) }
-- The UserLocal bit just helps make the code a little clearer
getUniqueDs :: DsM Unique
......
......@@ -115,8 +115,9 @@ coreExprToBCOs dflags expr
-- create a totally bogus name for the top-level BCO; this
-- should be harmless, since it's never used for anything
let invented_id = mkSysLocal SLIT("Expr-Top-Level") (mkPseudoUnique3 0)
(panic "invented_id's type")
let invented_id = mkSysLocal FSLIT("Expr-Top-Level")
(mkPseudoUnique3 0)
(panic "invented_id's type")
let invented_name = idName invented_id
annexpr = freeVars expr
......@@ -641,16 +642,14 @@ schemeT d s p app
)
-- Case 2
| let isVoidRepAtom (_, AnnVar v) = VoidRep == typePrimRep (idType v)
| [arg1,arg2] <- args_r_to_l,
let isVoidRepAtom (_, AnnVar v) = VoidRep == typePrimRep (idType v)
isVoidRepAtom (_, AnnNote n e) = isVoidRepAtom e
in is_con_call && isUnboxedTupleCon con
&& ( (args_r_to_l `lengthIs` 2 && isVoidRepAtom (last (args_r_to_l)))
|| (isSingleton args_r_to_l)
)
in isVoidRepAtom arg2
= --trace (if isSingleton args_r_to_l
-- then "schemeT: unboxed singleton"
-- else "schemeT: unboxed pair with Void first component") (
schemeT d s p (head args_r_to_l)
schemeT d s p arg1
--)
-- Case 3
......
......@@ -120,6 +120,7 @@ import IOExts ( IORef, readIORef, writeIORef )
import Constants -- Default values for some flags
import Util
import FastTypes
import FastString ( FastString, mkFastString )
import Config
import Maybes ( firstJust )
......@@ -496,14 +497,14 @@ minusWallOpts
-- main/DriverState.
GLOBAL_VAR(v_Static_hsc_opts, [], [String])
lookUp :: FAST_STRING -> Bool
lookUp :: FastString -> Bool
lookup_int :: String -> Maybe Int
lookup_def_int :: String -> Int -> Int
lookup_def_float :: String -> Float -> Float
lookup_str :: String -> Maybe String
unpacked_static_opts = unsafePerformIO (readIORef v_Static_hsc_opts)
packed_static_opts = map _PK_ unpacked_static_opts
packed_static_opts = map mkFastString unpacked_static_opts
lookUp sw = sw `elem` packed_static_opts
......@@ -547,38 +548,38 @@ unpacked_opts =
\begin{code}