From f7ecf7234c224489be8a5e63fced903b655d92ee Mon Sep 17 00:00:00 2001
From: partain <unknown>
Date: Fri, 19 Jul 1996 18:38:35 +0000
Subject: [PATCH] [project @ 1996-07-19 18:36:04 by partain] partain 1.3
changes through 960719
---
ghc/compiler/Jmakefile | 23 +-
ghc/compiler/README | 34 -
ghc/compiler/absCSyn/CLabel.lhs | 4 +-
ghc/compiler/basicTypes/Id.lhs | 3 +-
ghc/compiler/basicTypes/IdInfo.lhs | 3 +-
ghc/compiler/basicTypes/IdLoop_1_3.lhi | 2 +
ghc/compiler/basicTypes/IdUtils.lhs | 2 +-
ghc/compiler/basicTypes/Jmakefile | 12 -
ghc/compiler/basicTypes/Name.lhs | 6 +-
ghc/compiler/basicTypes/basicTypes.lit | 36 -
ghc/compiler/codeGen/ClosureInfo.lhs | 8 +-
ghc/compiler/codeGen/Jmakefile | 19 -
ghc/compiler/codeGen/cgintro.lit | 783 ---------------------
ghc/compiler/coreSyn/CoreUnfold.lhs | 4 +-
ghc/compiler/coreSyn/PprCore.lhs | 1 -
ghc/compiler/coreSyn/root.lit | 41 --
ghc/compiler/deSugar/DsBinds.lhs | 10 +-
ghc/compiler/deSugar/DsExpr.lhs | 19 +-
ghc/compiler/deSugar/DsUtils.lhs | 14 +-
ghc/compiler/deSugar/Jmakefile | 11 -
ghc/compiler/deSugar/intro.lit | 24 -
ghc/compiler/deSugar/root.lit | 53 --
ghc/compiler/hsSyn/HsDecls.lhs | 2 +-
ghc/compiler/hsSyn/HsExpr.lhs | 2 +-
ghc/compiler/main/CmdLineOpts.lhs | 6 +-
ghc/compiler/main/MkIface.lhs | 6 +-
ghc/compiler/nativeGen/Jmakefile | 22 -
ghc/compiler/nativeGen/root.lit | 60 --
ghc/compiler/parser/hschooks.c | 2 +-
ghc/compiler/prelude/Jmakefile | 19 -
ghc/compiler/prelude/Makefile-fig | 18 -
ghc/compiler/prelude/PrelInfo.lhs | 1 +
ghc/compiler/prelude/PrelVals.lhs | 21 +-
ghc/compiler/prelude/PrimOp.lhs | 2 +-
ghc/compiler/prelude/TysWiredIn.lhs | 4 +-
ghc/compiler/prelude/prelude-structure.fig | 67 --
ghc/compiler/prelude/prelude-structure.tex | 7 -
ghc/compiler/prelude/prelude.lit | 420 -----------
ghc/compiler/reader/Jmakefile | 18 -
ghc/compiler/reader/reader.lit | 30 -
ghc/compiler/rename/ParseIface.y | 8 +-
ghc/compiler/rename/ParseUtils.lhs | 4 +-
ghc/compiler/rename/Rename.lhs | 29 +-
ghc/compiler/rename/RnBinds.lhs | 4 +-
ghc/compiler/rename/RnExpr.lhs | 2 +-
ghc/compiler/rename/RnHsSyn.lhs | 8 +-
ghc/compiler/rename/RnIfaces.lhs | 34 +-
ghc/compiler/rename/RnMonad.lhs | 8 +-
ghc/compiler/rename/RnNames.lhs | 12 +-
ghc/compiler/rename/RnSource.lhs | 8 +-
ghc/compiler/root.lit | 115 ---
ghc/compiler/simplCore/FloatIn.lhs | 2 +-
ghc/compiler/simplCore/SimplCase.lhs | 28 +-
ghc/compiler/simplCore/SimplCore.lhs | 5 +-
ghc/compiler/simplCore/SimplEnv.lhs | 2 +-
ghc/compiler/simplCore/Simplify.lhs | 59 +-
ghc/compiler/simplCore/simplifier.tib | 2 +-
ghc/compiler/specialise/SpecEnv.lhs | 19 +-
ghc/compiler/stgSyn/CoreToStg.lhs | 14 +-
ghc/compiler/stgSyn/Jmakefile | 5 -
ghc/compiler/stgSyn/root.lit | 9 -
ghc/compiler/typecheck/Inst.lhs | 2 +-
ghc/compiler/typecheck/Jmakefile | 11 -
ghc/compiler/typecheck/TcClassDcl.lhs | 3 +-
ghc/compiler/typecheck/TcClassSig.lhs | 93 ---
ghc/compiler/typecheck/TcDeriv.lhs | 24 +-
ghc/compiler/typecheck/TcEnv.lhs | 4 +-
ghc/compiler/typecheck/TcInstDcls.lhs | 2 +-
ghc/compiler/typecheck/TcInstUtil.lhs | 25 +-
ghc/compiler/typecheck/TcLoop.lhs | 7 -
ghc/compiler/typecheck/TcMonad.lhs | 8 +-
ghc/compiler/typecheck/TcMonoType.lhs | 2 +-
ghc/compiler/typecheck/TcPat.lhs | 6 +-
ghc/compiler/typecheck/TcPragmas.lhs | 672 ------------------
ghc/compiler/typecheck/TcSimplify.lhs | 6 +-
ghc/compiler/typecheck/TcTyDecls.lhs | 2 +-
ghc/compiler/typecheck/TcType.lhs | 22 +-
ghc/compiler/typecheck/root.lit | 71 --
ghc/compiler/types/Class.lhs | 4 +-
ghc/compiler/types/PprType.lhs | 7 +-
ghc/compiler/types/TyCon.lhs | 2 +-
ghc/compiler/types/Type.lhs | 22 +-
ghc/compiler/utils/Util.lhs | 2 +-
83 files changed, 280 insertions(+), 2913 deletions(-)
delete mode 100644 ghc/compiler/basicTypes/Jmakefile
delete mode 100644 ghc/compiler/basicTypes/basicTypes.lit
delete mode 100644 ghc/compiler/codeGen/Jmakefile
delete mode 100644 ghc/compiler/codeGen/cgintro.lit
delete mode 100644 ghc/compiler/coreSyn/root.lit
delete mode 100644 ghc/compiler/deSugar/Jmakefile
delete mode 100644 ghc/compiler/deSugar/intro.lit
delete mode 100644 ghc/compiler/deSugar/root.lit
delete mode 100644 ghc/compiler/nativeGen/Jmakefile
delete mode 100644 ghc/compiler/nativeGen/root.lit
delete mode 100644 ghc/compiler/prelude/Jmakefile
delete mode 100644 ghc/compiler/prelude/Makefile-fig
delete mode 100644 ghc/compiler/prelude/prelude-structure.fig
delete mode 100644 ghc/compiler/prelude/prelude-structure.tex
delete mode 100644 ghc/compiler/prelude/prelude.lit
delete mode 100644 ghc/compiler/reader/Jmakefile
delete mode 100644 ghc/compiler/reader/reader.lit
delete mode 100644 ghc/compiler/root.lit
delete mode 100644 ghc/compiler/stgSyn/Jmakefile
delete mode 100644 ghc/compiler/stgSyn/root.lit
delete mode 100644 ghc/compiler/typecheck/Jmakefile
delete mode 100644 ghc/compiler/typecheck/TcClassSig.lhs
delete mode 100644 ghc/compiler/typecheck/TcLoop.lhs
delete mode 100644 ghc/compiler/typecheck/TcPragmas.lhs
delete mode 100644 ghc/compiler/typecheck/root.lit
diff --git a/ghc/compiler/Jmakefile b/ghc/compiler/Jmakefile
index aa105780b78a..7bc091c90d28 100644
--- a/ghc/compiler/Jmakefile
+++ b/ghc/compiler/Jmakefile
@@ -402,9 +402,17 @@ ALLINTS=$(ALLSRCS_LHS:.lhs=.hi) $(ALLSRCS_HS:.hs=.hi)
#endif
#if GhcWithHscOptimised == YES
-#define __version_sensitive_flags -O /*-DUSE_ATTACK_PRAGMAS -fshow-pragma-name-errs*/ -fomit-reexported-instances -fshow-import-specs
+# if GhcBuilderVersion >= 200
+# define __version_sensitive_flags -O -fshow-import-specs
+# else
+# define __version_sensitive_flags -O -fshow-import-specs -fomit-derived-read -fomit-reexported-instances
+# endif
#else
-#define __version_sensitive_flags -fomit-reexported-instances
+# if GhcBuilderVersion >= 200
+# define __version_sensitive_flags /*none*/
+# else
+# define __version_sensitive_flags -fomit-derived-read -fomit-reexported-instances
+# endif
#endif
/* avoid use of AllProjectsHcOpts; then put in HcMaxHeapFlag "by hand" */
@@ -412,8 +420,7 @@ ALLINTS=$(ALLSRCS_LHS:.lhs=.hi) $(ALLSRCS_HS:.hs=.hi)
#define AllProjectsHcOpts /**/
HC_OPTS = -cpp HcMaxHeapFlag -fhaskell-1.3 -fglasgow-exts -DCOMPILING_GHC \
- -fomit-derived-read \
- -I. -i$(SUBDIR_LIST) \
+ -Rghc-timing -I. -i$(SUBDIR_LIST) \
use_DDEBUG __version_sensitive_flags __omit_ncg_maybe __omit_deforester_flag
#undef __version_sensitive_flags
@@ -502,7 +509,7 @@ HaskellCompileWithExtraFlags_Recursive(module,isuf,o,-c,extra_flags)
rename/ParseIface.hs : rename/ParseIface.y
$(RM) rename/ParseIface.hs rename/ParseIface.hinfo
- happy -g -i rename/ParseIface.hinfo rename/ParseIface.y
+ happy -g rename/ParseIface.y
@chmod 444 rename/ParseIface.hs
compile(absCSyn/AbsCUtils,lhs,)
@@ -706,7 +713,7 @@ compile(typecheck/TcType,lhs,)
compile(typecheck/TcEnv,lhs,)
compile(typecheck/TcMonoType,lhs,)
compile(typecheck/TcPat,lhs,)
-compile(typecheck/TcPragmas,lhs,)
+/*compile(typecheck/TcPragmas,lhs,)*/
compile(typecheck/TcSimplify,lhs,)
compile(typecheck/TcTyClsDecls,lhs,)
compile(typecheck/TcTyDecls,lhs,)
@@ -745,12 +752,10 @@ objs:: $(ALLOBJS)
/* *** parser ************************************************* */
YACC_OPTS = -d
-CC_OPTS = -Iparser -I. -I$(COMPINFO_DIR) -DUGEN_DEBUG=1 /*-DHSP_DEBUG=1*/ -g
+CC_OPTS = -Iparser -I. -I$(COMPINFO_DIR) /*-DUGEN_DEBUG=1*/ /*-DHSP_DEBUG=1*/
/* add to these on the command line with, e.g., EXTRA_YACC_OPTS=-v */
-XCOMM D_DEBUG = -DDEBUG
-
CPP_DEFINES = $(D_DEBUG)
HSP_SRCS_C = parser/constr.c \
diff --git a/ghc/compiler/README b/ghc/compiler/README
index 0830fb3d4ef7..ca619cdde0d2 100644
--- a/ghc/compiler/README
+++ b/ghc/compiler/README
@@ -9,37 +9,3 @@ includes some tests that we use to make sure we're not going
backwards. The subdirs of the test directory "match" the subdirs of
the main source directory; e.g., the desugarer is in subdir deSugar/,
and the tests for the desugarer are in tests/deSugar/.
-
-The main information about how the compiler goes together is in
-./Jmakefile. The list of modules under "FRONTSRCS_LHS =",
-"TCSRCS_LHS =", etc., should show the basic organization of the (many)
-modules.
-
-TO ADD A MODULE TO THE COMPILER:
-
-0. Be familiar with "How to add an optimisation pass..." (in
- ghc/docs/add_to_compiler).
-
-1. Create an appropriately-named module in an appropriate subdirectory.
-
-2. Edit the Jmakefile:
-
- * If you created a new subdirectory for the module, add that
- directory to the SUBDIR_LIST and DASH_I_SUBDIR_LIST lists.
-
- * Add your module to one of the lists of modules in the compiler;
- e.g., TCSRCS_LHS.
-
-3. Re-make the Makefile: "make Makefile"
-
-4. Re-make the automatically-generated dependencies: "make depend".
-
-Your new module is now "wired in" and you may proceed normally...
-
- % make
-
-(see also: day-to-day make-worlding section of developer's guide, near
-the end)
-
-5. If you want to set up automagically (re-)runnable tests, follow
- the suggests in the file tests/README.
diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs
index 284d6e765cd6..1ecd2e10365c 100644
--- a/ghc/compiler/absCSyn/CLabel.lhs
+++ b/ghc/compiler/absCSyn/CLabel.lhs
@@ -66,11 +66,11 @@ import Id ( externallyVisibleId, cmpId_withSpecDataCon,
import Maybes ( maybeToBool )
import PprStyle ( PprStyle(..) )
import PprType ( showTyCon, GenType{-instance Outputable-} )
-import Pretty ( prettyToUn, ppPStr{-ToDo:rm-} )
+import Pretty ( prettyToUn{-, ppPStr ToDo:rm-} )
import TyCon ( TyCon{-instance Eq-} )
import Unique ( showUnique, pprUnique, Unique{-instance Eq-} )
import Unpretty -- NOTE!! ********************
-import Util ( assertPanic, pprTrace{-ToDo:rm-} )
+import Util ( assertPanic{-, pprTraceToDo:rm-} )
\end{code}
things we want to find out:
diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index ec613d6e9a9c..70963624a956 100644
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -165,7 +165,6 @@ import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix,
)
import PprStyle
import Pretty
-import SpecEnv ( SpecEnv(..) )
import MatchEnv ( MatchEnv )
import SrcLoc ( mkBuiltinSrcLoc )
import TyCon ( TyCon, mkTupleTyCon, tyConDataCons )
@@ -1057,7 +1056,7 @@ mkWorkerId u unwrkr ty info
= Id u n ty (WorkerId unwrkr) NoPragmaInfo info
where
unwrkr_name = getName unwrkr
- unwrkr_orig = trace "mkWorkerId:origName:" $ origName "mkWorkerId" unwrkr_name
+ unwrkr_orig = origName "mkWorkerId" unwrkr_name
umod = moduleOf unwrkr_orig
n = mkCompoundName u umod SLIT("wrk") [Left unwrkr_orig] unwrkr_name
diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs
index 0f7f0eb2ba40..4bfc2c864f6c 100644
--- a/ghc/compiler/basicTypes/IdInfo.lhs
+++ b/ghc/compiler/basicTypes/IdInfo.lhs
@@ -30,7 +30,6 @@ module IdInfo (
mkDemandInfo,
willBeDemanded,
- MatchEnv, -- the SpecEnv (why is this exported???)
StrictnessInfo(..), -- non-abstract
Demand(..), -- non-abstract
@@ -275,7 +274,7 @@ ppIdInfo sty for_this_id specs_please better_id_fn inline_env
else pp_unfolding sty for_this_id inline_env unfold,
if specs_please
- then panic "ppSpecs (ToDo)" -- sty (not (isDataCon for_this_id))
+ then pp_NONE -- ToDo -- sty (not (isDataCon for_this_id))
-- better_id_fn inline_env (mEnvToList specenv)
else pp_NONE,
diff --git a/ghc/compiler/basicTypes/IdLoop_1_3.lhi b/ghc/compiler/basicTypes/IdLoop_1_3.lhi
index 38ee2b9d0a06..30804febc88f 100644
--- a/ghc/compiler/basicTypes/IdLoop_1_3.lhi
+++ b/ghc/compiler/basicTypes/IdLoop_1_3.lhi
@@ -4,6 +4,7 @@ __exports__
CoreSyn CoreExpr
CoreUnfold FormSummary (..)
CoreUnfold Unfolding (..)
+CoreUnfold SimpleUnfolding (..)
CoreUnfold UnfoldingGuidance (..)
CoreUtils unTagBinders (..)
Id IdEnv
@@ -19,6 +20,7 @@ MagicUFs MagicUnfoldingFun
MagicUFs mkMagicUnfoldingFun (..)
OccurAnal occurAnalyseGlobalExpr (..)
PprType pprParendGenType (..)
+SpecEnv SpecEnv
SpecEnv isNullSpecEnv (..)
SpecEnv nullSpecEnv (..)
WwLib mAX_WORKER_ARGS (..)
diff --git a/ghc/compiler/basicTypes/IdUtils.lhs b/ghc/compiler/basicTypes/IdUtils.lhs
index 12c8d34d54de..94703c3fd594 100644
--- a/ghc/compiler/basicTypes/IdUtils.lhs
+++ b/ghc/compiler/basicTypes/IdUtils.lhs
@@ -10,12 +10,12 @@ module IdUtils ( primOpNameInfo, primOpId ) where
IMP_Ubiq()
IMPORT_DELOOPER(PrelLoop) -- here for paranoia checking
+IMPORT_DELOOPER(IdLoop) (SpecEnv)
import CoreSyn
import CoreUnfold ( UnfoldingGuidance(..), Unfolding )
import Id ( mkImported, mkTemplateLocals )
import IdInfo -- quite a few things
-import SpecEnv ( SpecEnv )
import Name ( mkPrimitiveName, OrigName(..) )
import PrelMods ( gHC_BUILTINS )
import PrimOp ( primOpInfo, tagOf_PrimOp, primOp_str,
diff --git a/ghc/compiler/basicTypes/Jmakefile b/ghc/compiler/basicTypes/Jmakefile
deleted file mode 100644
index 46f17a0453d6..000000000000
--- a/ghc/compiler/basicTypes/Jmakefile
+++ /dev/null
@@ -1,12 +0,0 @@
-/* this is a standalone Jmakefile; NOT part of ghc "make world" */
-
-LitStuffNeededHere(docs depend)
-InfoStuffNeededHere(docs)
-
-HaskellSuffixRules()
-
-/* LIT2LATEX_OPTS=-tbird */
-
-LIT2LATEX_OPTS=-ttgrind
-
-LitDocRootTargetWithNamedOutput(basicTypes,lit,basicTypes-standalone)
diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs
index d3eb0d5541b8..3fdedfbd8ca2 100644
--- a/ghc/compiler/basicTypes/Name.lhs
+++ b/ghc/compiler/basicTypes/Name.lhs
@@ -70,7 +70,7 @@ import SrcLoc ( mkBuiltinSrcLoc, mkUnknownSrcLoc, SrcLoc )
import Unique ( funTyConKey, mkTupleDataConUnique, mkTupleTyConUnique,
pprUnique, Unique
)
-import Util ( thenCmp, _CMP_STRING_, nOfThem, panic, assertPanic, pprTrace{-ToDo:rm-} )
+import Util ( thenCmp, _CMP_STRING_, nOfThem, panic, assertPanic{-, pprTrace ToDo:rm-} )
#ifdef REALLY_HASKELL_1_3
ord = fromEnum :: Char -> Int
@@ -376,7 +376,7 @@ changeUnique (Global _ m n p e os) u = Global u m n p e os
nameOrigName msg (Global _ m (Left n) _ _ _) = OrigName m n
nameOrigName msg (Global _ m (Right n) _ _ _) = let str = _CONCAT_ (glue n) in
- pprTrace ("nameOrigName:"++msg) (ppPStr str) $
+ --pprTrace ("nameOrigName:"++msg) (ppPStr str) $
OrigName m str
#ifdef DEBUG
nameOrigName msg (Local _ n _ _) = panic ("nameOrigName:Local:"++msg++":"++ _UNPK_ n)
@@ -385,7 +385,7 @@ nameOrigName msg (Local _ n _ _) = panic ("nameOrigName:Local:"++msg++":"++
nameOccName (Local _ n _ _) = Unqual n
nameOccName (Global _ m (Left n) _ _ [] ) = Qual m n
nameOccName (Global _ m (Right n) _ _ [] ) = let str = _CONCAT_ (glue n) in
- pprTrace "nameOccName:" (ppPStr str) $
+ --pprTrace "nameOccName:" (ppPStr str) $
Qual m str
nameOccName (Global _ m (Left _) _ _ (o:_)) = o
nameOccName (Global _ m (Right _) _ _ (o:_)) = panic "nameOccName:compound name"
diff --git a/ghc/compiler/basicTypes/basicTypes.lit b/ghc/compiler/basicTypes/basicTypes.lit
deleted file mode 100644
index 6490447b4b95..000000000000
--- a/ghc/compiler/basicTypes/basicTypes.lit
+++ /dev/null
@@ -1,36 +0,0 @@
-\begin{onlystandalone}
-\documentstyle[11pt,literate]{article}
-\begin{document}
-\title{Glasgow Haskell compiler: basicTypes}
-\author{The GRASP team}
-\date{August 1993}
-\maketitle
-\begin{rawlatex}
-\tableofcontents
-\pagebreak
-\end{rawlatex}
-\end{onlystandalone}
-
-\begin{onlypartofdoc}
-\section[basicTypes]{Basic types in GHC (alphabetically)}
-\downsection
-\end{onlypartofdoc}
-
-\input{CLabelInfo.lhs}
-\input{BasicLit.lhs}
-\input{Id.lhs}
-\input{IdInfo.lhs}
-\input{Inst.lhs}
-\input{NameTypes.lhs}
-\input{ProtoName.lhs}
-\input{SrcLoc.lhs}
-\input{Unique.lhs}
-
-\upsection
-\begin{onlypartofdoc}
-\upsection
-\end{onlypartofdoc}
-\begin{onlystandalone}
-\printindex
-\end{document}
-\end{onlystandalone}
diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs
index 1d4afc3ab692..73f9e6f4b793 100644
--- a/ghc/compiler/codeGen/ClosureInfo.lhs
+++ b/ghc/compiler/codeGen/ClosureInfo.lhs
@@ -91,7 +91,7 @@ import Maybes ( assocMaybe, maybeToBool )
import Name ( isLocallyDefined, nameOf, origName )
import PprStyle ( PprStyle(..) )
import PprType ( getTyDescription, GenType{-instance Outputable-} )
-import Pretty--ToDo:rm
+--import Pretty--ToDo:rm
import PrelInfo ( maybeCharLikeTyCon, maybeIntLikeTyCon )
import PrimRep ( getPrimRepSize, separateByPtrFollowness )
import SMRep -- all of it
@@ -1161,8 +1161,8 @@ fun_result_ty arity id
(_, de_foralld_ty) = splitForAllTy (idType id)
(arg_tys, res_ty) = splitFunTyExpandingDictsAndPeeking de_foralld_ty
in
- -- ASSERT(arity >= 0 && length arg_tys >= arity)
- (if (arity >= 0 && length arg_tys >= arity) then (\x->x) else pprPanic "fun_result_ty:" (ppCat [ppInt arity, ppr PprShowAll id, ppr PprDebug (idType id)])) $
+ ASSERT(arity >= 0 && length arg_tys >= arity)
+-- (if (arity >= 0 && length arg_tys >= arity) then (\x->x) else pprPanic "fun_result_ty:" (ppCat [ppInt arity, ppr PprShowAll id, ppr PprDebug (idType id)])) $
mkFunTys (drop arity arg_tys) res_ty
\end{code}
@@ -1261,7 +1261,7 @@ fastLabelFromCI (MkClosureInfo id _ _) = mkFastEntryLabel id fun_arity
arity_maybe = arityMaybe (getIdArity id)
fun_arity = case arity_maybe of
Just x -> x
- _ -> pprPanic "fastLabelFromCI:no arity:" (ppr PprShowAll id)
+ _ -> panic "fastLabelFromCI:no arity:" --(ppr PprShowAll id)
\end{code}
\begin{code}
diff --git a/ghc/compiler/codeGen/Jmakefile b/ghc/compiler/codeGen/Jmakefile
deleted file mode 100644
index 03e6c14122ad..000000000000
--- a/ghc/compiler/codeGen/Jmakefile
+++ /dev/null
@@ -1,19 +0,0 @@
-/* this is a standalone Jmakefile; NOT part of ghc "make world" */
-
-LitStuffNeededHere(docs depend)
-InfoStuffNeededHere(docs)
-HaskellSuffixRules()
-
-LitSuffixRule(.lit,/*none*/) /* no language really */
-LitSuffixRule(.lhs,.hs) /* Haskell */
-LitSuffixRule(.lhc,.hc) /* Haskell assembler (C) */
-LitSuffixRule(.lprl,.prl) /* Perl */
-LitSuffixRule(.lsh,.sh) /* Bourne shell */
-LitSuffixRule(.lc,.c) /* C */
-LitSuffixRule(.lh,.h)
-LitSuffixRule(.llex,.lex) /* Lex */
-LitSuffixRule(.lflex,.flex) /* Flex */
-
-LIT2LATEX_OPTS=-ttgrind
-
-LitDocRootTargetWithNamedOutput(codegen,lit,codegen-standalone)
diff --git a/ghc/compiler/codeGen/cgintro.lit b/ghc/compiler/codeGen/cgintro.lit
deleted file mode 100644
index 4df253e4bcf1..000000000000
--- a/ghc/compiler/codeGen/cgintro.lit
+++ /dev/null
@@ -1,783 +0,0 @@
-\section[codegen-intro]{Intro/background info for the code generator}
-
-\tr{NOTES.codeGen} LIVES!!!
-
-\begin{verbatim}
-=======================
-NEW! 10 Nov 93 Semi-tagging
-
-Rough idea
-
- case x of -- NB just a variable scrutinised
- [] -> ...
- (p:ps) -> ...p... -- eg. ps not used
-
-generates
-
- Node = a ptr to x
- while TRUE do { switch TAG(Node) {
-
- INDIRECTION_TAG : Node = Node[1]; break; -- Dereference indirection
-
- OTHER_TAG : adjust stack; push return address; ENTER(Node)
-
- 0 : adjust stack;
- JUMP( Nil_case )
-
- 1 : adjust stack;
- R2 := Node[2] -- Get ps
- JUMP( Cons_case )
- }
-
-* The "return address" is a vector table, which contains pointers to
- Nil_case and Cons_case.
-
-* The "adjust stack" in the case of OTHER_TAG is one word different to
- that in the case of a constructor tag (0,1,...), because it needs to
- take account of the return address. That's why the stack adjust
- shows up in the branches, rather than before the switch.
-
-* In the case of *unvectored* returns, the "return address" will be
- some code which switches on TagReg. Currently, the branches of the
- case at the return address have the code for the alternatives
- actually there:
-
- switch TagReg {
- 0 : code for nil case
- 1 : code for cons case
- }
-
-But with semi-tagging, we'll have to label each branch:
-
- switch TagReg {
- 0 : JUMP( Nil_case )
- 1 : JUMP( Cons_case )
- }
-
-So there's an extra jump. Boring. Boring. (But things are usually
-eval'd...in which case we save a jump.)
-
-* TAG is a macro which gets a "tag" from the info table. The tag
- encodes whether the thing is (a) an indirection, (b) evaluated
- constructor with tag N, or (c) something else. The "something else"
- usually indicates something unevaluated, but it might also include
- FETCH_MEs etc. Anything which must be entered.
-
-* Maybe we should get the info ptr out of Node, into a temporary
- InfoPtrReg, so that TAG and ENTER share the info-ptr fetch.
-
-* We only load registers which are live in the alternatives. So at
- the start of an alternative, either the unused fields *will* be in
- regs (if we came via enter/return) or they *won't* (if we came via
- the semi-tagging switch). If they aren't, GC had better not follow
- them. So we can't arrange that all live ptrs are neatly lined up in
- the first N regs any more. So GC has to take a liveness
- bit-pattern, not just a "number of live regs" number.
-
-* We need to know which of the constructors fields are live in the
- alternatives. Hence STG code has to be elaborated to keep live vars
- for each alternative, or to tag each bound-var in the alternatives
- with whether or not it is used.
-
-* The code generator needs to be able to construct unique labels for
- the case alternatives. (Previously this was done by the AbsC
- flattening pass.) Reason: we now have an explicit join point at the
- start of each alternative.
-
-* There's some question about how tags are mapped. Is 0 the first
- tag? (Good when switching on TagReg when there are only two
- constructors.) What is OTHER_TAG and INDIRECTION_TAG?
-
-* This whole deal can be freely mixed with un-semi-tagged code.
- There should be a compiler flag to control it.
-
-=======================
-Many of the details herein are moldy and dubious, but the general
-principles are still mostly sound.
-\end{verbatim}
-
-%************************************************************************
-%* *
-\subsection{LIST OF OPTIMISATIONS TO DO}
-%* *
-%************************************************************************
-
-\begin{itemize}
-\item
-Register return conventions.
-
-\item
-Optimisations for Enter when
- \begin{itemize}
- \item
- know code ptr, so don't indirect via Node
- \item
- know how many args
- \item
- top level closures don't load Node
- \end{itemize}
-\item
-Strings.
-
-\item
-Case of unboxed op with more than one alternative, should generate
-a switch or an if statement.
-\end{itemize}
-
-{\em Medium}
-
-\begin{itemize}
-\item
-Don't allocate constructors with no args.
-Instead have a single global one.
-
-\item
-Have global closures for all characters, and all small numbers.
-\end{itemize}
-
-
-{\em Small}
-
-\begin{itemize}
-\item
-When a closure is one of its own free variables, don't waste a field
-on it. Instead just use Node.
-\end{itemize}
-
-
-%************************************************************************
-%* *
-\subsection{ENTERING THE GARBAGE COLLECTOR}
-%* *
-%************************************************************************
-
-[WDP: OLD]
-
-There are the following ways to get into the garbage collector:
-
-\begin{verbatim}
-_HEAP_OVERFLOW_ReturnViaNode
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Used for the GC trap at closure entry.
-
- - Node is only live ptr
- - After GC, enter Node
-
-_HEAP_OVERFLOW_ReturnDirect0, _HEAP_OVERFLOW_ReturnDirect1, ...
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Used: for fast entry of functions, and
- case alternative where values are returned in regs
-
- - PtrReg1..n are live ptrs
- - ReturnReg points to start of code (before hp oflo check)
- - After GC, jump to ReturnReg
- - TagReg is preserved, in case this is an unvectored return
-
-
-_HEAP_OVERFLOW_CaseReturnViaNode
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- *** GRIP ONLY ***
-
-Used for case alternatives which return node in heap
-
- - Node is only live ptr
- - RetVecReg points to return vector
- - After GC, push RetVecReg and enter Node
-\end{verbatim}
-
-Exactly equivalent to @GC_ReturnViaNode@, preceded by pushing @ReturnVectorReg@.
-
-The only reason we re-enter Node is so that in a GRIP-ish world, the
-closure pointed to be Node is re-loaded into local store if necessary.
-
-%************************************************************************
-%* *
-\subsection{UPDATES}
-%* *
-%************************************************************************
-
-[New stuff 27 Nov 91]
-
-\subsubsection{Return conventions}
-%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-When executing the update continuation code for a constructor,
-@RetVecReg@ points to the {\em beginning of} the return vector. This is to
-enable the update code to find the normal continuation code.
-(@RetVecReg@ is set up by the code which jumps to the update continuation
-code.)
-
-\subsubsection{Stack arrangement}
-%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Each stack has a ``stack update ptr'', SuA and SuB, which point to the
-topmost word of the stack just after an update frame has been pushed.
-
-A standard update frame (on the B stack) looks like this
-(stack grows downward in this picture):
-
-\begin{verbatim}
- | |
- |---------------------------------------|
- | Saved SuA |
- |---------------------------------------|
- | Saved SuB |
- |---------------------------------------|
- | Pointer to closure to be updated |
- |---------------------------------------|
- | Pointer to Update return vector |
- |---------------------------------------|
-\end{verbatim}
-
-The SuB therefore points to the Update return vector component of the
-topmost update frame.
-
-A {\em constructor} update frame, which is pushed only by closures
-which know they will evaluate to a data object, looks just the
-same, but without the saved SuA pointer.
-
-\subsubsection{Pushing update frames}
-%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-An update is pushed right at the start of the code for an updatable
-closure. But {\em after} the stack overflow check. (The B-stack oflo
-check should thereby include allowance for the update frame itself.)
-
-\subsubsection{Return vectors}
-%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Every ``return address'' pushed on the stack by a boxed \tr{case} is a
-pointer to a vector of one or more pairs of code pointers:
-
-\begin{verbatim}
- ------> -----------------
- | Cont1 |
- |---------------|
- | Update1 |
- -----------------
- | Cont2 |
- |---------------|
- | Update2 |
- -----------------
- ...etc...
-\end{verbatim}
-
-Each pair consists of a {\em continuation} code pointer and an
-{\em update} code pointer.
-
-For data types with only one constructor, or too many constructors for
-vectoring, the return vector consists of a single pair.
-
-When the \tr{data} decl for each data type is compiled, as well as
-making info tables for each constructor, an update code sequence for
-each constructor (or a single one, if unvectored) is also created.
-
-ToDo: ** record naming convention for these code sequences somewhere **
-
-When the update code is entered, it uses the value stored in the
-return registers used by that constructor to update the thing pointed
-to by the update frame (all of which except for the return address is
-still on the B stack). If it can do an update in place (ie
-constructor takes 3 words or fewer) it does so.
-
-In the unvectored case, this code first has to do a switch on the tag,
-UNLESS the return is in the heap, in which case simply overwrite with
-an indirection to the thing Node points to.
-
-Tricky point: if the update code can't update in place it has to
-allocate a new object, by performing a heap-oflo check and jumping to
-the appropriate heap-overflow entry point depending on which RetPtr
-registers are live (just as when compiling a case alternative).
-
-When the update code is entered, a register @ReturnReg@ is assumed to
-contain the ``return address'' popped from the B stack. This is so
-that the update code can enter the normal continuation code when it is
-done.
-
-For standard update frames, the A and B stack update ptrs are restored
-from the saved versions before returning, too.
-
-\subsubsection{Update return vector}
-%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Both standard and constructor update frames have as their topmost word
-a pointer to a static, fixed, update return vector.
-
-The ``continuation'' entry of each pair in this vector sets UpdReg to
-point to the thing to be updated (gotten from the update frame), pops
-the update frame, and returns to the ``update'' entry of the
-corresponding pair in the next return vector (now exposed on top of B
-stk).
-
-The ``update'' entry of each pair in this vector overwrites the thing
-to be updated with an indirection to the thing UpdReg points to, and
-then returns in the same was as the "continuation" entry above.
-
-There need to be enough pairs in the update return vector to cater for
-any constructor at all.
-
-
-*************************
-
-Things which need to be altered if you change the number of constructors
-which switches off vectored returns:
-\begin{verbatim}
- Extra cases in update return vector (file xxx)
- The value xxxx in yyyy.lhs
- others?
-\end{verbatim}
-**************************
-
-%************************************************************************
-%* *
-\subsection{HEAP OBJECTS}
-%* *
-%************************************************************************
-
-The heap consists of {\em closures}.
-A closure can be either:
-\begin{itemize}
-\item
-a {\em suspension}, which is an unevaluated thunk.
-\item
-a {\em constructed object} (or just constructor); created by let(recs) and
-by updating.
-\item
-a {\em partial application} (only updating creates these).
-\end{itemize}
-
-Closures are laid out with the {\em info pointer} at the lowest
-address (but see notes on the Global Address field for parallel
-system). [We don't try to localise knowledge of this! It is a royal
-pain having to cope with closures laid out backwards.]
-
-Ptr fields occur first (before non-ptr ones).
-
-Non-normal-form closures are always at least 3 words in size (excl
-global address), so they can be updated with a list cell (should they
-evaluate to that).
-
-Normal form (constructor) closures are always at least 2 words in size
-(excl global address), so they have room enough for forwarding ptrs
-during GC, and FETCHME boxes after flushing.
-
-1-word closures for normal-form closures in static space. Explain
-more.
-
-Ideally, the info pointer of a closure would point to...
-\begin{verbatim}
- |-------------|
- | info table |
- |-------------|
-info ptr ---> code
-\end{verbatim}
-
-But when C is the target code we can't guarantee the relative
-positions of code and data. So the info ptr points to
-\begin{verbatim}
- |-------------|
-info ptr ---->| ------------------------> code
- |-------------|
- | info table |
- |-------------|
-\end{verbatim}
-
-That is, there's an extra indirection involved; and the info table
-occurs AFTER the info pointer rather than before. The info table
-entries are ``reversed'' too, so that bigger negative offsets in the
-``usual'' case turn into bigger positive offsets.
-
-SUSPENSIONS
-
-The simplest form of suspension is
-\begin{verbatim}
- info-ptr, ptr free vars, non-ptr free vars
-\end{verbatim}
-
-where the info table for info-ptr gives
-\begin{itemize}
-\item
-the total number of words of free vars
-\item
-the number of words of ptr free vars (== number of ptr free vars)
-in its extra-info part.
-\end{itemize}
-
-Optimised versions omit the size info from the info table, and instead
-use specialised GC routines.
-
-
-%************************************************************************
-%* *
-\subsection{NAMING CONVENTIONS for compiled code}
-%* *
-%************************************************************************
-
-
-Given a top-level closure called f defined in module M,
-
-\begin{verbatim}
- _M_f_closure labels the closure itself
- (only for top-level (ie static) closures)
-
- _M_f_entry labels the slow entry point of the code
- _M_f_fast labels the fast entry point of the code
-
- _M_f_info labels the info pointer for the closure for f
- (NB the info ptr of a closure isn't public
- in the sense that these labels
- are. It is private to a module, and
- its name can be a secret.)
-\end{verbatim}
-
-These names are the REAL names that the linker sees. The initial underscores
-are attached by the C compiler.
-
-A non-top-level closure has the same names, but as well as the \tr{f}
-the labels have the unique number, so that different local closures
-which share a name don't get confused. The reason we need a naming
-convention at all is that with a little optimisation a tail call may
-jump direct to the fast entry of a locally-defined closure.
-
-\tr{f} may be a constructor, in the case of closures which are the curried
-versions of the constructor.
-
-For constructor closures, we have the following naming conventions, where
-the constructor is C defined in module M:
-
-\begin{verbatim}
- _M_C_con_info is the info ptr for the constructor
- _M_C_con_entry is the corresponding code entry point
-\end{verbatim}
-
-%************************************************************************
-%* *
-\subsection{ENTRY CONVENTIONS}
-%* *
-%************************************************************************
-
-\begin{description}
-\item[Constructor objects:]
- On entry to the code for a constructor (\tr{_M_C_con_entry}), Node
- points to the constructor object. [Even if the constructor has arity
- zero...]
-
-\item[Non-top-level suspensions (both fast and slow entries):]
- Node points to the closure.
-
-\item[Top-level suspensions, slow entry:]
- ReturnReg points to the slow entry point itself
-
-\item[..ditto, fast entry:]
- No entry convention
-\end{description}
-
-
-%************************************************************************
-%* *
-\subsection{CONSTRUCTOR RETURN CONVENTIONS}
-%* *
-%************************************************************************
-
-There is lots of excitement concerning the way in which constructors
-are returned to case expressions.
-
-{\em Simplest version}
-%=====================
-
-The return address on the stack points directly to some code. It
-expects:
-
-\begin{verbatim}
-Boxed objects:
- PtrReg1 points to the constructed value (in the heap) (unless arity=0)
- Tag contains its tag (unless # of constructors = 1)
-
-Unboxed Ints: IntReg contains the int
- Float: FloatReg contains the returned value
-\end{verbatim}
-
-{\em Small improvement: vectoring}
-%=================================
-
-If there are fewer than (say) 8 constructors in the type, the return
-address points to a vector of return addresses. The constructor does
-a vectored return. No CSwitch.
-
-Complication: updates. Update frames are built before the type of the
-thing which will be returned is known. Hence their return address
-UPDATE has to be able to handle anything (vectored and nonvectored).
-
-Hence the vector table goes BACKWARD from ONE WORD BEFORE the word
-pointed to by the return address.
-
-{\em Big improvement: contents in registers}
-%===========================================
-
-Constructor with few enough components (eg 8ish) return their
-arguments in registers. [If there is only one constructor in the
-type, the tag register can be pressed into service for this purpose.]
-
-Complication: updates. Update frames are built before the type of the
-thing which will be returned is known. Hence their return address
-UPDATE has to be able to handle anything.
-
-So, a return address is a pointer to a PAIR of return addresses (or
-maybe a pointer to some code immediately preceded by a pointer to some
-code).
-
-The ``main'' return address is just as before.
-
-The ``update'' return address expects just the same regs to be in use
-as the ``main'' address, BUT AS WELL the magic loc UpdPtr points to a
-closure to be updated. It carries out the update, and contines with
-the main return address.
-
-The ``main'' code for UPDATE just loads UpdPtr the thing to be
-updated, and returns to the "update" entry of the next thing on the
-stack.
-
-The ``update'' entry for UPDATE just overwrites the thing to be
-updated with an indirection to UpdPtr.
-
-These two improvements can be combined orthogonally.
-
-
-%************************************************************************
-%* *
-\subsection{REGISTERS}
-%* *
-%************************************************************************
-
-Separate registers for
-\begin{verbatim}
- C stack (incl interrupt handling, if this is not done on
- another stk) (if interrupts don't mangle the C stack,
- we could save it for most of the time and reuse the
- register)
-
- Arg stack
- Basic value and control stack
- These two grow towards each other, so they are each
- other's limits!
-
- Heap pointer
-\end{verbatim}
-
-And probably also
-\begin{verbatim}
- Heap limit
-\end{verbatim}
-
-
-%************************************************************************
-%* *
-\subsection{THE OFFSET SWAMP}
-%* *
-%************************************************************************
-
-There are THREE kinds of offset:
-\begin{description}
-\item[virtual offsets:]
-
- start at 1 at base of frame, and increase towards top of stack.
-
- don't change when you adjust sp/hp.
-
- independent of stack direction.
-
- only exist inside the code generator, pre Abstract C
-
- for multi-word objects, the offset identifies the word of the
- object with smallest offset
-
-\item[reg-relative offsets:]
-
- start at 0 for elt to which sp points, and increase ``into the
- interesting stuff.''
-
- Specifically, towards
- \begin{itemize}
- \item
- bottom of stack (for SpA, SpB)
- \item
- beginning of heap (for Hp)
- \item
- end of closure (for Node)
- \end{itemize}
-
- offset for a particular item changes when you adjust sp.
-
- independent of stack direction.
-
- exist in abstract C CVal and CAddr addressing modes
-
- for multi-word objects, the offset identifies the word of the
- object with smallest offset
-
-\item[real offsets:]
-
- either the negation or identity of sp-relative offset.
-
- start at 0 for elt to which sp points, and either increase or
- decrease towards bottom of stk, depending on stk direction
-
- exist in real C, usually as a macro call passing an sp-rel offset
-
- for multi-word objects, the offset identifies the word of the
- object with lowest address
-\end{description}
-
-%************************************************************************
-%* *
-\subsection{STACKS}
-%* *
-%************************************************************************
-
-There are two stacks, as in the STG paper.
-\begin{description}
-\item[A stack:]
-contains only closure pointers. Its stack ptr is SpA.
-
-\item[B stack:]
-contains basic values, return addresses, update frames.
-Its stack ptr is SpB.
-\end{description}
-
-SpA and SpB point to the topmost allocated word of stack (though they
-may not be up to date in the middle of a basic block).
-
-\subsubsection{STACK ALLOCATION}
-
-A stack and B stack grow towards each other, so they overflow when
-they collide.
-
-The A stack grows downward; the B stack grows upward. [We'll try to
-localise stuff which uses this info.]
-
-We can check for stack {\em overflow} not just at the start of a basic
-block, but at the start of an entire expression evaluation. The
-high-water marks of case-expression alternatives can be max'd.
-
-Within the code for a closure, the ``stack frame'' is deemed to start
-with the last argument taken by the closure (ie the one deepest in the
-stack). Stack slots are can then be identified by ``virtual offsets''
-from the base of the frame; the bottom-most word of the frame has
-offset 1.
-
-For multi-word slots (B stack only) the offset identifies the word
-with the smallest virtual offset. [If B grows upward, this is the word
-with the lowest physical address too.]
-
-Since there are two stacks, a ``stack frame'' really consists of two
-stack frames, one on each stack.
-
-For each stack, we keep track of the following:
-
-\begin{verbatim}
-* virtSp virtual stack ptr offset of topmost occupied stack slot
- (initialised to 0 if no args)
-
-* realSp real stack ptr offset of real stack ptr reg
- (initialised to 0 if no args)
-
-* tailSp tail-call ptr offset of topmost slot to be retained
- at next tail call, excluding the
- argument to the tail call itself
-
-* hwSp high-water mark largest value taken by virtSp
- in this closure body
-\end{verbatim}
-
-The real stack pointer is (for now) only adjusted at the tail call itself,
-at which point it is made to point to the topmost occupied word of the stack.
-
-We can't always adjust it at the beginning, because we don't
-necessarily know which tail call will be made (a conditional might
-intervene). So stuff is actually put on the stack ``above'' the stack
-pointer. This is ok because interrupts are serviced on a different
-stack.
-
-The code generator works entirely in terms of stack {\em virtual
-offsets}. The conversion to real addressing modes is done solely when
-we look up a binding. When we move a stack pointer, the offsets of
-variables currently bound to stack offsets in the environment will
-change. We provide operations in the @cgBindings@ type to perform
-this offset-change (to wit, @shiftStkOffsets@), leaving open whether
-it is done pronto, or kept separate and applied to lookups.
-
-Stack overflow checking takes place at the start of a closure body, using
-the high-water mark information gotten from the closure body.
-
-
-%************************************************************************
-%* *
-\subsection{HEAP ALLOCATION}
-%* *
-%************************************************************************
-
-Heap ptr reg (Hp) points to the last word of allocated space (and not
-to the first word of free space).
-
-The heap limit register (HpLim) points to the last word of available
-space.
-
-A basic block allocates a chunk of heap called a ``heap frame''.
-The word of the frame nearest to the previously-allocated stuff
-has virtual offset 1, and offsets increase from 1 to the size of the
-frame in words.
-
-Closures are allocated with their code pointers having the lowest virtual
-offset.
-
-NOTE: this means that closures are only laid out with code ptr at
-lowest PHYSICAL address if the heap grows upwards.
-
-Heap ptr reg is moved at the beginning of a basic block to account for
-the allocation of the whole frame. At this time a heap exhaustion
-check is made (has the heap ptr gone past the heap limit?). In the
-basic block, indexed accesses off the heap ptr fill in this newly
-allocated block. [Bias to RISC here: no cheap auto-inc mode, and free
-indexing.]
-
-We maintain the following information during code generation:
-
-\begin{verbatim}
-* virtHp virtual heap ptr offset of last word
- of the frame allocated so far
- Starts at 0 and increases.
-* realHp virtual offset of
- the real Hp register
-\end{verbatim}
-
-Since virtHp only ever increases, it doubles as the heap high water mark.
-
-\subsubsection{BINDINGS}
-
-The code generator maintains info for each name about where it is.
-Each variable maps to:
-
-\begin{verbatim}
- - its kind
-
- - its volatile location:- a temporary variable
- - a virtual heap offset n, meaning the
- ADDRESS OF a word in the current
- heap frame
- - absent
-
- - its stable location: - a virtual stack offset n, meaning the
- CONTENTS OF an object in the
- current stack frame
- - absent
-\end{verbatim}
-
-\subsubsection{ENTERING AN OBJECT}
-
-When a closure is entered at the normal entry point, the magic locs
-\begin{verbatim}
- Node points to the closure (unless it is a top-level closure)
- ReturnReg points to the code being jumped to
-\end{verbatim}
-At the fast entry point, Node is still set up, but ReturnReg may not be.
-[Not sure about this.]
diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index 37eede1e4eec..c45c4989aa06 100644
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -43,11 +43,10 @@ import CoreUtils ( coreExprType )
import CostCentre ( ccMentionsId )
import Id ( idType, getIdArity, isBottomingId,
SYN_IE(IdSet), GenId{-instances-} )
-import PrimOp ( fragilePrimOp, PrimOp(..) )
+import PrimOp ( primOpCanTriggerGC, fragilePrimOp, PrimOp(..) )
import IdInfo ( arityMaybe, bottomIsGuaranteed )
import Literal ( isNoRepLit, isLitLitLit )
import Pretty
-import PrimOp ( primOpCanTriggerGC, PrimOp(..) )
import TyCon ( tyConFamilySize )
import Type ( getAppDataTyConExpandingDicts )
import UniqSet ( emptyUniqSet, unitUniqSet, mkUniqSet,
@@ -148,6 +147,7 @@ mkFormSummary expr
where
go n (Lit _) = ASSERT(n==0) ValueForm
go n (Con _ _) = ASSERT(n==0) ValueForm
+ go n (Prim _ _) = OtherForm
go n (SCC _ e) = go n e
go n (Coerce _ _ e) = go n e
go n (Let _ e) = OtherForm
diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index e9bb1790894d..57945cbc10f1 100644
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -31,7 +31,6 @@ import Id ( idType, getIdInfo, getIdStrictness, isTupleCon,
nullIdEnv, SYN_IE(DataCon), GenId{-instances-}
)
import IdInfo ( ppIdInfo, StrictnessInfo(..) )
-import IdLoop ( Unfolding ) -- Needed by IdInfo.hi?
import Literal ( Literal{-instances-} )
import Name ( isSymLexeme )
import Outputable -- quite a few things
diff --git a/ghc/compiler/coreSyn/root.lit b/ghc/compiler/coreSyn/root.lit
deleted file mode 100644
index caea1a66ad48..000000000000
--- a/ghc/compiler/coreSyn/root.lit
+++ /dev/null
@@ -1,41 +0,0 @@
-\begin{onlystandalone}
-\documentstyle[11pt,literate]{article}
-\begin{document}
-\title{CoreSyntax}
-\author{}
-\date{2 February 1994}
-\maketitle
-\tableofcontents
-\end{onlystandalone}
-
-\begin{onlypartofdoc}
-\section{Core Syntax}
-\downsection
-\end{onlypartofdoc}
-
-\input{CoreSyn.lhs}
-\input{AnnCoreSyn.lhs}
-
-\input{CoreFuns.lhs}
-
-\input{CoreLint.lhs}
-
-\section{Instances}
-\downsection
-\input{PlainCore.lhs}
-\input{TaggedCore.lhs}
-\input{TmplCore.lhs}
-\upsection
-
-\section{Utilities}
-\downsection
-\input{FreeVars.lhs}
-\upsection
-
-\begin{onlypartofdoc}
-\upsection
-\end{onlypartofdoc}
-\begin{onlystandalone}
-\printindex
-\end{document}
-\end{onlystandalone}
diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs
index a8f41bd8e3a7..0331a379832a 100644
--- a/ghc/compiler/deSugar/DsBinds.lhs
+++ b/ghc/compiler/deSugar/DsBinds.lhs
@@ -41,11 +41,11 @@ import Type ( mkTyVarTys, mkForAllTys, splitSigmaTy,
tyVarsOfType, tyVarsOfTypes, isDictTy
)
import TyVar ( tyVarSetToList, GenTyVar{-instance Eq-} )
-import Util ( isIn, panic, pprTrace{-ToDo:rm-} )
-import PprCore--ToDo:rm
-import PprType ( GenTyVar ) --ToDo:rm
-import Usage--ToDo:rm
-import Unique--ToDo:rm
+import Util ( isIn, panic{-, pprTrace ToDo:rm-} )
+--import PprCore--ToDo:rm
+--import PprType ( GenTyVar ) --ToDo:rm
+--import Usage--ToDo:rm
+--import Unique--ToDo:rm
\end{code}
%************************************************************************
diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index b2adec7fa508..4f2760ec479e 100644
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -77,7 +77,7 @@ around; if we get hits, we use the value accordingly.
\begin{code}
dsExpr :: TypecheckedHsExpr -> DsM CoreExpr
-dsExpr (HsVar var) = dsApp (HsVar var) []
+dsExpr e@(HsVar var) = dsApp e []
\end{code}
%************************************************************************
@@ -584,20 +584,9 @@ dsApp (TyApp expr tys) args
-- we might should look out for SectionLs, etc., here, but we don't
-dsApp (HsVar v) args = mkAppDs (Var v) args
-
-{- No need to do unfolding in desugarer now
- = lookupEnvDs v `thenDs` \ maybe_expr ->
- case maybe_expr of
- Just expr -> mkAppDs expr args
-
- Nothing -> -- we're only saturating constructors and PrimOps
- case getIdUnfolding v of
- SimpleUnfolding _ the_unfolding EssentialUnfolding
- -> do_unfold nullTyVarEnv nullIdEnv (unTagBinders the_unfolding) args
-
- _ -> mkAppDs (Var v) args
--}
+dsApp (HsVar v) args
+ = lookupEnvDs v `thenDs` \ maybe_expr ->
+ mkAppDs (case maybe_expr of { Nothing -> Var v; Just expr -> expr }) args
dsApp anything_else args
= dsExpr anything_else `thenDs` \ core_expr ->
diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index 4e2126c0dbbb..66472b77a14c 100644
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -43,7 +43,7 @@ import PprStyle ( PprStyle(..) )
import PrelVals ( iRREFUT_PAT_ERROR_ID, voidId )
import Pretty ( ppShow )
import Id ( idType, dataConArgTys, mkTupleCon,
- pprId{-ToDo:rm-},
+-- pprId{-ToDo:rm-},
SYN_IE(DataCon), SYN_IE(DictVar), SYN_IE(Id), GenId )
import Literal ( Literal(..) )
import TyCon ( mkTupleTyCon, isNewTyCon, tyConDataCons )
@@ -52,13 +52,13 @@ import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTy,
)
import TysPrim ( voidTy )
import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, SYN_IE(UniqSet) )
-import Util ( panic, assertPanic, pprTrace{-ToDo:rm-} )
-import PprCore{-ToDo:rm-}
+import Util ( panic, assertPanic{-, pprTrace ToDo:rm-} )
+import Usage ( SYN_IE(UVar) )
+--import PprCore{-ToDo:rm-}
--import PprType--ToDo:rm
-import Pretty--ToDo:rm
-import TyVar--ToDo:rm
-import Unique--ToDo:rm
-import Usage--ToDo:rm
+--import Pretty--ToDo:rm
+--import TyVar--ToDo:rm
+--import Unique--ToDo:rm
\end{code}
%************************************************************************
diff --git a/ghc/compiler/deSugar/Jmakefile b/ghc/compiler/deSugar/Jmakefile
deleted file mode 100644
index 3e0bd416332b..000000000000
--- a/ghc/compiler/deSugar/Jmakefile
+++ /dev/null
@@ -1,11 +0,0 @@
-/* this is a standalone Jmakefile; NOT part of ghc "make world" */
-
-LitStuffNeededHere(docs depend)
-InfoStuffNeededHere(docs)
-HaskellSuffixRules()
-
-/* LIT2LATEX_OPTS=-tbird */
-
-LIT2LATEX_OPTS=-ttgrind
-
-LitDocRootTargetWithNamedOutput(root,lit,root-standalone)
diff --git a/ghc/compiler/deSugar/intro.lit b/ghc/compiler/deSugar/intro.lit
deleted file mode 100644
index 6ae774723642..000000000000
--- a/ghc/compiler/deSugar/intro.lit
+++ /dev/null
@@ -1,24 +0,0 @@
-\section[Desugar_intro]{Introduction}
-
-This pass of the \Haskell{} compiler converts a typechecked program in
-@AbsSyntax@ form into a list of @CoreBinding@s, a much simpler form
-more suitable for subsequent passes. The basic tasks in this
-``desugaring'' are:
-\begin{enumerate}
-\item
-Compile pattern-matching into equivalent code, mainly case-expressions.
-
-\item
-Convert list comprehensions into equivalent code.
-
-\item
-Make explicit all of the implicit activity due to overloading,
-dictionaries, etc., etc.
-\end{enumerate}
-
-For the basic desugaring process, we assume familiarity with Phil
-Wadler's chapter~5 in SLPJ. The code here will be recognizable by the
-avid reader of that chapter. The main difference you will see is that
-this code uses a simple monad to pass around the name supply; if
-you've read much of this compiler's code, the idioms used will be
-grievously familiar.
diff --git a/ghc/compiler/deSugar/root.lit b/ghc/compiler/deSugar/root.lit
deleted file mode 100644
index 51c35f55072b..000000000000
--- a/ghc/compiler/deSugar/root.lit
+++ /dev/null
@@ -1,53 +0,0 @@
-\begin{onlystandalone}
-\documentstyle[11pt,literate,a4wide]{article}
-\begin{document}
-\title{Desugaring \Haskell{}}
-\author{The AQUA team}
-\date{February 1994}
-\maketitle
-\tableofcontents
-\end{onlystandalone}
-
-\begin{onlypartofdoc}
-\section[De_sugar_er]{Desugaring}
-\downsection
-\end{onlypartofdoc}
-
-\input{intro.lit}
-
-\input{Desugar.lhs}
-
-\section[Desugar_match]{@match@: compiling out pattern-matching}
-\downsection
-\input{Match.lhs}
-\input{MatchCon.lhs}
-\input{MatchLit.lhs}
-\input{MatchProc.lhs}
-\upsection
-
-\section[Desugar_absSyntax]{Mangling the abstract syntax}
-
-Roughly speaking, a function with a name of the form
-\tr{ds<Something>} is the de-sugar-er for the nonterminal
-\pl{<Something>} in module @AbsSyntaxTypes@.
-\downsection
-\input{DsBinds.lhs}
-\input{DsExpr.lhs}
-\input{DsGRHSs.lhs}
-\input{DsListComp.lhs}
-\input{DsParZF.lhs}
-\upsection
-
-\section[Desugar_utilities]{Utilities and constants for desugaring}
-\downsection
-\input{DsMonad.lhs}
-\input{DsUtils.lhs}
-\upsection
-
-\begin{onlypartofdoc}
-\upsection
-\end{onlypartofdoc}
-\begin{onlystandalone}
-\printindex
-\end{document}
-\end{onlystandalone}
diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index aac4f40abb41..6341f66a2622 100644
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -27,7 +27,7 @@ import Outputable ( interppSP, interpp'SP,
)
import Pretty
import SrcLoc ( SrcLoc )
-import Util ( panic#{-ToDo:rm eventually-} )
+--import Util ( panic#{-ToDo:rm eventually-} )
\end{code}
%************************************************************************
diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs
index e8bb141e531e..56ad5d23f65c 100644
--- a/ghc/compiler/hsSyn/HsExpr.lhs
+++ b/ghc/compiler/hsSyn/HsExpr.lhs
@@ -26,7 +26,7 @@ import Pretty
import PprStyle ( PprStyle(..) )
import SrcLoc ( SrcLoc )
import Usage ( GenUsage{-instance-} )
-import Util ( panic{-ToDo:rm eventually-} )
+--import Util ( panic{-ToDo:rm eventually-} )
\end{code}
%************************************************************************
diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs
index d6ccc129eee2..13abecba27f4 100644
--- a/ghc/compiler/main/CmdLineOpts.lhs
+++ b/ghc/compiler/main/CmdLineOpts.lhs
@@ -215,6 +215,8 @@ data SimplifierSwitch
-- Oops!
-- So only use this flag inside List.hs
-- (Sigh, what a HACK, Andy. WDP 96/01)
+
+ | SimplCaseMerge
\end{code}
%************************************************************************
@@ -406,6 +408,7 @@ classifyOpts = sep argv [] [] -- accumulators...
"-fdo-inline-foldr-build" -> SIMPL_SW(SimplDoInlineFoldrBuild)
"-freuse-con" -> SIMPL_SW(SimplReuseCon)
"-fcase-of-case" -> SIMPL_SW(SimplCaseOfCase)
+ "-fcase-merge" -> SIMPL_SW(SimplCaseMerge)
"-flet-to-case" -> SIMPL_SW(SimplLetToCase)
"-fpedantic-bottoms" -> SIMPL_SW(SimplPedanticBottoms)
"-fkeep-spec-pragma-ids" -> SIMPL_SW(KeepSpecPragmaIds)
@@ -484,11 +487,12 @@ tagOf_SimplSwitch SimplNoLetFromCase = ILIT(27)
tagOf_SimplSwitch SimplNoLetFromApp = ILIT(28)
tagOf_SimplSwitch SimplNoLetFromStrictLet = ILIT(29)
tagOf_SimplSwitch SimplDontFoldBackAppend = ILIT(30)
+tagOf_SimplSwitch SimplCaseMerge = ILIT(31)
-- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
tagOf_SimplSwitch _ = panic# "tagOf_SimplSwitch"
-lAST_SIMPL_SWITCH_TAG = IBOX(tagOf_SimplSwitch SimplDontFoldBackAppend)
+lAST_SIMPL_SWITCH_TAG = IBOX(tagOf_SimplSwitch SimplCaseMerge)
\end{code}
%************************************************************************
diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index 43d1ebb86730..d8ead0bcaa24 100644
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -48,12 +48,12 @@ import PrelInfo ( builtinValNamesMap, builtinTcNamesMap )
import Pretty ( prettyToUn )
import Unpretty -- ditto
import RnHsSyn ( isRnConstr, SYN_IE(RenamedHsModule), RnName(..) )
-import RnUtils ( SYN_IE(RnEnv), pprRnEnv{-ToDo:rm-} )
+import RnUtils ( SYN_IE(RnEnv) {-, pprRnEnv ToDo:rm-} )
import TcModule ( SYN_IE(TcIfaceInfo) )
import TcInstUtil ( InstInfo(..) )
import TyCon ( TyCon(..){-instance NamedThing-}, NewOrData(..) )
import Type ( mkSigmaTy, mkDictTy, getAppTyCon, splitForAllTy )
-import Util ( sortLt, removeDups, zipWithEqual, zipWith3Equal, assertPanic, panic{-ToDo:rm-}, pprTrace{-ToDo:rm-} )
+import Util ( sortLt, removeDups, zipWithEqual, zipWith3Equal, assertPanic, panic{-ToDo:rm-}{-, pprTrace ToDo:rm-} )
uppSemid x = uppBeside (prettyToUn (ppr PprInterface x)) uppSemi -- micro util
ppr_ty ty = prettyToUn (pprType PprInterface ty)
@@ -115,7 +115,7 @@ startIface mod
Nothing -> return Nothing -- not producing any .hi file
Just fn ->
openFile fn WriteMode >>= \ if_hdl ->
- hPutStr if_hdl ("interface "++ _UNPK_ mod) >>
+ hPutStr if_hdl ("{-# GHC_PRAGMA INTERFACE VERSION 20 #-}\ninterface "++ _UNPK_ mod) >>
return (Just if_hdl)
endIface Nothing = return ()
diff --git a/ghc/compiler/nativeGen/Jmakefile b/ghc/compiler/nativeGen/Jmakefile
deleted file mode 100644
index d98775c0d27a..000000000000
--- a/ghc/compiler/nativeGen/Jmakefile
+++ /dev/null
@@ -1,22 +0,0 @@
-/* this is a standalone Jmakefile; NOT part of ghc "make world" */
-
-
-LitStuffNeededHere(docs depend)
-InfoStuffNeededHere(docs)
-HaskellSuffixRules()
-
-LitSuffixRule(.lit,/*none*/) /* no language really */
-LitSuffixRule(.lhs,.hs) /* Haskell */
-LitSuffixRule(.lhc,.hc) /* Haskell assembler (C) */
-LitSuffixRule(.lprl,.prl) /* Perl */
-LitSuffixRule(.lsh,.sh) /* Bourne shell */
-LitSuffixRule(.lc,.c) /* C */
-LitSuffixRule(.lh,.h)
-LitSuffixRule(.llex,.lex) /* Lex */
-LitSuffixRule(.lflex,.flex) /* Flex */
-
-
-
-LIT2LATEX_OPTS=-ttgrind
-
-LitDocRootTarget(root,lit)
diff --git a/ghc/compiler/nativeGen/root.lit b/ghc/compiler/nativeGen/root.lit
deleted file mode 100644
index d383ab30fe14..000000000000
--- a/ghc/compiler/nativeGen/root.lit
+++ /dev/null
@@ -1,60 +0,0 @@
-\begin{onlystandalone}
-\documentstyle[11pt,literate,a4wide]{article}
-\begin{document}
-\title{Native Code Generation}
-\author{The AQUA team}
-\date{February 1994}
-\maketitle
-\tableofcontents
-\end{onlystandalone}
-
-\begin{onlypartofdoc}
-\section[Native_Code_Gen]{Native Code Generation}
-\downsection
-\end{onlypartofdoc}
-
-The following sections appear in fairly random order.
-
-\section{Asm}
-\downsection
-\input{AsmCodeGen.lhs}
-\input{AsmCodeClass.lhs}
-\input{AsmMatch.lhs}
-\input{AsmMonad.lhs}
-\input{AsmRegAlloc.lhs}
-\input{AsmUtils.lhs}
-\upsection
-
-\section{AbsC}
-\downsection
-\input{AbsCStixGen.lhs}
-\input{AbsCInline.lhs}
-\upsection
-
-\section{Stix}
-\downsection
-\input{Stix.lhs}
-\input{StixInfo.lhs}
-\input{StixMacro.lhs}
-\input{StixMisc.lhs}
-\input{StixPrim.lhs}
-\upsection
-
-\section{Sparc}
-\downsection
-\input{SparcGen.lhs}
-\input{SparcCode.lhs}
-\upsection
-
-\section{Misc}
-\downsection
-\input{MachDesc.lhs}
-\upsection
-
-\begin{onlypartofdoc}
-\upsection
-\end{onlypartofdoc}
-\begin{onlystandalone}
-\printindex
-\end{document}
-\end{onlystandalone}
diff --git a/ghc/compiler/parser/hschooks.c b/ghc/compiler/parser/hschooks.c
index b63019125611..7fb06bb94e0d 100644
--- a/ghc/compiler/parser/hschooks.c
+++ b/ghc/compiler/parser/hschooks.c
@@ -32,7 +32,7 @@ StackOverflowHook (I_ stack_size) /* in bytes */
void
PatErrorHdrHook (FILE *where)
{
- fprintf(where, "\n*** Pattern-matching error within GHC!\n\nThis is a compiler bug; please report it to glasgow-haskell-bugs@dcs.glasgow.ac.uk.\n\nFail: ");
+ fprintf(where, "\n*** Pattern-matching error within GHC!\n\nThis is a compiler bug; please report it to glasgow-haskell-bugs@dcs.gla.ac.uk.\n\nFail: ");
}
void
diff --git a/ghc/compiler/prelude/Jmakefile b/ghc/compiler/prelude/Jmakefile
deleted file mode 100644
index 9bc27367be7b..000000000000
--- a/ghc/compiler/prelude/Jmakefile
+++ /dev/null
@@ -1,19 +0,0 @@
-/* this is a standalone Jmakefile; NOT part of ghc "make world" */
-
-LitStuffNeededHere(docs depend)
-InfoStuffNeededHere(docs)
-HaskellSuffixRules()
-
-LitSuffixRule(.lit,/*none*/) /* no language really */
-LitSuffixRule(.lhs,.hs) /* Haskell */
-LitSuffixRule(.lhc,.hc) /* Haskell assembler (C) */
-LitSuffixRule(.lprl,.prl) /* Perl */
-LitSuffixRule(.lsh,.sh) /* Bourne shell */
-LitSuffixRule(.lc,.c) /* C */
-LitSuffixRule(.lh,.h)
-LitSuffixRule(.llex,.lex) /* Lex */
-LitSuffixRule(.lflex,.flex) /* Flex */
-
-LIT2LATEX_OPTS=-ttgrind
-
-LitDocRootTarget(prelude,lit)
diff --git a/ghc/compiler/prelude/Makefile-fig b/ghc/compiler/prelude/Makefile-fig
deleted file mode 100644
index bcb4e608d558..000000000000
--- a/ghc/compiler/prelude/Makefile-fig
+++ /dev/null
@@ -1,18 +0,0 @@
-#
-# TransFig makefile
-#
-
-all: prelude-structure.tex
-
-# translation into ps
-
-prelude-structure.tex: prelude-structure.ps Makefile-fig
- fig2ps2tex prelude-structure.ps >prelude-structure.tex
-clean::
- rm -f prelude-structure.tex
-
-prelude-structure.ps: prelude-structure.fig Makefile-fig
- fig2dev -L ps prelude-structure.fig > prelude-structure.ps
-clean::
- rm -f prelude-structure.ps
-
diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs
index c62c6fd53a8b..04bd913e5fe1 100644
--- a/ghc/compiler/prelude/PrelInfo.lhs
+++ b/ghc/compiler/prelude/PrelInfo.lhs
@@ -20,6 +20,7 @@ module PrelInfo (
IMP_Ubiq()
IMPORT_DELOOPER(PrelLoop) ( primOpNameInfo )
+IMPORT_DELOOPER(IdLoop) ( SpecEnv )
-- friends:
import PrelMods -- Prelude module names
diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs
index fe5b026662c9..37d6f6b746c8 100644
--- a/ghc/compiler/prelude/PrelVals.lhs
+++ b/ghc/compiler/prelude/PrelVals.lhs
@@ -9,7 +9,7 @@
module PrelVals where
IMP_Ubiq()
-IMPORT_DELOOPER(IdLoop) ( UnfoldingGuidance(..) )
+IMPORT_DELOOPER(IdLoop) ( UnfoldingGuidance(..), nullSpecEnv, SpecEnv )
import Id ( SYN_IE(Id), GenId, mkImported, mkUserId, mkTemplateLocals )
IMPORT_DELOOPER(PrelLoop)
@@ -26,7 +26,6 @@ import Literal ( mkMachInt )
import Name ( ExportFlag(..) )
import PragmaInfo
import PrimOp ( PrimOp(..) )
-import SpecEnv ( SYN_IE(SpecEnv), nullSpecEnv )
import Type ( mkTyVarTy )
import TyVar ( openAlphaTyVar, alphaTyVar, betaTyVar, gammaTyVar )
import Unique -- lots of *Keys
@@ -81,7 +80,7 @@ eRROR_ID
= pc_bottoming_Id errorIdKey pRELUDE SLIT("error") errorTy
generic_ERROR_ID u n
- = pc_bottoming_Id u gHC__ n errorTy
+ = pc_bottoming_Id u SLIT("GHCerr") n errorTy
pAT_ERROR_ID
= generic_ERROR_ID patErrorIdKey SLIT("patError")
@@ -99,15 +98,17 @@ nO_EXPLICIT_METHOD_ERROR_ID
= generic_ERROR_ID nonExplicitMethodErrorIdKey SLIT("noExplicitMethodError")
aBSENT_ERROR_ID
- = pc_bottoming_Id absentErrorIdKey gHC__ SLIT("absentErr")
- (mkSigmaTy [alphaTyVar] [] alphaTy)
+ = pc_bottoming_Id absentErrorIdKey SLIT("GHCerr") SLIT("absentErr")
+ (mkSigmaTy [openAlphaTyVar] [] openAlphaTy)
pAR_ERROR_ID
- = pcMiscPrelId parErrorIdKey gHC__ SLIT("parError")
- (mkSigmaTy [alphaTyVar] [] alphaTy) noIdInfo
+ = pcMiscPrelId parErrorIdKey SLIT("GHCerr") SLIT("parError")
+ (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noIdInfo
+
+openAlphaTy = mkTyVarTy openAlphaTyVar
errorTy :: Type
-errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] (mkTyVarTy openAlphaTyVar))
+errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
\end{code}
We want \tr{GHCbase.trace} to be wired in
@@ -577,7 +578,7 @@ voidId = pcMiscPrelId voidIdKey gHC_BUILTINS SLIT("void") voidTy noIdInfo
\begin{code}
buildId
- = pcMiscPrelId buildIdKey gHC__ SLIT("build") buildTy
+ = pcMiscPrelId buildIdKey SLIT("GHCerr") SLIT("build") buildTy
((((noIdInfo
{-LATER:`addInfo_UF` mkMagicUnfolding buildIdKey-})
`addInfo` mkStrictnessInfo [WwStrict] Nothing)
@@ -622,7 +623,7 @@ mkBuild ty tv c n g expr
\begin{code}
augmentId
- = pcMiscPrelId augmentIdKey gHC__ SLIT("augment") augmentTy
+ = pcMiscPrelId augmentIdKey SLIT("GHCerr") SLIT("augment") augmentTy
(((noIdInfo
{-LATER:`addInfo_UF` mkMagicUnfolding augmentIdKey-})
`addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs
index 0aa3a74d1fc6..413bdf70f236 100644
--- a/ghc/compiler/prelude/PrimOp.lhs
+++ b/ghc/compiler/prelude/PrimOp.lhs
@@ -38,7 +38,7 @@ import TysWiredIn
import CStrings ( identToC )
import CgCompInfo ( mIN_MP_INT_SIZE, mP_STRUCT_SIZE )
import HeapOffs ( addOff, intOff, totHdrSize, HeapOffset )
-import PprStyle ( codeStyle, PprStyle(..){-ToDo:rm-} )
+import PprStyle ( codeStyle{-, PprStyle(..) ToDo:rm-} )
import PprType ( pprParendGenType, GenTyVar{-instance Outputable-} )
import Pretty
import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs
index ff2f55a6f97a..5b1e3d0a0c3a 100644
--- a/ghc/compiler/prelude/TysWiredIn.lhs
+++ b/ghc/compiler/prelude/TysWiredIn.lhs
@@ -86,14 +86,14 @@ module TysWiredIn (
--import Kind
IMP_Ubiq()
-IMPORT_DELOOPER(TyLoop) ( mkDataCon, StrictnessMark(..) )
+IMPORT_DELOOPER(TyLoop) ( mkDataCon, StrictnessMark(..) )
+IMPORT_DELOOPER(IdLoop) ( SpecEnv )
-- friends:
import PrelMods
import TysPrim
-- others:
-import SpecEnv ( SYN_IE(SpecEnv) )
import Kind ( mkBoxedTypeKind, mkArrowKind )
import Name ( mkWiredInName, ExportFlag(..) )
import SrcLoc ( mkBuiltinSrcLoc )
diff --git a/ghc/compiler/prelude/prelude-structure.fig b/ghc/compiler/prelude/prelude-structure.fig
deleted file mode 100644
index 0eada43bb71f..000000000000
--- a/ghc/compiler/prelude/prelude-structure.fig
+++ /dev/null
@@ -1,67 +0,0 @@
-#FIG 2.1
-80 2
-1 2 0 1 -1 0 0 0 0.000 1 0.000 59 49 40 30 19 19 99 79
-1 2 0 1 -1 0 0 0 0.000 1 0.000 324 49 40 30 284 19 364 79
-1 2 0 1 -1 0 0 0 0.000 1 0.000 188 137 29 15 159 123 217 152
-1 2 0 1 -1 0 0 0 0.000 1 0.000 188 181 29 15 159 167 217 196
-1 2 0 1 -1 0 0 0 0.000 1 0.000 188 225 29 15 159 211 217 240
-1 2 0 1 -1 0 0 0 0.000 1 0.000 188 269 29 15 159 254 217 284
-1 2 0 1 -1 0 0 0 0.000 1 0.000 188 313 29 15 159 298 217 328
-1 2 0 1 -1 0 0 0 0.000 1 0.000 188 357 29 15 159 342 217 371
-1 2 0 1 -1 0 0 0 0.000 1 0.000 190 87 39 22 151 65 229 109
-2 1 0 1 -1 0 0 0 0.000 0 1 0
- 0 0 1.000 4.000 8.000
- 99 49 279 49 9999 9999
-2 4 0 2 -1 0 0 0 0.000 7 0 0
- 379 389 379 9 9 9 9 389 379 389 9999 9999
-2 1 0 1 -1 0 0 0 0.000 0 1 0
- 0 0 1.000 4.000 8.000
- 119 49 119 359 159 359 9999 9999
-2 1 0 1 -1 0 0 0 0.000 24 1 0
- 0 0 1.000 4.000 8.000
- 119 314 159 314 9999 9999
-2 1 0 1 -1 0 0 0 0.000 32 1 0
- 0 0 1.000 4.000 8.000
- 119 269 159 269 9999 9999
-2 1 0 1 -1 0 0 0 0.000 5111825 1 0
- 0 0 1.000 4.000 8.000
- 119 224 159 224 9999 9999
-2 1 0 1 -1 0 0 0 0.000 11534361 1 0
- 0 0 1.000 4.000 8.000
- 119 184 159 184 9999 9999
-2 1 0 1 -1 0 0 0 0.000 13893695 1 0
- 0 0 1.000 4.000 8.000
- 119 139 159 139 9999 9999
-2 1 0 1 -1 0 0 0 0.000 123 1 0
- 0 0 1.000 4.000 8.000
- 119 89 149 89 9999 9999
-2 1 0 1 -1 0 0 0 0.000 0 1 0
- 0 0 1.000 4.000 8.000
- 219 359 259 359 259 69 284 59 9999 9999
-2 1 0 1 -1 0 0 0 0.000 16 1 0
- 0 0 1.000 4.000 8.000
- 219 314 239 314 259 299 9999 9999
-2 1 0 1 -1 0 0 0 0.000 16842916 1 0
- 0 0 1.000 4.000 8.000
- 219 269 239 269 259 254 9999 9999
-2 1 0 1 -1 0 0 0 0.000 1703935 1 0
- 0 0 1.000 4.000 8.000
- 219 224 239 224 259 209 9999 9999
-2 1 0 1 -1 0 0 0 0.000 726872 1 0
- 0 0 1.000 4.000 8.000
- 219 179 239 179 259 159 9999 9999
-2 1 0 1 -1 0 0 0 0.000 40 1 0
- 0 0 1.000 4.000 8.000
- 219 139 239 139 259 119 9999 9999
-2 1 0 1 -1 0 0 0 0.000 1 1 0
- 0 0 1.000 4.000 8.000
- 229 89 244 89 259 79 9999 9999
-4 0 1 12 0 -1 0 0.000 0 9 42 39 54 BuiltIn
-4 0 1 12 0 -1 0 0.000 0 9 42 309 54 Prelude
-4 0 1 10 0 -1 0 0.000 0 9 24 174 94 Core
-4 0 1 10 0 -1 0 0.000 0 9 24 179 144 Text
-4 0 1 10 0 -1 0 0.000 0 9 30 174 184 Ratio
-4 0 1 10 0 -1 0 0.000 0 11 42 169 229 Complex
-4 0 1 10 0 -1 0 0.000 0 11 30 174 269 Array
-4 0 1 10 0 -1 0 0.000 0 9 12 179 314 IO
-4 0 1 10 0 -1 0 0.000 0 9 24 179 359 List
diff --git a/ghc/compiler/prelude/prelude-structure.tex b/ghc/compiler/prelude/prelude-structure.tex
deleted file mode 100644
index bcb71890b11d..000000000000
--- a/ghc/compiler/prelude/prelude-structure.tex
+++ /dev/null
@@ -1,7 +0,0 @@
-\makebox[4.625in][l]{
- \vbox to 4.750in{
- \vfill
- \special{psfile=prelude-structure.ps}
- }
- \vspace{-\baselineskip}
-}
diff --git a/ghc/compiler/prelude/prelude.lit b/ghc/compiler/prelude/prelude.lit
deleted file mode 100644
index 615f779e9179..000000000000
--- a/ghc/compiler/prelude/prelude.lit
+++ /dev/null
@@ -1,420 +0,0 @@
-\documentstyle[11pt,literate,a4wide]{article}
-
-%--------------------
-\begin{rawlatex}
-%\input{transfig}
-
-%\newcommand{\folks}[1]{$\spadesuit$ {\em #1} $\spadesuit$}
-%\newcommand{\ToDo}[1]{$\spadesuit$ {\bf ToDo:} {\em #1} $\spadesuit$}
-
-% to avoid src-location marginpars, comment in/out this defn.
-%\newcommand{\srcloc}[1]{{\tt #1}}
-%\newcommand{\srclocnote}[1]{}
-%\newcommand{\srclocnote}[1]{\marginpar{\small\srcloc{#1}}}
-
-\setcounter{secnumdepth}{6}
-\setcounter{tocdepth}{6}
-\end{rawlatex}
-%--------------------
-
-\begin{document}
-\title{Basic types and the standard Prelude: OBSOLETE}
-\author{The AQUA team}
-\date{November 1992 (obsolete February 1994)}
-\maketitle
-\begin{rawlatex}
-\tableofcontents
-\pagebreak
-\end{rawlatex}
-
-% added to keep DPH stuff happy:
-\begin{rawlatex}
-\def\DPHaskell{DPHaskell}
-\def\POD{POD}
-\end{rawlatex}
-
-This document describes how we deal with Haskell's standard prelude,
-notably what the compiler itself ``knows'' about it. There's nothing
-intellectually difficult here---it's just vast and occasionally
-delicate.
-
-First, some introduction, mostly terminology. Second, the actual
-compiler source code which defines what the compiler knows about the
-prelude. Finally, something about how we compile the prelude code
-(with GHC, of course) to produce the executable bits for the prelude.
-
-%************************************************************************
-%* *
-\section{Introduction and terminology}
-%* *
-%************************************************************************
-
-The standard prelude is made of many, many pieces. The GHC system
-must deal with these pieces in different ways. For example, the
-compiler must obviously do different things for primitive operations
-(e.g., addition on machine-level @Ints@) and for plain
-written-in-Haskell functions (e.g., @tail@).
-
-In this section, the main thing we do is explain the various ways that
-we categorise prelude thingies, most notably types.
-
-%************************************************************************
-%* *
-\subsection{Background information}
-%* *
-%************************************************************************
-
-%************************************************************************
-%* *
-\subsubsection{Background terms: Heap objects}
-%* *
-%************************************************************************
-
-A {\em heap object} (equivalently {\em closure}) is always a
-contiguous block of memory, starting with an info pointer. {\em
-Dynamic} heap objects are allocated by a sequence of instructions in
-the usual way.
-
-In contrast, {\em static heap objects} are statically allocated at
-fixed, labelled locations outside the dynamic heap --- but we still
-call them heap objects! Their GC code does not evacuate them, and
-they are never scavenged since they never appear in to-space. Note:
-the ``staticness'' does {\em not} mean they are read-only; they may be
-updatable.
-
-(Much) more on this stuff in the STG paper.
-
-%************************************************************************
-%* *
-\subsection{Categorising the prelude bits}
-%* *
-%************************************************************************
-
-Here are four different ways in which we might categorise prelude
-things generally. Note, also, the {\em simplifying assumptions} that
-we make so that we can have a ``Prelude onion,'' in which each
-``layer'' includes the preceding ones.
-
-\begin{description}
-%------------------------------------------------------------------
-\item[Primitive vs Haskell-able:]
-
-Some parts of the prelude cannot be expressed in Haskell ({\em
-primitive}), whereas most of it can be ({\em Haskell-able}).
-
-BIG NOTE: Because of our non-standard support for unboxed numbers and
-operations thereon, some of the things in @PreludeBuiltin@ in the
-report {\em are} Haskell-able. For example, the @negate@ operation on
-an @Int@ is just:
-
-\begin{verbatim}
-negateInt i
- = case i of MkInt i# -> case (negateInt# i#) of j# -> MkInt j#
-\end{verbatim}
-
-Of course, this just moves the goalposts: @negateInt#@ is now the
-primitive, non-Haskell-able thingy...
-
-So: something is ``primitive'' if we cannot define it in our
-GHC-extended Haskell.
-
-For more information, please see \sectionref{prelude-more-on-types}
-for further discussion about types in the Prelude.
-
-%------------------------------------------------------------------
-\item[From (exported by) PreludeCore or not:]
-The module @PreludeCore@ exports all the types, classes, and instances
-in the prelude. These entities are ``immutable;'' they can't be
-hidden, renamed, or really fiddled in any way.
-
-(NB: The entities {\em exported by} @PreludeCore@ may {\em originally}
-be from another module. For example, the @Complex@ datatype is
-defined in @PreludeComplex@; nonetheless, it is exported by
-@PreludeCore@ and falls into the category under discussion here.)
-
-{\em Simplifying assumption:} We take everything primitive (see
-previous classification) to be ``from PreludeCore''.
-
-{\em Simplifying assumption:} We take all {\em values} from
-@PreludeBuiltin@ to be ``from PreludeCore.'' This includes @error@
-and the various \tr{prim*} functions (which may or may not be
-``primitive'' in our system [because of our extensions for unboxery]).
-It shouldn't be hard to believe that something from @PreludeBuiltin@
-is (at least) slightly magic and not just another value...
-
-{\em Simplifying assumption:} The GHC compiler has ``wired in''
-information about {\em all} @fromPreludeCore@ things. The fact that
-they are ``immutable'' means we don't have to worry about ``unwiring''
-them in the face of renaming, etc., (which would be pretty bizarre,
-anyway).
-
-Not-exported-by-PreludeCore things (non-@PreludeBuiltin@ values) can
-be renamed, hidden, etc.
-
-%------------------------------------------------------------------
-\item[Compiler-must-know vs compiler-chooses-to-know vs compiler-unknown:]
-
-There are some prelude things that the compiler has to ``know about.''
-For example, it must know about the @Bool@ data type, because (for one
-reason) it needs it to typecheck guards.
-
-{\em Simplifying assumption:} By decree, the compiler ``must know''
-about everything exported from @PreludeCore@ (see previous
-classification). This is only slight overkill: there are a few types
-(e.g., @Request@), classes (e.g., @RealFrac@), and instances (e.g.,
-anything for @RealFrac@)---all @fromPreludeCore@---that the compiler
-could, strictly speaking, get away with not knowing about. However,
-it is a {\em pain} to maintain the distinction...
-
-On the other hand, the compiler really {\em doesn't} need to know
-about the non-@fromPreludeCore@ stuff (as defined above). It can read
-the relevant information out of a \tr{.hi} interface file, just as it
-would for a user-defined module (and, indeed, that's what it does).
-An example of something the compiler doesn't need to know about is the
-@tail@ function, defined in @PreludeList@, exported by @Prelude@.
-
-There are some non-@fromPreludeCore@ things that the compiler may {\em
-choose} to clutch to its bosom: this is so it can do unfolding on the
-use of a function. For example, we always want to unfold uses of @&&@
-and @||@, so we wire info about them into the compiler. (We won't
-need this when we are able to pass unfolding info via interface
-files.)
-
-%------------------------------------------------------------------
-\item[Per-report vs Glasgow-extension:]
-Some of our prelude stuff is not strictly as per the Haskell report,
-notably the support for monadic I/O, and our different notion of what
-is truly primitive in Haskell (c.f. @PreludeBuiltin@'s ideas).
-
-In this document, ``Haskell'' always means ``Glasgow-extended
-Haskell.''
-\end{description}
-
-%************************************************************************
-%* *
-\subsection[prelude-more-on-types]{More about the Prelude datatypes}
-%* *
-%************************************************************************
-
-The previous section explained how we categorise the prelude as a
-whole. In this section, we home in on prelude datatypes.
-
-%************************************************************************
-%* *
-\subsubsection{Boxed vs unboxed types}
-%* *
-%************************************************************************
-
-Objects of a particular type are all represented the same way.
-We recognise two kinds of types:
-\begin{description}
-
-\item[Boxed types.]
-The domain of a boxed type includes bottom. Values of boxed type are
-always represented by a pointer to a heap object, which may or may not
-be evaluated. Anyone needing to scrutinise a value of boxed type must
-evaluate it first by entering it. Value of boxed type can be passed
-to polymorphic functions.
-
-\item[Unboxed types.]
-The domain of an unboxed type does not include bottom, so values of
-unboxed type do not need a representation which accommodates the
-possibility that it is not yet evaluated.
-
-Unboxed values are represented by one or more words. At present, if
-it is represented by more than one word then none of the words are
-pointers, but we plan to lift this restriction eventually.
-(At present, the only multi-word values are @Double#@s.)
-
-An unboxed value may be represented by a pointer to a heap object:
-primitive strings and arbitrary-precision integers are examples (see
-Section~\ref{sect-primitive}).
-\end{description}
-
-%************************************************************************
-%* *
-\subsubsection{Primitive vs algebraic types}
-%* *
-%************************************************************************
-
-There is a second classification of types, which is not quite orthogonal:
-\begin{description}
-
-\item[Primitive types.]
-A type is called {\em primitive} if it cannot be defined in
-(Glasgow-extended) Haskell, and the only operations which manipulate its
-representation are primitive ones. It follows that the domain
-corresponding to a primitive type has no bottom element; that is, all
-primitive data types are unboxed.
-
-By convention, the names of all primitive types end with @#@.
-
-\item[Algebraic data types.]
-These are built with Haskell's @data@ declaration. Currently, @data@
-declarations can {\em only} build boxed types (and hence {\em all
-unboxed types are also primitive}), but we plan to lift this
-restriction in due course.
-\end{description}
-
-%************************************************************************
-%* *
-\subsection[prelude-onion]{Summary of the ``Prelude onion''}
-%* *
-%************************************************************************
-
-Summarizing:
-\begin{enumerate}
-\item
-{\em Primitive} types, and operations thereon (@PrimitiveOps@), are at
-the core of the onion.
-
-\item
-Everything exported @fromPreludeCore@ (w/ all noted provisos) makes up
-the next layer of the onion; and, by decree, the compiler has built-in
-knowledge of all of it. All the primitive stuff is included in this
-category.
-
-\item
-The compiler {\em chooses to know} about a few of the
-non-@fromPreludeCore@ values in the @Prelude@. This is (exclusively)
-for access to their unfoldings.
-
-\item
-The rest of the @Prelude@ is ``unknown'' to the compiler itself; it
-gets its information from a \tr{Prelude.hi} file, exactly as it does
-for user-defined modules.
-\end{enumerate}
-
-%************************************************************************
-%* *
-\section{What the compiler knows about the prelude}
-%* *
-%************************************************************************
-
-This is essentially the stuff in the directory \tr{ghc/compiler/prelude}.
-
-%************************************************************************
-%* *
-\subsection{What the compiler knows about prelude types (and ops thereon)}
-%* *
-%************************************************************************
-
-The compiler has wired into it knowledge of all the types in the
-standard prelude, all of which are exported by @PreludeCore@.
-Strictly speaking, it needn't know about some types (e.g., the
-@Request@ and @Response@ datatypes), but it's tidier in the end to
-wire in everything.
-
-Primitive types, and related stuff, are covered first. Then the more
-ordinary prelude types. The more turgid parts may be arranged
-alphabetically...
-
-\downsection
-\downsection
-% pretty ugly, no?
-%************************************************************************
-%* *
-\section{Primitive types (and ``kinds'') {\em and} operations thereon}
-\label{sect-primitive}
-%* *
-%************************************************************************
-
-There are the following primitive types.
-%partain:\begin{center}
-\begin{tabular}{|llll|}
-\hline
-Type & Represents & Size (32|64-bit words) & Pointer? \\
-\hline
-@Void#@ & zero-element type & 1 & No \\
-@Char#@ & characters & 1 & No \\
-@Int#@ & 32|64-bit integers & 1 & No \\
-@Float#@ & 32|64-bit floats & 1 & No \\
-@Double#@ & 64|128-bit floats & 2 & No \\
-@Arr#@ & array of pointers & ? & Yes \\
-@Arr# Char#@ & array of @Char#@s & ? & No \\
-@Arr# Int#@ & array of @Int#@s & ? & No \\
-@Arr# Float#@ & array of @Float#@s & ? & No \\
-@Arr# Double#@ & array of @Double#@s & ? & No \\
-@Integer#@ & arbitrary-precision integers & 1 & Yes \\
-@LitString#@ & literal C-style strings & 1 & No \\
-\hline
-\end{tabular}
-%partain:\end{center}
-
-Notes: (a)~@Integer#s@ have a pointer in them, to a @Arr# Int#@; see
-the discussion in @TyInteger@. (b)~@LitString#@ is a magical type
-used {\em only} to handle literal C-strings; this is a convenience; we
-could use an @Arr# Char#@ instead.
-
-What the compiler knows about these primitive types is either
-(a)~given with the corresponding algebraic type (e.g., @Int#@ stuff is
-with @Int@ stuff), or (b)~in a module of its own (e.g., @Void#@).
-
-\downsection
-\input{PrimKind.lhs}
-
-\section{Details about ``Glasgow-special'' types}
-
-\downsection
-\input{TysPrim.lhs}
-\input{TyPod.lhs}
-\input{TyProcs.lhs}
-\upsection
-
-\input{PrimOps.lhs}
-\upsection
-
-%************************************************************************
-%* *
-\section{Details (mostly) about non-primitive Prelude types}
-\label{sect-nonprim-tys}
-%* *
-%************************************************************************
-
-\downsection
-\input{TysWiredIn.lhs}
-\upsection
-
-%************************************************************************
-%* *
-%\subsection{What the compiler knows about prelude values}
-%* *
-%************************************************************************
-\downsection
-\input{PrelVals.lhs}
-\upsection
-
-%************************************************************************
-%* *
-\subsection{Uniquifiers and utility bits for this prelude stuff}
-%* *
-%************************************************************************
-\downsection
-\downsection
-\input{PrelFuns.lhs}
-\upsection
-\upsection
-
-%************************************************************************
-%* *
-%\subsection{The @AbsPrel@ interface to the compiler's prelude knowledge}
-%* *
-%************************************************************************
-\downsection
-\input{AbsPrel.lhs}
-\upsection
-
-%************************************************************************
-%* *
-\section{The executable code for prelude bits}
-%* *
-%************************************************************************
-
-This essentially describes what happens in the directories
-\tr{ghc/lib/{io,prelude}}; the former is to support the (non-std)
-Glasgow I/O; the latter is regular prelude things.
-
-ToDo: more.
-
-\printindex
-\end{document}
diff --git a/ghc/compiler/reader/Jmakefile b/ghc/compiler/reader/Jmakefile
deleted file mode 100644
index 905d494c7bce..000000000000
--- a/ghc/compiler/reader/Jmakefile
+++ /dev/null
@@ -1,18 +0,0 @@
-/* this is a standalone Jmakefile; NOT part of ghc "make world" */
-
-LitStuffNeededHere(docs depend)
-InfoStuffNeededHere(docs)
-
-HaskellSuffixRules()
-
-LitSuffixRule(.lit,/*none*/) /* no language really */
-LitSuffixRule(.lhs,.hs) /* Haskell */
-LitSuffixRule(.lhc,.hc) /* Haskell assembler (C) */
-LitSuffixRule(.lprl,.prl) /* Perl */
-LitSuffixRule(.lsh,.sh) /* Bourne shell */
-LitSuffixRule(.lc,.c) /* C */
-LitSuffixRule(.lh,.h)
-LitSuffixRule(.llex,.lex) /* Lex */
-LitSuffixRule(.lflex,.flex) /* Flex */
-
-LitDocRootTargetWithNamedOutput(reader,lit,reader-standalone)
diff --git a/ghc/compiler/reader/reader.lit b/ghc/compiler/reader/reader.lit
deleted file mode 100644
index 27b6dacd26cf..000000000000
--- a/ghc/compiler/reader/reader.lit
+++ /dev/null
@@ -1,30 +0,0 @@
-\begin{onlystandalone}
-\documentstyle[11pt,literate]{article}
-\begin{document}
-\title{Glasgow Haskell compiler: reader}
-\author{The GRASP team}
-\date{August 1993}
-\maketitle
-\begin{rawlatex}
-\tableofcontents
-\pagebreak
-\end{rawlatex}
-\end{onlystandalone}
-
-\begin{onlypartofdoc}
-\section[reader]{Reader}
-\downsection
-\end{onlypartofdoc}
-
-\input{PrefixSyn.lhs}
-\input{ReadPrefix.lhs}
-\input{PrefixToHs.lhs}
-
-\upsection
-\begin{onlypartofdoc}
-\upsection
-\end{onlypartofdoc}
-\begin{onlystandalone}
-\printindex
-\end{document}
-\end{onlystandalone}
diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index 015f6aa04005..30083ff093ae 100644
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -16,10 +16,10 @@ import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap )
import Name ( ExportFlag(..), mkTupNameStr, preludeQual,
RdrName(..){-instance Outputable:ToDo:rm-}
)
-import Outputable -- ToDo:rm
-import PprStyle ( PprStyle(..) ) -- ToDo: rm debugging
+--import Outputable -- ToDo:rm
+--import PprStyle ( PprStyle(..) ) -- ToDo: rm debugging
import SrcLoc ( mkIfaceSrcLoc )
-import Util ( panic, pprPanic{-ToDo:rm-} )
+import Util ( panic{-, pprPanic ToDo:rm-} )
-----------------------------------------------------------------
@@ -254,7 +254,7 @@ btype : gtyconapp { case $1 of (tc, tys) -> MonoTyApp tc tys }
MonoListTy ty -> MonoTyApp (preludeQual SLIT("[]")) (ty:tys);
MonoTupleTy ts -> MonoTyApp (preludeQual (mkTupNameStr (length ts)))
(ts++tys);
- _ -> pprPanic "test:" (ppr PprDebug $1)
+-- _ -> pprPanic "test:" (ppr PprDebug $1)
}}
}
diff --git a/ghc/compiler/rename/ParseUtils.lhs b/ghc/compiler/rename/ParseUtils.lhs
index 08266c601620..4e28daf6c4bf 100644
--- a/ghc/compiler/rename/ParseUtils.lhs
+++ b/ghc/compiler/rename/ParseUtils.lhs
@@ -24,13 +24,13 @@ import FiniteMap ( unitFM, listToFM, lookupFM, plusFM, FiniteMap )
import Maybes ( maybeToBool, MaybeErr(..) )
import Name ( isLexConId, isLexVarId, isLexConSym,
mkTupNameStr, preludeQual, isRdrLexCon,
- RdrName(..){-instance Outputable:ToDo:rm-}
+ RdrName(..) {-instance Outputable:ToDo:rm-}
)
import PprStyle ( PprStyle(..) ) -- ToDo: rm debugging
import PrelMods ( pRELUDE )
import Pretty ( ppCat, ppPStr, ppInt, ppShow, ppStr )
import SrcLoc ( mkIfaceSrcLoc )
-import Util ( startsWith, isIn, panic, assertPanic, pprTrace{-ToDo:rm-} )
+import Util ( startsWith, isIn, panic, assertPanic{-, pprTrace ToDo:rm-} )
\end{code}
\begin{code}
diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index 3c827c16db77..2d8bd929457f 100644
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -39,19 +39,19 @@ import RnUtils ( SYN_IE(RnEnv), extendGlobalRnEnv, emptyRnEnv )
import Bag ( isEmptyBag, unionBags, unionManyBags, bagToList, listToBag )
import CmdLineOpts ( opt_HiMap, opt_NoImplicitPrelude )
import ErrUtils ( SYN_IE(Error), SYN_IE(Warning) )
-import FiniteMap ( emptyFM, eltsFM, fmToList, addToFM, lookupFM{-ToDo:rm-}, FiniteMap )
+import FiniteMap ( emptyFM, eltsFM, fmToList, addToFM, FiniteMap )
import Maybes ( catMaybes )
import Name ( isLocallyDefined, mkWiredInName, getLocalName, isLocalName,
origName,
Name, RdrName(..), ExportFlag(..)
)
-import PprStyle -- ToDo:rm
+--import PprStyle -- ToDo:rm
import PrelInfo ( builtinNameMaps, builtinKeysMap, SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) )
-import Pretty -- ToDo:rm
+import Pretty
import Unique ( ixClassKey )
import UniqFM ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM )
import UniqSupply ( splitUniqSupply )
-import Util ( panic, assertPanic, pprTrace{-ToDo:rm-} )
+import Util ( panic, assertPanic{-, pprTrace ToDo:rm-} )
\end{code}
\begin{code}
@@ -90,7 +90,7 @@ renameModule us input@(HsModule modname _ _ imports _ _ _ _ _ _ _ _ _ _)
, ppCat (map pp_pair (keysFM builtinKeysMap))
]}) $
-}
--- _scc_ "rnGlobalNames"
+ -- _scc_ "rnGlobalNames"
makeHiMap opt_HiMap >>= \ hi_files ->
-- pprTrace "HiMap:\n" (ppAboves [ ppCat [ppPStr m, ppStr p] | (m,p) <- fmToList hi_files])
initIfaceCache modname hi_files >>= \ iface_cache ->
@@ -112,7 +112,7 @@ renameModule us input@(HsModule modname _ _ imports _ _ _ _ _ _ _ _ _ _)
else
-- No top-level name errors so rename source ...
--- _scc_ "rnSource"
+ -- _scc_ "rnSource"
case initRn True modname occ_env us2
(rnSource imp_mods unqual_imps imp_fixes input) of {
((rn_module, export_fn, module_dotdots, src_occs), src_errs, src_warns) ->
@@ -150,7 +150,7 @@ renameModule us input@(HsModule modname _ _ imports _ _ _ _ _ _ _ _ _ _)
else
-- No errors renaming source so rename the interfaces ...
--- _scc_ "preRnIfaces"
+ -- _scc_ "preRnIfaces"
let
-- split up all names that occurred in the source; between
-- those that are defined therein and those merely mentioned.
@@ -190,22 +190,15 @@ renameModule us input@(HsModule modname _ _ imports _ _ _ _ _ _ _ _ _ _)
else case (origName "pairify_rn" name) of { OrigName m n ->
Qual m n }
, rn)
-
- must_haves
- | opt_NoImplicitPrelude
- = [{-no Prelude.hi, no point looking-}]
- | otherwise
- = [ name_fn (mkWiredInName u orig ExportAll)
- | (orig@(OrigName mod str), (u, name_fn)) <- fmToList builtinKeysMap ]
in
-- ASSERT (isEmptyBag orig_occ_dups)
- (if (isEmptyBag orig_occ_dups) then \x->x
- else pprTrace "orig_occ_dups:" (ppAboves [ ppCat [ppr PprDebug m, ppr PprDebug n, ppr PprDebug o] | (m,n,o) <- bagToList orig_occ_dups])) $
+-- (if (isEmptyBag orig_occ_dups) then \x->x
+-- else pprTrace "orig_occ_dups:" (ppAboves [ ppCat [ppr PprDebug m, ppr PprDebug n, ppr PprDebug o] | (m,n,o) <- bagToList orig_occ_dups])) $
ASSERT (isEmptyBag orig_def_dups)
--- _scc_ "rnIfaces"
+ -- _scc_ "rnIfaces"
rnIfaces iface_cache imp_mods us3 orig_def_env orig_occ_env
- rn_module (must_haves {-initMustHaves-} ++ imports_used) >>=
+ rn_module (initMustHaves ++ imports_used) >>=
\ (rn_module_with_imports, final_env,
(implicit_val_fm, implicit_tc_fm),
usage_stuff,
diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs
index ac8dc51be0e7..ced653a84e8a 100644
--- a/ghc/compiler/rename/RnBinds.lhs
+++ b/ghc/compiler/rename/RnBinds.lhs
@@ -34,12 +34,12 @@ import Digraph ( stronglyConnComp )
import ErrUtils ( addErrLoc, addShortErrLocLine )
import Name ( getLocalName, RdrName )
import Maybes ( catMaybes )
-import PprStyle--ToDo:rm
+--import PprStyle--ToDo:rm
import Pretty
import UniqSet ( emptyUniqSet, unitUniqSet, mkUniqSet,
unionUniqSets, unionManyUniqSets,
elementOfUniqSet, uniqSetToList, SYN_IE(UniqSet) )
-import Util ( thenCmp, isIn, removeDups, panic, panic#, assertPanic, pprTrace{-ToDo:rm-} )
+import Util ( thenCmp, isIn, removeDups, panic, panic#, assertPanic )
\end{code}
-- ToDo: Put the annotations into the monad, so that they arrive in the proper
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 220a9456cde1..08b176386e8a 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -28,7 +28,7 @@ import RnMonad
import ErrUtils ( addErrLoc, addShortErrLocLine )
import Name ( isLocallyDefinedName, pprSym, Name, RdrName )
import Pretty
-import UniqFM ( lookupUFM, ufmToList{-ToDo:rm-} )
+import UniqFM ( lookupUFM{-, ufmToList ToDo:rm-} )
import UniqSet ( emptyUniqSet, unitUniqSet,
unionUniqSets, unionManyUniqSets,
SYN_IE(UniqSet)
diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs
index e06d1e718200..db994b15617f 100644
--- a/ghc/compiler/rename/RnHsSyn.lhs
+++ b/ghc/compiler/rename/RnHsSyn.lhs
@@ -13,8 +13,8 @@ IMP_Ubiq()
import HsSyn
import Id ( isDataCon, GenId, SYN_IE(Id) )
-import Name ( isLocalName, nameUnique, Name, RdrName(..){-ToDo: rm ..-},
- mkLocalName{-ToDo:rm-}
+import Name ( isLocalName, nameUnique, Name, RdrName(..),
+ mkLocalName
)
import Outputable ( Outputable(..){-instance * []-} )
import PprStyle ( PprStyle(..) )
@@ -23,7 +23,7 @@ import Pretty
import TyCon ( TyCon )
import TyVar ( GenTyVar )
import Unique ( mkAlphaTyVarUnique, Unique )
-import Util ( panic, pprPanic, pprTrace{-ToDo:rm-} )
+import Util ( panic, pprPanic{-, pprTrace ToDo:rm-} )
\end{code}
\begin{code}
@@ -82,7 +82,7 @@ isRnField (RnField _ _) = True
isRnField _ = False
isRnClassOp cls (RnClassOp _ op_cls) = eqUniqsNamed cls op_cls
-isRnClassOp cls n = pprTrace "isRnClassOp:" (ppr PprShowAll n) $ True -- let it past anyway
+isRnClassOp cls n = True -- pprTrace "isRnClassOp:" (ppr PprShowAll n) $ True -- let it past anyway
isRnImplicit (RnImplicit _) = True
isRnImplicit (RnImplicitTyCon _) = True
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index f805e312e9b6..396f021ab094 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -43,19 +43,19 @@ import Bag ( emptyBag, unitBag, consBag, snocBag,
import ErrUtils ( SYN_IE(Error), SYN_IE(Warning) )
import FiniteMap ( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, eltsFM,
fmToList, delListFromFM, sizeFM, foldFM, unitFM,
- plusFM_C, addListToFM, keysFM{-ToDo:rm-}, FiniteMap
+ plusFM_C, addListToFM{-, keysFM ToDo:rm-}, FiniteMap
)
import Maybes ( maybeToBool, MaybeErr(..) )
import Name ( origName, moduleOf, nameOf, qualToOrigName, OrigName(..),
isLexCon, RdrName(..), Name{-instance NamedThing-} )
-import PprStyle -- ToDo:rm
-import Outputable -- ToDo:rm
+--import PprStyle -- ToDo:rm
+--import Outputable -- ToDo:rm
import PrelInfo ( builtinNameMaps, builtinKeysMap, builtinTcNamesMap, SYN_IE(BuiltinNames) )
import Pretty
import UniqFM ( emptyUFM )
import UniqSupply ( splitUniqSupply )
import Util ( sortLt, removeDups, cmpPString, startsWith,
- panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} )
+ panic, pprPanic, assertPanic{-, pprTrace ToDo:rm-} )
\end{code}
\begin{code}
@@ -154,8 +154,8 @@ cachedIface (IfaceCache _ _ iface_var) want_orig_iface item modname
----------
mergeIfaces (ParsedIface mod1 (_, files1) _ _ _ _ _ _ fixes1 tdefs1 vdefs1 idefs1 prags1)
(ParsedIface mod2 (_, files2) _ _ _ _ _ _ fixes2 tdefs2 vdefs2 idefs2 prags2)
- = pprTrace "mergeIfaces:" (ppCat [ppStr "import", ppCat (map ppPStr (bagToList files2)),
- ppStr "merged with", ppPStr mod1]) $
+ = --pprTrace "mergeIfaces:" (ppCat [ppStr "import", ppCat (map ppPStr (bagToList files2)),
+ -- ppStr "merged with", ppPStr mod1]) $
ASSERT(mod1 == mod2)
ParsedIface mod1
(True, unionBags files2 files1)
@@ -165,16 +165,16 @@ mergeIfaces (ParsedIface mod1 (_, files1) _ _ _ _ _ _ fixes1 tdefs1 vdefs1 idefs
(panic "mergeIface: decl version numbers")
(panic "mergeIface: exports")
(panic "mergeIface: instance modules")
- (plusFM_C (dup_merge "fixity" (ppr PprDebug . fixDeclName)) fixes1 fixes2)
- (plusFM_C (dup_merge "tycon/class" (ppr PprDebug . idecl_nm)) tdefs1 tdefs2)
- (plusFM_C (dup_merge "value" (ppr PprDebug . idecl_nm)) vdefs1 vdefs2)
+ (plusFM_C (dup_merge {-"fixity" (ppr PprDebug . fixDeclName)-}) fixes1 fixes2)
+ (plusFM_C (dup_merge {-"tycon/class" (ppr PprDebug . idecl_nm)-}) tdefs1 tdefs2)
+ (plusFM_C (dup_merge {-"value" (ppr PprDebug . idecl_nm)-}) vdefs1 vdefs2)
(unionBags idefs1 idefs2)
- (plusFM_C (dup_merge "pragma" ppStr) prags1 prags2)
+ (plusFM_C (dup_merge {-"pragma" ppStr-}) prags1 prags2)
where
- dup_merge str ppr_dup dup1 dup2
- = pprTrace "mergeIfaces:"
- (ppCat [ppPStr mod1, ppPStr mod2, ppStr ": dup", ppStr str, ppStr "decl",
- ppr_dup dup1, ppr_dup dup2]) $
+ dup_merge {-str ppr_dup-} dup1 dup2
+ = --pprTrace "mergeIfaces:"
+ -- (ppCat [ppPStr mod1, ppPStr mod2, ppStr ": dup", ppStr str, ppStr "decl",
+ -- ppr_dup dup1, ppr_dup dup2]) $
dup2
idecl_nm (TypeSig n _ _) = n
@@ -244,7 +244,7 @@ cachedDeclByType iface_cache rn
case rn of
WiredInId _ -> return_failed (ifaceLookupWiredErr "value" rn)
WiredInTyCon _ -> return_failed (ifaceLookupWiredErr "type constructor" rn)
- RnUnbound _ -> pprPanic "cachedDeclByType:" (ppr PprDebug rn)
+ RnUnbound _ -> panic "cachedDeclByType:" -- (ppr PprDebug rn)
RnSyn _ -> return_maybe_decl
RnData _ _ _ -> return_maybe_decl
@@ -440,7 +440,7 @@ rnIfaces iface_cache imp_mods us
cachedDeclByType iface_cache n >>= \ maybe_ans ->
case maybe_ans of
CachingAvoided _ ->
- pprTrace "do_decls:caching avoided:" (ppr PprDebug n) $
+ --pprTrace "do_decls:caching avoided:" (ppr PprDebug n) $
do_decls ns down to_return
CachingFail err -> -- add the error, but keep going:
@@ -501,7 +501,7 @@ new_uniqsupply us (def_env, occ_env, _) = (def_env, occ_env, us)
add_occs (val_defds, tc_defds) (val_imps, tc_imps) (def_env, occ_env, us)
= case (extendGlobalRnEnv def_env val_defds tc_defds) of { (new_def_env, def_dups) ->
- (if isEmptyBag def_dups then \x->x else pprTrace "add_occs:" (ppCat [ppr PprDebug n | (n,_,_) <- bagToList def_dups])) $
+ --(if isEmptyBag def_dups then \x->x else pprTrace "add_occs:" (ppCat [ppr PprDebug n | (n,_,_) <- bagToList def_dups])) $
-- ASSERT(isEmptyBag def_dups)
let
de_orig imps = [ (Qual m n, v) | (OrigName m n, v) <- fmToList imps ]
diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index 0f668bf06b1b..22cb653f79f9 100644
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -51,7 +51,7 @@ import CmdLineOpts ( opt_WarnNameShadowing )
import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine,
SYN_IE(Error), SYN_IE(Warning)
)
-import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, fmToList{-ToDo:rm-} )
+import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM{-, fmToList ToDo:rm-} )
import Maybes ( assocMaybe )
import Name ( SYN_IE(Module), RdrName(..), isQual,
OrigName(..), Name, mkLocalName, mkImplicitName,
@@ -59,9 +59,9 @@ import Name ( SYN_IE(Module), RdrName(..), isQual,
)
import PrelInfo ( builtinNameMaps, builtinKeysMap, SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) )
import PrelMods ( pRELUDE )
-import PprStyle{-ToDo:rm-}
-import Outputable{-ToDo:rm-}
-import Pretty--ToDo:rm ( SYN_IE(Pretty), PrettyRep )
+--import PprStyle{-ToDo:rm-}
+--import Outputable{-ToDo:rm-}
+import Pretty
import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
import UniqFM ( UniqFM, emptyUFM )
import UniqSet ( SYN_IE(UniqSet), mkUniqSet, minusUniqSet )
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 05d9e5afb218..f7879502d7bf 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -31,7 +31,7 @@ import Bag ( emptyBag, unitBag, consBag, snocBag, unionBags,
unionManyBags, mapBag, foldBag, filterBag, listToBag, bagToList )
import CmdLineOpts ( opt_NoImplicitPrelude, opt_CompilingGhcInternals )
import ErrUtils ( SYN_IE(Error), SYN_IE(Warning), addErrLoc, addShortErrLocLine, addShortWarnLocLine )
-import FiniteMap ( emptyFM, addToFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM, keysFM{-ToDo:rm-}, FiniteMap )
+import FiniteMap ( emptyFM, addToFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM, FiniteMap )
import Id ( GenId )
import Maybes ( maybeToBool, catMaybes, MaybeErr(..) )
import Name ( RdrName(..), Name, isQual, mkTopLevName, mkWiredInName, origName,
@@ -49,9 +49,9 @@ import TyCon ( tyConDataCons )
import UniqFM ( emptyUFM, addListToUFM_C, lookupUFM )
import UniqSupply ( splitUniqSupply )
import Util ( isIn, assoc, cmpPString, sortLt, removeDups,
- equivClasses, panic, assertPanic, pprPanic{-ToDo:rm-}, pprTrace{-ToDo:rm-}
+ equivClasses, panic, assertPanic
)
-import PprStyle --ToDo:rm
+--import PprStyle --ToDo:rm
\end{code}
\begin{code}
@@ -332,7 +332,7 @@ newGlobalName locn maybe_exp is_val_name rdr@(Qual mod name)
= case (lookupFM b_keys orig) of
Just (key,_) -> (key, True)
Nothing -> case (lookupFM (if is_val_name then b_val_names else b_tc_names) orig) of
- Nothing -> (pprPanic "newGlobalName:Qual:uniq:" (ppr PprDebug rdr), True)
+ Nothing -> (panic "newGlobalName:Qual:uniq", True)
Just xx -> (uniqueOf xx, False{-builtin!-})
exp = case maybe_exp of
@@ -347,7 +347,7 @@ newGlobalName locn maybe_exp is_val_name rdr@(Qual mod name)
| otherwise
= addErrRn (qualNameErr "name in definition" (rdr, locn)) `thenRn_`
- returnRn (pprPanic "newGlobalName:Qual:" (ppr PprDebug rdr))
+ returnRn (panic "newGlobalName:Qual")
\end{code}
*********************************************************
@@ -624,7 +624,7 @@ getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) modname maybe_spec
(str, orig)
= case (ie_name ie) of
Unqual s -> (s, OrigName modname s)
- Qual m s -> pprTrace "do_builtin:surprising qual!" (ppCat [ppPStr m, ppPStr s]) $
+ Qual m s -> --pprTrace "do_builtin:surprising qual!" (ppCat [ppPStr m, ppPStr s]) $
(s, OrigName modname s)
in
case (lookupFM b_tc_names orig) of -- NB: we favour the tycon/class FM...
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 277862f3bf0e..d650c01154f0 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -30,8 +30,8 @@ import ListSetOps ( unionLists, minusList )
import Maybes ( maybeToBool, catMaybes )
import Name ( isLocallyDefined, isLexVarId, getLocalName, ExportFlag(..),
nameImportFlag, RdrName, pprNonSym, Name )
-import Outputable -- ToDo:rm
-import PprStyle -- ToDo:rm
+import Outputable ( Outputable(..){-instances-} )
+--import PprStyle -- ToDo:rm
import Pretty
import SrcLoc ( SrcLoc )
import TyCon ( tyConDataCons, TyCon{-instance NamedThing-} )
@@ -39,7 +39,7 @@ import Unique ( Unique )
import UniqFM ( emptyUFM, addListToUFM_C, listToUFM, plusUFM, lookupUFM, eltsUFM )
import UniqSet ( SYN_IE(UniqSet) )
import Util ( isIn, isn'tIn, thenCmp, sortLt, removeDups, mapAndUnzip3, cmpPString,
- panic, assertPanic, pprTrace{-ToDo:rm-} )
+ panic, assertPanic{- , pprTrace ToDo:rm-} )
\end{code}
rnSource `renames' the source module and export list.
@@ -301,7 +301,7 @@ rnIE mods (IEThingWith name names)
failButContinueRn (emptyBag, emptyBag) (synAllExportErr True{-error-} rn src_loc)
checkIEWith (WiredInTyCon _) rns = panic "RnSource.rnIE:checkIEWith:WiredInTyCon:ToDo (boring)"
checkIEWith rn rns
- = pprTrace "rnIE:IEWith:panic? ToDo?:" (ppr PprDebug rn) $
+ = --pprTrace "rnIE:IEWith:panic? ToDo?:" (ppr PprDebug rn) $
returnRn (emptyBag, emptyBag)
exp_all n = (n, ExportAll)
diff --git a/ghc/compiler/root.lit b/ghc/compiler/root.lit
deleted file mode 100644
index 120cdad33ced..000000000000
--- a/ghc/compiler/root.lit
+++ /dev/null
@@ -1,115 +0,0 @@
-\begin{onlystandalone}
-\documentstyle[11pt,literate]{article}
-\begin{document}
-\title{Glasgow Haskell Compiler Sources}
-
-\author{The GRASP Team}
-}
-\date{February 1991}
-\maketitle
-\tableofcontents
-\end{onlystandalone}
-
-#\input{main/Main.lhs}
-
-#\section[prefix_form_reader]{Reader}
-#\downsection
-#\input{reader/ReaderIntermForm.lhs}
-#\input{reader/ReaderIntermSyntax.lhs}
-#\input{reader/RIFToHaskell.lhs}
-#\upsection
-#
-#\section[Names]{Things to do with names}
-#\downsection
-#\input{names/Names.lhs}
-#\input{names/NameSupply.lhs}
-#\input{names/UniqInts.lhs}
-#\input{names/NameSupplyMonad.lhs}
-#\input{names/SpecialStrings.lhs}
-#\upsection
-#
-#\section[AbsSyntax_stuff]{Abstract syntax stuff}
-#\downsection
-#\input{absSyntax/AbsSyntax.lhs}
-#\input{absSyntax/PrintAbsSyntax.lhs}
-#\input{absSyntax/PrettyAbsSyntax.lhs}
-#\input{absSyntax/UniType.lhs}
-#\input{absSyntax/PrintUniType.lhs}
-#\input{absSyntax/PrettyUniType.lhs}
-#\input{absSyntax/TypeFuns.lhs}
-#\input{absSyntax/AbsSyntaxRepFuns.lhs}
-#\upsection
-#
-#\section[Error_reporting]{Error reporting things}
-#\downsection
-#\input{errors/Error.lhs}
-#\upsection
-#
-#\section[Dependency_analysis]{Dependency analysis}
-#\downsection
-#\input{depanal/Depend.lhs}
-#\input{depanal/StronglyConnComp.lhs}
-#\upsection
-#
-#\input{typecheck/root.lit}
-#
-#\section[SyntaxPrimitives_stuff]{Basic syntax stuff}
-#\downsection
-#\input{syntaxPrims/SyntaxPrimitives.lhs}
-#\input{syntaxPrims/PrintSyntaxPrims.lhs}
-#\input{syntaxPrims/SyntaxConstants.lhs}
-#\input{syntaxPrims/SyntaxConstants.lh}
-#\upsection
-#
-#\section[CoreSyntax_stuff]{CoreSyntax syntax stuff}
-#\downsection
-#\input{coreSyntax/CoreSyntax.lhs}
-#\input{coreSyntax/PrintCoreSyntax.lhs}
-#\input{coreSyntax/AnnCoreSyntax.lhs}
-#\upsection
-#
-#\input{deSugar/root.lit}
-#
-#\section[Simplify_stuff]{Simplifying core expressions}
-#\downsection
-#\input{simplify/Simplify.lhs}
-#\upsection
-#
-#\section[Lambda_lifting]{A simple lambda-lifter}
-#\downsection
-#\input{llift/LambdaLift.lhs}
-#\upsection
-#
-#\section[core-to-stg-conversion]{Converting core syntax to STG syntax}
-#\downsection
-#\input{core2stg/CoreToStg.lhs}
-#\upsection
-
-\section[stg-syntax]{The STG syntax}
-\downsection
-\input{stgSyntax/StgSyntax.lhs}
-\input{stgSyntax/PrintStgSyntax.lhs}
-\upsection
-
-\input{codeGen/root.lit}
-
-#\section[abstract-C-syntax]{Abstract C syntax}
-#\downsection
-#\input{absCSyntax/AbstractC.lhs}
-#\input{absCSyntax/FlattenAbsC.lhs}
-#\input{absCSyntax/PrintAbstractC.lhs}
-#\input{absCSyntax/AbsToRealC.lhs}
-#\upsection
-
-#\section[Utility_functions]{Utility functions}
-#\downsection
-#\input{utils/Util.lhs}
-#\input{utils/Util2.lhs}
-#\input{utils/Pretty.lhs}
-#\input{utils/Set.lhs}
-#\upsection
-
-\begin{onlystandalone}
-\printindex
-\end{document}
-\end{onlystandalone}
diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs
index 9cf9d7c142f4..29ce8a9dd349 100644
--- a/ghc/compiler/simplCore/FloatIn.lhs
+++ b/ghc/compiler/simplCore/FloatIn.lhs
@@ -198,7 +198,7 @@ fiExpr to_drop (_, AnnSCC cc expr)
\begin{code}
fiExpr to_drop (_, AnnCoerce c ty expr)
- = trace "fiExpr:Coerce:wimping out" $
+ = --trace "fiExpr:Coerce:wimping out" $
mkCoLets' to_drop (Coerce c ty (fiExpr [] expr))
\end{code}
diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs
index ab3e4b29a634..786f723ca6f3 100644
--- a/ghc/compiler/simplCore/SimplCase.lhs
+++ b/ghc/compiler/simplCore/SimplCase.lhs
@@ -16,7 +16,8 @@ IMPORT_DELOOPER(SmplLoop) ( simplBind, simplExpr, MagicUnfoldingFun )
import BinderInfo -- too boring to try to select things...
import CmdLineOpts ( SimplifierSwitch(..) )
import CoreSyn
-import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..), SimpleUnfolding
+import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..),
+ SimpleUnfolding, FormSummary
)
import CoreUtils ( coreAltsType, nonErrorRHSs, maybeErrorApp,
unTagBindersAlts
@@ -371,7 +372,7 @@ constructor or literal, because that would have been inlined
\begin{code}
completeCase env scrut alts rhs_c
= simplAlts env scrut alts rhs_c `thenSmpl` \ alts' ->
- mkCoCase scrut alts'
+ mkCoCase env scrut alts'
\end{code}
@@ -682,7 +683,8 @@ completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c
-- let-bind the binder to the constructor
cloneId env binder `thenSmpl` \ id' ->
let
- new_env = extendEnvGivenBinding env occ_info id' (Con con con_args)
+ env1 = extendIdEnvWithClone env binder id'
+ new_env = extendEnvGivenBinding env1 occ_info id' (Con con con_args)
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
returnSmpl (Let (NonRec id' (Con con con_args)) rhs')
@@ -692,7 +694,7 @@ Case absorption and identity-case elimination
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-mkCoCase :: OutExpr -> OutAlts -> SmplM OutExpr
+mkCoCase :: SimplEnv -> OutExpr -> OutAlts -> SmplM OutExpr
\end{code}
@mkCoCase@ tries the following transformation (if possible):
@@ -742,12 +744,13 @@ The following code handles *both* these transformations (one
equation for AlgAlts, one for PrimAlts):
\begin{code}
-mkCoCase scrut (AlgAlts outer_alts
+mkCoCase env scrut (AlgAlts outer_alts
(BindDefault deflt_var
(Case (Var scrut_var')
(AlgAlts inner_alts inner_deflt))))
- | (scrut_is_var && scrut_var == scrut_var') -- First transformation
- || deflt_var == scrut_var' -- Second transformation
+ | switchIsSet env SimplCaseMerge &&
+ ((scrut_is_var && scrut_var == scrut_var') || -- First transformation
+ deflt_var == scrut_var') -- Second transformation
= -- Aha! The default-absorption rule applies
tick CaseMerge `thenSmpl_`
returnSmpl (Case scrut (AlgAlts (outer_alts ++ munged_reduced_inner_alts)
@@ -775,13 +778,14 @@ mkCoCase scrut (AlgAlts outer_alts
arg_tys = case (getAppDataTyConExpandingDicts (idType deflt_var)) of
(_, arg_tys, _) -> arg_tys
-mkCoCase scrut (PrimAlts
+mkCoCase env scrut (PrimAlts
outer_alts
(BindDefault deflt_var (Case
(Var scrut_var')
(PrimAlts inner_alts inner_deflt))))
- | (scrut_is_var && scrut_var == scrut_var') ||
- deflt_var == scrut_var'
+ | switchIsSet env SimplCaseMerge &&
+ ((scrut_is_var && scrut_var == scrut_var') ||
+ deflt_var == scrut_var')
= -- Aha! The default-absorption rule applies
tick CaseMerge `thenSmpl_`
returnSmpl (Case scrut (PrimAlts (outer_alts ++ munged_reduced_inner_alts)
@@ -831,7 +835,7 @@ Now the identity-case transformation:
and similar friends.
\begin{code}
-mkCoCase scrut alts
+mkCoCase env scrut alts
| identity_alts alts
= tick CaseIdentity `thenSmpl_`
returnSmpl scrut
@@ -868,7 +872,7 @@ mkCoCase scrut alts
The catch-all case
\begin{code}
-mkCoCase other_scrut other_alts = returnSmpl (Case other_scrut other_alts)
+mkCoCase env other_scrut other_alts = returnSmpl (Case other_scrut other_alts)
\end{code}
Boring local functions used above. They simply introduce a trivial binding
diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs
index d8aa0070e2d3..0d3c544c4106 100644
--- a/ghc/compiler/simplCore/SimplCore.lhs
+++ b/ghc/compiler/simplCore/SimplCore.lhs
@@ -34,14 +34,14 @@ import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), switchIsOn,
import CoreLint ( lintCoreBindings )
import CoreSyn
import CoreUnfold
-import CoreUtils ( substCoreBindings, whnfOrBottom )
+import CoreUtils ( substCoreBindings )
import ErrUtils ( ghcExit )
import FiniteMap ( FiniteMap )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
import FoldrBuildWW ( mkFoldrBuildWW )
import Id ( idType, toplevelishId, idWantsToBeINLINEd,
- unfoldingUnfriendlyId,
+ unfoldingUnfriendlyId, isWrapperId,
nullIdEnv, addOneToIdEnv, delOneFromIdEnv,
lookupIdEnv, SYN_IE(IdEnv),
GenId{-instance Outputable-}
@@ -72,7 +72,6 @@ import DefUtils ( deforestable )
#endif
isWrapperFor = panic "SimplCore.isWrapperFor (ToDo)"
-isWrapperId = panic "SimplCore.isWrapperId (ToDo)"
\end{code}
\begin{code}
diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs
index b75369b0921f..f9847642790f 100644
--- a/ghc/compiler/simplCore/SimplEnv.lhs
+++ b/ghc/compiler/simplCore/SimplEnv.lhs
@@ -526,7 +526,7 @@ data UnfoldConApp
nullConApps = emptyFM
extendConApps con_apps id (Con con args)
- = addToFM_C (\old new -> new++old) con_apps (UCA con val_args) [(ty_args,con)]
+ = addToFM_C (\old new -> new++old) con_apps (UCA con val_args) [(ty_args,id)]
where
val_args = filter isValArg args -- Literals and Ids
ty_args = [ty | TyArg ty <- args] -- Just types
diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 5f00a8e9e7c9..f1ac5d87f88b 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -194,7 +194,7 @@ simplTopBinds env (NonRec binder@(in_id,occ_info) rhs : binds)
= -- No cloning necessary at top level
-- Process the binding
simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
- completeNonRec env binder rhs' `thenSmpl` \ (new_env, binds1') ->
+ completeNonRec True env binder rhs' `thenSmpl` \ (new_env, binds1') ->
-- Process the other bindings
simplTopBinds new_env binds `thenSmpl` \ binds2' ->
@@ -733,10 +733,17 @@ simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
simpl_bind env rhs | will_be_demanded &&
try_let_to_case &&
type_ok_for_let_to_case rhs_ty &&
- rhs_is_whnf -- note: WHNF, but not bottom, (comment below)
+ not rhs_is_whnf -- note: WHNF, but not bottom, (comment below)
= tick Let2Case `thenSmpl_`
mkIdentityAlts rhs_ty `thenSmpl` \ id_alts ->
- simplCase env rhs id_alts (\env rhs -> simpl_bind env rhs) body_ty
+ simplCase env rhs id_alts (\env rhs -> complete_bind env rhs) body_ty
+ -- NB: it's tidier to call complete_bind not simpl_bind, else
+ -- we nearly end up in a loop. Consider:
+ -- let x = rhs in b
+ -- ==> case rhs of (p,q) -> let x=(p,q) in b
+ -- This effectively what the above simplCase call does.
+ -- Now, the inner let is a let-to-case target again! Actually, since
+ -- the RHS is in WHNF it won't happen, but it's a close thing!
-- Try let-from-let
simpl_bind env (Let bind rhs) | let_floating_ok
@@ -763,10 +770,12 @@ simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
returnSmpl (Let extra_binding case_expr)
-- None of the above; simplify rhs and tidy up
- simpl_bind env rhs
- = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
- completeNonRec env binder rhs' `thenSmpl` \ (new_env, binds) ->
- body_c new_env `thenSmpl` \ body' ->
+ simpl_bind env rhs = complete_bind env rhs
+
+ complete_bind env rhs
+ = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
+ completeNonRec False env binder rhs' `thenSmpl` \ (new_env, binds) ->
+ body_c new_env `thenSmpl` \ body' ->
returnSmpl (mkCoLetsAny binds body')
@@ -951,7 +960,7 @@ simplBind env (Rec pairs) body_c body_ty
let
env_w_clones = extendIdEnvWithClones env binders ids'
in
- simplRecursiveGroup env ids' floated_pairs `thenSmpl` \ (binding, new_env) ->
+ simplRecursiveGroup env_w_clones ids' floated_pairs `thenSmpl` \ (binding, new_env) ->
body_c new_env `thenSmpl` \ body' ->
@@ -989,7 +998,8 @@ simplBind env (Rec pairs) body_c body_ty
simplRecursiveGroup env new_ids pairs
= -- Add unfoldings to the new_ids corresponding to their RHS
let
- occs = [occ | ((_,occ), _) <- pairs]
+ binders = map fst pairs
+ occs = map snd binders
new_ids_w_pairs = zipEqual "simplRecGp" new_ids pairs
rhs_env = foldl extendEnvForRecBinding
env new_ids_w_pairs
@@ -998,11 +1008,12 @@ simplRecursiveGroup env new_ids pairs
mapSmpl (\(binder,rhs) -> simplRhsExpr rhs_env binder rhs) pairs `thenSmpl` \ new_rhss ->
let
- new_pairs = zipEqual "simplRecGp" new_ids new_rhss
+ new_pairs = zipEqual "simplRecGp" new_ids new_rhss
occs_w_new_pairs = zipEqual "simplRecGp" occs new_pairs
- new_env = foldl (\env (occ_info,(new_id,new_rhs)) ->
- extendEnvGivenBinding env occ_info new_id new_rhs)
- env occs_w_new_pairs
+ new_env = foldl add_binding env occs_w_new_pairs
+
+ add_binding env (occ_info,(new_id,new_rhs))
+ = extendEnvGivenBinding env occ_info new_id new_rhs
in
returnSmpl (Rec new_pairs, new_env)
\end{code}
@@ -1052,12 +1063,12 @@ x. That's just what completeLetBinding does.
-- Sigh: rather disgusting case for coercions. We want to
-- ensure that all let-bound Coerces have atomic bodies, so
-- they can freely be inlined.
-completeNonRec env binder@(_,occ_info) (Coerce coercion ty rhs)
+completeNonRec top_level env binder@(_,occ_info) (Coerce coercion ty rhs)
= (case rhs of
Var v -> returnSmpl (env, [], rhs)
Lit l -> returnSmpl (env, [], rhs)
other -> newId (coreExprType rhs) `thenSmpl` \ inner_id ->
- completeNonRec env
+ completeNonRec top_level env
(inner_id, dangerousArgOcc) rhs `thenSmpl` \ (env1, extra_bind) ->
-- Dangerous occ because, like constructor args,
-- it can be duplicated easily
@@ -1079,22 +1090,30 @@ completeNonRec env binder@(_,occ_info) (Coerce coercion ty rhs)
in
returnSmpl (new_env, extra_bind ++ [NonRec new_id new_rhs])
-completeNonRec env binder new_rhs
+completeNonRec top_level env binder@(id,_) new_rhs
-- See if RHS is an atom, or a reusable constructor
| maybeToBool maybe_atomic_rhs
= let
new_env = extendIdEnvWithAtom env binder rhs_atom
+ result_binds | top_level = [NonRec id new_rhs] -- Don't discard top-level bindings
+ -- (they'll be dropped later if not
+ -- exported and dead)
+ | otherwise = []
in
tick atom_tick_type `thenSmpl_`
- returnSmpl (new_env, [])
+ returnSmpl (new_env, result_binds)
where
maybe_atomic_rhs = exprToAtom env new_rhs
Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs
-completeNonRec env binder@(_,occ_info) new_rhs
- = cloneId env binder `thenSmpl` \ new_id ->
+completeNonRec top_level env binder@(old_id,occ_info) new_rhs
+ = (if top_level then
+ returnSmpl old_id -- Only clone local binders
+ else
+ cloneId env binder
+ ) `thenSmpl` \ new_id ->
let
- env1 = extendIdEnvWithClone env binder new_id
+ env1 = extendIdEnvWithClone env binder new_id
new_env = extendEnvGivenBinding env1 occ_info new_id new_rhs
in
returnSmpl (new_env, [NonRec new_id new_rhs])
diff --git a/ghc/compiler/simplCore/simplifier.tib b/ghc/compiler/simplCore/simplifier.tib
index 375724bab3eb..18acd279436e 100644
--- a/ghc/compiler/simplCore/simplifier.tib
+++ b/ghc/compiler/simplCore/simplifier.tib
@@ -17,7 +17,7 @@
\author{Simon Peyton Jones and Andre Santos\\
Department of Computing Science, University of Glasgow, G12 8QQ \\
- @simonpj@@dcs.glasgow.ac.uk@
+ @simonpj@@dcs.gla.ac.uk@
}
\maketitle
diff --git a/ghc/compiler/specialise/SpecEnv.lhs b/ghc/compiler/specialise/SpecEnv.lhs
index d7528b8c7fc9..6efc6af98dc8 100644
--- a/ghc/compiler/specialise/SpecEnv.lhs
+++ b/ghc/compiler/specialise/SpecEnv.lhs
@@ -18,8 +18,19 @@ import MatchEnv
import Type ( matchTys, isTyVarTy )
import Usage ( SYN_IE(UVar) )
import OccurAnal ( occurAnalyseGlobalExpr )
-import CoreSyn ( CoreExpr(..), SimplifiableCoreExpr(..) )
+import CoreSyn ( SYN_IE(CoreExpr), SYN_IE(SimplifiableCoreExpr) )
import Maybes ( MaybeErr(..) )
+--import PprStyle--ToDo:rm
+--import Util(pprTrace)--ToDo:rm
+--import Outputable--ToDo:rm
+--import PprType--ToDo:rm
+--import Pretty--ToDo:rm
+--import PprCore--ToDo:rm
+--import Id--ToDo:rm
+--import TyVar--ToDo:rm
+--import Unique--ToDo:rm
+--import IdInfo--ToDo:rm
+--import PprEnv--ToDo:rm
\end{code}
@@ -67,12 +78,14 @@ isNullSpecEnv (SpecEnv env) = null (mEnvToList env)
addOneToSpecEnv :: SpecEnv -> [Type] -> CoreExpr -> MaybeErr SpecEnv ([Type], SimplifiableCoreExpr)
addOneToSpecEnv (SpecEnv env) tys rhs
- = case (insertMEnv matchTys env tys (occurAnalyseGlobalExpr rhs)) of
+ = --pprTrace "addOneToSpecEnv" (ppAbove (ppr PprDebug tys) (ppr PprDebug rhs)) $
+ case (insertMEnv matchTys env tys (occurAnalyseGlobalExpr rhs)) of
Succeeded menv -> Succeeded (SpecEnv menv)
Failed err -> Failed err
lookupSpecEnv :: SpecEnv -> [Type] -> Maybe (SimplifiableCoreExpr, ([(TyVar,Type)], [Type]))
lookupSpecEnv (SpecEnv env) tys
| all isTyVarTy tys = Nothing -- Short cut: no specialisation for simple tyvars
- | otherwise = lookupMEnv matchTys env tys
+ | otherwise = --pprTrace "lookupSpecEnv" (ppr PprDebug tys) $
+ lookupMEnv matchTys env tys
\end{code}
diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index c3a8d4b2882a..114131aeac3c 100644
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -41,12 +41,12 @@ import Type ( maybeAppDataTyCon, getAppDataTyConExpandingDicts )
import TysWiredIn ( stringTy )
import Unique ( integerTyConKey, ratioTyConKey, Unique{-instance Eq-} )
import UniqSupply -- all of it, really
-import Util ( panic, assertPanic, pprTrace{-ToDo:rm-} )
-import Pretty--ToDo:rm
-import PprStyle--ToDo:rm
-import PprType --ToDo:rm
-import Outputable--ToDo:rm
-import PprEnv--ToDo:rm
+import Util ( panic, assertPanic{-, pprTrace ToDo:rm-} )
+--import Pretty--ToDo:rm
+--import PprStyle--ToDo:rm
+--import PprType --ToDo:rm
+--import Outputable--ToDo:rm
+--import PprEnv--ToDo:rm
isLeakFreeType x y = False -- safe option; ToDo
\end{code}
@@ -343,7 +343,7 @@ litToStgArg (NoRepInteger i integer_ty)
litToStgArg (NoRepRational r rational_ty)
= --ASSERT(is_rational_ty)
- (if is_rational_ty then \x->x else pprTrace "litToStgArg:not rational?" (pprType PprDebug rational_ty)) $
+ --(if is_rational_ty then \x->x else pprTrace "litToStgArg:not rational?" (pprType PprDebug rational_ty)) $
litToStgArg (NoRepInteger (numerator r) integer_ty) `thenUs` \ (num_atom, binds1) ->
litToStgArg (NoRepInteger (denominator r) integer_ty) `thenUs` \ (denom_atom, binds2) ->
newStgVar rational_ty `thenUs` \ var ->
diff --git a/ghc/compiler/stgSyn/Jmakefile b/ghc/compiler/stgSyn/Jmakefile
deleted file mode 100644
index 32b8199f6a82..000000000000
--- a/ghc/compiler/stgSyn/Jmakefile
+++ /dev/null
@@ -1,5 +0,0 @@
-/* this is a standalone Jmakefile; NOT part of ghc "make world" */
-
-/*LIT2LATEX_OPTS=-ttgrind*/
-
-LitDocRootTarget(root,lit)
diff --git a/ghc/compiler/stgSyn/root.lit b/ghc/compiler/stgSyn/root.lit
deleted file mode 100644
index 9842848fd953..000000000000
--- a/ghc/compiler/stgSyn/root.lit
+++ /dev/null
@@ -1,9 +0,0 @@
-\documentstyle[11pt,literate,a4wide]{article}
-
-\begin{document}
-\author{Simon and friends}
-\title{STG Syntax}
-\maketitle
-
-\input{StgSyn.lhs}
-\end{document}
diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index 34f09908a83b..6b8a7afbe2a3 100644
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -57,7 +57,7 @@ import Outputable
import PprType ( GenClass, TyCon, GenType, GenTyVar, pprParendGenType )
import PprStyle ( PprStyle(..) )
import Pretty
-import SpecEnv ( SYN_IE(SpecEnv) )
+import SpecEnv ( SpecEnv )
import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
import Type ( GenType, eqSimpleTy, instantiateTy,
isTyVarTy, mkDictTy, splitForAllTy, splitSigmaTy,
diff --git a/ghc/compiler/typecheck/Jmakefile b/ghc/compiler/typecheck/Jmakefile
deleted file mode 100644
index 3e0bd416332b..000000000000
--- a/ghc/compiler/typecheck/Jmakefile
+++ /dev/null
@@ -1,11 +0,0 @@
-/* this is a standalone Jmakefile; NOT part of ghc "make world" */
-
-LitStuffNeededHere(docs depend)
-InfoStuffNeededHere(docs)
-HaskellSuffixRules()
-
-/* LIT2LATEX_OPTS=-tbird */
-
-LIT2LATEX_OPTS=-ttgrind
-
-LitDocRootTargetWithNamedOutput(root,lit,root-standalone)
diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index c2818b345313..fea81a43da4d 100644
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -25,7 +25,6 @@ import TcHsSyn ( TcIdOcc(..), SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds), SYN_IE(Tc
import Inst ( Inst, InstOrigin(..), SYN_IE(LIE), emptyLIE, plusLIE, newDicts, newMethod )
import TcEnv ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds, tcExtendGlobalTyVars )
-import SpecEnv ( SpecEnv )
import TcInstDcls ( processInstBinds )
import TcKind ( unifyKind, TcKind )
import TcMonad hiding ( rnMtoTcM )
@@ -46,7 +45,7 @@ import PrelVals ( nO_DEFAULT_METHOD_ERROR_ID )
import PprStyle
import Pretty
import PprType ( GenType, GenTyVar, GenClassOp )
-import SpecEnv ( SYN_IE(SpecEnv) )
+import SpecEnv ( SpecEnv )
import SrcLoc ( mkGeneratedSrcLoc )
import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
mkForAllTy, mkSigmaTy, splitSigmaTy)
diff --git a/ghc/compiler/typecheck/TcClassSig.lhs b/ghc/compiler/typecheck/TcClassSig.lhs
deleted file mode 100644
index 08e2fe10bb1a..000000000000
--- a/ghc/compiler/typecheck/TcClassSig.lhs
+++ /dev/null
@@ -1,93 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[TcClassSig]{Typecheck a class signature}
-
-\begin{code}
-#include "HsVersions.h"
-
-module TcClassSig ( tcClassSigs ) where
-
-import TcMonad hiding ( rnMtoTcM )
-import HsSyn -- the stuff being typechecked
-
-import Type
-import Id ( mkDefaultMethodId, mkClassOpId, IdInfo )
-import IdInfo
-import TcMonoType ( tcPolyType )
-import TcPragmas ( tcClassOpPragmas )
-import Util
-\end{code}
-
-\begin{code}
-tcClassSigs :: E -> TVE -> Class -- Knot tying only!
- -> (ClassOp -> SpecEnv) -- Ditto; the spec info for the class ops
- -> TyVarTemplate -- The class type variable, used for error check only
- -> [RnName] -- Names with default methods
- -> [RenamedClassOpSig]
- -> Baby_TcM ([ClassOp], -- class ops
- GVE, -- env for looking up the class ops
- [Id], -- selector ids
- [Id]) -- default-method ids
-
-tcClassSigs e tve rec_clas rec_classop_spec_fn clas_tyvar defm_names sigs
- = mapB_Tc tc_sig sigs `thenB_Tc` \ stuff ->
- let
- (ops, op_gves, sel_ids, defm_ids) = unzip4 stuff
- in
- returnB_Tc (ops, foldr plusGVE nullGVE op_gves, sel_ids, defm_ids)
- where
- rec_ce = getE_CE e
- rec_tce = getE_TCE e
---FAKE: fake_E = mkE rec_tce rec_ce
-
- tc_sig (ClassOpSig name@(ClassOpName op_uniq _ op_name tag) poly_ty pragmas src_loc)
- = addSrcLocB_Tc src_loc (
- tcPolyType rec_ce rec_tce tve poly_ty `thenB_Tc` \ local_ty ->
- let
- (local_tyvar_tmpls, theta, tau) = splitSigmaTy local_ty
- full_theta = (rec_clas, (mkTyVarTemplateTy clas_tyvar)) : theta
- full_tyvar_tmpls = clas_tyvar : local_tyvar_tmpls
- global_ty = mkForallTy full_tyvar_tmpls (mkRhoTy full_theta tau)
- class_op = mkClassOp op_name tag local_ty
-
- not_elem = isn'tIn "tcClassSigs"
- in
- -- Check that the class type variable is mentioned
- checkB_Tc (clas_tyvar `not_elem` extractTyVarTemplatesFromTy local_ty)
- (methodTypeLacksTyVarErr clas_tyvar (_UNPK_ op_name) src_loc) `thenB_Tc_`
-
- -- Munch the pragmas, building a suitable default-method
- -- Id from the details found there.
- getUniqueB_Tc `thenB_Tc` \ d_uniq ->
-
- fixB_Tc ( \ ~(rec_op_id, rec_defm_id) ->
- tcClassOpPragmas e{-fake_E-}
- global_ty
- rec_op_id rec_defm_id
- (rec_classop_spec_fn class_op)
- pragmas `thenB_Tc` \ (op_info, defm_info) ->
- let
- -- the default method is error "No default ..." if there is no
- -- default method code or the imported default method is bottoming.
-
- error_defm = if isLocallyDefined clas_name then
- name `notElem` defm_names
- else
- bottomIsGuaranteed (getInfo defm_info)
- in
- returnB_Tc (
- mkClassOpId op_uniq rec_clas class_op global_ty op_info,
- mkDefaultMethodId d_uniq rec_clas class_op error_defm global_ty defm_info
- )
-
- ) `thenB_Tc` \ (selector_id, default_method_id) ->
-
- returnB_Tc (class_op, unitGVE name selector_id, selector_id, default_method_id)
- )
-
- tc_sig (ClassOpSig name _ _ src_loc)
- = failB_Tc (confusedNameErr
- "Bad name on a class-method signature (a Prelude name?)"
- name src_loc)
-\end{code}
diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index 35995fd0b737..c93795707008 100644
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -32,7 +32,7 @@ import RnMonad
import RnUtils ( SYN_IE(RnEnv), extendGlobalRnEnv )
import RnBinds ( rnMethodBinds, rnTopBinds )
-import Bag ( emptyBag{-ToDo:rm-}, Bag, isEmptyBag, unionBags, listToBag )
+import Bag ( Bag, isEmptyBag, unionBags, listToBag )
import Class ( classKey, needsDataDeclCtxtClassKeys, GenClass )
import ErrUtils ( pprBagOfErrors, addErrLoc, SYN_IE(Error) )
import Id ( dataConArgTys, isNullaryDataCon, mkDictFunId )
@@ -45,8 +45,8 @@ import Outputable ( Outputable(..){-instances e.g., (,)-} )
import PprType ( GenType, GenTyVar, GenClass, TyCon )
import PprStyle ( PprStyle(..) )
import Pretty ( ppAbove, ppAboves, ppCat, ppBesides, ppStr, ppHang, SYN_IE(Pretty) )
-import Pretty--ToDo:rm
-import FiniteMap--ToDo:rm
+--import Pretty--ToDo:rm
+--import FiniteMap--ToDo:rm
import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings,
tyConTheta, maybeTyConSingleCon,
@@ -61,8 +61,8 @@ import TyVar ( GenTyVar )
import UniqFM ( emptyUFM )
import Unique -- Keys stuff
import Util ( zipWithEqual, zipEqual, sortLt, removeDups, assoc,
- thenCmp, cmpList, panic, pprPanic, pprPanic#,
- assertPanic, pprTrace{-ToDo:rm-}
+ thenCmp, cmpList, panic, panic#, pprPanic, pprPanic#,
+ assertPanic-- , pprTrace{-ToDo:rm-}
)
\end{code}
@@ -439,7 +439,7 @@ solveDerivEqns inst_decl_infos_in orig_eqns
= (tv1 `cmp` tv2) `thenCmp` (c1 `cmp` c2)
#ifdef DEBUG
cmp_rhs other_1 other_2
- = pprPanic# "tcDeriv:cmp_rhs:" (ppCat [ppr PprDebug other_1, ppr PprDebug other_2])
+ = panic# "tcDeriv:cmp_rhs:" --(ppCat [ppr PprDebug other_1, ppr PprDebug other_2])
#endif
\end{code}
@@ -490,7 +490,7 @@ add_solns inst_infos_in eqns solns
-- We can't leave it as a panic because to get the theta part we
-- have to run down the type!
- my_panic str = pprPanic ("add_soln:"++str) (ppCat [ppChar ':', ppr PprDebug clas, ppr PprDebug tycon])
+ my_panic str = panic "add_soln" -- pprPanic ("add_soln:"++str) (ppCat [ppChar ':', ppr PprDebug clas, ppr PprDebug tycon])
\end{code}
%************************************************************************
@@ -611,8 +611,9 @@ gen_inst_info modname fixities deriver_rn_env
) `thenNF_Tc` \ (mbinds, errs) ->
if not (isEmptyBag errs) then
- pprPanic "gen_inst_info:renamer errs!\n"
- (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug proto_mbinds))
+ panic "gen_inst_info:renamer errs!\n"
+-- pprPanic "gen_inst_info:renamer errs!\n"
+-- (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug proto_mbinds))
else
-- All done
let
@@ -681,8 +682,9 @@ gen_tag_n_con_binds rn_env nm_alist_etc
) `thenNF_Tc` \ (binds, errs) ->
if not (isEmptyBag errs) then
- pprPanic "gen_tag_n_con_binds:renamer errs!\n"
- (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug binds))
+ panic "gen_tag_n_con_binds:renamer errs!\n"
+-- pprPanic "gen_tag_n_con_binds:renamer errs!\n"
+-- (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug binds))
else
returnTc (binds, deriver_rn_env)
\end{code}
diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 1360c47b9c68..bda4f4a81be9 100644
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -41,10 +41,10 @@ import Name ( getOccName, getSrcLoc, Name{-instance NamedThing-} )
import PprStyle
import Pretty
import RnHsSyn ( RnName(..) )
-import Unique ( pprUnique10, pprUnique{-ToDo:rm-} )
+import Unique ( pprUnique10{-, pprUnique ToDo:rm-} )
import UniqFM
import Util ( zipEqual, zipWithEqual, zipWith3Equal, zipLazy,
- panic, pprPanic, pprTrace{-ToDo:rm-}
+ panic, pprPanic{-, pprTrace ToDo:rm-}
)
\end{code}
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index e12fb7ae82a1..df32170f2bcc 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -80,7 +80,7 @@ import Type ( GenType(..), SYN_IE(ThetaType), mkTyVarTys,
splitSigmaTy, splitAppTy, isTyVarTy, matchTy, mkSigmaTy,
getTyCon_maybe, maybeBoxedPrimType, splitRhoTy, eqTy
)
-import TyVar ( GenTyVar, GenTyVarSet(..), mkTyVarSet, unionTyVarSets )
+import TyVar ( GenTyVar, SYN_IE(GenTyVarSet), mkTyVarSet, unionTyVarSets )
import TysWiredIn ( stringTy )
import Unique ( Unique )
import Util ( zipEqual, panic )
diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs
index 12e0f14bb91e..38b8f2fb4103 100644
--- a/ghc/compiler/typecheck/TcInstUtil.lhs
+++ b/ghc/compiler/typecheck/TcInstUtil.lhs
@@ -35,7 +35,7 @@ import Maybes ( MaybeErr(..), mkLookupFunDef )
import Name ( getSrcLoc, Name{--O only-} )
import PprType ( GenClass, GenType, GenTyVar )
import Pretty
-import SpecEnv ( SYN_IE(SpecEnv), nullSpecEnv, addOneToSpecEnv )
+import SpecEnv ( SpecEnv, nullSpecEnv, addOneToSpecEnv )
import SrcLoc ( SrcLoc )
import Type ( mkSigmaTy, mkForAllTys, mkDictTy, mkTyVarTys,
splitForAllTy, instantiateTy, matchTy, SYN_IE(ThetaType) )
@@ -121,11 +121,11 @@ mkInstanceRelatedIds from_here src_loc inst_mod inst_pragmas
-- MAKE THE CONSTANT-METHOD IDS
-- if there are no type variables involved
- (if not (null inst_decl_theta)
+ (if (null inst_decl_theta)
then
- returnTc []
- else
mapTc mk_const_meth_id class_ops
+ else
+ returnTc []
) `thenTc` \ const_meth_ids ->
returnTc (dfun_id, dfun_theta, const_meth_ids)
@@ -244,14 +244,17 @@ addClassInstance
-- If there are any constant methods, then add them to
-- the SpecEnv of each class op (ie selector)
--
- -- Example. class Foo a where { op :: Baz b => a -> b }
- -- instance Foo (p,q) where { op (x,y) = ... }
+ -- Example. class Foo a where { op :: Baz b => a -> b; ... }
+ -- instance Foo (p,q) where { op (x,y) = ... ; ... }
+ --
+ -- The class decl means that
+ -- op :: forall a. Foo a => forall b. Baz b => a -> b
--
-- The constant method from the instance decl will be:
-- op_Pair :: forall p q b. Baz b => (p,q) -> b
--
-- What we put in op's SpecEnv is
- -- (p,q) b |--> (\d::Foo (p,q) -> op_Pair p q b)
+ -- (p,q) |--> (\d::Foo (p,q) -> op_Pair p q)
--
-- Here, [p,q] are the inst_tyvars, and d is a dict whose only
-- purpose is to cancel with the dict to which op is applied.
@@ -270,15 +273,11 @@ addClassInstance
| otherwise = zipWithEqual "add_const_meth" add_const_meth op_spec_envs const_meth_ids
add_const_meth (op,spec_env) meth_id
- = (op, case addOneToSpecEnv spec_env (inst_ty : local_tyvar_tys) rhs of
+ = (op, case addOneToSpecEnv spec_env [inst_ty] rhs of
Failed (tys', rhs') -> panic "TcInstDecls:add_const_meth"
Succeeded spec_env' -> spec_env' )
where
- (local_tyvars, _) = splitForAllTy (classOpLocalType op)
- local_tyvar_tys = mkTyVarTys local_tyvars
- rhs = mkValLam [dict] (mkTyApp (mkTyApp (Var meth_id)
- (mkTyVarTys inst_tyvars))
- local_tyvar_tys)
+ rhs = mkValLam [dict] (mkTyApp (Var meth_id) (mkTyVarTys inst_tyvars))
in
returnTc (class_inst_env', op_spec_envs')
}
diff --git a/ghc/compiler/typecheck/TcLoop.lhs b/ghc/compiler/typecheck/TcLoop.lhs
deleted file mode 100644
index 39cf96c150e0..000000000000
--- a/ghc/compiler/typecheck/TcLoop.lhs
+++ /dev/null
@@ -1,7 +0,0 @@
-This module breaks the loops among the typechecker modules
-TcExpr, TcBinds, TcMonoBnds, TcQuals, TcGRHSs, TcMatches.
-
-\begin{code}
-module TcLoop( tcGRHSsAndBinds )
-import TcGRHSs( tcGRHSsAndBinds )
-\end{code}
diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs
index fa642c55ec06..e595a839e4c1 100644
--- a/ghc/compiler/typecheck/TcMonad.lhs
+++ b/ghc/compiler/typecheck/TcMonad.lhs
@@ -57,7 +57,7 @@ import RnUtils ( SYN_IE(RnEnv) )
import Bag ( Bag, emptyBag, isEmptyBag,
foldBag, unitBag, unionBags, snocBag )
-import FiniteMap ( FiniteMap, emptyFM, isEmptyFM, keysFM{-ToDo:rm-} )
+import FiniteMap ( FiniteMap, emptyFM, isEmptyFM{-, keysFM ToDo:rm-} )
--import Outputable ( Outputable(..), NamedThing(..), ExportFlag )
import Maybes ( MaybeErr(..) )
--import Name ( Name )
@@ -494,9 +494,9 @@ rnMtoTcM rn_env rn_action down env
getImplicitUpRn `thenRn` \ implicit_env@(v_env,tc_env) ->
if (isEmptyFM v_env && isEmptyFM tc_env)
then returnRn result
- else pprPanic "rnMtoTcM: non-empty ImplicitEnv!"
- (ppAboves ([ ppCat [ppPStr m, ppPStr n] | (OrigName m n) <- keysFM v_env]
- ++ [ ppCat [ppPStr m, ppPStr n] | (OrigName m n) <- keysFM tc_env]))
+ else panic "rnMtoTcM: non-empty ImplicitEnv!"
+-- (ppAboves ([ ppCat [ppPStr m, ppPStr n] | (OrigName m n) <- keysFM v_env]
+-- ++ [ ppCat [ppPStr m, ppPStr n] | (OrigName m n) <- keysFM tc_env]))
)
in
returnSST (rn_result, rn_errs)
diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index 5988dbb7f757..d933c2f85bd3 100644
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -35,7 +35,7 @@ import TysWiredIn ( mkListTy, mkTupleTy )
import Unique ( Unique )
import PprStyle
import Pretty
-import Util ( zipWithEqual, panic, pprPanic{-ToDo:rm-} )
+import Util ( zipWithEqual, panic{-, pprPanic ToDo:rm-} )
\end{code}
diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index 046ab6de2609..becc2d6104aa 100644
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -33,7 +33,7 @@ import Id ( GenId, idType )
import Kind ( Kind, mkBoxedTypeKind, mkTypeKind )
import Maybes ( maybeToBool )
import PprType ( GenType, GenTyVar )
-import PprStyle--ToDo:rm
+--import PprStyle--ToDo:rm
import Pretty
import Type ( splitFunTy, splitRhoTy, splitSigmaTy, mkTyVarTys,
getFunTy_maybe, maybeAppDataTyCon,
@@ -45,7 +45,7 @@ import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
)
import TysWiredIn ( charTy, stringTy, mkListTy, mkTupleTy, addrTy )
import Unique ( Unique, eqClassOpKey )
-import Util ( assertPanic, panic{-ToDo:rm-} )
+import Util ( assertPanic, panic )
\end{code}
\begin{code}
@@ -60,7 +60,7 @@ tcPat :: RenamedPat -> TcM s (TcPat s, LIE s, TcType s)
\begin{code}
tcPat (VarPatIn name)
- = tcLookupLocalValueOK ("tcPat1:"++ppShow 80 (ppr PprDebug name)) name `thenNF_Tc` \ id ->
+ = tcLookupLocalValueOK ("tcPat1:"{-++ppShow 80 (ppr PprDebug name)-}) name `thenNF_Tc` \ id ->
returnTc (VarPat (TcId id), emptyLIE, idType id)
tcPat (LazyPatIn pat)
diff --git a/ghc/compiler/typecheck/TcPragmas.lhs b/ghc/compiler/typecheck/TcPragmas.lhs
deleted file mode 100644
index 065215247a2c..000000000000
--- a/ghc/compiler/typecheck/TcPragmas.lhs
+++ /dev/null
@@ -1,672 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
-%
-\section[TcPragmas]{Typecheck ``pragmas'' of various kinds}
-
-\begin{code}
-#include "HsVersions.h"
-
-module TcPragmas (
- tcClassOpPragmas,
- tcDataPragmas,
- tcDictFunPragmas,
- tcGenPragmas
- ) where
-
-import TcMonad hiding ( rnMtoTcM )
-import HsSyn -- the stuff being typechecked
-
---import PrelInfo ( PrimOp(..) -- to see CCallOp
--- )
-import Type
-import CmdLineOpts
-import CostCentre
-import HsCore -- ****** NEED TO SEE CONSTRUCTORS ******
-import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ******
-import Id
-import IdInfo
---import WwLib ( mkWwBodies )
-import Maybes ( assocMaybe, catMaybes )
---import CoreLint ( lintUnfolding )
-import TcMonoType ( tcMonoType, tcPolyType )
-import Util
-import SrcLoc
-\end{code}
-
-The basic idea is: Given an @Id@ that only lacks its @IdInfo@
-(represented as a function \tr{IdInfo -> Id}, use the pragmas given to
-figure out the @IdInfo@, then give back the now-complete @Id@.
-
-Of course, the pragmas also need to be checked.
-
-%************************************************************************
-%* *
-\subsection[tcClassOpPragmas]{@ClassOp@ pragmas}
-%* *
-%************************************************************************
-
-\begin{code}
-tcClassOpPragmas :: E -- Class/TyCon lookup tables
- -> Type -- global type of the class method
- -> Id -- *final* ClassOpId
- -> Id -- *final* DefaultMethodId
- -> SpecEnv -- Instance info for this class op
- -> RenamedClassOpPragmas -- info w/ which to complete, giving...
- -> Baby_TcM (IdInfo, IdInfo) -- ... final info for ClassOp and DefaultMethod
-
-tcClassOpPragmas _ _ rec_classop_id rec_defm_id spec_infos NoClassOpPragmas
- = returnB_Tc (noIdInfo `addInfo` spec_infos, noIdInfo)
-
-tcClassOpPragmas e global_ty
- rec_classop_id rec_defm_id
- spec_infos
- (ClassOpPragmas classop_pragmas defm_pragmas)
- = tcGenPragmas e
- Nothing{-ty unknown-} rec_classop_id
- classop_pragmas `thenB_Tc` \ classop_idinfo ->
-
- tcGenPragmas e
- Nothing{-ty unknown-} rec_defm_id
- defm_pragmas `thenB_Tc` \ defm_idinfo ->
-
- returnB_Tc (classop_idinfo `addInfo` spec_infos, defm_idinfo)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[tcInstancePragmas]{Instance-related pragmas of various sorts}
-%* *
-%************************************************************************
-
-{\em Every} instance declaration produces a ``dictionary function''
-(dfun) of some sort; every flavour of @InstancePragmas@ gives a way to
-convey information about a DictFunId.
-
-\begin{code}
-tcDictFunPragmas
- :: E -- Class/TyCon lookup tables
- -> Type -- DictFunId type
- -> Id -- final DictFunId (don't touch)
- -> RenamedInstancePragmas -- info w/ which to complete, giving...
- -> Baby_TcM IdInfo -- ... final DictFun IdInfo
-
-tcDictFunPragmas _ _ final_dfun NoInstancePragmas
- = returnB_Tc noIdInfo
-
-tcDictFunPragmas e dfun_ty final_dfun pragmas
- = let
- dfun_pragmas
- = case pragmas of
- SimpleInstancePragma x -> x
- ConstantInstancePragma x _ -> x
- SpecialisedInstancePragma x _ -> x
- in
- tcGenPragmas e (Just dfun_ty) final_dfun dfun_pragmas
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[tcGenPragmas]{Basic pragmas about a value}
-%* *
-%************************************************************************
-
-Nota bene: @tcGenPragmas@ guarantees to succeed; if it encounters
-a problem, it just returns @noIdInfo@.
-
-\begin{code}
-tcGenPragmas
- :: E -- lookup table
- -> Maybe Type -- of Id, if we have it (for convenience)
- -> Id -- *incomplete* Id (do not *touch*!)
- -> RenamedGenPragmas -- info w/ which to complete, giving...
- -> Baby_TcM IdInfo -- IdInfo for this Id
-
-tcGenPragmas e ty_maybe rec_final_id NoGenPragmas
- = returnB_Tc noIdInfo
-
-tcGenPragmas e ty_maybe rec_final_id
- (GenPragmas arity_maybe upd_maybe def strictness unfold specs)
- = -- Guarantee success!
- recoverIgnoreErrorsB_Tc noIdInfo (
-
- -- OK, now we do the business
- let
- arity_info = get_arity arity_maybe
- upd_info = get_upd upd_maybe
- in
- tc_strictness e ty_maybe rec_final_id strictness
- `thenB_Tc` \ (strict_info, wrapper_unfold_info) ->
-
- -- If the unfolding fails to look consistent, we don't
- -- want to junk *all* the IdInfo
- recoverIgnoreErrorsB_Tc noInfo_UF (
- tc_unfolding e unfold
- ) `thenB_Tc` \ unfold_info ->
-
- -- Same as unfolding; if we fail, don't junk all IdInfo
- recoverIgnoreErrorsB_Tc nullSpecEnv (
- tc_specs e rec_final_id ty_maybe specs
- ) `thenB_Tc` \ spec_env ->
-
- returnB_Tc (
- noIdInfo
- `addInfo` arity_info
- `addInfo` upd_info
- `addInfo` def
-
- -- The strictness info *may* imply an unfolding
- -- (the "wrapper_unfold"); that info is added; if
- -- there is also an explicit unfolding, it will
- -- take precedence, because it is "added" later.
- `addInfo` strict_info
- `addInfo_UF` wrapper_unfold_info
-
- `addInfo_UF` unfold_info
- `addInfo` spec_env
- ))
- where
- get_arity Nothing = noInfo
- get_arity (Just a) = mkArityInfo a
-
- get_upd Nothing = noInfo
- get_upd (Just u) = (u :: UpdateInfo)
-\end{code}
-
-Don't use the strictness info if a flag set.
-\begin{code}
-tc_strictness
- :: E
- -> Maybe Type
- -> Id -- final Id (do not *touch*)
- -> ImpStrictness Name
- -> Baby_TcM (StrictnessInfo, Unfolding)
-
-tc_strictness e ty_maybe rec_final_id info
- = getSwitchCheckerB_Tc `thenB_Tc` \ sw_chkr ->
- if sw_chkr IgnoreStrictnessPragmas then
- returnB_Tc (noInfo, noInfo_UF)
- else
- do_strictness e ty_maybe rec_final_id info
-\end{code}
-
-An easy one first:
-\begin{code}
-do_strictness e ty_maybe rec_final_id NoImpStrictness
- = returnB_Tc (noInfo, noInfo_UF)
-\end{code}
-
-We come to a nasty one now. We have strictness info---possibly
-implying a worker---but (for whatever reason) no {\em type}
-information for the wrapper. We therefore want (a)~{\em not} to
-create a wrapper unfolding (we {\em cannot}) \& to be sure that one is
-never asked for (!); and (b)~we want to keep the strictness/absence
-info, because there's too much good stuff there to ignore completely.
-We are not bothered about any pragmatic info for any alleged worker.
-NB: this code applies only to {\em imported} info. So here we go:
-
-\begin{code}
-do_strictness e Nothing rec_final_id (ImpStrictness is_bot arg_info _)
- = let
- strictness_info
- = if is_bot
- then mkBottomStrictnessInfo
- else mkStrictnessInfo arg_info Nothing
- in
- returnB_Tc (strictness_info, noInfo_UF)
- -- no unfolding: the key --^^^^^^
-\end{code}
-
-And, finally, the have-everthing, know-everything, do-everything
-``normal case''.
-\begin{code}
-do_strictness e (Just wrapper_ty) rec_final_id
- (ImpStrictness is_bot wrap_arg_info wrkr_pragmas)
-
- | is_bot -- it's a "bottoming Id"
- = returnB_Tc (mkBottomStrictnessInfo, noInfo_UF)
-
- | not (indicatesWorker wrap_arg_info)
- = -- No worker
- returnB_Tc (mkStrictnessInfo wrap_arg_info Nothing, noInfo_UF)
-
- | otherwise
- = -- Strictness info suggests a worker. Things could still
- -- go wrong if there's an abstract type involved, mind you.
- let
- (tv_tmpls, arg_tys, ret_ty) = splitFunTyExpandingDicts wrapper_ty
- n_wrapper_args = length wrap_arg_info
- -- Don't have more args than this, else you risk
- -- losing laziness!!
- in
- getUniquesB_Tc (length tv_tmpls) `thenB_Tc` \ tyvar_uniqs ->
- getUniquesB_Tc n_wrapper_args `thenB_Tc` \ arg_uniqs ->
-
- let
- (inst_env, tyvars, tyvar_tys) = instantiateTyVarTemplates tv_tmpls tyvar_uniqs
-
- inst_arg_tys = map (instantiateTy inst_env) arg_tys
- (undropped_inst_arg_tys, dropped_inst_arg_tys)
- = splitAt n_wrapper_args inst_arg_tys
-
- inst_ret_ty = glueTyArgs dropped_inst_arg_tys
- (instantiateTy inst_env ret_ty)
-
- args = zipWithEqual "do_strictness" mk_arg arg_uniqs undropped_inst_arg_tys
- mk_arg uniq ty = mkSysLocal SLIT("wrap") uniq ty mkUnknownSrcLoc
- -- ASSERT: length args = n_wrapper_args
- in
-
- uniqSMtoBabyTcM (mkWwBodies inst_ret_ty tyvars args wrap_arg_info)
- `thenB_Tc` \ result ->
- case result of
-
- Nothing -> -- Alas, we met an abstract type
- returnB_Tc (mkStrictnessInfo wrap_arg_info Nothing, noInfo_UF)
-
- Just (wrapper_w_hole, worker_w_hole, worker_strictness, worker_ty_w_hole) ->
-
- let
- worker_ty = worker_ty_w_hole inst_ret_ty
- in
- getUniqueB_Tc `thenB_Tc` \ uniq ->
- fixB_Tc ( \ rec_wrkr_id ->
-
- tcGenPragmas e
- (Just worker_ty)
- rec_wrkr_id
- wrkr_pragmas `thenB_Tc` \ wrkr_id_info ->
-
- returnB_Tc (mkWorkerId uniq rec_final_id worker_ty
- (wrkr_id_info `addInfo` worker_strictness))
- -- Note: the above will *clobber* any strictness
- -- info for the worker which was read in from the
- -- interface (but there usually isn't any).
-
- ) `thenB_Tc` \ worker_id ->
-
- let
- wrapper_rhs = wrapper_w_hole worker_id
- n_tyvars = length tyvars
- arity = length args
-
- in
- returnB_Tc (
- mkStrictnessInfo wrap_arg_info (Just worker_id),
- mkUnfolding UnfoldAlways ({-pprTrace "imp wrapper:\n" (ppAboves [ppr PprDebug wrapper_rhs, ppInfo PprDebug (\x->x) worker_strictness])-} wrapper_rhs)
- -- We only do this for imported things, which this is.
- )
-\end{code}
-
-\begin{code}
-tc_specs :: E
- -> Id -- final Id for which these are specialisations (do not *touch*)
- -> Maybe Type
- -> [([Maybe RenamedMonoType], Int, RenamedGenPragmas)]
- -> Baby_TcM SpecEnv
-
-tc_specs e rec_main_id Nothing{-no type, we lose-} spec_pragmas
- = returnB_Tc nullSpecEnv -- ToDo: msg????????
-
-tc_specs e rec_main_id (Just main_ty) spec_pragmas
- = mapB_Tc do_one_pragma spec_pragmas `thenB_Tc` \ spec_infos ->
- returnB_Tc (mkSpecEnv spec_infos)
- where
- (main_tyvars, _) = splitForalls main_ty
-
- rec_ce = getE_CE e
- rec_tce = getE_TCE e
-
- do_one_pragma (maybe_monotys, dicts_to_ignore, gen_prags)
- = mapB_Tc (tc_ty_maybe rec_ce rec_tce) maybe_monotys
- `thenB_Tc` \ maybe_tys ->
- getSrcLocB_Tc `thenB_Tc` \ locn ->
- getUniqueB_Tc `thenB_Tc` \ uniq ->
-
- checkB_Tc (length main_tyvars /= length maybe_tys)
- (badSpecialisationErr "value" "wrong number of specialising types"
- (length main_tyvars) maybe_tys locn)
- `thenB_Tc_`
- let
- spec_ty = specialiseTy main_ty maybe_tys dicts_to_ignore
- in
- fixB_Tc ( \ rec_spec_id ->
-
- tcGenPragmas e (Just spec_ty) rec_spec_id gen_prags
- `thenB_Tc` \ spec_id_info ->
-
- returnB_Tc (mkSpecId uniq rec_main_id maybe_tys spec_ty spec_id_info)
-
- ) `thenB_Tc` \ spec_id ->
-
- returnB_Tc (SpecInfo maybe_tys dicts_to_ignore spec_id)
-
-tc_ty_maybe rec_ce rec_tce Nothing = returnB_Tc Nothing
-tc_ty_maybe rec_ce rec_tce (Just ty)
- = tcMonoType rec_ce rec_tce nullTVE ty `thenB_Tc` \ new_ty ->
- returnB_Tc (Just new_ty)
-\end{code}
-
-\begin{code}
-tc_unfolding e NoImpUnfolding = returnB_Tc noInfo_UF
-tc_unfolding e (ImpMagicUnfolding tag) = returnB_Tc (mkMagicUnfolding tag)
-
-tc_unfolding e (ImpUnfolding guidance uf_core)
- = tc_uf_core nullLVE nullTVE uf_core `thenB_Tc` \ core_expr ->
- getSrcLocB_Tc `thenB_Tc` \ locn ->
- let
- -- Bad unfoldings are so painful that we always lint-check them,
- -- marking them with BadUnfolding if lintUnfolding fails
- -- NB: We cant check the lint result and return noInfo_UF if
- -- lintUnfolding failed as this is too strict
- -- Instead getInfo_UF tests for BadUnfolding and converts
- -- to NoUnfolding when the unfolding is accessed
-
- maybe_lint_expr = lintUnfolding locn core_expr
-
- (lint_guidance, lint_expr) = case maybe_lint_expr of
- Just lint_expr -> (guidance, lint_expr)
- Nothing -> (BadUnfolding, panic_expr)
- in
- returnB_Tc (mkUnfolding lint_guidance lint_expr)
- where
- rec_ce = getE_CE e
- rec_tce = getE_TCE e
-
- panic_expr = panic "TcPragmas: BadUnfolding should not be touched"
-
- tc_uf_core :: LVE -- lookup table for local binders
- -- (others: we hope we can figure them out)
- -> TVE -- lookup table for tyvars
- -> UnfoldingCoreExpr Name
- -> Baby_TcM CoreExpr
-
- tc_uf_core lve tve (UfVar v)
- = tc_uf_Id lve v `thenB_Tc` \ id ->
- returnB_Tc (Var id)
-
- tc_uf_core lve tve (UfLit l)
- = returnB_Tc (Lit l)
-
- tc_uf_core lve tve (UfCon con tys as)
- = tc_uf_Id lve (BoringUfId con) `thenB_Tc` \ con_id ->
- mapB_Tc (tc_uf_type tve) tys `thenB_Tc` \ core_tys ->
- mapB_Tc (tc_uf_atom lve tve) as `thenB_Tc` \ core_atoms ->
- returnB_Tc (Con con_id core_tys core_atoms)
-
- -- If a ccall, we have to patch in the types read from the pragma.
-
- tc_uf_core lve tve (UfPrim (UfCCallOp str is_casm may_gc arg_tys res_ty) app_tys as)
- = ASSERT(null app_tys)
- mapB_Tc (tc_uf_type tve) arg_tys `thenB_Tc` \ core_arg_tys ->
- tc_uf_type tve res_ty `thenB_Tc` \ core_res_ty ->
- mapB_Tc (tc_uf_type tve) app_tys `thenB_Tc` \ core_app_tys ->
- mapB_Tc (tc_uf_atom lve tve) as `thenB_Tc` \ core_atoms ->
- returnB_Tc (Prim (CCallOp str is_casm may_gc core_arg_tys core_res_ty)
- core_app_tys core_atoms)
-
- tc_uf_core lve tve (UfPrim (UfOtherOp op) tys as)
- = mapB_Tc (tc_uf_type tve) tys `thenB_Tc` \ core_tys ->
- mapB_Tc (tc_uf_atom lve tve) as `thenB_Tc` \ core_atoms ->
- returnB_Tc (Prim op core_tys core_atoms)
-
- tc_uf_core lve tve (UfLam binder body)
- = tc_uf_binders tve [binder] `thenB_Tc` \ lve2 ->
- let
- [new_binder] = map snd lve2
- new_lve = lve2 `plusLVE` lve
- in
- tc_uf_core new_lve tve body `thenB_Tc` \ new_body ->
- returnB_Tc (Lam new_binder new_body)
-
- tc_uf_core lve tve (UfApp fun arg)
- = tc_uf_core lve tve fun `thenB_Tc` \ new_fun ->
- tc_uf_atom lve tve arg `thenB_Tc` \ new_arg ->
- returnB_Tc (App new_fun new_arg)
-
- tc_uf_core lve tve (UfCase scrut alts)
- = tc_uf_core lve tve scrut `thenB_Tc` \ new_scrut ->
- tc_alts alts `thenB_Tc` \ new_alts ->
- returnB_Tc (Case new_scrut new_alts)
- where
- tc_alts (UfCoAlgAlts alts deflt)
- = mapB_Tc tc_alg_alt alts `thenB_Tc` \ new_alts ->
- tc_deflt deflt `thenB_Tc` \ new_deflt ->
- returnB_Tc (AlgAlts new_alts new_deflt)
- where
- tc_alg_alt (con, params, rhs)
- = tc_uf_Id lve (BoringUfId con) `thenB_Tc` \ con_id ->
- tc_uf_binders tve params `thenB_Tc` \ lve2 ->
- let
- new_params = map snd lve2
- new_lve = lve2 `plusLVE` lve
- in
- tc_uf_core new_lve tve rhs `thenB_Tc` \ new_rhs ->
- returnB_Tc (con_id, new_params, new_rhs)
-
- tc_alts (UfCoPrimAlts alts deflt)
- = mapB_Tc tc_prim_alt alts `thenB_Tc` \ new_alts ->
- tc_deflt deflt `thenB_Tc` \ new_deflt ->
- returnB_Tc (PrimAlts new_alts new_deflt)
- where
- tc_prim_alt (lit, rhs)
- = tc_uf_core lve tve rhs `thenB_Tc` \ new_rhs ->
- returnB_Tc (lit, new_rhs)
-
- tc_deflt UfCoNoDefault = returnB_Tc NoDefault
- tc_deflt (UfCoBindDefault b rhs)
- = tc_uf_binders tve [b] `thenB_Tc` \ lve2 ->
- let
- [new_b] = map snd lve2
- new_lve = lve2 `plusLVE` lve
- in
- tc_uf_core new_lve tve rhs `thenB_Tc` \ new_rhs ->
- returnB_Tc (BindDefault new_b new_rhs)
-
- tc_uf_core lve tve (UfLet (UfCoNonRec b rhs) body)
- = tc_uf_core lve tve rhs `thenB_Tc` \ new_rhs ->
- tc_uf_binders tve [b] `thenB_Tc` \ lve2 ->
- let
- [new_b] = map snd lve2
- new_lve = lve2 `plusLVE` lve
- in
- tc_uf_core new_lve tve body `thenB_Tc` \ new_body ->
- returnB_Tc (Let (NonRec new_b new_rhs) new_body)
-
- tc_uf_core lve tve (UfLet (UfCoRec pairs) body)
- = let
- (binders, rhss) = unzip pairs
- in
- tc_uf_binders tve binders `thenB_Tc` \ lve2 ->
- let
- new_binders = map snd lve2
- new_lve = lve2 `plusLVE` lve
- in
- mapB_Tc (tc_uf_core new_lve tve) rhss `thenB_Tc` \ new_rhss ->
- tc_uf_core new_lve tve body `thenB_Tc` \ new_body ->
- returnB_Tc (Let (Rec (zipEqual "tc_uf_core" new_binders new_rhss)) new_body)
-
- tc_uf_core lve tve (UfSCC uf_cc body)
- = tc_uf_cc uf_cc `thenB_Tc` \ new_cc ->
- tc_uf_core lve tve body `thenB_Tc` \ new_body ->
- returnB_Tc (SCC new_cc new_body)
- where
- tc_uf_cc (UfAutoCC id m g is_dupd is_caf)
- = tc_uf_Id lve id `thenB_Tc` \ new_id ->
- returnB_Tc (adjust is_caf is_dupd (mkAutoCC new_id m g IsNotCafCC))
-
- tc_uf_cc (UfDictCC id m g is_dupd is_caf)
- = tc_uf_Id lve id `thenB_Tc` \ new_id ->
- returnB_Tc (adjust is_caf is_dupd (mkDictCC new_id m g IsNotCafCC))
-
- tc_uf_cc (UfUserCC n m g d c) = returnB_Tc (adjust c d (mkUserCC n m g))
-
- tc_uf_cc (UfPreludeDictsCC d) = returnB_Tc (preludeDictsCostCentre d)
- tc_uf_cc (UfAllDictsCC m g d) = returnB_Tc (mkAllDictsCC m g d)
-
- --------
- adjust is_caf is_dupd cc
- = let
- maybe_cafify = if is_caf then cafifyCC else (\x->x)
- maybe_dupify = if is_dupd then dupifyCC else (\x->x)
- in
- maybe_dupify (maybe_cafify cc)
-
- ---------------
- tc_uf_atom lve tve (UfCoLitAtom l)
- = returnB_Tc (LitArg l)
-
- tc_uf_atom lve tve (UfCoVarAtom v)
- = tc_uf_Id lve v `thenB_Tc` \ new_v ->
- returnB_Tc (VarArg new_v)
-
- ---------------
- tc_uf_binders tve ids_and_tys
- = let
- (ids, tys) = unzip ids_and_tys
- in
- mapB_Tc (tc_uf_type tve) tys `thenB_Tc` \ new_tys ->
-
- returnB_Tc (mkIdsWithGivenTys ids new_tys (repeat noIdInfo))
-
- ---------------
- -- "tyvar" binders (see tcPolyType for the TyVarTemplate equiv):
-
- tc_uf_tyvar (Short u short_name)
- = let
- tyvar = mkUserTyVar u short_name
- in
- (tyvar, u, mkTyVarTy tyvar)
-
- ---------------
- tc_uf_Id lve (BoringUfId v)
- = case (assocMaybe lve v) of
- Just xx -> returnB_Tc xx
- Nothing -> case (lookupE_ValueQuietly e v) of
- Just xx -> returnB_Tc xx
- Nothing -> -- pprTrace "WARNING: Discarded bad unfolding from interface:\n"
- -- (ppCat [ppStr "Failed lookup for BoringUfId:",
- -- ppr PprDebug v])
- (failB_Tc (panic "tc_uf_Id:BoringUfId: no lookup"))
- -- will be recover'd from
- -- ToDo: shouldn't the renamer have handled this? [wdp 94/04/29]
-
- tc_uf_Id lve (SuperDictSelUfId c sc)
- = let
- clas = lookupCE rec_ce c
- super_clas = lookupCE rec_ce sc
- in
- returnB_Tc (classSuperDictSelId clas super_clas)
-
- tc_uf_Id lve (ClassOpUfId c op_name)
- = let
- clas = lookupCE rec_ce c
- op = lookup_class_op clas op_name
- in
- returnB_Tc (classOpId clas op)
-
- tc_uf_Id lve (DefaultMethodUfId c op_name)
- = let
- clas = lookupCE rec_ce c
- op = lookup_class_op clas op_name
- in
- returnB_Tc (classDefaultMethodId clas op)
-
- tc_uf_Id lve uf_id@(DictFunUfId c ty)
- = tc_uf_type nullTVE ty `thenB_Tc` \ new_ty ->
- let
- clas = lookupCE rec_ce c
- dfun_id = case (lookupClassInstAtSimpleType clas new_ty) of
- Just id -> id
- Nothing -> pprPanic "tc_uf_Id:DictFunUfId:"
- (ppr PprDebug (UfVar uf_id))
- -- The class and type are both
- -- visible, so the instance should
- -- jolly well be too!
- in
- returnB_Tc dfun_id
-
- tc_uf_Id lve (ConstMethodUfId c op_name ty)
- = tc_uf_type nullTVE ty `thenB_Tc` \ new_ty ->
- let
- clas = lookupCE rec_ce c
- op = lookup_class_op clas op_name
- in
- returnB_Tc (getConstMethodId clas op new_ty)
-
- tc_uf_Id lve uf_id@(SpecUfId unspec ty_maybes)
- = tc_uf_Id lve unspec `thenB_Tc` \ unspec_id ->
- mapB_Tc (tc_ty_maybe rec_ce rec_tce) ty_maybes
- `thenB_Tc` \ maybe_tys ->
- let
- spec_id = lookupSpecId unspec_id maybe_tys
- in
- returnB_Tc spec_id
-
- tc_uf_Id lve (WorkerUfId unwrkr)
- = tc_uf_Id lve unwrkr `thenB_Tc` \ unwrkr_id ->
- let
- strictness_info = getIdStrictness unwrkr_id
- in
- if isLocallyDefined unwrkr_id
- then
- -- A locally defined value will not have any strictness info (yet),
- -- so we can't extract the locally defined worker Id from it :-(
-
- pprTrace "WARNING: Discarded bad unfolding from interface:\n"
- (ppCat [ppStr "Worker Id in unfolding is defined locally:",
- ppr PprDebug unwrkr_id])
- (failB_Tc (panic "tc_uf_Id:WorkerUfId: locally defined"))
- -- will be recover'd from
- else
- returnB_Tc (getWorkerId strictness_info)
-
- ---------------
- lookup_class_op clas (ClassOpName _ _ _ tag)
- = classOps clas !! (tag - 1)
-
- ---------------------------------------------------------------------
- tc_uf_type :: TVE -> UnfoldingType Name -> Baby_TcM Type
-
- tc_uf_type tve ty = tcPolyType rec_ce rec_tce tve ty
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[tcDataPragmas]{@data@ type pragmas}
-%* *
-%************************************************************************
-
-The purpose of a @data@ pragma is to convey data-constructor
-information that would otherwise be unknown.
-
-It also records specialisation information which is added to each data
-constructor. This info just contains the type info for the
-specialisations which exist. No specialised Ids are actually created.
-
-\begin{code}
-tcDataPragmas :: TCE -> TVE -> TyCon -> [TyVarTemplate]
- -> RenamedDataPragmas
- -> Baby_TcM ([RenamedConDecl], -- any pragma condecls
- [SpecInfo]) -- specialisation info from pragmas
-
-tcDataPragmas rec_tce tve rec_tycon new_tyvars (DataPragmas con_decls specs)
- = mapB_Tc do_one_spec specs `thenB_Tc` \ spec_infos ->
- returnB_Tc (con_decls, spec_infos)
- where
- do_one_spec maybe_monotys
- = mapB_Tc (tc_ty_maybe nullCE rec_tce) maybe_monotys
- `thenB_Tc` \ maybe_tys ->
- getSrcLocB_Tc `thenB_Tc` \ locn ->
-
- checkB_Tc (length new_tyvars /= length maybe_tys)
- (badSpecialisationErr "data" "wrong number of specialising types"
- (length new_tyvars) maybe_tys locn)
- `thenB_Tc_`
-
- checkB_Tc (not (all isUnboxedType (catMaybes maybe_tys)))
- (badSpecialisationErr "data" "not all unboxed types"
- (length new_tyvars) maybe_tys locn)
- `thenB_Tc_`
-
- returnB_Tc (SpecInfo maybe_tys 0 (panic "DataPragma:SpecInfo:SpecId"))
-\end{code}
diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index f9ac4f305c3e..061dc653cab1 100644
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -42,11 +42,10 @@ import Class ( GenClass, SYN_IE(Class), SYN_IE(ClassInstEnv),
import Id ( GenId )
import Maybes ( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool )
import Outputable ( Outputable(..){-instance * []-} )
-import PprStyle--ToDo:rm
-import PprType ( GenType, GenTyVar, GenClass{-instance Outputable;ToDo:rm-} )
+--import PprStyle--ToDo:rm
+import PprType ( GenType, GenTyVar )
import Pretty
import SrcLoc ( mkUnknownSrcLoc )
-import Util
import Type ( GenType, SYN_IE(Type), SYN_IE(TauType), mkTyVarTy, getTyVar, eqSimpleTy,
getTyVar_maybe )
import TysWiredIn ( intTy )
@@ -54,6 +53,7 @@ import TyVar ( GenTyVar, SYN_IE(GenTyVarSet),
elementOfTyVarSet, emptyTyVarSet, unionTyVarSets,
isEmptyTyVarSet, tyVarSetToList )
import Unique ( Unique )
+import Util
\end{code}
diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index a6f55f2c451e..0eff0ad51c5b 100644
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -47,7 +47,7 @@ import Id ( mkDataCon, dataConSig, mkRecordSelId, idType,
)
import FieldLabel
import Kind ( Kind, mkArrowKind, mkBoxedTypeKind )
-import SpecEnv ( SYN_IE(SpecEnv), nullSpecEnv )
+import SpecEnv ( SpecEnv, nullSpecEnv )
import Name ( nameSrcLoc, isLocallyDefinedName, getSrcLoc,
Name{-instance Ord3-}
)
diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index e27dab5442cc..eff458dc8b11 100644
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -61,12 +61,12 @@ IMP_Ubiq()
import Unique ( Unique )
import UniqFM ( UniqFM )
import Maybes ( assocMaybe )
-import Util ( zipEqual, nOfThem, panic, pprPanic, pprTrace{-ToDo:rm-} )
+import Util ( zipEqual, nOfThem, panic{-, pprPanic, pprTrace ToDo:rm-} )
-import Outputable ( Outputable(..) ) -- Debugging messages
-import PprType ( GenTyVar, GenType )
-import Pretty -- ditto
-import PprStyle ( PprStyle(..) ) -- ditto
+--import Outputable ( Outputable(..) ) -- Debugging messages
+--import PprType ( GenTyVar, GenType )
+--import Pretty -- ditto
+--import PprStyle ( PprStyle(..) ) -- ditto
\end{code}
@@ -188,8 +188,8 @@ tcInstType tenv ty_to_inst
bind_fn = inst_tyvar UnBound
occ_fn env tyvar = case lookupTyVarEnv env tyvar of
Just ty -> returnNF_Tc ty
- Nothing -> pprPanic "tcInstType:" (ppAboves [ppr PprDebug ty_to_inst,
- ppr PprDebug tyvar])
+ Nothing -> panic "tcInstType:1" --(ppAboves [ppr PprDebug ty_to_inst,
+ -- ppr PprDebug tyvar])
tcInstSigType :: GenType (GenTyVar flexi) UVar -> NF_TcM s (TcType s)
tcInstSigType ty_to_inst
@@ -198,8 +198,8 @@ tcInstSigType ty_to_inst
bind_fn = inst_tyvar DontBind
occ_fn env tyvar = case lookupTyVarEnv env tyvar of
Just ty -> returnNF_Tc ty
- Nothing -> pprPanic "tcInstType:" (ppAboves [ppr PprDebug ty_to_inst,
- ppr PprDebug tyvar])
+ Nothing -> panic "tcInstType:2"-- (ppAboves [ppr PprDebug ty_to_inst,
+ -- ppr PprDebug tyvar])
zonkTcTyVarToTyVar :: TcTyVar s -> NF_TcM s TyVar
zonkTcTyVarToTyVar tv
@@ -208,7 +208,7 @@ zonkTcTyVarToTyVar tv
TyVarTy tv' -> returnNF_Tc (tcTyVarToTyVar tv')
- _ -> pprTrace "zonkTcTyVarToTyVar:" (ppCat [ppr PprDebug tv, ppr PprDebug tv_ty]) $
+ _ -> --pprTrace "zonkTcTyVarToTyVar:" (ppCat [ppr PprDebug tv, ppr PprDebug tv_ty]) $
returnNF_Tc (tcTyVarToTyVar tv)
@@ -376,7 +376,7 @@ zonkTcType (ForAllTy tv ty)
case tv_ty of -- Should be a tyvar!
TyVarTy tv' ->
returnNF_Tc (ForAllTy tv' ty')
- _ -> pprTrace "zonkTcType:ForAllTy:" (ppCat [ppr PprDebug tv, ppr PprDebug tv_ty]) $
+ _ -> --pprTrace "zonkTcType:ForAllTy:" (ppCat [ppr PprDebug tv, ppr PprDebug tv_ty]) $
returnNF_Tc (ForAllTy tv{-(tcTyVarToTyVar tv)-} ty')
diff --git a/ghc/compiler/typecheck/root.lit b/ghc/compiler/typecheck/root.lit
deleted file mode 100644
index 401055f7429b..000000000000
--- a/ghc/compiler/typecheck/root.lit
+++ /dev/null
@@ -1,71 +0,0 @@
-\begin{onlystandalone}
-\documentstyle[11pt,literate,a4wide]{article}
-\begin{document}
-\title{The Glasgow \Haskell{} typechecker}
-\author{The AQUA team}
-\date{February 1994}
-\maketitle
-\tableofcontents
-\end{onlystandalone}
-
-\begin{onlypartofdoc}
-\section[Typechecker]{The typechecker}
-\downsection
-\end{onlypartofdoc}
-
-\input{Typecheck.lhs}
-
-\section[Typechecker-monadery]{Typechecker: monad stuff (Saps)}
-\downsection
-\input{TcMonad.lhs}
-\input{TcMonadFns.lhs}
-\upsection
-
-\section{Typechecker: misc}
-\downsection
-\input{BackSubst.lhs}
-\input{Disambig.lhs}
-\input{Spec.lhs}
-\input{Subst.lhs}
-\input{Unify.lhs}
-\upsection
-
-\section[Typechecker-toplevel]{Typechecker: top-level modules}
-\downsection
-\input{TcModule.lhs}
-\upsection
-
-\section[Typechecker-core]{Typechecking the abstract syntax}
-\downsection
-\input{TcBinds.lhs}
-\input{TcClassDcl.lhs}
-\input{TcClassSig.lhs}
-\input{TcConDecls.lhs}
-\input{TcContext.lhs}
-\input{TcExpr.lhs}
-\input{TcGRHSs.lhs}
-\input{TcIfaceSig.lhs}
-\input{TcInstDcls.lhs}
-\input{TcMatches.lhs}
-\input{TcMonoBnds.lhs}
-\input{TcMonoType.lhs}
-\input{TcPat.lhs}
-\input{TcPolyType.lhs}
-\input{TcPragmas.lhs}
-\input{TcQuals.lhs}
-\input{TcTyDecls.lhs}
-\upsection
-
-\section[Typechecker-support]{Typechecker: supporting modules}
-\downsection
-\input{GenSpecEtc.lhs}
-\input{TcSimplify.lhs}
-\upsection
-
-\begin{onlypartofdoc}
-\upsection
-\end{onlypartofdoc}
-\begin{onlystandalone}
-\printindex
-\end{document}
-\end{onlystandalone}
diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs
index e97634972cf8..adfbe516f2bb 100644
--- a/ghc/compiler/types/Class.lhs
+++ b/ghc/compiler/types/Class.lhs
@@ -40,8 +40,8 @@ import MatchEnv ( MatchEnv )
import Maybes ( assocMaybe )
import Name ( changeUnique, Name )
import Unique -- Keys for built-in classes
-import Pretty ( SYN_IE(Pretty), ppCat{-ToDo:rm-}, ppPStr{-ditto-} )
-import PprStyle ( PprStyle )
+import Pretty ( SYN_IE(Pretty), ppCat, ppPStr )
+--import PprStyle ( PprStyle )
import SrcLoc ( SrcLoc )
import Util
\end{code}
diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs
index fd203292bd2f..7a6480f22afe 100644
--- a/ghc/compiler/types/PprType.lhs
+++ b/ghc/compiler/types/PprType.lhs
@@ -51,8 +51,7 @@ import Outputable ( ifPprShowAll, interpp'SP )
import PprEnv
import PprStyle ( PprStyle(..), codeStyle, showUserishTypes )
import Pretty
-import TysWiredIn ( listTyCon )
-import UniqFM ( addToUFM_Directly, lookupUFM_Directly, ufmToList{-ToDo:rm-} )
+import UniqFM ( addToUFM_Directly, lookupUFM_Directly{-, ufmToList ToDo:rm-} )
import Unique ( pprUnique10, pprUnique, incrUnique, listTyConKey )
import Util
\end{code}
@@ -198,7 +197,7 @@ ppr_corner sty env ctxt_prec (TyConTy (TupleTyCon _ _ a) usage) arg_tys
arg_tys_w_commas = ppIntersperse pp'SP (map (ppr_ty sty env tOP_PREC) arg_tys)
ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys
- | not (codeStyle sty) && tycon == listTyCon
+ | not (codeStyle sty) && uniqueOf tycon == listTyConKey
= ASSERT(length arg_tys == 1)
ppBesides [ppLbrack, ppr_ty sty env tOP_PREC ty1, ppRbrack]
where
@@ -540,7 +539,7 @@ nmbrTyVar tv@(TyVar u _ _ _) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
= case (lookupUFM_Directly tvenv u) of
Just xx -> (nenv, xx)
Nothing ->
- pprTrace "nmbrTyVar: lookup failed:" (ppCat (ppr PprDebug u : [ppCat [ppr PprDebug x, ppStr "=>", ppr PprDebug tv] | (x,tv) <- ufmToList tvenv])) $
+ --pprTrace "nmbrTyVar: lookup failed:" (ppCat (ppr PprDebug u : [ppCat [ppr PprDebug x, ppStr "=>", ppr PprDebug tv] | (x,tv) <- ufmToList tvenv])) $
(nenv, tv)
\end{code}
diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs
index a6b4730cc462..e38da87182e0 100644
--- a/ghc/compiler/types/TyCon.lhs
+++ b/ghc/compiler/types/TyCon.lhs
@@ -60,7 +60,7 @@ import Unique ( Unique, funTyConKey, mkTupleTyConUnique )
import Pretty ( SYN_IE(Pretty), PrettyRep )
import PrimRep ( PrimRep(..) )
import SrcLoc ( SrcLoc, mkBuiltinSrcLoc )
-import Util ( nOfThem, isIn, Ord3(..), panic, panic#, assertPanic, pprPanic{-ToDo:rm-} )
+import Util ( nOfThem, isIn, Ord3(..), panic, panic#, assertPanic )
--import {-hide me-}
-- PprType (pprTyCon)
--import {-hide me-}
diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index 4ae211d7c47f..7b77b998a1a9 100644
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -64,20 +64,20 @@ import Maybes ( maybeToBool, assocMaybe )
import PrimRep ( PrimRep(..) )
import Unique -- quite a few *Keys
import Util ( thenCmp, zipEqual, assoc,
- panic, panic#, assertPanic, pprTrace{-ToDo:rm-}, pprPanic{-ToDo:rm-},
+ panic, panic#, assertPanic,
Ord3(..){-instances-}
)
-- ToDo:rm all these
-import {-mumble-}
- Pretty
-import {-mumble-}
- PprStyle
+--import {-mumble-}
+-- Pretty
+--import {-mumble-}
+-- PprStyle
--import {-mumble-}
-- PprType --(pprType )
-import {-mumble-}
- UniqFM (ufmToList )
-import {-mumble-}
- Outputable
+--import {-mumble-}
+-- UniqFM (ufmToList )
+--import {-mumble-}
+-- Outputable
\end{code}
Data types
@@ -747,10 +747,8 @@ matchTy ty1 ty2 = match ty1 ty2 (\s -> Just s) []
matchTys tys1 tys2 = go [] tys1 tys2
where
go s [] tys2 = Just (s,tys2)
- go s (ty1:tys1) [] = panic "matchTys"
+ go s (ty1:tys1) [] = trace "matchTys" Nothing
go s (ty1:tys1) (ty2:tys2) = match ty1 ty2 (\s' -> go s' tys1 tys2) s
-
-
\end{code}
@match@ is the main function.
diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs
index c3f503942d48..adc6e65ba932 100644
--- a/ghc/compiler/utils/Util.lhs
+++ b/ghc/compiler/utils/Util.lhs
@@ -773,7 +773,7 @@ unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
panic x = error ("panic! (the `impossible' happened):\n\t"
++ x ++ "\n\n"
++ "Please report it as a compiler bug "
- ++ "to glasgow-haskell-bugs@dcs.glasgow.ac.uk.\n\n" )
+ ++ "to glasgow-haskell-bugs@dcs.gla.ac.uk.\n\n" )
pprPanic heading pretty_msg = panic (heading++(ppShow 80 pretty_msg))
pprError heading pretty_msg = error (heading++(ppShow 80 pretty_msg))
--
GitLab