Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
e7498a3e
Commit
e7498a3e
authored
Jun 05, 1996
by
partain
Browse files
[project @ 1996-06-05 06:44:31 by partain]
SLPJ changes through 960604
parent
30cf375e
Changes
215
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
fi
le absC
= upp
AppendFile fi
le 80 (
writeRealC
hand
le absC
= upp
PutStr hand
le 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