Commit 26741ec4 authored by partain's avatar partain

[project @ 1996-06-26 10:26:00 by partain]

SLPJ 1.3 changes through 96/06/25
parent ae45ff0e
......@@ -10,14 +10,6 @@ you will screw up the layout where they are used in case expressions!
#endif
#ifdef __GLASGOW_HASKELL__
#define TAG_ Int#
#define LT_ -1#
#define EQ_ 0#
#define GT_ 1#
#endif
#define GT__ _
#define COMMA ,
#ifdef DEBUG
......@@ -35,25 +27,38 @@ you will screw up the layout where they are used in case expressions!
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 200
# define REALLY_HASKELL_1_3
# define SYN_IE(a) a
# define EXP_MODULE(a) module a
# define IMPORT_DELOOPER(mod) import CAT2(mod,_1_3)
# define IMPORT_1_3(mod) import mod
# define _tagCmp compare
# define _LT LT
# define _EQ EQ
# define _GT GT
# define _Addr GHCbase.Addr
# define Text Show
# define IMP_Ubiq() IMPORT_DELOOPER(Ubiq); import qualified GHCbase
# define CHK_Ubiq() IMPORT_DELOOPER(Ubiq); import qualified GHCbase
# define minInt (minBound::Int)
# define maxInt (maxBound::Int)
#else
# define SYN_IE(a) a(..)
# define EXP_MODULE(a) a..
# define IMPORT_DELOOPER(mod) import mod
# define IMPORT_1_3(mod) {--}
# define IMP_Ubiq() IMPORT_DELOOPER(Ubiq)
# define CHK_Ubiq() IMPORT_DELOOPER(Ubiq)
#endif
#define IMP_Ubiq() IMPORT_DELOOPER(Ubiq)
#define CHK_Ubiq() IMPORT_DELOOPER(Ubiq)
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 26
#if __GLASGOW_HASKELL__ >= 26 && __GLASGOW_HASKELL__ < 200
#define trace _trace
#endif
#define TAG_ Int#
#define LT_ -1#
#define EQ_ 0#
#define GT_ 1#
#define GT__ _
#if defined(__GLASGOW_HASKELL__)
#define FAST_INT Int#
#define ILIT(x) (x#)
......@@ -100,36 +105,53 @@ you will screw up the layout where they are used in case expressions!
#endif {- ! __GLASGOW_HASKELL__ -}
#if __GLASGOW_HASKELL__ >= 23
#define USE_FAST_STRINGS 1
#define FAST_STRING _PackedString
#define SLIT(x) (_packCString (A# x#))
#define _CMP_STRING_ cmpPString
#define _NULL_ _nullPS
#define _NIL_ _nilPS
#define _CONS_ _consPS
#define _HEAD_ _headPS
#define _TAIL_ _tailPS
#define _LENGTH_ _lengthPS
#define _PK_ _packString
#define _UNPK_ _unpackPS
#define _SUBSTR_ _substrPS
#define _APPEND_ `_appendPS`
#define _CONCAT_ _concatPS
# define USE_FAST_STRINGS 1
# if __GLASGOW_HASKELL__ < 200
# define FAST_STRING _PackedString
# define SLIT(x) (_packCString (A# x#))
# define _CMP_STRING_ cmpPString
# define _NULL_ _nullPS
# define _NIL_ _nilPS
# define _CONS_ _consPS
# define _HEAD_ _headPS
# define _TAIL_ _tailPS
# define _LENGTH_ _lengthPS
# define _PK_ _packString
# define _UNPK_ _unpackPS
# define _SUBSTR_ _substrPS
# define _APPEND_ `_appendPS`
# define _CONCAT_ _concatPS
# else
# define FAST_STRING GHCbase.PackedString
# define SLIT(x) (packCString (GHCbase.A# x#))
# define _CMP_STRING_ cmpPString
# define _NULL_ nullPS
# define _NIL_ nilPS
# define _CONS_ consPS
# define _HEAD_ headPS
# define _TAIL_ tailPS
# define _LENGTH_ lengthPS
# define _PK_ packString
# define _UNPK_ unpackPS
# define _SUBSTR_ substrPS
# define _APPEND_ `appendPS`
# define _CONCAT_ concatPS
# endif
#else
#define FAST_STRING String
#define SLIT(x) (x)
#define _CMP_STRING_ cmpString
#define _NULL_ null
#define _NIL_ ""
#define _CONS_ (:)
#define _HEAD_ head
#define _TAIL_ tail
#define _LENGTH_ length
#define _PK_ (\x->x)
#define _UNPK_ (\x->x)
#define _SUBSTR_ substr{-from Utils-}
#define _APPEND_ ++
#define _CONCAT_ concat
# define FAST_STRING String
# define SLIT(x) (x)
# define _CMP_STRING_ cmpString
# define _NULL_ null
# define _NIL_ ""
# define _CONS_ (:)
# define _HEAD_ head
# define _TAIL_ tail
# define _LENGTH_ length
# define _PK_ (\x->x)
# define _UNPK_ (\x->x)
# define _SUBSTR_ substr{-from Utils-}
# define _APPEND_ ++
# define _CONCAT_ concat
#endif
#endif
......@@ -25,7 +25,6 @@ SUBDIRS = __ghc_compiler_tests_dir
*/
SuffixRules_flexish()
SuffixRule_c_o()
LitSuffixRule(.lprl,.prl) /* for makeSymbolList.prl */
.SUFFIXES: .lhi
.lhi.hi:
......@@ -231,9 +230,7 @@ stranal/StrictAnal.lhs \
stranal/SaLib.lhs \
stranal/SaAbsInt.lhs \
stranal/WwLib.lhs \
stranal/WorkWrap.lhs \
\
profiling/SCCauto.lhs DEFORESTER_SRCS_LHS
stranal/WorkWrap.lhs DEFORESTER_SRCS_LHS
#define STG_SRCS_LHS \
stgSyn/CoreToStg.lhs \
......@@ -606,7 +603,6 @@ compile(prelude/PrimOp,lhs,-K3m -H10m)
compile(prelude/TysPrim,lhs,)
compile(prelude/TysWiredIn,lhs,)
compile(profiling/SCCauto,lhs,)
compile(profiling/SCCfinal,lhs,)
compile(profiling/CostCentre,lhs,)
......@@ -820,6 +816,11 @@ InstallBinaryTarget(hsp,$(INSTLIBDIR_GHC))
YaccRunWithExpectMsg(parser/hsparser,12,0)
parser/hslexer.o : parser/hslexer.c parser/hsparser.tab.h
$(RM) $@
$(CC) $(CFLAGS) -c $<
@if [ \( $(@D) != '.' \) -a \( $(@D) != './' \) ] ; then echo mv $(@F) $@ ; mv $(@F) $@ ; else exit 0 ; fi
UgenTarget(parser,constr)
UgenTarget(parser,binding)
UgenTarget(parser,pbinding)
......
\begin{code}
interface AbsCLoop_1_3 1
__exports__
MachMisc fixedHdrSizeInWords (..)
MachMisc varHdrSizeInWords (..)
CgRetConv ctrlReturnConvAlg (..)
CgRetConv CtrlReturnConvention(..)
\end{code}
......@@ -42,8 +42,8 @@ import CgCompInfo ( mAX_Vanilla_REG, mAX_Float_REG,
lIVENESS_R3, lIVENESS_R4, lIVENESS_R5,
lIVENESS_R6, lIVENESS_R7, lIVENESS_R8
)
import HeapOffs ( VirtualSpAOffset(..), VirtualSpBOffset(..),
VirtualHeapOffset(..)
import HeapOffs ( SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset),
SYN_IE(VirtualHeapOffset)
)
import Literal ( mkMachInt )
import PrimRep ( isFollowableRep, PrimRep(..) )
......
......@@ -26,7 +26,7 @@ import AbsCSyn
import CLabel ( mkReturnPtLabel )
import Digraph ( stronglyConnComp )
import HeapOffs ( possiblyEqualHeapOffset )
import Id ( fIRST_TAG, ConTag(..) )
import Id ( fIRST_TAG, SYN_IE(ConTag) )
import Literal ( literalPrimRep, Literal(..) )
import PrimRep ( getPrimRepSize, PrimRep(..) )
import Unique ( Unique{-instance Eq-} )
......
......@@ -61,16 +61,16 @@ import Id ( externallyVisibleId, cmpId_withSpecDataCon,
isConstMethodId_maybe,
isDefaultMethodId_maybe,
isSuperDictSelId_maybe, fIRST_TAG,
ConTag(..), GenId{-instance Outputable-}
SYN_IE(ConTag), GenId{-instance Outputable-}
)
import Maybes ( maybeToBool )
import PprStyle ( PprStyle(..) )
import PprType ( showTyCon, GenType{-instance Outputable-} )
import Pretty ( prettyToUn )
import Pretty ( prettyToUn, ppPStr{-ToDo:rm-} )
import TyCon ( TyCon{-instance Eq-} )
import Unique ( showUnique, pprUnique, Unique{-instance Eq-} )
import Unpretty -- NOTE!! ********************
import Util ( assertPanic )
import Util ( assertPanic, pprTrace{-ToDo:rm-} )
\end{code}
things we want to find out:
......@@ -335,11 +335,11 @@ pprCLabel (PprForAsm prepend_cSEP _) lbl
prLbl = pprCLabel PprForC lbl
pprCLabel sty (TyConLabel tc UnvecConUpdCode)
= uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc),
= uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_tycon sty tc,
pp_cSEP, uppPStr SLIT("upd")]
pprCLabel sty (TyConLabel tc (VecConUpdCode tag))
= uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc), pp_cSEP,
= uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_tycon sty tc, pp_cSEP,
uppInt tag, pp_cSEP, uppPStr SLIT("upd")]
pprCLabel sty (TyConLabel tc (StdUpdCode tag))
......@@ -348,10 +348,10 @@ pprCLabel sty (TyConLabel tc (StdUpdCode tag))
VectoredReturn _ -> uppBeside (uppPStr SLIT("IndUpdRetV")) (uppInt (tag - fIRST_TAG))
pprCLabel sty (TyConLabel tc InfoTblVecTbl)
= uppBesides [uppStr (showTyCon sty tc), pp_cSEP, uppPStr SLIT("itblvtbl")]
= uppBesides [ppr_tycon sty tc, pp_cSEP, uppPStr SLIT("itblvtbl")]
pprCLabel sty (TyConLabel tc StdUpdVecTbl)
= uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, uppStr (showTyCon sty tc),
= uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, ppr_tycon sty tc,
pp_cSEP, uppPStr SLIT("upd")]
pprCLabel sty (CaseLabel u CaseReturnPt)
......@@ -382,6 +382,13 @@ pprCLabel sty (IdLabel (CLabelId id) flavor)
ppr_u u = prettyToUn (pprUnique u)
ppr_tycon sty tc
= let
str = showTyCon sty tc
in
--pprTrace "ppr_tycon:" (ppStr str) $
uppStr str
ppFlavor :: IdLabelInfo -> Unpretty
ppFlavor x = uppBeside pp_cSEP
......
......@@ -26,9 +26,9 @@ module HeapOffs (
hpRelToInt,
#endif
VirtualHeapOffset(..), HpRelOffset(..),
VirtualSpAOffset(..), VirtualSpBOffset(..),
SpARelOffset(..), SpBRelOffset(..)
SYN_IE(VirtualHeapOffset), SYN_IE(HpRelOffset),
SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset),
SYN_IE(SpARelOffset), SYN_IE(SpBRelOffset)
) where
IMP_Ubiq(){-uitous-}
......
......@@ -48,7 +48,7 @@ import SMRep ( getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
)
import Unique ( pprUnique, Unique{-instance NamedThing-} )
import UniqSet ( emptyUniqSet, elementOfUniqSet,
addOneToUniqSet, UniqSet(..)
addOneToUniqSet, SYN_IE(UniqSet)
)
import Unpretty -- ********** NOTE **********
import Util ( nOfThem, panic, assertPanic )
......
......@@ -11,7 +11,7 @@ module FieldLabel where
IMP_Ubiq(){-uitous-}
import Name ( Name{-instance Eq/Outputable-} )
import Type ( Type(..) )
import Type ( SYN_IE(Type) )
\end{code}
\begin{code}
......
......@@ -6,102 +6,138 @@
\begin{code}
#include "HsVersions.h"
module Id {- (
GenId, Id(..), -- Abstract
StrictnessMark(..), -- An enumaration
ConTag(..), DictVar(..), DictFun(..), DataCon(..),
module Id (
-- TYPES
GenId(..), -- *naughtily* used in some places (e.g., TcHsSyn)
SYN_IE(Id), IdDetails,
StrictnessMark(..),
SYN_IE(ConTag), fIRST_TAG,
SYN_IE(DataCon), SYN_IE(DictFun), SYN_IE(DictVar),
-- CONSTRUCTION
mkSysLocal, mkUserLocal,
mkSpecPragmaId,
mkSpecId, mkSameSpecCon,
selectIdInfoForSpecId,
mkTemplateLocals,
mkImported,
mkDataCon, mkTupleCon,
mkConstMethodId,
mkDataCon,
mkDefaultMethodId,
mkDictFunId,
mkIdWithNewUniq,
mkMethodSelId, mkSuperDictSelId, mkDefaultMethodId,
mkConstMethodId, getConstMethodId,
updateIdType,
mkId, mkDictFunId, mkInstId,
mkImported,
mkInstId,
mkMethodSelId,
mkRecordSelId,
mkSuperDictSelId,
mkSysLocal,
mkTemplateLocals,
mkTupleCon,
mkUserId,
mkUserLocal,
mkWorkerId,
localiseId,
-- DESTRUCTION
-- MANGLING
unsafeGenId2Id,
-- DESTRUCTION (excluding pragmatic info)
idPrimRep,
idType,
getIdInfo, replaceIdInfo,
getPragmaInfo,
idPrimRep, getInstIdModule,
getMentionedTyConsAndClassesFromId,
idUnique,
dataConTag, dataConStrictMarks,
dataConSig, dataConRawArgTys, dataConArgTys,
dataConTyCon, dataConArity,
dataConArgTys,
dataConArity,
dataConNumFields,
dataConFieldLabels,
dataConRawArgTys,
dataConSig,
dataConStrictMarks,
dataConTag,
dataConTyCon,
recordSelectorFieldLabel,
-- PREDICATES
isDataCon, isTupleCon,
isNullaryDataCon,
isSpecId_maybe, isSpecPragmaId_maybe,
toplevelishId, externallyVisibleId,
isTopLevId, isWorkerId, isWrapperId,
isImportedId, isSysLocalId,
isBottomingId,
isMethodSelId, isDefaultMethodId_maybe, isSuperDictSelId_maybe,
isDictFunId,
--??? isInstId_maybe,
isConstMethodId_maybe,
cmpEqDataCon,
cmpId,
cmpId_withSpecDataCon,
myWrapperMaybe,
whatsMentionedInId,
unfoldingUnfriendlyId, -- ToDo: rm, eventually
externallyVisibleId,
idHasNoFreeTyVars,
idWantsToBeINLINEd,
-- dataConMentionsNonPreludeTyCon,
isBottomingId,
isConstMethodId,
isConstMethodId_maybe,
isDataCon,
isDefaultMethodId,
isDefaultMethodId_maybe,
isDictFunId,
isImportedId,
isMethodSelId,
isNullaryDataCon,
isSpecPragmaId,
isSuperDictSelId_maybe,
isSysLocalId,
isTopLevId,
isTupleCon,
isWorkerId,
toplevelishId,
unfoldingUnfriendlyId,
-- SUBSTITUTION
applySubstToId, applyTypeEnvToId,
-- not exported: apply_to_Id, -- please don't use this, generally
-- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
getIdArity, addIdArity,
getIdDemandInfo, addIdDemandInfo,
getIdSpecialisation, addIdSpecialisation,
getIdStrictness, addIdStrictness,
getIdUnfolding, addIdUnfolding,
getIdUpdateInfo, addIdUpdateInfo,
getIdArgUsageInfo, addIdArgUsageInfo,
getIdFBTypeInfo, addIdFBTypeInfo,
-- don't export the types, lest OptIdInfo be dragged in!
-- MISCELLANEOUS
unlocaliseId,
fIRST_TAG,
showId,
pprIdInUnfolding,
applyTypeEnvToId,
apply_to_Id,
-- PRINTING and RENUMBERING
addId,
nmbrDataCon,
nmbrId,
pprId,
showId,
-- "Environments" keyed off of Ids, and sets of Ids
IdEnv(..),
lookupIdEnv, lookupNoFailIdEnv, nullIdEnv, unitIdEnv, mkIdEnv,
growIdEnv, growIdEnvList, isNullIdEnv, addOneToIdEnv,
delOneFromIdEnv, delManyFromIdEnv, modifyIdEnv, combineIdEnvs,
rngIdEnv, mapIdEnv,
-- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
addIdArity,
addIdDemandInfo,
addIdStrictness,
addIdUpdateInfo,
getIdArity,
getIdDemandInfo,
getIdInfo,
getIdStrictness,
getIdUnfolding,
getIdUpdateInfo,
getPragmaInfo,
-- and to make the interface self-sufficient...
GenIdSet(..), IdSet(..)
)-} where
-- IdEnvs AND IdSets
SYN_IE(IdEnv), SYN_IE(GenIdSet), SYN_IE(IdSet),
addOneToIdEnv,
addOneToIdSet,
combineIdEnvs,
delManyFromIdEnv,
delOneFromIdEnv,
elementOfIdSet,
emptyIdSet,
growIdEnv,
growIdEnvList,
idSetToList,
intersectIdSets,
isEmptyIdSet,
isNullIdEnv,
lookupIdEnv,
lookupNoFailIdEnv,
mapIdEnv,
minusIdSet,
mkIdEnv,
mkIdSet,
modifyIdEnv,
nullIdEnv,
rngIdEnv,
unionIdSets,
unionManyIdSets,
unitIdEnv,
unitIdSet
) where
IMP_Ubiq()
IMPORT_DELOOPER(IdLoop) -- for paranoia checking
IMPORT_DELOOPER(TyLoop) -- for paranoia checking
import Bag
import Class ( classOpString, Class(..), GenClass, ClassOp(..), GenClassOp )
import CStrings ( identToC, cSEP )
import Class ( classOpString, SYN_IE(Class), GenClass, SYN_IE(ClassOp), GenClassOp )
import IdInfo
import Maybes ( maybeToBool )
import Name ( appendRdr, nameUnique, mkLocalName, isLocalName,
......@@ -115,7 +151,7 @@ import Name ( appendRdr, nameUnique, mkLocalName, isLocalName,
)
import FieldLabel ( fieldLabelName, FieldLabel(..){-instances-} )
import PragmaInfo ( PragmaInfo(..) )
import PprEnv -- ( NmbrM(..), NmbrEnv(..) )
import PprEnv -- ( SYN_IE(NmbrM), NmbrEnv(..) )
import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix,
nmbrType, nmbrTyVar,
GenType, GenTyVar
......@@ -125,11 +161,11 @@ import Pretty
import SrcLoc ( mkBuiltinSrcLoc )
import TyCon ( TyCon, mkTupleTyCon, tyConDataCons )
import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
applyTyCon, isPrimType, instantiateTy,
applyTyCon, instantiateTy,
tyVarsOfType, applyTypeEnvToTy, typePrimRep,
GenType, ThetaType(..), TauType(..), Type(..)
GenType, SYN_IE(ThetaType), SYN_IE(TauType), SYN_IE(Type)
)
import TyVar ( alphaTyVars, isEmptyTyVarSet, TyVarEnv(..) )
import TyVar ( alphaTyVars, isEmptyTyVarSet, SYN_IE(TyVarEnv) )
import UniqFM
import UniqSet -- practically all of it
import Unique ( getBuiltinUniques, pprUnique, showUnique,
......@@ -797,30 +833,15 @@ externallyVisibleId :: Id -> Bool
externallyVisibleId id@(Id _ _ _ details _ _)
= if isLocallyDefined id then
toplevelishId id && isExported id && not (weird_datacon details)
toplevelishId id && (isExported id || isDataCon id)
-- NB: the use of "isExported" is most dodgy;
-- We may eventually move to a situation where
-- every Id is "externallyVisible", even if the
-- module system's namespace control renders it
-- "not exported".
else
not (weird_tuplecon details)
True
-- if visible here, it must be visible elsewhere, too.
where
-- If it's a DataCon, it's not enough to know it (meaning
-- its TyCon) is exported; we need to know that it might
-- be visible outside. Consider:
--
-- data Foo a = Mumble | BigFoo a WeirdLocalType
--
-- We can't tell the outside world *anything* about Foo, because
-- of WeirdLocalType; but we need to know this when asked if
-- "Mumble" is externally visible...
{- LATER: if at all:
weird_datacon (DataConId _ _ _ _ _ _ tycon)
= maybeToBool (maybePurelyLocalTyCon tycon)
-}
weird_datacon not_a_datacon_therefore_not_weird = False
weird_tuplecon (TupleConId arity)
= arity > 32 -- sigh || isBigTupleTyCon tycon -- generated *purely* for local use
weird_tuplecon _ = False