Skip to content

GitLab

Commit e7498a3e authored by partain's avatar partain
Browse files

[project @ 1996-06-05 06:44:31 by partain] 

SLPJ changes through 960604
parent 30cf375e
Hide whitespace changes
Inline Side-by-side
ghc/compiler/HsVersions.h
View file @ e7498a3e
......@@ -25,7 +25,30 @@ you will screw up the layout where they are used in case expressions!
#else
#define ASSERT(e)
#endif
#define CHK_Ubiq() import Ubiq
#if __STDC__
#define CAT2(a,b)a##b
#else
#define CAT2(a,b)a/**/b
#endif
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 200
# define REALLY_HASKELL_1_3
# define SYN_IE(a) 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 Text Show
#else
# define SYN_IE(a) a(..)
# define IMPORT_DELOOPER(mod) import mod
# define IMPORT_1_3(mod) {--}
#endif
#define IMP_Ubiq() IMPORT_DELOOPER(Ubiq)
#define CHK_Ubiq() IMPORT_DELOOPER(Ubiq)
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 26
#define trace _trace
......@@ -76,7 +99,7 @@ you will screw up the layout where they are used in case expressions!
#endif {- ! __GLASGOW_HASKELL__ -}
#if __GLASGOW_HASKELL__ >= 23
#if __GLASGOW_HASKELL__ >= 23 && __GLASGOW_HASKELL__ < 200
#define USE_FAST_STRINGS 1
#define FAST_STRING _PackedString
#define SLIT(x) (_packCString (A# x#))
......
ghc/compiler/Jmakefile
View file @ e7498a3e
......@@ -27,6 +27,12 @@ SuffixRules_flexish()
SuffixRule_c_o()
LitSuffixRule(.lprl,.prl) /* for makeSymbolList.prl */
.SUFFIXES: .lhi
.lhi.hi:
$(RM) $@
$(GHC_UNLIT) $< $@
@chmod 444 $@
/* assume ALL source is in subdirectories one level below
they don't have Jmakefiles; this Jmakefile controls everything
*/
......@@ -356,6 +362,28 @@ SIMPL_SRCS_LHS \
STG_SRCS_LHS \
BACKSRCS_LHS NATIVEGEN_SRCS_LHS
#if GhcBuilderVersion >= 200
# define loop_hi(f) CAT3(f,_1_3,.hi)
#else
# define loop_hi(f) CAT2(f,.hi)
#endif
DELOOP_HIs = \
utils/Ubiq.hi \
absCSyn/AbsCLoop.hi \
basicTypes/IdLoop.hi \
codeGen/CgLoop1.hi \
codeGen/CgLoop2.hi \
deSugar/DsLoop.hi \
hsSyn/HsLoop.hi \
nativeGen/NcgLoop.hi \
prelude/PrelLoop.hi \
rename/RnLoop.hi \
simplCore/SmplLoop.hi \
typecheck/TcMLoop.hi \
typecheck/TcLoop.hi \
types/TyLoop.hi
/*
\
*/
......@@ -471,36 +499,6 @@ HaskellCompileWithExtraFlags_Recursive(module,isuf,o,-c,extra_flags)
/* OK, here we go: */
utils/Ubiq.hi : utils/Ubiq.lhi
$(GHC_UNLIT) utils/Ubiq.lhi utils/Ubiq.hi
absCSyn/AbsCLoop.hi : absCSyn/AbsCLoop.lhi
$(GHC_UNLIT) absCSyn/AbsCLoop.lhi absCSyn/AbsCLoop.hi
basicTypes/IdLoop.hi : basicTypes/IdLoop.lhi
$(GHC_UNLIT) basicTypes/IdLoop.lhi basicTypes/IdLoop.hi
codeGen/CgLoop1.hi : codeGen/CgLoop1.lhi
$(GHC_UNLIT) codeGen/CgLoop1.lhi codeGen/CgLoop1.hi
codeGen/CgLoop2.hi : codeGen/CgLoop2.lhi
$(GHC_UNLIT) codeGen/CgLoop2.lhi codeGen/CgLoop2.hi
deSugar/DsLoop.hi : deSugar/DsLoop.lhi
$(GHC_UNLIT) deSugar/DsLoop.lhi deSugar/DsLoop.hi
hsSyn/HsLoop.hi : hsSyn/HsLoop.lhi
$(GHC_UNLIT) hsSyn/HsLoop.lhi hsSyn/HsLoop.hi
nativeGen/NcgLoop.hi : nativeGen/NcgLoop.lhi
$(GHC_UNLIT) nativeGen/NcgLoop.lhi nativeGen/NcgLoop.hi
prelude/PrelLoop.hi : prelude/PrelLoop.lhi
$(GHC_UNLIT) prelude/PrelLoop.lhi prelude/PrelLoop.hi
rename/RnLoop.hi : rename/RnLoop.lhi
$(GHC_UNLIT) rename/RnLoop.lhi rename/RnLoop.hi
simplCore/SmplLoop.hi : simplCore/SmplLoop.lhi
$(GHC_UNLIT) simplCore/SmplLoop.lhi simplCore/SmplLoop.hi
typecheck/TcMLoop.hi : typecheck/TcMLoop.lhi
$(GHC_UNLIT) typecheck/TcMLoop.lhi typecheck/TcMLoop.hi
typecheck/TcLoop.hi : typecheck/TcLoop.lhi
$(GHC_UNLIT) typecheck/TcLoop.lhi typecheck/TcLoop.hi
types/TyLoop.hi : types/TyLoop.lhi
$(GHC_UNLIT) types/TyLoop.lhi types/TyLoop.hi
rename/ParseIface.hs : rename/ParseIface.y
$(RM) rename/ParseIface.hs rename/ParseIface.hinfo
happy -g -i rename/ParseIface.hinfo rename/ParseIface.y
......@@ -620,7 +618,7 @@ compile(reader/RdrHsSyn,lhs,)
compile(rename/ParseIface,hs,)
compile(rename/ParseUtils,lhs,)
compile(rename/RnHsSyn,lhs,)
compile(rename/RnMonad,lhs,)
compile(rename/RnMonad,lhs,if_ghc(-fvia-C))
compile(rename/Rename,lhs,)
compile(rename/RnNames,lhs,)
compile(rename/RnSource,lhs,)
......@@ -672,7 +670,7 @@ compile(deforest/Deforest,lhs,)
compile(deforest/TreelessForm,lhs,)
#endif
compile(specialise/Specialise,lhs,)
compile(specialise/Specialise,lhs,-H12m if_ghc(-Onot)) /* -Onot for compile-space reasons */
compile(specialise/SpecEnv,lhs,)
compile(specialise/SpecUtils,lhs,)
......@@ -702,7 +700,7 @@ compile(typecheck/TcInstDcls,lhs,)
compile(typecheck/TcInstUtil,lhs,)
compile(typecheck/TcMatches,lhs,)
compile(typecheck/TcModule,lhs,)
compile(typecheck/TcMonad,lhs,)
compile(typecheck/TcMonad,lhs,if_ghc(-fvia-C))
compile(typecheck/TcKind,lhs,)
compile(typecheck/TcType,lhs,)
compile(typecheck/TcEnv,lhs,)
......@@ -716,7 +714,7 @@ compile(typecheck/Unify,lhs,)
compile(types/Class,lhs,)
compile(types/Kind,lhs,)
compile(types/PprType,lhs,)
compile(types/PprType,lhs,if_ghc26(-Onot)) /* avoid a 0.26 bug */
compile(types/TyCon,lhs,)
compile(types/TyVar,lhs,)
compile(types/Usage,lhs,)
......@@ -822,17 +820,17 @@ InstallBinaryTarget(hsp,$(INSTLIBDIR_GHC))
YaccRunWithExpectMsg(parser/hsparser,12,0)
UgenTarget(parser/constr)
UgenTarget(parser/binding)
UgenTarget(parser/pbinding)
UgenTarget(parser/entidt)
UgenTarget(parser/list)
UgenTarget(parser/literal)
UgenTarget(parser/maybe)
UgenTarget(parser/either)
UgenTarget(parser/qid)
UgenTarget(parser/tree)
UgenTarget(parser/ttype)
UgenTarget(parser,constr)
UgenTarget(parser,binding)
UgenTarget(parser,pbinding)
UgenTarget(parser,entidt)
UgenTarget(parser,list)
UgenTarget(parser,literal)
UgenTarget(parser,maybe)
UgenTarget(parser,either)
UgenTarget(parser,qid)
UgenTarget(parser,tree)
UgenTarget(parser,ttype)
UGENS_C = parser/constr.c \
parser/binding.c \
......@@ -884,6 +882,7 @@ MKDEPENDHS_OPTS= -o .hc -I$(MAIN_INCLUDE_DIR) -I$(COMPINFO_DIR) -x HsVersions.h
#if HaskellCompilerType != HC_USE_HC_FILES
/* otherwise, the dependencies jeopardize our .hc files --
which are all we have! */
depend :: $(DELOOP_HIs)
HaskellDependTarget( $(DEPSRCS) )
#endif
......
ghc/compiler/absCSyn/AbsCSyn.lhs
View file @ e7498a3e
......@@ -35,7 +35,7 @@ module AbsCSyn {- (
CostRes(Cost)
)-} where
import Ubiq{-uitous-}
IMP_Ubiq(){-uitous-}
import CgCompInfo ( mAX_Vanilla_REG, mAX_Float_REG,
mAX_Double_REG, lIVENESS_R1, lIVENESS_R2,
......
ghc/compiler/absCSyn/AbsCUtils.lhs
View file @ e7498a3e
......@@ -19,7 +19,7 @@ module AbsCUtils (
-- printing/forcing stuff comes from PprAbsC
) where
import Ubiq{-uitous-}
IMP_Ubiq(){-uitous-}
import AbsCSyn
......
ghc/compiler/absCSyn/CLabel.lhs
View file @ e7498a3e
......@@ -16,7 +16,9 @@ module CLabel (
mkConEntryLabel,
mkStaticConEntryLabel,
mkRednCountsLabel,
mkConInfoTableLabel,
mkPhantomInfoTableLabel,
mkStaticClosureLabel,
mkStaticInfoTableLabel,
mkVapEntryLabel,
mkVapInfoTableLabel,
......@@ -45,12 +47,12 @@ module CLabel (
#endif
) where
import Ubiq{-uitous-}
import AbsCLoop ( CtrlReturnConvention(..),
IMP_Ubiq(){-uitous-}
IMPORT_DELOOPER(AbsCLoop) ( CtrlReturnConvention(..),
ctrlReturnConvAlg
)
#if ! OMIT_NATIVE_CODEGEN
import NcgLoop ( underscorePrefix, fmtAsmLbl )
IMPORT_DELOOPER(NcgLoop) ( underscorePrefix, fmtAsmLbl )
#endif
import CStrings ( pp_cSEP )
......@@ -110,26 +112,25 @@ unspecialised constructors are compared.
\begin{code}
data CLabelId = CLabelId Id
instance Ord3 CLabelId where
cmp (CLabelId a) (CLabelId b) = cmpId_withSpecDataCon a b
instance Eq CLabelId where
CLabelId a == CLabelId b = case cmpId_withSpecDataCon a b of { EQ_ -> True; _ -> False }
CLabelId a /= CLabelId b = case cmpId_withSpecDataCon a b of { EQ_ -> False; _ -> True }
CLabelId a == CLabelId b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
CLabelId a /= CLabelId b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
instance Ord CLabelId where
CLabelId a <= CLabelId b = case cmpId_withSpecDataCon a b
of { LT_ -> True; EQ_ -> True; GT__ -> False }
CLabelId a < CLabelId b = case cmpId_withSpecDataCon a b
of { LT_ -> True; EQ_ -> False; GT__ -> False }
CLabelId a >= CLabelId b = case cmpId_withSpecDataCon a b
of { LT_ -> False; EQ_ -> True; GT__ -> True }
CLabelId a > CLabelId b = case cmpId_withSpecDataCon a b
of { LT_ -> False; EQ_ -> False; GT__ -> True }
_tagCmp (CLabelId a) (CLabelId b) = case cmpId_withSpecDataCon a b
of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
CLabelId a <= CLabelId b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
CLabelId a < CLabelId b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
CLabelId a >= CLabelId b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
CLabelId a > CLabelId b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
_tagCmp (CLabelId a) (CLabelId b) = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
\end{code}
\begin{code}
data IdLabelInfo
= Closure -- Label for (static???) closure
| StaticClosure -- Static closure -- e.g., nullary constructor
| InfoTbl -- Info table for a closure; always read-only
......@@ -139,14 +140,15 @@ data IdLabelInfo
-- encoded into the name)
| ConEntry -- the only kind of entry pt for constructors
| StaticConEntry -- static constructor entry point
| ConInfoTbl -- corresponding info table
| StaticConEntry -- static constructor entry point
| StaticInfoTbl -- corresponding info table
| PhantomInfoTbl -- for phantom constructors that only exist in regs
| VapInfoTbl Bool -- True <=> the update-reqd version; False <=> the no-update-reqd version
| VapEntry Bool
| VapEntry Bool
-- Ticky-ticky counting
| RednCounts -- Label of place to keep reduction-count info for this Id
......@@ -195,18 +197,28 @@ data RtsLabelInfo
\end{code}
\begin{code}
mkClosureLabel id = IdLabel (CLabelId id) Closure
mkInfoTableLabel id = IdLabel (CLabelId id) InfoTbl
mkStdEntryLabel id = IdLabel (CLabelId id) EntryStd
mkClosureLabel id = IdLabel (CLabelId id) Closure
mkInfoTableLabel id = IdLabel (CLabelId id) InfoTbl
mkStdEntryLabel id = IdLabel (CLabelId id) EntryStd
mkFastEntryLabel id arity = ASSERT(arity > 0)
IdLabel (CLabelId id) (EntryFast arity)
mkConEntryLabel id = IdLabel (CLabelId id) ConEntry
mkStaticConEntryLabel id = IdLabel (CLabelId id) StaticConEntry
mkRednCountsLabel id = IdLabel (CLabelId id) RednCounts
mkPhantomInfoTableLabel id = IdLabel (CLabelId id) PhantomInfoTbl
mkStaticInfoTableLabel id = IdLabel (CLabelId id) StaticInfoTbl
mkVapEntryLabel id upd_flag = IdLabel (CLabelId id) (VapEntry upd_flag)
mkVapInfoTableLabel id upd_flag = IdLabel (CLabelId id) (VapInfoTbl upd_flag)
IdLabel (CLabelId id) (EntryFast arity)
mkStaticClosureLabel con = ASSERT(isDataCon con)
IdLabel (CLabelId con) StaticClosure
mkStaticInfoTableLabel con = ASSERT(isDataCon con)
IdLabel (CLabelId con) StaticInfoTbl
mkConInfoTableLabel con = ASSERT(isDataCon con)
IdLabel (CLabelId con) ConInfoTbl
mkPhantomInfoTableLabel con = ASSERT(isDataCon con)
IdLabel (CLabelId con) PhantomInfoTbl
mkConEntryLabel con = ASSERT(isDataCon con)
IdLabel (CLabelId con) ConEntry
mkStaticConEntryLabel con = ASSERT(isDataCon con)
IdLabel (CLabelId con) StaticConEntry
mkRednCountsLabel id = IdLabel (CLabelId id) RednCounts
mkVapEntryLabel id upd_flag = IdLabel (CLabelId id) (VapEntry upd_flag)
mkVapInfoTableLabel id upd_flag = IdLabel (CLabelId id) (VapInfoTbl upd_flag)
mkConUpdCodePtrVecLabel tycon tag = TyConLabel tycon (VecConUpdCode tag)
mkStdUpdCodePtrVecLabel tycon tag = TyConLabel tycon (StdUpdCode tag)
......@@ -258,11 +270,12 @@ needsCDecl other = True
Whether the labelled thing can be put in C "text space":
\begin{code}
isReadOnly (IdLabel _ InfoTbl) = True -- info-tables: yes
isReadOnly (IdLabel _ StaticInfoTbl) = True -- and so on, for other
isReadOnly (IdLabel _ PhantomInfoTbl) = True
isReadOnly (IdLabel _ (VapInfoTbl _)) = True
isReadOnly (IdLabel _ other) = False -- others: pessimistically, no
isReadOnly (IdLabel _ InfoTbl) = True -- info-tables: yes
isReadOnly (IdLabel _ ConInfoTbl) = True -- and so on, for other
isReadOnly (IdLabel _ StaticInfoTbl) = True
isReadOnly (IdLabel _ PhantomInfoTbl) = True
isReadOnly (IdLabel _ (VapInfoTbl _)) = True
isReadOnly (IdLabel _ other) = False -- others: pessimistically, no
isReadOnly (TyConLabel _ _) = True
isReadOnly (CaseLabel _ _) = True
......@@ -378,7 +391,9 @@ ppFlavor x = uppBeside pp_cSEP
EntryStd -> uppPStr SLIT("entry")
EntryFast arity -> --false:ASSERT (arity > 0)
uppBeside (uppPStr SLIT("fast")) (uppInt arity)
ConEntry -> uppPStr SLIT("entry")
StaticClosure -> uppPStr SLIT("static_closure")
ConEntry -> uppPStr SLIT("con_entry")
ConInfoTbl -> uppPStr SLIT("con_info")
StaticConEntry -> uppPStr SLIT("static_entry")
StaticInfoTbl -> uppPStr SLIT("static_info")
PhantomInfoTbl -> uppPStr SLIT("inregs_info")
......
ghc/compiler/absCSyn/CStrings.lhs
View file @ e7498a3e
......@@ -18,6 +18,12 @@ CHK_Ubiq() -- debugging consistency check
import Pretty
import Unpretty( uppChar )
IMPORT_1_3(Char (isAlphanum))
#ifdef REALLY_HASKELL_1_3
ord = fromEnum :: Char -> Int
chr = toEnum :: Int -> Char
#endif
\end{code}
......
ghc/compiler/absCSyn/Costs.lhs
View file @ e7498a3e
......@@ -57,7 +57,7 @@ module Costs( costs,
addrModeCosts, CostRes(Cost), nullCosts, Side(..)
) where
import Ubiq{-uitous-}
IMP_Ubiq(){-uitous-}
import AbsCSyn
import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
......
ghc/compiler/absCSyn/HeapOffs.lhs
View file @ e7498a3e
......@@ -31,9 +31,9 @@ module HeapOffs (
SpARelOffset(..), SpBRelOffset(..)
) where
import Ubiq{-uitous-}
IMP_Ubiq(){-uitous-}
#if ! OMIT_NATIVE_CODEGEN
import AbsCLoop ( fixedHdrSizeInWords, varHdrSizeInWords )
IMPORT_DELOOPER(AbsCLoop) ( fixedHdrSizeInWords, varHdrSizeInWords )
#endif
import Maybes ( catMaybes )
......
ghc/compiler/absCSyn/PprAbsC.lhs
View file @ e7498a3e
......@@ -18,8 +18,8 @@ module PprAbsC (
#endif
) where
import Ubiq{-uitous-}
import AbsCLoop -- break its dependence on ClosureInfo
IMP_Ubiq(){-uitous-}
IMPORT_DELOOPER(AbsCLoop) -- break its dependence on ClosureInfo
import AbsCSyn
......@@ -62,10 +62,10 @@ call to a cost evaluation function @GRAN_EXEC@. For that,
@pprAbsC@ has a new ``costs'' argument. %% HWL
\begin{code}
writeRealC :: _FILE -> AbstractC -> IO ()
writeRealC :: Handle -> AbstractC -> IO ()
writeRealC file absC
= uppAppendFile file 80 (
writeRealC handle absC
= uppPutStr handle 80 (
uppAbove (pprAbsC PprForC absC (costs absC)) (uppChar '\n')
)
......
ghc/compiler/basicTypes/FieldLabel.lhs
View file @ e7498a3e
......@@ -8,7 +8,7 @@
module FieldLabel where
import Ubiq{-uitous-}
IMP_Ubiq(){-uitous-}
import Name ( Name{-instance Eq/Outputable-} )
import Type ( Type(..) )
......
ghc/compiler/basicTypes/Id.lhs
View file @ e7498a3e
......@@ -36,7 +36,7 @@ module Id {- (
getMentionedTyConsAndClassesFromId,
dataConTag, dataConStrictMarks,
dataConSig, dataConArgTys,
dataConSig, dataConRawArgTys, dataConArgTys,
dataConTyCon, dataConArity,
dataConFieldLabels,
......@@ -44,6 +44,7 @@ module Id {- (
-- PREDICATES
isDataCon, isTupleCon,
isNullaryDataCon,
isSpecId_maybe, isSpecPragmaId_maybe,
toplevelishId, externallyVisibleId,
isTopLevId, isWorkerId, isWrapperId,
......@@ -94,9 +95,9 @@ module Id {- (
GenIdSet(..), IdSet(..)
)-} where
import Ubiq
import IdLoop -- for paranoia checking
import TyLoop -- for paranoia checking
IMP_Ubiq()
IMPORT_DELOOPER(IdLoop) -- for paranoia checking
IMPORT_DELOOPER(TyLoop) -- for paranoia checking
import Bag
import Class ( classOpString, Class(..), GenClass, ClassOp(..), GenClassOp )
......@@ -1043,17 +1044,17 @@ mkSuperDictSelId u c sc ty info
n = mkCompoundName u SLIT("sdsel") [origName cname, origName sc] cname
mkMethodSelId u c op ty info
= Id u n ty (MethodSelId c op) NoPragmaInfo info
mkMethodSelId u rec_c op ty info
= Id u n ty (MethodSelId rec_c op) NoPragmaInfo info
where
cname = getName c -- we get other info out of here
cname = getName rec_c -- we get other info out of here
n = mkCompoundName u SLIT("meth") [origName cname, Unqual (classOpString op)] cname
mkDefaultMethodId u c op gen ty info
= Id u n ty (DefaultMethodId c op gen) NoPragmaInfo info
mkDefaultMethodId u rec_c op gen ty info
= Id u n ty (DefaultMethodId rec_c op gen) NoPragmaInfo info
where
cname = getName c -- we get other info out of here
cname = getName rec_c -- we get other info out of here
n = mkCompoundName u SLIT("defm") [origName cname, Unqual (classOpString op)] cname
......@@ -1227,6 +1228,8 @@ dataConArity id@(Id _ _ _ _ _ id_info)
Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id)
Just i -> i
isNullaryDataCon con = dataConArity con == 0 -- function of convenience
addIdArity :: Id -> Int -> Id
addIdArity (Id u n ty details pinfo info) arity
= Id u n ty details pinfo (info `addInfo` (mkArityInfo arity))
......@@ -1405,6 +1408,9 @@ dataConStrictMarks (Id _ _ _ (DataConId _ stricts _ _ _ _ _) _ _) = stricts
dataConStrictMarks (Id _ _ _ (TupleConId arity) _ _)
= nOfThem arity NotMarkedStrict
dataConRawArgTys :: DataCon -> [TauType] -- a function of convenience
dataConRawArgTys con = case (dataConSig con) of { (_,_, arg_tys,_) -> arg_tys }
dataConArgTys :: DataCon
-> [Type] -- Instantiated at these types
-> [Type] -- Needs arguments of these types
......@@ -1583,15 +1589,15 @@ instance Ord3 (GenId ty) where
cmp = cmpId
instance Eq (GenId ty) where
a == b = case cmpId a b of { EQ_ -> True; _ -> False }
a /= b = case cmpId a b of { EQ_ -> False; _ -> True }
a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
instance Ord (GenId ty) where
a <= b = case cmpId a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
a < b = case cmpId a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
a >= b = case cmpId a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
a > b = case cmpId a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
_tagCmp a b = case cmpId a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
_tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
\end{code}
@cmpId_withSpecDataCon@ ensures that any spectys are taken into
......
ghc/compiler/basicTypes/IdInfo.lhs
View file @ e7498a3e
......@@ -67,9 +67,9 @@ module IdInfo (
) where
import Ubiq
IMP_Ubiq()
import IdLoop -- IdInfo is a dependency-loop ranch, and
IMPORT_DELOOPER(IdLoop) -- IdInfo is a dependency-loop ranch, and
-- we break those loops by using IdLoop and
-- *not* importing much of anything else,
-- except from the very general "utils".
......@@ -77,6 +77,7 @@ import IdLoop -- IdInfo is a dependency-loop ranch, and
import CmdLineOpts ( opt_OmitInterfacePragmas )
import Maybes ( firstJust )
import MatchEnv ( nullMEnv, isEmptyMEnv, mEnvToList )
import OccurAnal ( occurAnalyseGlobalExpr )
import Outputable ( ifPprInterface, Outputable(..){-instances-} )
import PprStyle ( PprStyle(..) )
import Pretty
......@@ -84,10 +85,13 @@ import SrcLoc ( mkUnknownSrcLoc )
import Type ( eqSimpleTy, splitFunTyExpandingDicts )
import Util ( mapAccumL, panic, assertPanic, pprPanic )
#ifdef REALLY_HASKELL_1_3
ord = fromEnum :: Char -> Int
#endif
applySubstToTy = panic "IdInfo.applySubstToTy"
showTypeCategory = panic "IdInfo.showTypeCategory"
mkFormSummary = panic "IdInfo.mkFormSummary"
occurAnalyseGlobalExpr = panic "IdInfo.occurAnalyseGlobalExpr"
isWrapperFor = panic "IdInfo.isWrapperFor"
pprCoreUnfolding = panic "IdInfo.pprCoreUnfolding"
\end{code}
......@@ -607,7 +611,11 @@ as the worker requires. Hence we have to give up altogether, and call
the wrapper only; so under these circumstances we return \tr{False}.
\begin{code}
#ifdef REALLY_HASKELL_1_3
instance Read Demand where
#else
instance Text Demand where
#endif
readList str = read_em [{-acc-}] str
where
read_em acc [] = [(reverse acc, "")]
......@@ -626,6 +634,9 @@ instance Text Demand where
read_em acc other = panic ("IdInfo.readem:"++other)
#ifdef REALLY_HASKELL_1_3
instance Show Demand where
#endif
showList wrap_args rest = (concat (map show1 wrap_args)) ++ rest
where
show1 (WwLazy False) = "L"
......@@ -725,7 +736,7 @@ pp_strictness sty for_this_id_maybe better_id_fn inline_env
\begin{code}
mkUnfolding guide expr
= GenForm False (mkFormSummary NoStrictnessInfo expr)
= GenForm (mkFormSummary NoStrictnessInfo expr)
(occurAnalyseGlobalExpr expr)
guide
\end{code}
......@@ -735,8 +746,8 @@ noInfo_UF = NoUnfoldingDetails
getInfo_UF (IdInfo _ _ _ _ unfolding _ _ _ _ _)
= case unfolding of
GenForm _ _ _ BadUnfolding -> NoUnfoldingDetails
unfolding_as_was -> unfolding_as_was
GenForm _ _ BadUnfolding -> NoUnfoldingDetails
unfolding_as_was -> unfolding_as_was
-- getInfo_UF ensures that any BadUnfoldings are never returned
-- We had to delay the test required in TcPragmas until now due
......@@ -757,9 +768,9 @@ pp_unfolding sty for_this_id inline_env uf_details
pp (MagicForm tag _)
= ppCat [ppPStr SLIT("_MF_"), ppPStr tag]
pp (GenForm _ _ _ BadUnfolding) = pp_NONE
pp (GenForm _ _ BadUnfolding) = pp_NONE
pp (GenForm _ _ template guide)
pp (GenForm _ template guide)
= let
untagged = unTagBinders template
in
......@@ -798,7 +809,11 @@ updateInfoMaybe (SomeUpdateInfo u) = Just u
Text instance so that the update annotations can be read in.
\begin{code}
#ifdef REALLY_HASKELL_1_3
instance Read UpdateInfo where
#else
instance Text UpdateInfo where
#endif
readsPrec p s | null s = panic "IdInfo: empty update pragma?!"
| otherwise = [(SomeUpdateInfo (map ok_digit s),"")]
where
......
ghc/compiler/basicTypes/IdLoop.lhi
View file @ e7498a3e
......@@ -65,11 +65,9 @@ data MagicUnfoldingFun
data FormSummary = WhnfForm | BottomForm | OtherForm
data UnfoldingDetails
= NoUnfoldingDetails
| LitForm Literal
| OtherLitForm [Literal]
| ConForm (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) [GenCoreArg (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique]
| OtherConForm [GenId (GenType (GenTyVar (GenUsage Unique)) Unique)]
| GenForm Bool FormSummary (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique) UnfoldingGuidance
| GenForm FormSummary (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique) UnfoldingGuidance
| MagicForm _PackedString MagicUnfoldingFun
data UnfoldingGuidance
......
ghc/compiler/basicTypes/IdUtils.lhs
View file @ e7498a3e
......@@ -8,19 +8,19 @@
module IdUtils ( primOpNameInfo, primOpId ) where
import Ubiq
import PrelLoop -- here for paranoia checking
IMP_Ubiq()
IMPORT_DELOOPER(PrelLoop) -- here for paranoia checking
import CoreSyn
import CoreUnfold ( UnfoldingGuidance(..) )
import Id ( mkPreludeId )
import Id ( mkPreludeId, mkTemplateLocals )
import IdInfo -- quite a few things
import Name ( mkBuiltinName )
import PrelMods ( pRELUDE_BUILTIN )