Commit 9af77fa4 authored by simonpj's avatar simonpj

[project @ 2002-09-13 15:02:25 by simonpj]

--------------------------------------
	Make Template Haskell into the HEAD
	--------------------------------------

This massive commit transfers to the HEAD all the stuff that
Simon and Tim have been doing on Template Haskell.  The
meta-haskell-branch is no more!

WARNING: make sure that you

  * Update your links if you are using link trees.
    Some modules have been added, some have gone away.

  * Do 'make clean' in all library trees.
    The interface file format has changed, and you can
    get strange panics (sadly) if GHC tries to read old interface files:
    e.g.  ghc-5.05: panic! (the `impossible' happened, GHC version 5.05):
	  Binary.get(TyClDecl): ForeignType

  * You need to recompile the rts too; Linker.c has changed


However the libraries are almost unaltered; just a tiny change in
Base, and to the exports in Prelude.


NOTE: so far as TH itself is concerned, expression splices work
fine, but declaration splices are not complete.


		---------------
		The main change
		---------------

The main structural change: renaming and typechecking have to be
interleaved, because we can't rename stuff after a declaration splice
until after we've typechecked the stuff before (and the splice
itself).

* Combine the renamer and typecheker monads into one
	(TcRnMonad, TcRnTypes)
  These two replace TcMonad and RnMonad

* Give them a single 'driver' (TcRnDriver).  This driver
  replaces TcModule.lhs and Rename.lhs

* The haskell-src library package has a module
	Language/Haskell/THSyntax
  which defines the Haskell data type seen by the TH programmer.

* New modules:
	hsSyn/Convert.hs 	converts THSyntax -> HsSyn
	deSugar/DsMeta.hs 	converts HsSyn -> THSyntax

* New module typecheck/TcSplice type-checks Template Haskell splices.

		-------------
		Linking stuff
		-------------

* ByteCodeLink has been split into
	ByteCodeLink	(which links)
	ByteCodeAsm	(which assembles)

* New module ghci/ObjLink is the object-code linker.

* compMan/CmLink is removed entirely (was out of place)
  Ditto CmTypes (which was tiny)

* Linker.c initialises the linker when it is first used (no need to call
  initLinker any more).  Template Haskell makes it harder to know when
  and whether to initialise the linker.


	-------------------------------------
	Gathering the LIE in the type checker
	-------------------------------------

* Instead of explicitly gathering constraints in the LIE
	tcExpr :: RenamedExpr -> TcM (TypecheckedExpr, LIE)
  we now dump the constraints into a mutable varabiable carried
  by the monad, so we get
	tcExpr :: RenamedExpr -> TcM TypecheckedExpr

  Much less clutter in the code, and more efficient too.
  (Originally suggested by Mark Shields.)


		-----------------
		Remove "SysNames"
		-----------------

Because the renamer and the type checker were entirely separate,
we had to carry some rather tiresome implicit binders (or "SysNames")
along inside some of the HsDecl data structures.  They were both
tiresome and fragile.

Now that the typechecker and renamer are more intimately coupled,
we can eliminate SysNames (well, mostly... default methods still
carry something similar).

		-------------
		Clean up HsPat
		-------------

One big clean up is this: instead of having two HsPat types (InPat and
OutPat), they are now combined into one.  This is more consistent with
the way that HsExpr etc is handled; there are some 'Out' constructors
for the type checker output.

So:
	HsPat.InPat	--> HsPat.Pat
	HsPat.OutPat	--> HsPat.Pat
	No 'pat' type parameter in HsExpr, HsBinds, etc

	Constructor patterns are nicer now: they use
		HsPat.HsConDetails
	for the three cases of constructor patterns:
		prefix, infix, and record-bindings

	The *same* data type HsConDetails is used in the type
	declaration of the data type (HsDecls.TyData)

Lots of associated clean-up operations here and there.  Less code.
Everything is wonderful.
parent 69e55e74
# ----------------------------------------------------------------------------- # -----------------------------------------------------------------------------
# $Id: Makefile,v 1.221 2002/09/06 14:35:43 simonmar Exp $ # $Id: Makefile,v 1.222 2002/09/13 15:02:25 simonpj Exp $
TOP = .. TOP = ..
...@@ -101,11 +101,14 @@ CLEAN_FILES += $(CONFIG_HS) ...@@ -101,11 +101,14 @@ CLEAN_FILES += $(CONFIG_HS)
ALL_DIRS = \ ALL_DIRS = \
utils basicTypes types hsSyn prelude rename typecheck deSugar coreSyn \ utils basicTypes types hsSyn prelude rename typecheck deSugar coreSyn \
specialise simplCore stranal stgSyn simplStg codeGen absCSyn main \ specialise simplCore stranal stgSyn simplStg codeGen absCSyn main \
profiling parser usageSP cprAnalysis compMan ndpFlatten profiling parser usageSP cprAnalysis compMan ndpFlatten
# Make sure we include Config.hs even if it doesn't exist yet... # Make sure we include Config.hs even if it doesn't exist yet...
ALL_SRCS += $(CONFIG_HS) ALL_SRCS += $(CONFIG_HS)
# HsGeneric.hs is not used just now
EXCLUDED_SRCS += hsSyn/HsGeneric.hs
ifeq ($(GhcWithNativeCodeGen),YES) ifeq ($(GhcWithNativeCodeGen),YES)
ALL_DIRS += nativeGen ALL_DIRS += nativeGen
else else
...@@ -132,15 +135,17 @@ compiling_with_4xx = $(shell if (test $(GhcCanonVersion) -lt 500); then echo YES ...@@ -132,15 +135,17 @@ compiling_with_4xx = $(shell if (test $(GhcCanonVersion) -lt 500); then echo YES
endif endif
# Only include GHCi if we're bootstrapping with at least version 411 # Only include GHCi if we're bootstrapping with at least version 411
ifeq "$(GhcWithInterpreter)" "YES" ifeq "$(GhcWithInterpreter) $(bootstrapped)" "YES YES"
ifeq "$(bootstrapped)" "YES" # Yes, include the interepreter, readline, and Template Haskell extensions
SRC_HC_OPTS += -DGHCI -package readline SRC_HC_OPTS += -DGHCI -package readline -package haskell-src
ifneq "$(TARGETPLATFORM)" "i386-unknown-mingw32" ifneq "$(TARGETPLATFORM)" "i386-unknown-mingw32"
SRC_HC_OPTS += -package unix SRC_HC_OPTS += -package unix
endif endif
ALL_DIRS += ghci ALL_DIRS += ghci
endif else
endif # No interpreter, so exclude Template Haskell modules
EXCLUDED_SRCS += deSugar/DsMeta.hs typecheck/TcSplice.lhs hsSyn/Convert.lhs
endif
# There are some C files to include in HS_PROG, so add these to HS_OBJS # There are some C files to include in HS_PROG, so add these to HS_OBJS
HS_OBJS += $(C_OBJS) HS_OBJS += $(C_OBJS)
......
% %
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
% %
% $Id: AbsCSyn.lhs,v 1.49 2002/08/02 13:08:33 simonmar Exp $ % $Id: AbsCSyn.lhs,v 1.50 2002/09/13 15:02:25 simonpj Exp $
% %
\section[AbstractC]{Abstract C: the last stop before machine code} \section[AbstractC]{Abstract C: the last stop before machine code}
......
% %
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
% %
% $Id: CLabel.lhs,v 1.54 2002/07/18 09:16:12 simonmar Exp $ % $Id: CLabel.lhs,v 1.55 2002/09/13 15:02:26 simonpj Exp $
% %
\section[CLabel]{@CLabel@: Information to make C Labels} \section[CLabel]{@CLabel@: Information to make C Labels}
...@@ -90,7 +90,6 @@ import TyCon ( TyCon ) ...@@ -90,7 +90,6 @@ import TyCon ( TyCon )
import Unique ( pprUnique, Unique ) import Unique ( pprUnique, Unique )
import PrimOp ( PrimOp ) import PrimOp ( PrimOp )
import CostCentre ( CostCentre, CostCentreStack ) import CostCentre ( CostCentre, CostCentreStack )
import BasicTypes ( Version )
import Outputable import Outputable
import FastString import FastString
\end{code} \end{code}
......
...@@ -20,7 +20,7 @@ module BasicTypes( ...@@ -20,7 +20,7 @@ module BasicTypes(
Unused, unused, Unused, unused,
Fixity(..), FixityDirection(..), FixitySig(..), Fixity(..), FixityDirection(..),
defaultFixity, maxPrecedence, defaultFixity, maxPrecedence,
arrowFixity, negateFixity, negatePrecedence, arrowFixity, negateFixity, negatePrecedence,
compareFixity, compareFixity,
...@@ -46,12 +46,15 @@ module BasicTypes( ...@@ -46,12 +46,15 @@ module BasicTypes(
StrictnessMark(..), isMarkedUnboxed, isMarkedStrict, StrictnessMark(..), isMarkedUnboxed, isMarkedStrict,
CompilerPhase, CompilerPhase,
Activation(..), isActive, isNeverActive, isAlwaysActive Activation(..), isActive, isNeverActive, isAlwaysActive,
SuccessFlag(..), succeeded, failed, successIf
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
import Outputable import Outputable
import SrcLoc
\end{code} \end{code}
%************************************************************************ %************************************************************************
...@@ -137,21 +140,34 @@ mapIPName f (Linear n) = Linear (f n) ...@@ -137,21 +140,34 @@ mapIPName f (Linear n) = Linear (f n)
%************************************************************************ %************************************************************************
\begin{code} \begin{code}
------------------------
data FixitySig name = FixitySig name Fixity SrcLoc
instance Eq name => Eq (FixitySig name) where
(FixitySig n1 f1 _) == (FixitySig n2 f2 _) = n1==n2 && f1==f2
instance Outputable name => Outputable (FixitySig name) where
ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
------------------------
data Fixity = Fixity Int FixityDirection data Fixity = Fixity Int FixityDirection
data FixityDirection = InfixL | InfixR | InfixN
deriving(Eq)
instance Outputable Fixity where instance Outputable Fixity where
ppr (Fixity prec dir) = hcat [ppr dir, space, int prec] ppr (Fixity prec dir) = hcat [ppr dir, space, int prec]
instance Eq Fixity where -- Used to determine if two fixities conflict
(Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2
------------------------
data FixityDirection = InfixL | InfixR | InfixN
deriving(Eq)
instance Outputable FixityDirection where instance Outputable FixityDirection where
ppr InfixL = ptext SLIT("infixl") ppr InfixL = ptext SLIT("infixl")
ppr InfixR = ptext SLIT("infixr") ppr InfixR = ptext SLIT("infixr")
ppr InfixN = ptext SLIT("infix") ppr InfixN = ptext SLIT("infix")
instance Eq Fixity where -- Used to determine if two fixities conflict ------------------------
(Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2
maxPrecedence = (9::Int) maxPrecedence = (9::Int)
defaultFixity = Fixity maxPrecedence InfixL defaultFixity = Fixity maxPrecedence InfixL
...@@ -405,6 +421,28 @@ instance Outputable StrictnessMark where ...@@ -405,6 +421,28 @@ instance Outputable StrictnessMark where
\end{code} \end{code}
%************************************************************************
%* *
\subsection{Success flag}
%* *
%************************************************************************
\begin{code}
data SuccessFlag = Succeeded | Failed
successIf :: Bool -> SuccessFlag
successIf True = Succeeded
successIf False = Failed
succeeded, failed :: SuccessFlag -> Bool
succeeded Succeeded = True
succeeded Failed = False
failed Succeeded = False
failed Failed = True
\end{code}
%************************************************************************ %************************************************************************
%* * %* *
\subsection{Activation} \subsection{Activation}
...@@ -443,3 +481,4 @@ isNeverActive act = False ...@@ -443,3 +481,4 @@ isNeverActive act = False
isAlwaysActive AlwaysActive = True isAlwaysActive AlwaysActive = True
isAlwaysActive other = False isAlwaysActive other = False
\end{code} \end{code}
...@@ -25,7 +25,7 @@ module IdInfo ( ...@@ -25,7 +25,7 @@ module IdInfo (
-- New demand and strictness info -- New demand and strictness info
newStrictnessInfo, setNewStrictnessInfo, newStrictnessInfo, setNewStrictnessInfo,
newDemandInfo, setNewDemandInfo, newDemandInfo, setNewDemandInfo, pprNewStrictness,
-- Strictness; imported from Demand -- Strictness; imported from Demand
StrictnessInfo(..), StrictnessInfo(..),
...@@ -94,12 +94,12 @@ import BasicTypes ( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBrea ...@@ -94,12 +94,12 @@ import BasicTypes ( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBrea
import DataCon ( DataCon ) import DataCon ( DataCon )
import ForeignCall ( ForeignCall ) import ForeignCall ( ForeignCall )
import FieldLabel ( FieldLabel ) import FieldLabel ( FieldLabel )
import Type ( usOnce, usMany ) import Type ( usOnce )
import Demand hiding( Demand, seqDemand ) import Demand hiding( Demand, seqDemand )
import qualified Demand import qualified Demand
import NewDemand import NewDemand
import Outputable import Outputable
import Util ( seqList, listLengthCmp ) import Util ( listLengthCmp )
import Maybe ( isJust ) import Maybe ( isJust )
import List ( replicate ) import List ( replicate )
...@@ -153,6 +153,9 @@ setAllStrictnessInfo info (Just sig) ...@@ -153,6 +153,9 @@ setAllStrictnessInfo info (Just sig)
seqNewStrictnessInfo Nothing = () seqNewStrictnessInfo Nothing = ()
seqNewStrictnessInfo (Just ty) = seqStrictSig ty seqNewStrictnessInfo (Just ty) = seqStrictSig ty
pprNewStrictness Nothing = empty
pprNewStrictness (Just sig) = ftext FSLIT("Str:") <+> ppr sig
#ifdef OLD_STRICTNESS #ifdef OLD_STRICTNESS
oldStrictnessFromNew :: StrictSig -> Demand.StrictnessInfo oldStrictnessFromNew :: StrictSig -> Demand.StrictnessInfo
oldStrictnessFromNew sig = mkStrictnessInfo (map oldDemand dmds, isBotRes res_info) oldStrictnessFromNew sig = mkStrictnessInfo (map oldDemand dmds, isBotRes res_info)
......
...@@ -42,8 +42,8 @@ import Util ( thenCmp ) ...@@ -42,8 +42,8 @@ import Util ( thenCmp )
import Ratio ( numerator ) import Ratio ( numerator )
import FastString ( uniqueOfFS, lengthFS ) import FastString ( uniqueOfFS, lengthFS )
import Int ( Int8, Int16, Int32 ) import DATA_INT ( Int8, Int16, Int32 )
import Word ( Word8, Word16, Word32 ) import DATA_WORD ( Word8, Word16, Word32 )
import Char ( ord, chr ) import Char ( ord, chr )
\end{code} \end{code}
......
...@@ -49,7 +49,6 @@ import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp, ...@@ -49,7 +49,6 @@ import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp,
isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType, isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
tcSplitFunTys, tcSplitForAllTys, mkPredTy tcSplitFunTys, tcSplitForAllTys, mkPredTy
) )
import Module ( Module )
import CoreUtils ( exprType ) import CoreUtils ( exprType )
import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon ) import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon )
import Literal ( Literal(..), nullAddrLit ) import Literal ( Literal(..), nullAddrLit )
...@@ -58,8 +57,7 @@ import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons, ...@@ -58,8 +57,7 @@ import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons,
import Class ( Class, classTyCon, classTyVars, classSelIds ) import Class ( Class, classTyCon, classTyVars, classSelIds )
import Var ( Id, TyVar, Var ) import Var ( Id, TyVar, Var )
import VarSet ( isEmptyVarSet ) import VarSet ( isEmptyVarSet )
import Name ( mkWiredInName, mkFCallName, Name ) import Name ( mkFCallName, Name )
import OccName ( mkVarOcc )
import PrimOp ( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName ) import PrimOp ( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName )
import ForeignCall ( ForeignCall ) import ForeignCall ( ForeignCall )
import DataCon ( DataCon, import DataCon ( DataCon,
...@@ -98,7 +96,6 @@ import FastString ...@@ -98,7 +96,6 @@ import FastString
import ListSetOps ( assoc, assocMaybe ) import ListSetOps ( assoc, assocMaybe )
import UnicodeUtil ( stringToUtf8 ) import UnicodeUtil ( stringToUtf8 )
import List ( nubBy ) import List ( nubBy )
import Char ( ord )
\end{code} \end{code}
%************************************************************************ %************************************************************************
...@@ -811,7 +808,7 @@ another gun with which to shoot yourself in the foot. ...@@ -811,7 +808,7 @@ another gun with which to shoot yourself in the foot.
\begin{code} \begin{code}
-- unsafeCoerce# :: forall a b. a -> b -- unsafeCoerce# :: forall a b. a -> b
unsafeCoerceId unsafeCoerceId
= pcMiscPrelId unsafeCoerceIdKey gHC_PRIM FSLIT("unsafeCoerce#") ty info = pcMiscPrelId unsafeCoerceName ty info
where where
info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
...@@ -826,13 +823,13 @@ unsafeCoerceId ...@@ -826,13 +823,13 @@ unsafeCoerceId
-- The reason is is here is because we don't provide -- The reason is is here is because we don't provide
-- a way to write this literal in Haskell. -- a way to write this literal in Haskell.
nullAddrId nullAddrId
= pcMiscPrelId nullAddrIdKey gHC_PRIM FSLIT("nullAddr#") addrPrimTy info = pcMiscPrelId nullAddrName addrPrimTy info
where where
info = noCafIdInfo `setUnfoldingInfo` info = noCafIdInfo `setUnfoldingInfo`
mkCompulsoryUnfolding (Lit nullAddrLit) mkCompulsoryUnfolding (Lit nullAddrLit)
seqId seqId
= pcMiscPrelId seqIdKey gHC_PRIM FSLIT("seq") ty info = pcMiscPrelId seqName ty info
where where
info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
...@@ -849,7 +846,7 @@ seqId ...@@ -849,7 +846,7 @@ seqId
-- the info in PrelBase.hi. This is important, because the strictness -- the info in PrelBase.hi. This is important, because the strictness
-- analyser will spot it as strict! -- analyser will spot it as strict!
lazyId lazyId
= pcMiscPrelId lazyIdKey pREL_BASE FSLIT("lazy") ty info = pcMiscPrelId lazyIdName ty info
where where
info = noCafIdInfo info = noCafIdInfo
ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy) ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy)
...@@ -865,7 +862,7 @@ evaluate its argument and call the dataToTag# primitive. ...@@ -865,7 +862,7 @@ evaluate its argument and call the dataToTag# primitive.
\begin{code} \begin{code}
getTagId getTagId
= pcMiscPrelId getTagIdKey gHC_PRIM FSLIT("getTag#") ty info = pcMiscPrelId getTagName ty info
where where
info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
-- We don't provide a defn for this; you must inline it -- We don't provide a defn for this; you must inline it
...@@ -890,8 +887,7 @@ This comes up in strictness analysis ...@@ -890,8 +887,7 @@ This comes up in strictness analysis
\begin{code} \begin{code}
realWorldPrimId -- :: State# RealWorld realWorldPrimId -- :: State# RealWorld
= pcMiscPrelId realWorldPrimIdKey gHC_PRIM FSLIT("realWorld#") = pcMiscPrelId realWorldName realWorldStatePrimTy
realWorldStatePrimTy
(noCafIdInfo `setUnfoldingInfo` mkOtherCon []) (noCafIdInfo `setUnfoldingInfo` mkOtherCon [])
-- The mkOtherCon makes it look that realWorld# is evaluated -- The mkOtherCon makes it look that realWorld# is evaluated
-- which in turn makes Simplify.interestingArg return True, -- which in turn makes Simplify.interestingArg return True,
...@@ -937,22 +933,21 @@ mkRuntimeErrorApp err_id res_ty err_msg ...@@ -937,22 +933,21 @@ mkRuntimeErrorApp err_id res_ty err_msg
where where
err_string = Lit (MachStr (mkFastString (stringToUtf8 err_msg))) err_string = Lit (MachStr (mkFastString (stringToUtf8 err_msg)))
rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrIdKey FSLIT("recSelError") rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName
rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorIdKey FSLIT("runtimeError") rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName
iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorName
iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorIdKey FSLIT("irrefutPatError") rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName
rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorIdKey FSLIT("recConError") nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName
nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorIdKey FSLIT("nonExhaustiveGuardsError") pAT_ERROR_ID = mkRuntimeErrorId patErrorName
pAT_ERROR_ID = mkRuntimeErrorId patErrorIdKey FSLIT("patError") nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName
nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorIdKey FSLIT("noMethodBindingError")
-- The runtime error Ids take a UTF8-encoded string as argument -- The runtime error Ids take a UTF8-encoded string as argument
mkRuntimeErrorId key name = pc_bottoming_Id key pREL_ERR name runtimeErrorTy mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy
runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy) runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy)
\end{code} \end{code}
\begin{code} \begin{code}
eRROR_ID = pc_bottoming_Id errorIdKey pREL_ERR FSLIT("error") errorTy eRROR_ID = pc_bottoming_Id errorName errorTy
errorTy :: Type errorTy :: Type
errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy) errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
...@@ -969,21 +964,17 @@ errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy ...@@ -969,21 +964,17 @@ errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy
%************************************************************************ %************************************************************************
\begin{code} \begin{code}
pcMiscPrelId :: Unique{-IdKey-} -> Module -> FastString -> Type -> IdInfo -> Id pcMiscPrelId :: Name -> Type -> IdInfo -> Id
pcMiscPrelId key mod str ty info pcMiscPrelId name ty info
= let = mkVanillaGlobal name ty info
name = mkWiredInName mod (mkVarOcc str) key
imp = mkVanillaGlobal name ty info -- the usual case...
in
imp
-- We lie and say the thing is imported; otherwise, we get into -- We lie and say the thing is imported; otherwise, we get into
-- a mess with dependency analysis; e.g., core2stg may heave in -- a mess with dependency analysis; e.g., core2stg may heave in
-- random calls to GHCbase.unpackPS__. If GHCbase is the module -- random calls to GHCbase.unpackPS__. If GHCbase is the module
-- being compiled, then it's just a matter of luck if the definition -- being compiled, then it's just a matter of luck if the definition
-- will be in "the right place" to be in scope. -- will be in "the right place" to be in scope.
pc_bottoming_Id key mod name ty pc_bottoming_Id name ty
= pcMiscPrelId key mod name ty bottoming_info = pcMiscPrelId name ty bottoming_info
where where
bottoming_info = hasCafIdInfo `setAllStrictnessInfo` Just strict_sig bottoming_info = hasCafIdInfo `setAllStrictnessInfo` Just strict_sig
-- Do *not* mark them as NoCafRefs, because they can indeed have -- Do *not* mark them as NoCafRefs, because they can indeed have
......
...@@ -41,8 +41,8 @@ module Module ...@@ -41,8 +41,8 @@ module Module
( (
Module, -- Abstract, instance of Eq, Ord, Outputable Module, -- Abstract, instance of Eq, Ord, Outputable
, PackageName -- = FastString; instance of Outputable, Uniquable , ModLocation(..),
, preludePackage -- :: PackageName , showModMsg
, ModuleName , ModuleName
, pprModuleName -- :: ModuleName -> SDoc , pprModuleName -- :: ModuleName -> SDoc
...@@ -59,7 +59,6 @@ module Module ...@@ -59,7 +59,6 @@ module Module
, mkVanillaModule -- :: ModuleName -> Module , mkVanillaModule -- :: ModuleName -> Module
, isVanillaModule -- :: Module -> Bool , isVanillaModule -- :: Module -> Bool
, mkPrelModule -- :: UserString -> Module , mkPrelModule -- :: UserString -> Module
, mkModule -- :: ModuleName -> PackageName -> Module
, mkHomeModule -- :: ModuleName -> Module , mkHomeModule -- :: ModuleName -> Module
, isHomeModule -- :: Module -> Bool , isHomeModule -- :: Module -> Bool
, mkPackageModule -- :: ModuleName -> Module , mkPackageModule -- :: ModuleName -> Module
...@@ -70,15 +69,13 @@ module Module ...@@ -70,15 +69,13 @@ module Module
, pprModule, , pprModule,
-- Where to find a .hi file
, WhereFrom(..)
, ModuleEnv, , ModuleEnv,
, elemModuleEnv, extendModuleEnv, extendModuleEnvList, plusModuleEnv_C , elemModuleEnv, extendModuleEnv, extendModuleEnvList, plusModuleEnv_C
, delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv , delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv
, lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv , lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv
, moduleEnvElts, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv , moduleEnvElts, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv
, lookupModuleEnvByName, extendModuleEnv_C , extendModuleEnv_C
, lookupModuleEnvByName, extendModuleEnvByName, unitModuleEnvByName
, ModuleSet, emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, elemModuleSet , ModuleSet, emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, elemModuleSet
...@@ -87,9 +84,11 @@ module Module ...@@ -87,9 +84,11 @@ module Module
#include "HsVersions.h" #include "HsVersions.h"
import OccName import OccName
import Outputable import Outputable
import Packages ( PackageName, preludePackage )
import CmdLineOpts ( opt_InPackage ) import CmdLineOpts ( opt_InPackage )
import FastString ( FastString ) import FastString ( FastString )
import Unique ( Uniquable(..) ) import Unique ( Uniquable(..) )
import Maybes ( expectJust )
import UniqFM import UniqFM
import UniqSet import UniqSet
import Binary import Binary
...@@ -134,11 +133,6 @@ data PackageInfo ...@@ -134,11 +133,6 @@ data PackageInfo
-- Later on (in RnEnv.newTopBinder) we'll update the cache -- Later on (in RnEnv.newTopBinder) we'll update the cache
-- to have the right PackageName -- to have the right PackageName
type PackageName = FastString -- No encoding at all
preludePackage :: PackageName
preludePackage = FSLIT("base")
packageInfoPackage :: PackageInfo -> PackageName packageInfoPackage :: PackageInfo -> PackageName
packageInfoPackage ThisPackage = opt_InPackage packageInfoPackage ThisPackage = opt_InPackage
packageInfoPackage DunnoYet = FSLIT("<?>") packageInfoPackage DunnoYet = FSLIT("<?>")
...@@ -152,28 +146,44 @@ instance Outputable PackageInfo where ...@@ -152,28 +146,44 @@ instance Outputable PackageInfo where
%************************************************************************ %************************************************************************
%* *